Open-ILS/src/perlmods/OpenILS/Application/Acq/Order.pm

   1 package OpenILS::Application::Acq::BatchManager;
   2 use strict; use warnings;
   3
   4 sub new {
   5     my($class, %args) = @_;
   6     my $self = bless(\%args, $class);
   7     $self->{args} = {
   8         lid => 0,
   9         li => 0,
  10         copies => 0,
  11         progress => 0,
  12         debits_accrued => 0,
  13         purchase_order => undef,
  14         picklist => undef,
  15         complete => 0,
  16         total => 0
  17     };
  18     $self->{cache} = {};
  19     return $self;
  20 }
  21
  22 sub conn {
  23     my($self, $val) = @_;
  24     $self->{conn} = $val if $val;
  25     return $self->{conn};
  26 }
  27 sub throttle {
  28     my($self, $val) = @_;
  29     $self->{throttle} = $val if $val;
  30     return $self->{throttle};
  31 }
  32 sub respond {
  33     my($self, %other_args) = @_;
  34     if($self->throttle and not %other_args) {
  35         return unless (
  36             ($self->{args}->{progress} - $self->{last_respond_progress}) >= $self->throttle
  37         );
  38     }
  39     $self->conn->respond({ %{$self->{args}}, %other_args });
  40     $self->{last_respond_progress} = $self->{args}->{progress};
  41 }
  42 sub respond_complete {
  43     my($self, %other_args) = @_;
  44     $self->complete;
  45     $self->conn->respond_complete({ %{$self->{args}}, %other_args });
  46     return undef;
  47 }
  48 sub total {
  49     my($self, $val) = @_;
  50     $self->{args}->{total} = $val if defined $val;
  51     return $self->{args}->{total};
  52 }
  53 sub purchase_order {
  54     my($self, $val) = @_;
  55     $self->{args}->{purchase_order} = $val if $val;
  56     return $self;
  57 }
  58 sub picklist {
  59     my($self, $val) = @_;
  60     $self->{args}->{picklist} = $val if $val;
  61     return $self;
  62 }
  63 sub add_lid {
  64     my $self = shift;
  65     $self->{args}->{lid} += 1;
  66     $self->{args}->{progress} += 1;
  67     return $self;
  68 }
  69 sub add_li {
  70     my $self = shift;
  71     $self->{args}->{li} += 1;
  72     $self->{args}->{progress} += 1;
  73     return $self;
  74 }
  75 sub add_copy {
  76     my $self = shift;
  77     $self->{args}->{copies} += 1;
  78     $self->{args}->{progress} += 1;
  79     return $self;
  80 }
  81 sub add_debit {
  82     my($self, $amount) = @_;
  83     $self->{args}->{debits_accrued} += $amount;
  84     $self->{args}->{progress} += 1;
  85     return $self;
  86 }
  87 sub editor {
  88     my($self, $editor) = @_;
  89     $self->{editor} = $editor if defined $editor;
  90     return $self->{editor};
  91 }
  92 sub complete {
  93     my $self = shift;
  94     $self->{args}->{complete} = 1;
  95     return $self;
  96 }
  97
  98 sub cache {
  99     my($self, $org, $key, $val) = @_;
 100     $self->{cache}->{$org} = {} unless $self->{cache}->{org};
 101     $self->{cache}->{$org}->{$key} = $val if defined $val;
 102     return $self->{cache}->{$org}->{$key};
 103 }
 104
 105
 106 package OpenILS::Application::Acq::Order;
 107 use base qw/OpenILS::Application/;
 108 use strict; use warnings;
 109 # ----------------------------------------------------------------------------
 110 # Break up each component of the order process and pieces into managable
 111 # actions that can be shared across different workflows
 112 # ----------------------------------------------------------------------------
 113 use OpenILS::Event;
 114 use OpenSRF::Utils::Logger qw(:logger);
 115 use OpenSRF::Utils::JSON;
 116 use OpenILS::Utils::Fieldmapper;
 117 use OpenILS::Utils::CStoreEditor q/:funcs/;
 118 use OpenILS::Const qw/:const/;
 119 use OpenSRF::EX q/:try/;
 120 use OpenILS::Application::AppUtils;
 121 use OpenILS::Application::Cat::BibCommon;
 122 use OpenILS::Application::Cat::AssetCommon;
 123 use MARC::Record;
 124 use MARC::Batch;
 125 use MARC::File::XML;
 126 my $U = 'OpenILS::Application::AppUtils';
 127
 128
 129 # ----------------------------------------------------------------------------
 130 # Lineitem
 131 # ----------------------------------------------------------------------------
 132 sub create_lineitem {
 133     my($mgr, %args) = @_;
 134     my $li = Fieldmapper::acq::lineitem->new;
 135     $li->creator($mgr->editor->requestor->id);
 136     $li->selector($li->creator);
 137     $li->editor($li->creator);
 138     $li->create_time('now');
 139     $li->edit_time('now');
 140     $li->state('new');
 141     $li->$_($args{$_}) for keys %args;
 142     if($li->picklist) {
 143         return 0 unless update_picklist($mgr, $li->picklist);
 144     }
 145     $mgr->add_li;
 146     return $mgr->editor->create_acq_lineitem($li);
 147 }
 148
 149 sub update_lineitem {
 150     my($mgr, $li) = @_;
 151     $li->edit_time('now');
 152     $li->editor($mgr->editor->requestor->id);
 153     return $li if $mgr->editor->update_acq_lineitem($li);
 154     $mgr->add_lid;
 155     return undef;
 156 }
 157
 158 sub delete_lineitem {
 159     my($mgr, $li) = @_;
 160     $li = $mgr->editor->retrieve_acq_lineitem($li) unless ref $li;
 161
 162     if($li->picklist) {
 163         return 0 unless update_picklist($mgr, $li->picklist);
 164     }
 165
 166     if($li->purchase_order) {
 167         return 0 unless update_purchase_order($mgr, $li->purchase_order);
 168     }
 169
 170     # delete the attached lineitem_details
 171     my $lid_ids = $mgr->editor->search_acq_lineitem_detail({lineitem => $li->id}, {idlist=>1});
 172     for my $lid_id (@$lid_ids) {
 173         return 0 unless delete_lineitem_detail($mgr, undef, $lid_id);
 174     }
 175
 176     return $mgr->editor->delete_acq_lineitem($li);
 177 }
 178
 179 # ----------------------------------------------------------------------------
 180 # Lineitem Detail
 181 # ----------------------------------------------------------------------------
 182 sub create_lineitem_detail {
 183     my($mgr, %args) = @_;
 184     my $lid = Fieldmapper::acq::lineitem_detail->new;
 185     $lid->$_($args{$_}) for keys %args;
 186     $mgr->editor->create_acq_lineitem_detail($lid) or return 0;
 187     $mgr->add_lid;
 188
 189     # create some default values
 190     unless($lid->barcode) {
 191         my $pfx = $U->ou_ancestor_setting_value($lid->owning_lib, 'acq.tmp_barcode_prefix') || 'ACQ';
 192         $lid->barcode($pfx.$lid->id);
 193     }
 194
 195     unless($lid->cn_label) {
 196         my $pfx = $U->ou_ancestor_setting_value($lid->owning_lib, 'acq.tmp_callnumber_prefix') || 'ACQ';
 197         $lid->cn_label($pfx.$lid->id);
 198     }
 199
 200     if(!$lid->location and my $loc = $U->ou_ancestor_setting_value($lid->owning_lib, 'acq.default_copy_location')) {
 201         $lid->location($loc);
 202     }
 203
 204     if(!$lid->circ_modifier and my $mod = get_default_circ_modifier($mgr, $lid->owning_lib)) {
 205         $lid->circ_modifier($mod);
 206     }
 207
 208     $mgr->editor->update_acq_lineitem_detail($lid) or return 0;
 209     my $li = $mgr->editor->retrieve_acq_lineitem($lid->lineitem) or return 0;
 210     update_lineitem($mgr, $li) or return 0;
 211     return $lid;
 212 }
 213
 214 sub get_default_circ_modifier {
 215     my($mgr, $org) = @_;
 216     my $mod = $mgr->cache($org, 'def_circ_mod');
 217     return $mod if $mod;
 218     $mod = $U->ou_ancestor_setting_value($org, 'acq.default_circ_modifier');
 219     return $mgr->cache($org, 'def_circ_mod', $mod) if $mod;
 220     return undef;
 221 }
 222
 223 sub delete_lineitem_detail {
 224     my($mgr, $lid) = @_;
 225     $lid = $mgr->editor->retrieve_acq_lineitem_detail($lid) unless ref $lid;
 226     return $mgr->editor->delete_acq_lineitem_detail($lid);
 227 }
 228
 229
 230 # ----------------------------------------------------------------------------
 231 # Lineitem Attr
 232 # ----------------------------------------------------------------------------
 233 sub set_lineitem_attr {
 234     my($mgr, %args) = @_;
 235     my $attr_type = $args{attr_type};
 236
 237     # first, see if it's already set.  May just need to overwrite it
 238     my $attr = $mgr->editor->search_acq_lineitem_attr({
 239         lineitem => $args{lineitem},
 240         attr_type => $args{attr_type},
 241         attr_name => $args{attr_name}
 242     })->[0];
 243
 244     if($attr) {
 245         $attr->attr_value($args{attr_value});
 246         return $attr if $mgr->editor->update_acq_lineitem_attr($attr);
 247         return undef;
 248
 249     } else {
 250
 251         $attr = Fieldmapper::acq::lineitem_attr->new;
 252         $attr->$_($args{$_}) for keys %args;
 253
 254         unless($attr->definition) {
 255             my $find = "search_acq_$attr_type";
 256             my $attr_def_id = $mgr->editor->$find({code => $attr->attr_name}, {idlist=>1})->[0] or return 0;
 257             $attr->definition($attr_def_id);
 258         }
 259         return $mgr->editor->create_acq_lineitem_attr($attr);
 260     }
 261 }
 262
 263 sub get_li_price {
 264     my $li = shift;
 265     my $attrs = $li->attributes;
 266     my ($marc_estimated, $local_estimated, $local_actual, $prov_estimated, $prov_actual);
 267
 268     for my $attr (@$attrs) {
 269         if($attr->attr_name eq 'estimated_price') {
 270             $local_estimated = $attr->attr_value
 271                 if $attr->attr_type eq 'lineitem_local_attr_definition';
 272             $prov_estimated = $attr->attr_value
 273                 if $attr->attr_type eq 'lineitem_prov_attr_definition';
 274             $marc_estimated = $attr->attr_value
 275                 if $attr->attr_type eq 'lineitem_marc_attr_definition';
 276
 277         } elsif($attr->attr_name eq 'actual_price') {
 278             $local_actual = $attr->attr_value
 279                 if $attr->attr_type eq 'lineitem_local_attr_definition';
 280             $prov_actual = $attr->attr_value
 281                 if $attr->attr_type eq 'lineitem_prov_attr_definition';
 282         }
 283     }
 284
 285     return ($local_actual, 1) if $local_actual;
 286     return ($prov_actual, 2) if $prov_actual;
 287     return ($local_estimated, 1) if $local_estimated;
 288     return ($prov_estimated, 2) if $prov_estimated;
 289     return ($marc_estimated, 3);
 290 }
 291
 292
 293 # ----------------------------------------------------------------------------
 294 # Lineitem Debits
 295 # ----------------------------------------------------------------------------
 296 sub create_lineitem_debits {
 297     my($mgr, $li, $price, $ptype) = @_;
 298
 299     ($price, $ptype) = get_li_price($li) unless $price;
 300
 301     unless($price) {
 302         $mgr->editor->event(OpenILS::Event->new('ACQ_LINEITEM_NO_PRICE', payload => $li->id));
 303         $mgr->editor->rollback;
 304         return 0;
 305     }
 306
 307     unless($li->provider) {
 308         $mgr->editor->event(OpenILS::Event->new('ACQ_LINEITEM_NO_PROVIDER', payload => $li->id));
 309         $mgr->editor->rollback;
 310         return 0;
 311     }
 312
 313     my $lid_ids = $mgr->editor->search_acq_lineitem_detail(
 314         {lineitem => $li->id},
 315         {idlist=>1}
 316     );
 317
 318     for my $lid_id (@$lid_ids) {
 319
 320         my $lid = $mgr->editor->retrieve_acq_lineitem_detail([
 321             $lid_id,
 322             {   flesh => 1,
 323                 flesh_fields => {acqlid => ['fund']}
 324             }
 325         ]);
 326
 327         create_lineitem_detail_debit($mgr, $li, $lid, $price, $ptype) or return 0;
 328     }
 329
 330     return 1;
 331 }
 332
 333
 334 # flesh li->provider
 335 # flesh lid->fund
 336 # ptype 1=local, 2=provider, 3=marc
 337 sub create_lineitem_detail_debit {
 338     my($mgr, $li, $lid, $price, $ptype) = @_;
 339
 340     unless(ref $li and ref $li->provider) {
 341        $li = $mgr->editor->retrieve_acq_lineitem([
 342             $li,
 343             {   flesh => 1,
 344                 flesh_fields => {jub => ['provider']},
 345             }
 346         ]);
 347     }
 348
 349     unless(ref $lid and ref $lid->fund) {
 350         $lid = $mgr->editor->retrieve_acq_lineitem_detail([
 351             $lid,
 352             {   flesh => 1,
 353                 flesh_fields => {acqlid => ['fund']}
 354             }
 355         ]);
 356     }
 357
 358     my $ctype = $lid->fund->currency_type;
 359     my $amount = $price;
 360
 361     if($ptype == 2) { # price from vendor
 362         $ctype = $li->provider->currency_type;
 363         $amount = currency_conversion($mgr, $ctype, $lid->fund->currency_type, $price);
 364     }
 365
 366     my $debit = create_fund_debit(
 367         $mgr,
 368         fund => $lid->fund->id,
 369         origin_amount => $price,
 370         origin_currency_type => $ctype,
 371         amount => $amount
 372     ) or return 0;
 373
 374     $lid->fund_debit($debit->id);
 375     $lid->fund($lid->fund->id);
 376     $mgr->editor->update_acq_lineitem_detail($lid) or return 0;
 377     return $debit;
 378 }
 379
 380
 381 # ----------------------------------------------------------------------------
 382 # Fund Debit
 383 # ----------------------------------------------------------------------------
 384 sub create_fund_debit {
 385     my($mgr, %args) = @_;
 386     my $debit = Fieldmapper::acq::fund_debit->new;
 387     $debit->debit_type('purchase');
 388     $debit->encumbrance('t');
 389     $debit->$_($args{$_}) for keys %args;
 390     $mgr->add_debit($debit->amount);
 391     return $mgr->editor->create_acq_fund_debit($debit);
 392 }
 393
 394 sub currency_conversion {
 395     my($mgr, $src_currency, $dest_currency, $amount) = @_;
 396     my $result = $mgr->editor->json_query(
 397         {from => ['acq.exchange_ratio', $src_currency, $dest_currency, $amount]});
 398     return $result->[0]->{'acq.exchange_ratio'};
 399 }
 400
 401
 402 # ----------------------------------------------------------------------------
 403 # Picklist
 404 # ----------------------------------------------------------------------------
 405 sub create_picklist {
 406     my($mgr, %args) = @_;
 407     my $picklist = Fieldmapper::acq::picklist->new;
 408     $picklist->creator($mgr->editor->requestor->id);
 409     $picklist->owner($picklist->creator);
 410     $picklist->editor($picklist->creator);
 411     $picklist->create_time('now');
 412     $picklist->edit_time('now');
 413     $picklist->org_unit($mgr->editor->requestor->ws_ou);
 414     $picklist->owner($mgr->editor->requestor->id);
 415     $picklist->$_($args{$_}) for keys %args;
 416     $mgr->picklist($picklist);
 417     return $mgr->editor->create_acq_picklist($picklist);
 418 }
 419
 420 sub update_picklist {
 421     my($mgr, $picklist) = @_;
 422     $picklist = $mgr->editor->retrieve_acq_picklist($picklist) unless ref $picklist;
 423     $picklist->edit_time('now');
 424     $picklist->editor($mgr->editor->requestor->id);
 425     $mgr->picklist($picklist);
 426     return $picklist if $mgr->editor->update_acq_picklist($picklist);
 427     return undef;
 428 }
 429
 430 sub delete_picklist {
 431     my($mgr, $picklist) = @_;
 432     $picklist = $mgr->editor->retrieve_acq_picklist($picklist) unless ref $picklist;
 433
 434     # delete all 'new' lineitems
 435     my $lis = $mgr->editor->search_acq_lineitem({picklist => $picklist->id, state => 'new'});
 436     for my $li (@$lis) {
 437         return 0 unless delete_lineitem($mgr, $li);
 438     }
 439
 440     # detach all non-'new' lineitems
 441     $lis = $mgr->editor->search_acq_lineitem({picklist => $picklist->id, state => {'!=' => 'new'}});
 442     for my $li (@$lis) {
 443         $li->clear_picklist;
 444         return 0 unless update_lineitem($li);
 445     }
 446
 447     # remove any picklist-specific object perms
 448     my $ops = $mgr->editor->search_permission_usr_object_perm_map({object_type => 'acqpl', object_id => ''.$picklist->id});
 449     for my $op (@$ops) {
 450         return 0 unless $mgr->editor->delete_usr_object_perm_map($op);
 451     }
 452
 453     return $mgr->editor->delete_acq_picklist($picklist);
 454 }
 455
 456 # ----------------------------------------------------------------------------
 457 # Purchase Order
 458 # ----------------------------------------------------------------------------
 459 sub update_purchase_order {
 460     my($mgr, $po) = @_;
 461     $po = $mgr->editor->retrieve_acq_purchase_order($po) unless ref $po;
 462     $po->editor($mgr->editor->requestor->id);
 463     $po->edit_time('now');
 464     $mgr->purchase_order($po);
 465     return $po if $mgr->editor->update_acq_purchase_order($po);
 466     return undef;
 467 }
 468
 469 sub create_purchase_order {
 470     my($mgr, %args) = @_;
 471     my $po = Fieldmapper::acq::purchase_order->new;
 472     $po->creator($mgr->editor->requestor->id);
 473     $po->editor($mgr->editor->requestor->id);
 474     $po->owner($mgr->editor->requestor->id);
 475     $po->edit_time('now');
 476     $po->create_time('now');
 477     $po->ordering_agency($mgr->editor->requestor->ws_ou);
 478     $po->$_($args{$_}) for keys %args;
 479     $mgr->purchase_order($po);
 480     return $mgr->editor->create_acq_purchase_order($po);
 481 }
 482
 483
 484 # ----------------------------------------------------------------------------
 485 # Bib, Callnumber, and Copy data
 486 # ----------------------------------------------------------------------------
 487
 488 sub create_lineitem_assets {
 489     my($mgr, $li_id) = @_;
 490     my $evt;
 491
 492     my $li = $mgr->editor->retrieve_acq_lineitem([
 493         $li_id,
 494         {   flesh => 1,
 495             flesh_fields => {jub => ['purchase_order', 'attributes']}
 496         }
 497     ]) or return 0;
 498
 499     # -----------------------------------------------------------------
 500     # first, create the bib record if necessary
 501     # -----------------------------------------------------------------
 502     unless($li->eg_bib_id) {
 503         create_bib($mgr, $li) or return 0;
 504     }
 505
 506     my $li_details = $mgr->editor->search_acq_lineitem_detail({lineitem => $li_id}, {idlist=>1});
 507
 508     # -----------------------------------------------------------------
 509     # for each lineitem_detail, create the volume if necessary, create
 510     # a copy, and link them all together.
 511     # -----------------------------------------------------------------
 512     for my $lid_id (@{$li_details}) {
 513
 514         my $lid = $mgr->editor->retrieve_acq_lineitem_detail($lid_id) or return 0;
 515         next if $lid->eg_copy_id;
 516
 517         my $org = $lid->owning_lib;
 518         my $label = $lid->cn_label;
 519         my $bibid = $li->eg_bib_id;
 520
 521         my $volume = $mgr->cache($org, "cn.$bibid.$label");
 522         unless($volume) {
 523             $volume = create_volume($mgr, $li, $lid) or return 0;
 524             $mgr->cache($org, "cn.$bibid.$label", $volume);
 525         }
 526         create_copy($mgr, $volume, $lid) or return 0;
 527     }
 528
 529     return 1;
 530 }
 531
 532 sub create_bib {
 533     my($mgr, $li) = @_;
 534
 535     my $record = OpenILS::Application::Cat::BibCommon->biblio_record_xml_import(
 536         $mgr->editor, $li->marc, undef, undef, 1); #$rec->bib_source
 537
 538     if($U->event_code($record)) {
 539         $mgr->editor->event($record);
 540         $mgr->editor->rollback;
 541         return 0;
 542     }
 543
 544     $li->eg_bib_id($record->id);
 545     return update_lineitem($mgr, $li);
 546 }
 547
 548 sub create_volume {
 549     my($mgr, $li, $lid) = @_;
 550
 551     my ($volume, $evt) =
 552         OpenILS::Application::Cat::AssetCommon->find_or_create_volume(
 553             $mgr->editor,
 554             $lid->cn_label,
 555             $li->eg_bib_id,
 556             $lid->owning_lib
 557         );
 558
 559     if($evt) {
 560         $mgr->editor->event($evt);
 561         return 0;
 562     }
 563
 564     return $volume;
 565 }
 566
 567 sub create_copy {
 568     my($mgr, $volume, $lid) = @_;
 569     my $copy = Fieldmapper::asset::copy->new;
 570     $copy->isnew(1);
 571     $copy->loan_duration(2);
 572     $copy->fine_level(2);
 573     $copy->status(OILS_COPY_STATUS_ON_ORDER);
 574     $copy->barcode($lid->barcode);
 575     $copy->location($lid->location);
 576     $copy->call_number($volume->id);
 577     $copy->circ_lib($volume->owning_lib);
 578     $copy->circ_modifier($lid->circ_modifier);
 579
 580     my $evt = OpenILS::Application::Cat::AssetCommon->create_copy($mgr->editor, $volume, $copy);
 581     if($evt) {
 582         $mgr->editor->event($evt);
 583         return 0;
 584     }
 585
 586     $mgr->add_copy;
 587     $lid->eg_copy_id($copy->id);
 588     $mgr->editor->update_acq_lineitem_detail($lid) or return 0;
 589 }
 590
 591
 592
 593
 594
 595
 596 # ----------------------------------------------------------------------------
 597 # Workflow: Build a selection list from a Z39.50 search
 598 # ----------------------------------------------------------------------------
 599
 600 __PACKAGE__->register_method(
 601         method => 'zsearch',
 602         api_name => 'open-ils.acq.picklist.search.z3950',
 603     stream => 1,
 604         signature => {
 605         desc => 'Performs a z3950 federated search and creates a picklist and associated lineitems',
 606         params => [
 607             {desc => 'Authentication token', type => 'string'},
 608             {desc => 'Search definition', type => 'object'},
 609             {desc => 'Picklist name, optional', type => 'string'},
 610         ]
 611     }
 612 );
 613
 614 sub zsearch {
 615     my($self, $conn, $auth, $search, $name, $options) = @_;
 616     my $e = new_editor(authtoken=>$auth);
 617     return $e->event unless $e->checkauth;
 618     return $e->event unless $e->allowed('CREATE_PICKLIST');
 619
 620     $search->{limit} ||= 10;
 621     $options ||= {};
 622
 623     my $ses = OpenSRF::AppSession->create('open-ils.search');
 624     my $req = $ses->request('open-ils.search.z3950.search_class', $auth, $search);
 625
 626     my $first = 1;
 627     my $picklist;
 628     my $mgr;
 629     while(my $resp = $req->recv(timeout=>60)) {
 630
 631         if($first) {
 632             my $e = new_editor(requestor=>$e->requestor, xact=>1);
 633             $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
 634             $picklist = zsearch_build_pl($mgr, $name);
 635             $first = 0;
 636         }
 637
 638         my $result = $resp->content;
 639         my $count = $result->{count};
 640         $mgr->total( (($count < $search->{limit}) ? $count : $search->{limit})+1 );
 641
 642         for my $rec (@{$result->{records}}) {
 643
 644             my $li = create_lineitem($mgr,
 645                 picklist => $picklist->id,
 646                 source_label => $result->{service},
 647                 marc => $rec->{marcxml},
 648                 eg_bib_id => $rec->{bibid}
 649             );
 650
 651             if($$options{respond_li}) {
 652                 $li->attributes($mgr->editor->search_acq_lineitem_attr({lineitem => $li->id}))
 653                     if $$options{flesh_attrs};
 654                 $li->clear_marc if $$options{clear_marc};
 655                 $mgr->respond(lineitem => $li);
 656             } else {
 657                 $mgr->respond;
 658             }
 659         }
 660     }
 661
 662     $mgr->editor->commit;
 663     return $mgr->respond_complete;
 664 }
 665
 666 sub zsearch_build_pl {
 667     my($mgr, $name) = @_;
 668     $name ||= '';
 669
 670     my $picklist = $mgr->editor->search_acq_picklist({
 671         owner => $mgr->editor->requestor->id,
 672         name => $name
 673     })->[0];
 674
 675     if($name eq '' and $picklist) {
 676         return 0 unless delete_picklist($mgr, $picklist);
 677         $picklist = undef;
 678     }
 679
 680     return update_picklist($mgr, $picklist) if $picklist;
 681     return create_picklist($mgr, name => $name);
 682 }
 683
 684
 685 # ----------------------------------------------------------------------------
 686 # Workflow: Build a selection list / PO by importing a batch of MARC records
 687 # ----------------------------------------------------------------------------
 688
 689 __PACKAGE__->register_method(
 690     method => 'upload_records',
 691     api_name => 'open-ils.acq.process_upload_records',
 692     stream => 1,
 693 );
 694
 695 sub upload_records {
 696     my($self, $conn, $auth, $key) = @_;
 697
 698         my $e = new_editor(authtoken => $auth, xact => 1);
 699     return $e->die_event unless $e->checkauth;
 700
 701     my $mgr = OpenILS::Application::Acq::BatchManager->new(
 702         editor => $e,
 703         conn => $conn,
 704         throttle => 5
 705     );
 706
 707     my $cache = OpenSRF::Utils::Cache->new;
 708
 709     my $data = $cache->get_cache("vandelay_import_spool_$key");
 710         my $purpose = $data->{purpose};
 711     my $filename = $data->{path};
 712     my $provider = $data->{provider};
 713     my $picklist = $data->{picklist};
 714     my $create_po = $data->{create_po};
 715     my $ordering_agency = $data->{ordering_agency};
 716     my $create_assets = $data->{create_assets};
 717     my $po;
 718     my $evt;
 719
 720     unless(-r $filename) {
 721         $logger->error("unable to read MARC file $filename");
 722         $e->rollback;
 723         return OpenILS::Event->new('FILE_UPLOAD_ERROR', payload => {filename => $filename});
 724     }
 725
 726     $provider = $e->retrieve_acq_provider($provider) or return $e->die_event;
 727
 728     if($picklist) {
 729         $picklist = $e->retrieve_acq_picklist($picklist) or return $e->die_event;
 730         if($picklist->owner != $e->requestor->id) {
 731             return $e->die_event unless
 732                 $e->allowed('CREATE_PICKLIST', $picklist->org_unit, $picklist);
 733         }
 734     }
 735
 736     if($create_po) {
 737         $po = create_purchase_order($mgr,
 738             ordering_agency => $ordering_agency,
 739             provider => $provider->id
 740         ) or return $mgr->editor->die_event;
 741     }
 742
 743     $logger->info("acq processing MARC file=$filename");
 744
 745     my $marctype = 'USMARC'; # ?
 746         my $batch = new MARC::Batch ($marctype, $filename);
 747         $batch->strict_off;
 748
 749         my $count = 0;
 750
 751         while(1) {
 752
 753             my $err;
 754         my $xml;
 755                 $count++;
 756         my $r;
 757
 758                 try {
 759             $r = $batch->next;
 760         } catch Error with {
 761             $err = shift;
 762                         $logger->warn("Proccessing of record $count in set $key failed with error $err.  Skipping this record");
 763         };
 764
 765         next if $err;
 766         last unless $r;
 767
 768                 try {
 769             ($xml = $r->as_xml_record()) =~ s/\n//sog;
 770             $xml =~ s/^<\?xml.+\?\s*>//go;
 771             $xml =~ s/>\s+</></go;
 772             $xml =~ s/\p{Cc}//go;
 773             $xml = $U->entityize($xml);
 774             $xml =~ s/[\x00-\x1f]//go;
 775
 776                 } catch Error with {
 777                         $err = shift;
 778                         $logger->warn("Proccessing XML of record $count in set $key failed with error $err.  Skipping this record");
 779                 };
 780
 781         next if $err or not $xml;
 782
 783         my %args = (
 784             source_label => $provider->code,
 785             provider => $provider->id,
 786             marc => $xml,
 787         );
 788
 789         $args{picklist} = $picklist->id if $picklist;
 790         if($po) {
 791             $args{purchase_order} = $po->id;
 792             $args{state} = 'on-order';
 793         }
 794
 795         my $li = create_lineitem($mgr, %args) or return $mgr->editor->die_event;
 796         $mgr->respond;
 797         $li->provider($provider); # flesh it, we'll need it later
 798
 799         import_lineitem_details($mgr, $ordering_agency, $li) or return $mgr->editor->die_event;
 800         $mgr->respond;
 801
 802         if($create_assets) {
 803             create_lineitem_assets($mgr, $li->id) or return $mgr->editor->die_event;
 804         }
 805
 806         $mgr->respond;
 807         }
 808
 809         $e->commit;
 810     unlink($filename);
 811     $cache->delete_cache('vandelay_import_spool_' . $key);
 812
 813     return $mgr->respond_complete;
 814 }
 815
 816 sub import_lineitem_details {
 817     my($mgr, $ordering_agency, $li) = @_;
 818
 819     my $holdings = $mgr->editor->json_query({from => ['acq.extract_provider_holding_data', $li->id]});
 820     return 1 unless @$holdings;
 821     my $org_path = $U->get_org_ancestors($ordering_agency);
 822     $org_path = [ reverse (@$org_path) ];
 823     my $price;
 824
 825     my $idx = 1;
 826     while(1) {
 827         # create a lineitem detail for each copy in the data
 828
 829         my $compiled = extract_lineitem_detail_data($mgr, $org_path, $holdings, $idx);
 830         last unless defined $compiled;
 831         return 0 unless $compiled;
 832
 833         # this takes the price of the last copy and uses it as the lineitem price
 834         # need to determine if a given record would include different prices for the same item
 835         $price = $$compiled{price};
 836
 837         for(1..$$compiled{quantity}) {
 838             my $lid = create_lineitem_detail($mgr,
 839                 lineitem => $li->id,
 840                 owning_lib => $$compiled{owning_lib},
 841                 cn_label => $$compiled{call_number},
 842                 fund => $$compiled{fund},
 843                 circ_modifier => $$compiled{circ_modifier},
 844                 note => $$compiled{note},
 845                 location => $$compiled{copy_location}
 846             ) or return 0;
 847         }
 848
 849         $mgr->respond;
 850         $idx++;
 851     }
 852
 853     # set the price attr so we'll know the source of the price
 854     set_lineitem_attr(
 855         $mgr,
 856         attr_name => 'estimated_price',
 857         attr_type => 'lineitem_local_attr_definition',
 858         attr_value => $price,
 859         lineitem => $li->id
 860     ) or return 0;
 861
 862     # if we're creating a purchase order, create the debits
 863     if($li->purchase_order) {
 864         create_lineitem_debits($mgr, $li, $price, 2) or return 0;
 865         $mgr->respond;
 866     }
 867
 868     return 1;
 869 }
 870
 871 # return hash on success, 0 on error, undef on no more holdings
 872 sub extract_lineitem_detail_data {
 873     my($mgr, $org_path, $holdings, $index) = @_;
 874
 875     my @data_list = grep { $_->{holding} eq $index } @$holdings;
 876     return undef unless @data_list;
 877
 878     my %compiled = map { $_->{attr} => $_->{data} } @data_list;
 879     my $base_org = $$org_path[0];
 880
 881     my $killme = sub {
 882         my $msg = shift;
 883         $logger->error("Item import extraction error: $msg");
 884         $logger->error('Holdings Data: ' . OpenSRF::Utils::JSON->perl2JSON(\%compiled));
 885         $mgr->editor->rollback;
 886         $mgr->editor->event(OpenILS::Event->new('ACQ_IMPORT_ERROR', payload => $msg));
 887         return 0;
 888     };
 889
 890     $compiled{quantity} ||= 1;
 891
 892     # ---------------------------------------------------------------------
 893     # Fund
 894     my $code = $compiled{fund_code};
 895     return $killme->('no fund code provided') unless $code;
 896
 897     my $fund = $mgr->cache($base_org, "fund.$code");
 898     unless($fund) {
 899         # search up the org tree for the most appropriate fund
 900         for my $org (@$org_path) {
 901             $fund = $mgr->editor->search_acq_fund(
 902                 {org => $org, code => $code, year => DateTime->now->year}, {idlist => 1})->[0];
 903             last if $fund;
 904         }
 905     }
 906     return $killme->("no fund with code $code at orgs [@$org_path]") unless $fund;
 907     $compiled{fund} = $fund;
 908     $mgr->cache($base_org, "fund.$code", $fund);
 909
 910
 911     # ---------------------------------------------------------------------
 912     # Owning lib
 913     my $sn = $compiled{owning_lib};
 914     return $killme->('no owning_lib defined') unless $sn;
 915     my $org_id =
 916         $mgr->cache($base_org, "orgsn.$sn") ||
 917             $mgr->editor->search_actor_org_unit({shortname => $sn}, {idlist => 1})->[0];
 918     return $killme->("invalid owning_lib defined: $sn") unless $org_id;
 919     $compiled{owning_lib} = $org_id;
 920     $mgr->cache($$org_path[0], "orgsn.$sn", $org_id);
 921
 922
 923     # ---------------------------------------------------------------------
 924     # Circ Modifier
 925     my $mod;
 926     $code = $compiled{circ_modifier};
 927
 928     if($code) {
 929
 930         $mod = $mgr->cache($base_org, "mod.$code") ||
 931             $mgr->editor->retrieve_config_circ_modifier($code);
 932         return $killme->("invlalid circ_modifier $code") unless $mod;
 933         $mgr->cache($base_org, "mod.$code", $mod);
 934
 935     } else {
 936         # try the default
 937         $mod = get_default_circ_modifier($mgr, $base_org)
 938             or return $killme->('no circ_modifier defined');
 939     }
 940
 941     $compiled{circ_modifier} = $mod;
 942
 943
 944     # ---------------------------------------------------------------------
 945     # Shelving Location
 946     my $name = $compiled{copy_location};
 947     return $killme->('no copy_location defined') unless $name;
 948     my $loc = $mgr->cache($base_org, "copy_loc.$name");
 949     unless($loc) {
 950         for my $org (@$org_path) {
 951             $loc = $mgr->editor->search_asset_copy_location(
 952                 {owning_lib => $org, name => $name}, {idlist => 1})->[0];
 953             last if $loc;
 954         }
 955     }
 956     return $killme->("Invalid copy location $name") unless $loc;
 957     $compiled{copy_location} = $loc;
 958     $mgr->cache($base_org, "copy_loc.$name", $loc);
 959
 960     return \%compiled;
 961 }
 962
 963
 964
 965 # ----------------------------------------------------------------------------
 966 # Workflow: Given an existing purchase order, import/create the bibs,
 967 # callnumber and copy objects
 968 # ----------------------------------------------------------------------------
 969
 970 __PACKAGE__->register_method(
 971         method => 'create_po_assets',
 972         api_name        => 'open-ils.acq.purchase_order.assets.create',
 973         signature => {
 974         desc => q/Creates assets for each lineitem in the purchase order/,
 975         params => [
 976             {desc => 'Authentication token', type => 'string'},
 977             {desc => 'The purchase order id', type => 'number'},
 978         ],
 979         return => {desc => 'Streams a total versus completed counts object, event on error'}
 980     }
 981 );
 982
 983 sub create_po_assets {
 984     my($self, $conn, $auth, $po_id) = @_;
 985     my $e = new_editor(authtoken=>$auth, xact=>1);
 986     return $e->die_event unless $e->checkauth;
 987
 988     my $mgr = OpenILS::Application::Acq::BatchManager->new(
 989         editor => $e,
 990         conn => $conn,
 991         throttle => 5
 992     );
 993
 994     my $po = $e->retrieve_acq_purchase_order($po_id) or return $e->die_event;
 995     return $e->die_event unless $e->allowed('IMPORT_PURCHASE_ORDER_ASSETS', $po->ordering_agency);
 996
 997     my $li_ids = $e->search_acq_lineitem({purchase_order => $po_id}, {idlist => 1});
 998
 999     # it's ugly, but it's fast.  Get the total count of lineitem detail objects to process
1000     my $lid_total = $e->json_query({
1001         select => { acqlid => [{aggregate => 1, transform => 'count', column => 'id'}] },
1002         from => {
1003             acqlid => {
1004                 jub => {
1005                     fkey => 'lineitem',
1006                     field => 'id',
1007                     join => {acqpo => {fkey => 'purchase_order', field => 'id'}}
1008                 }
1009             }
1010         },
1011         where => {'+acqpo' => {id => $po_id}}
1012     })->[0]->{id};
1013
1014     $mgr->total(scalar(@$li_ids) + $lid_total);
1015
1016     for my $li_id (@$li_ids) {
1017         return $e->die_event unless create_lineitem_assets($mgr, $li_id);
1018         $mgr->respond;
1019     }
1020
1021     return $e->die_event unless update_purchase_order($mgr, $po);
1022
1023     $e->commit;
1024     return $mgr->respond_complete;
1025 }
1026
1027
1028 1;