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->{purchase_order} = $val if $val;
  52     return $self;
  53 }
  54 sub picklist {
  55     my($self, $val) = @_;
  56     $self->{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     return $picklist if $mgr->editor->update_acq_picklist($picklist);
 421     return undef;
 422 }
 423
 424 sub delete_picklist {
 425     my($mgr, $picklist) = @_;
 426     $picklist = $mgr->editor->retrieve_acq_picklist($picklist) unless ref $picklist;
 427
 428     # delete all 'new' lineitems
 429     my $lis = $mgr->editor->search_acq_lineitem({picklist => $picklist->id, state => 'new'});
 430     for my $li (@$lis) {
 431         return 0 unless delete_lineitem($mgr, $li);
 432     }
 433
 434     # detach all non-'new' lineitems
 435     $lis = $mgr->editor->search_acq_lineitem({picklist => $picklist->id, state => {'!=' => 'new'}});
 436     for my $li (@$lis) {
 437         $li->clear_picklist;
 438         return 0 unless update_lineitem($li);
 439     }
 440
 441     # remove any picklist-specific object perms
 442     my $ops = $mgr->editor->search_permission_usr_object_perm_map({object_type => 'acqpl', object_id => "".$picklist->id});
 443     for my $op (@$ops) {
 444         return 0 unless $mgr->editor->delete_usr_object_perm_map($op);
 445     }
 446
 447     return $mgr->editor->delete_acq_picklist($picklist);
 448 }
 449
 450 # ----------------------------------------------------------------------------
 451 # Purchase Order
 452 # ----------------------------------------------------------------------------
 453 sub update_purchase_order {
 454     my($mgr, $po) = @_;
 455     $po = $mgr->editor->retrieve_acq_purchase_order($po) unless ref $po;
 456     $po->editor($mgr->editor->requestor->id);
 457     $po->edit_date('now');
 458     return $po if $mgr->editor->update_acq_purchase_order($po);
 459     return undef;
 460 }
 461
 462 sub create_purchase_order {
 463     my($mgr, %args) = @_;
 464     my $po = Fieldmapper::acq::purchase_order->new;
 465     $po->creator($mgr->editor->requestor->id);
 466     $po->editor($mgr->editor->requestor->id);
 467     $po->owner($mgr->editor->requestor->id);
 468     $po->edit_time('now');
 469     $po->create_time('now');
 470     $po->ordering_agency($mgr->editor->requestor->ws_ou);
 471     $po->$_($args{$_}) for keys %args;
 472     $mgr->purchase_order($po);
 473     return $mgr->editor->create_acq_purchase_order($po);
 474 }
 475
 476
 477 # ----------------------------------------------------------------------------
 478 # Bib, Callnumber, and Copy data
 479 # ----------------------------------------------------------------------------
 480
 481 sub create_lineitem_assets {
 482     my($mgr, $li_id) = @_;
 483     my $evt;
 484
 485     my $li = $mgr->editor->retrieve_acq_lineitem([
 486         $li_id,
 487         {   flesh => 1,
 488             flesh_fields => {jub => ['purchase_order', 'attributes']}
 489         }
 490     ]) or return 0;
 491
 492     # -----------------------------------------------------------------
 493     # first, create the bib record if necessary
 494     # -----------------------------------------------------------------
 495     unless($li->eg_bib_id) {
 496         create_bib($mgr, $li) or return 0;
 497     }
 498
 499     my $li_details = $mgr->editor->search_acq_lineitem_detail({lineitem => $li_id}, {idlist=>1});
 500
 501     # -----------------------------------------------------------------
 502     # for each lineitem_detail, create the volume if necessary, create
 503     # a copy, and link them all together.
 504     # -----------------------------------------------------------------
 505     for my $lid_id (@{$li_details}) {
 506
 507         my $lid = $mgr->editor->retrieve_acq_lineitem_detail($lid_id) or return 0;
 508         my $org = $lid->owning_lib;
 509         my $label = $lid->cn_label;
 510
 511         my $volume = $mgr->cache($org, "cn.$label");
 512         unless($volume) {
 513             $volume = create_volume($mgr, $li, $lid) or return 0;
 514             $mgr->cache($org, "cn.$label", $volume);
 515         }
 516         create_copy($mgr, $volume, $lid) or return 0;
 517     }
 518
 519     return 1;
 520 }
 521
 522 sub create_bib {
 523     my($mgr, $li) = @_;
 524
 525     my $record = OpenILS::Application::Cat::BibCommon->biblio_record_xml_import(
 526         $mgr->editor, $li->marc, undef, undef, 1); #$rec->bib_source
 527
 528     if($U->event_code($record)) {
 529         $mgr->editor->event($record);
 530         $mgr->editor->rollback;
 531         return 0;
 532     }
 533
 534     $li->eg_bib_id($record->id);
 535     return update_lineitem($mgr, $li);
 536 }
 537
 538 sub create_volume {
 539     my($mgr, $li, $lid) = @_;
 540
 541     my ($volume, $evt) =
 542         OpenILS::Application::Cat::AssetCommon->find_or_create_volume(
 543             $mgr->editor,
 544             $lid->cn_label,
 545             $li->eg_bib_id,
 546             $lid->owning_lib
 547         );
 548
 549     if($evt) {
 550         $mgr->editor->event($evt);
 551         return 0;
 552     }
 553
 554     return $volume;
 555 }
 556
 557 sub create_copy {
 558     my($mgr, $volume, $lid) = @_;
 559     my $copy = Fieldmapper::asset::copy->new;
 560     $copy->isnew(1);
 561     $copy->loan_duration(2);
 562     $copy->fine_level(2);
 563     $copy->status(OILS_COPY_STATUS_ON_ORDER);
 564     $copy->barcode($lid->barcode);
 565     $copy->location($lid->location);
 566     $copy->call_number($volume->id);
 567     $copy->circ_lib($volume->owning_lib);
 568     $copy->circ_modifier($lid->circ_modifier);
 569
 570     my $evt = OpenILS::Application::Cat::AssetCommon->create_copy($mgr->editor, $volume, $copy);
 571     if($evt) {
 572         $mgr->editor->event($evt);
 573         return 0;
 574     }
 575
 576     $mgr->add_copy;
 577     $lid->eg_copy_id($copy->id);
 578     $mgr->editor->update_acq_lineitem_detail($lid) or return 0;
 579 }
 580
 581
 582
 583
 584
 585
 586 # ----------------------------------------------------------------------------
 587 # Workflow: Build a selection list from a Z39.50 search
 588 # ----------------------------------------------------------------------------
 589
 590 __PACKAGE__->register_method(
 591         method => 'zsearch',
 592         api_name => 'open-ils.acq.picklist.search.z3950',
 593     stream => 1,
 594         signature => {
 595         desc => 'Performs a z3950 federated search and creates a picklist and associated lineitems',
 596         params => [
 597             {desc => 'Authentication token', type => 'string'},
 598             {desc => 'Search definition', type => 'object'},
 599             {desc => 'Picklist name, optional', type => 'string'},
 600         ]
 601     }
 602 );
 603
 604 sub zsearch {
 605     my($self, $conn, $auth, $search, $name, $options) = @_;
 606     my $e = new_editor(authtoken=>$auth);
 607     return $e->event unless $e->checkauth;
 608     return $e->event unless $e->allowed('CREATE_PICKLIST');
 609
 610     $search->{limit} ||= 10;
 611     $options ||= {};
 612
 613     my $ses = OpenSRF::AppSession->create('open-ils.search');
 614     my $req = $ses->request('open-ils.search.z3950.search_class', $auth, $search);
 615
 616     my $first = 1;
 617     my $picklist;
 618     my $mgr;
 619     while(my $resp = $req->recv(timeout=>60)) {
 620
 621         if($first) {
 622             my $e = new_editor(requestor=>$e->requestor, xact=>1);
 623             $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
 624             $picklist = zsearch_build_pl($mgr, $name);
 625             $first = 0;
 626         }
 627
 628         my $result = $resp->content;
 629         my $count = $result->{count};
 630         $mgr->total( (($count < $search->{limit}) ? $count : $search->{limit})+1 );
 631
 632         for my $rec (@{$result->{records}}) {
 633
 634             my $li = create_lineitem($mgr,
 635                 picklist => $picklist->id,
 636                 source_label => $result->{service},
 637                 marc => $rec->{marcxml},
 638                 eg_bib_id => $rec->{bibid}
 639             );
 640
 641             if($$options{respond_li}) {
 642                 $li->attributes($mgr->editor->search_acq_lineitem_attr({lineitem => $li->id}))
 643                     if $$options{flesh_attrs};
 644                 $li->clear_marc if $$options{clear_marc};
 645                 $mgr->respond(lineitem => $li);
 646             } else {
 647                 $mgr->respond;
 648             }
 649         }
 650     }
 651
 652     $mgr->editor->commit;
 653     return $mgr->respond_complete;
 654 }
 655
 656 sub zsearch_build_pl {
 657     my($mgr, $name) = @_;
 658     $name ||= '';
 659
 660     my $picklist = $mgr->editor->search_acq_picklist({
 661         owner => $mgr->editor->requestor->id,
 662         name => $name
 663     })->[0];
 664
 665     if($name eq '' and $picklist) {
 666         return 0 unless delete_picklist($mgr, $picklist);
 667         $picklist = undef;
 668     }
 669
 670     return update_picklist($mgr, $picklist) if $picklist;
 671     return create_picklist($mgr, name => $name);
 672 }
 673
 674
 675 # ----------------------------------------------------------------------------
 676 # Workflow: Build a selection list / PO by importing a batch of MARC records
 677 # ----------------------------------------------------------------------------
 678
 679 __PACKAGE__->register_method(
 680     method => 'upload_records',
 681     api_name => 'open-ils.acq.process_upload_records',
 682     stream => 1,
 683 );
 684
 685 sub upload_records {
 686     my($self, $conn, $auth, $key) = @_;
 687
 688         my $e = new_editor(authtoken => $auth, xact => 1);
 689     return $e->die_event unless $e->checkauth;
 690
 691     my $mgr = OpenILS::Application::Acq::BatchManager->new(
 692         editor => $e,
 693         conn => $conn,
 694         throttle => 5
 695     );
 696
 697     my $cache = OpenSRF::Utils::Cache->new;
 698
 699     my $data = $cache->get_cache("vandelay_import_spool_$key");
 700         my $purpose = $data->{purpose};
 701     my $filename = $data->{path};
 702     my $provider = $data->{provider};
 703     my $picklist = $data->{picklist};
 704     my $create_po = $data->{create_po};
 705     my $ordering_agency = $data->{ordering_agency};
 706     my $create_assets = $data->{create_assets};
 707     my $po;
 708     my $evt;
 709
 710     unless(-r $filename) {
 711         $logger->error("unable to read MARC file $filename");
 712         $e->rollback;
 713         return OpenILS::Event->new('FILE_UPLOAD_ERROR', payload => {filename => $filename});
 714     }
 715
 716     $provider = $e->retrieve_acq_provider($provider) or return $e->die_event;
 717
 718     if($picklist) {
 719         $picklist = $e->retrieve_acq_picklist($picklist) or return $e->die_event;
 720         if($picklist->owner != $e->requestor->id) {
 721             return $e->die_event unless
 722                 $e->allowed('CREATE_PICKLIST', $picklist->org_unit, $picklist);
 723         }
 724     }
 725
 726     if($create_po) {
 727         $po = create_purchase_order($mgr,
 728             ordering_agency => $ordering_agency,
 729             provider => $provider->id
 730         ) or return $mgr->editor->die_event;
 731     }
 732
 733     $logger->info("acq processing MARC file=$filename");
 734
 735     my $marctype = 'USMARC'; # ?
 736         my $batch = new MARC::Batch ($marctype, $filename);
 737         $batch->strict_off;
 738
 739         my $count = 0;
 740
 741         while(1) {
 742
 743             my $err;
 744         my $xml;
 745                 $count++;
 746         my $r;
 747
 748                 try {
 749             $r = $batch->next;
 750         } catch Error with {
 751             $err = shift;
 752                         $logger->warn("Proccessing of record $count in set $key failed with error $err.  Skipping this record");
 753         };
 754
 755         next if $err;
 756         last unless $r;
 757
 758                 try {
 759             ($xml = $r->as_xml_record()) =~ s/\n//sog;
 760             $xml =~ s/^<\?xml.+\?\s*>//go;
 761             $xml =~ s/>\s+</></go;
 762             $xml =~ s/\p{Cc}//go;
 763             $xml = $U->entityize($xml);
 764             $xml =~ s/[\x00-\x1f]//go;
 765
 766                 } catch Error with {
 767                         $err = shift;
 768                         $logger->warn("Proccessing XML of record $count in set $key failed with error $err.  Skipping this record");
 769                 };
 770
 771         next if $err or not $xml;
 772
 773         my %args = (
 774             source_label => $provider->code,
 775             provider => $provider->id,
 776             marc => $xml,
 777         );
 778
 779         $args{picklist} = $picklist->id if $picklist;
 780         if($po) {
 781             $args{purchase_order} = $po->id;
 782             $args{state} = 'on-order';
 783         }
 784
 785         my $li = create_lineitem($mgr, %args) or return $mgr->editor->die_event;
 786         $mgr->respond;
 787         $li->provider($provider); # flesh it, we'll need it later
 788
 789         import_lineitem_details($mgr, $ordering_agency, $li) or return $mgr->editor->die_event;
 790         $mgr->respond;
 791
 792         if($create_assets) {
 793             create_lineitem_assets($mgr, $li->id) or return $mgr->editor->die_event;
 794         }
 795
 796         $mgr->respond;
 797         }
 798
 799         $e->commit;
 800     unlink($filename);
 801     $cache->delete_cache('vandelay_import_spool_' . $key);
 802
 803     return $mgr->respond_complete;
 804 }
 805
 806 sub import_lineitem_details {
 807     my($mgr, $ordering_agency, $li) = @_;
 808
 809     my $holdings = $mgr->editor->json_query({from => ['acq.extract_provider_holding_data', $li->id]});
 810     return 1 unless @$holdings;
 811     my $org_path = $U->get_org_ancestors($ordering_agency);
 812     $org_path = [ reverse (@$org_path) ];
 813     my $price;
 814
 815     my $idx = 1;
 816     while(1) {
 817         # create a lineitem detail for each copy in the data
 818
 819         my $compiled = extract_lineitem_detail_data($mgr, $org_path, $holdings, $idx);
 820         last unless defined $compiled;
 821         return 0 unless $compiled;
 822
 823         # this takes the price of the last copy and uses it as the lineitem price
 824         # need to determine if a given record would include different prices for the same item
 825         $price = $$compiled{price};
 826
 827         for(1..$$compiled{quantity}) {
 828             my $lid = create_lineitem_detail($mgr,
 829                 lineitem => $li->id,
 830                 owning_lib => $$compiled{owning_lib},
 831                 cn_label => $$compiled{call_number},
 832                 fund => $$compiled{fund},
 833                 circ_modifier => $$compiled{circ_modifier},
 834                 note => $$compiled{note}
 835             ) or return 0;
 836         }
 837
 838         $mgr->respond;
 839         $idx++;
 840     }
 841
 842     # set the price attr so we'll know the source of the price
 843     set_lineitem_attr(
 844         $mgr,
 845         attr_name => 'estimated_price',
 846         attr_type => 'lineitem_provider_attr_definition',
 847         attr_value => $price,
 848         lineitem => $li->id
 849     ) or return 0;
 850
 851     # if we're creating a purchase order, create the debits
 852     if($li->purchase_order) {
 853         create_lineitem_debits($mgr, $li, $price, 2) or return 0;
 854         $mgr->respond;
 855     }
 856
 857     return 1;
 858 }
 859
 860 # return hash on success, 0 on error, undef on no more holdings
 861 sub extract_lineitem_detail_data {
 862     my($mgr, $org_path, $holdings, $index) = @_;
 863
 864     my @data_list = grep { $_->{holding} eq $index } @$holdings;
 865     return undef unless @data_list;
 866
 867     my %compiled = map { $_->{attr} => $_->{data} } @data_list;
 868     my $base_org = $$org_path[0];
 869
 870     my $killme = sub {
 871         my $msg = shift;
 872         $logger->error("Item import extraction error: $msg");
 873         $logger->error("Holdings Data: " . OpenSRF::Utils::JSON->perl2JSON(\%compiled));
 874         $mgr->editor->rollback;
 875         $mgr->editor->event(OpenILS::Event->new('ACQ_IMPORT_ERROR', payload => $msg));
 876         return 0;
 877     };
 878
 879     $compiled{quantity} ||= 1;
 880
 881     # ---------------------------------------------------------------------
 882     # Fund
 883     my $code = $compiled{fund_code};
 884     return $killme->("no fund code provided") unless $code;
 885
 886     my $fund = $mgr->cache($base_org, "fund.$code");
 887     unless($fund) {
 888         # search up the org tree for the most appropriate fund
 889         for my $org (@$org_path) {
 890             $fund = $mgr->editor->search_acq_fund(
 891                 {org => $org, code => $code, year => DateTime->now->year}, {idlist => 1})->[0];
 892             last if $fund;
 893         }
 894     }
 895     return $killme->("no fund with code $code at orgs [@$org_path]") unless $fund;
 896     $compiled{fund} = $fund;
 897     $mgr->cache($base_org, "fund.$code", $fund);
 898
 899
 900     # ---------------------------------------------------------------------
 901     # Owning lib
 902     my $sn = $compiled{owning_lib};
 903     return $killme->("no owning_lib defined") unless $sn;
 904     my $org_id =
 905         $mgr->cache($base_org, "orgsn.$sn") ||
 906             $mgr->editor->search_actor_org_unit({shortname => $sn}, {idlist => 1})->[0];
 907     return $killme->("invalid owning_lib defined: $sn") unless $org_id;
 908     $compiled{owning_lib} = $org_id;
 909     $mgr->cache($$org_path[0], "orgsn.$sn", $org_id);
 910
 911
 912     # ---------------------------------------------------------------------
 913     # Circ Modifier
 914     my $mod;
 915     $code = $compiled{circ_modifier};
 916
 917     if($code) {
 918
 919         $mod = $mgr->cache($base_org, "mod.$code") ||
 920             $mgr->editor->retrieve_config_circ_modifier($code);
 921         return $killme->("invlalid circ_modifier $code") unless $mod;
 922         $mgr->cache($base_org, "mod.$code", $mod);
 923
 924     } else {
 925         # try the default
 926         $mod = get_default_circ_modifier($mgr, $base_org)
 927             or return $killme->("no circ_modifier defined");
 928     }
 929
 930     $compiled{circ_modifier} = $mod;
 931
 932
 933     # ---------------------------------------------------------------------
 934     # Shelving Location
 935     my $name = $compiled{copy_location};
 936     return $killme->("no copy_location defined") unless $name;
 937     my $loc = $mgr->cache($base_org, "copy_loc.$name");
 938     unless($loc) {
 939         for my $org (@$org_path) {
 940             $loc = $mgr->editor->search_asset_copy_location(
 941                 {owning_lib => $org, name => $name}, {idlist => 1})->[0];
 942             last if $loc;
 943         }
 944     }
 945     return $killme->("Invalid copy location $name") unless $loc;
 946     $compiled{copy_location} = $loc;
 947     $mgr->cache($base_org, "copy_loc.$name", $loc);
 948
 949     return \%compiled;
 950 }
 951
 952
 953 1;