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