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

   1 package OpenILS::Application::Acq::BatchManager;
   2 use OpenILS::Application::Acq::Financials;
   3 use OpenSRF::AppSession;
   4 use OpenSRF::EX qw/:try/;
   5 use strict; use warnings;
   6
   7 sub new {
   8     my($class, %args) = @_;
   9     my $self = bless(\%args, $class);
  10     $self->{args} = {
  11         lid => 0,
  12         li => 0,
  13         vqbr => 0,
  14         copies => 0,
  15         bibs => 0,
  16         progress => 0,
  17         debits_accrued => 0,
  18         purchase_order => undef,
  19         picklist => undef,
  20         complete => 0,
  21         indexed => 0,
  22         queue => undef,
  23         total => 0
  24     };
  25     $self->{cache} = {};
  26     $self->throttle(4) unless $self->throttle;
  27     $self->{post_proc_queue} = [];
  28     $self->{last_respond_progress} = 0;
  29     return $self;
  30 }
  31
  32 sub conn {
  33     my($self, $val) = @_;
  34     $self->{conn} = $val if $val;
  35     return $self->{conn};
  36 }
  37 sub throttle {
  38     my($self, $val) = @_;
  39     $self->{throttle} = $val if $val;
  40     return $self->{throttle};
  41 }
  42 sub respond {
  43     my($self, %other_args) = @_;
  44     if($self->throttle and not %other_args) {
  45         return unless (
  46             ($self->{args}->{progress} - $self->{last_respond_progress}) >= $self->throttle
  47         );
  48     }
  49     $self->conn->respond({ %{$self->{args}}, %other_args });
  50     $self->{last_respond_progress} = $self->{args}->{progress};
  51     $self->throttle($self->throttle * 2) unless $self->throttle >= 256;
  52 }
  53 sub respond_complete {
  54     my($self, %other_args) = @_;
  55     $self->complete;
  56     $self->conn->respond_complete({ %{$self->{args}}, %other_args });
  57     $self->run_post_response_hooks;
  58     return undef;
  59 }
  60
  61 # run the post response hook subs, shifting them off as we go
  62 sub run_post_response_hooks {
  63     my($self) = @_;
  64     (shift @{$self->{post_proc_queue}})->() while @{$self->{post_proc_queue}};
  65 }
  66
  67 # any subs passed to this method will be run after the call to respond_complete
  68 sub post_process {
  69     my($self, $sub) = @_;
  70     push(@{$self->{post_proc_queue}}, $sub);
  71 }
  72
  73 sub total {
  74     my($self, $val) = @_;
  75     $self->{args}->{total} = $val if defined $val;
  76     $self->{args}->{maximum} = $self->{args}->{total};
  77     return $self->{args}->{total};
  78 }
  79 sub purchase_order {
  80     my($self, $val) = @_;
  81     $self->{args}->{purchase_order} = $val if $val;
  82     return $self;
  83 }
  84 sub picklist {
  85     my($self, $val) = @_;
  86     $self->{args}->{picklist} = $val if $val;
  87     return $self;
  88 }
  89 sub add_lid {
  90     my $self = shift;
  91     $self->{args}->{lid} += 1;
  92     $self->{args}->{progress} += 1;
  93     return $self;
  94 }
  95 sub add_li {
  96     my $self = shift;
  97     $self->{args}->{li} += 1;
  98     $self->{args}->{progress} += 1;
  99     return $self;
 100 }
 101 sub add_vqbr {
 102     my $self = shift;
 103     $self->{args}->{vqbr} += 1;
 104     $self->{args}->{progress} += 1;
 105     return $self;
 106 }
 107 sub add_copy {
 108     my $self = shift;
 109     $self->{args}->{copies} += 1;
 110     $self->{args}->{progress} += 1;
 111     return $self;
 112 }
 113 sub add_bib {
 114     my $self = shift;
 115     $self->{args}->{bibs} += 1;
 116     $self->{args}->{progress} += 1;
 117     return $self;
 118 }
 119 sub add_debit {
 120     my($self, $amount) = @_;
 121     $self->{args}->{debits_accrued} += $amount;
 122     $self->{args}->{progress} += 1;
 123     return $self;
 124 }
 125 sub editor {
 126     my($self, $editor) = @_;
 127     $self->{editor} = $editor if defined $editor;
 128     return $self->{editor};
 129 }
 130 sub complete {
 131     my $self = shift;
 132     $self->{args}->{complete} = 1;
 133     return $self;
 134 }
 135
 136 sub cache {
 137     my($self, $org, $key, $val) = @_;
 138     $self->{cache}->{$org} = {} unless $self->{cache}->{org};
 139     $self->{cache}->{$org}->{$key} = $val if defined $val;
 140     return $self->{cache}->{$org}->{$key};
 141 }
 142
 143
 144 package OpenILS::Application::Acq::Order;
 145 use base qw/OpenILS::Application/;
 146 use strict; use warnings;
 147 # ----------------------------------------------------------------------------
 148 # Break up each component of the order process and pieces into managable
 149 # actions that can be shared across different workflows
 150 # ----------------------------------------------------------------------------
 151 use OpenILS::Event;
 152 use OpenSRF::Utils::Logger qw(:logger);
 153 use OpenSRF::Utils::JSON;
 154 use OpenSRF::AppSession;
 155 use OpenILS::Utils::Fieldmapper;
 156 use OpenILS::Utils::CStoreEditor q/:funcs/;
 157 use OpenILS::Utils::Normalize qw/clean_marc/;
 158 use OpenILS::Const qw/:const/;
 159 use OpenSRF::EX q/:try/;
 160 use OpenILS::Application::AppUtils;
 161 use OpenILS::Application::Cat::BibCommon;
 162 use OpenILS::Application::Cat::AssetCommon;
 163 use MARC::Record;
 164 use MARC::Batch;
 165 use MARC::File::XML (BinaryEncoding => 'UTF-8');
 166 use Digest::MD5 qw(md5_hex);
 167 use Data::Dumper;
 168 $Data::Dumper::Indent = 0;
 169 my $U = 'OpenILS::Application::AppUtils';
 170
 171
 172 # ----------------------------------------------------------------------------
 173 # Lineitem
 174 # ----------------------------------------------------------------------------
 175 sub create_lineitem {
 176     my($mgr, %args) = @_;
 177     my $li = Fieldmapper::acq::lineitem->new;
 178     $li->creator($mgr->editor->requestor->id);
 179     $li->selector($li->creator);
 180     $li->editor($li->creator);
 181     $li->create_time('now');
 182     $li->edit_time('now');
 183     $li->state('new');
 184     $li->$_($args{$_}) for keys %args;
 185     $li->clear_id;
 186     $mgr->add_li;
 187     $mgr->editor->create_acq_lineitem($li) or return 0;
 188
 189     unless($li->estimated_unit_price) {
 190         # extract the price from the MARC data
 191         my $price = get_li_price_from_attr($mgr->editor, $li) or return $li;
 192         $li->estimated_unit_price($price);
 193         return update_lineitem($mgr, $li);
 194     }
 195
 196     return $li;
 197 }
 198
 199 sub get_li_price_from_attr {
 200     my($e, $li) = @_;
 201     my $attrs = $li->attributes || $e->search_acq_lineitem_attr({lineitem => $li->id});
 202
 203     for my $attr_type (qw/
 204             lineitem_local_attr_definition
 205             lineitem_prov_attr_definition
 206             lineitem_marc_attr_definition/) {
 207
 208         my ($attr) = grep {
 209             $_->attr_name eq 'estimated_price' and
 210             $_->attr_type eq $attr_type } @$attrs;
 211
 212         return $attr->attr_value if $attr;
 213     }
 214
 215     return undef;
 216 }
 217
 218
 219 sub update_lineitem {
 220     my($mgr, $li) = @_;
 221     $li->edit_time('now');
 222     $li->editor($mgr->editor->requestor->id);
 223     $mgr->add_li;
 224     return $mgr->editor->retrieve_acq_lineitem($mgr->editor->data) if
 225         $mgr->editor->update_acq_lineitem($li);
 226     return undef;
 227 }
 228
 229
 230 # ----------------------------------------------------------------------------
 231 # Create real holds from patron requests for a given lineitem
 232 # ----------------------------------------------------------------------------
 233 sub promote_lineitem_holds {
 234     my($mgr, $li) = @_;
 235
 236     my $requests = $mgr->editor->search_acq_user_request(
 237         { lineitem => $li->id,
 238           '-or' =>
 239             [ { need_before => {'>' => 'now'} },
 240               { need_before => undef }
 241             ]
 242         }
 243     );
 244
 245     for my $request ( @$requests ) {
 246
 247         $request->eg_bib( $li->eg_bib_id );
 248         $mgr->editor->update_acq_user_request( $request ) or return 0;
 249
 250         next unless ($U->is_true( $request->hold ));
 251
 252         my $hold = Fieldmapper::action::hold_request->new;
 253         $hold->usr( $request->usr );
 254         $hold->requestor( $request->usr );
 255         $hold->request_time( $request->request_date );
 256         $hold->pickup_lib( $request->pickup_lib );
 257         $hold->request_lib( $request->pickup_lib );
 258         $hold->selection_ou( $request->pickup_lib );
 259         $hold->phone_notify( $request->phone_notify );
 260         $hold->email_notify( $request->email_notify );
 261         $hold->expire_time( $request->need_before );
 262
 263         if ($request->holdable_formats) {
 264             my $mrm = $mgr->editor->search_metabib_metarecord_source_map( { source => $li->eg_bib_id } )->[0];
 265             if ($mrm) {
 266                 $hold->hold_type( 'M' );
 267                 $hold->holdable_formats( $request->holdable_formats );
 268                 $hold->target( $mrm->metarecord );
 269             }
 270         }
 271
 272         if (!$hold->target) {
 273             $hold->hold_type( 'T' );
 274             $hold->target( $li->eg_bib_id );
 275         }
 276
 277         # if behind-the-desk holds are supported at the
 278         # pickup library, apply the patron default
 279         my $bdous = $U->ou_ancestor_setting_value(
 280             $hold->pickup_lib,
 281             'circ.holds.behind_desk_pickup_supported',
 282             $mgr->editor
 283         );
 284
 285         if ($bdous) {
 286             my $set = $mgr->editor->search_actor_user_setting(
 287                 {usr => $hold->usr, name => 'circ.holds_behind_desk'})->[0];
 288
 289             $hold->behind_desk('t') if $set and
 290                 OpenSRF::Utils::JSON->JSON2perl($set->value);
 291         }
 292
 293         $mgr->editor->create_action_hold_request( $hold ) or return 0;
 294     }
 295
 296     return $li;
 297 }
 298
 299 sub delete_lineitem {
 300     my($mgr, $li) = @_;
 301     $li = $mgr->editor->retrieve_acq_lineitem($li) unless ref $li;
 302
 303     # delete the attached lineitem_details
 304     my $lid_ids = $mgr->editor->search_acq_lineitem_detail({lineitem => $li->id}, {idlist=>1});
 305     for my $lid_id (@$lid_ids) {
 306         return 0 unless delete_lineitem_detail($mgr, $lid_id);
 307     }
 308
 309     $mgr->add_li;
 310     return $mgr->editor->delete_acq_lineitem($li);
 311 }
 312
 313 # begins and commit transactions as it goes
 314 # bib_only exits before creation of copies and callnumbers
 315 sub create_lineitem_list_assets {
 316     my($mgr, $li_ids, $vandelay, $bib_only) = @_;
 317
 318     # Do not create line items if none are specified
 319     return {} unless (scalar(@$li_ids));
 320
 321     if (check_import_li_marc_perms($mgr, $li_ids)) { # event on error
 322         $logger->error("acq-vl: user does not have permission to import acq records");
 323         return undef;
 324     }
 325
 326     my $res = import_li_bibs_via_vandelay($mgr, $li_ids, $vandelay);
 327     return undef unless $res;
 328     return $res if $bib_only;
 329
 330     # create the bibs/volumes/copies for the successfully imported records
 331     for my $li_id (@{$res->{li_ids}}) {
 332         $mgr->editor->xact_begin;
 333         my $data = create_lineitem_assets($mgr, $li_id) or return undef;
 334         $mgr->editor->xact_commit;
 335         $mgr->respond;
 336     }
 337
 338     return $res;
 339 }
 340
 341 sub test_vandelay_import_args {
 342     my $vandelay = shift;
 343     my $q_needed = shift;
 344
 345     # we need valid args and (sometimes) a queue
 346     return 0 unless $vandelay and (
 347         !$q_needed or
 348         $vandelay->{queue_name} or
 349         $vandelay->{existing_queue}
 350     );
 351
 352     # match-based merge/overlay import
 353     return 2 if $vandelay->{merge_profile} and (
 354         $vandelay->{auto_overlay_exact} or
 355         $vandelay->{auto_overlay_1match} or
 356         $vandelay->{auto_overlay_best_match}
 357     );
 358
 359     # no-match import
 360     return 2 if $vandelay->{import_no_match};
 361
 362     return 1; # queue only
 363 }
 364
 365 sub find_or_create_vandelay_queue {
 366     my ($e, $vandelay) = @_;
 367
 368     my $queue;
 369     if (my $name = $vandelay->{queue_name}) {
 370
 371         # first, see if a queue w/ this name already exists
 372         # for this user.  If so, use that instead.
 373
 374         $queue = $e->search_vandelay_bib_queue(
 375             {name => $name, owner => $e->requestor->id})->[0];
 376
 377         if ($queue) {
 378
 379             $logger->info("acq-vl: using existing queue $name");
 380
 381         } else {
 382
 383             $logger->info("acq-vl: creating new vandelay queue $name");
 384
 385             $queue = new Fieldmapper::vandelay::bib_queue;
 386             $queue->name($name);
 387             $queue->queue_type('acq');
 388             $queue->owner($e->requestor->id);
 389             $queue->match_set($vandelay->{match_set} || undef); # avoid ''
 390             $queue = $e->create_vandelay_bib_queue($queue) or return undef;
 391         }
 392
 393     } else {
 394         $queue = $e->retrieve_vandelay_bib_queue($vandelay->{existing_queue})
 395             or return undef;
 396     }
 397
 398     return $queue;
 399 }
 400
 401
 402 sub import_li_bibs_via_vandelay {
 403     my ($mgr, $li_ids, $vandelay) = @_;
 404     my $res = {li_ids => []};
 405     my $e = $mgr->editor;
 406     $e->xact_begin;
 407
 408     my $needs_importing = $e->search_acq_lineitem(
 409         {id => $li_ids, eg_bib_id => undef},
 410         {idlist => 1}
 411     );
 412
 413     if (!@$needs_importing) {
 414         $logger->info("acq-vl: all records already imported.  no Vandelay work to do");
 415         return {li_ids => $li_ids};
 416     }
 417
 418     # see if we have any records that are not yet linked to VL records (i.e.
 419     # not in a queue).  This will tell us if lack of a queue name is an error.
 420     my $non_queued = $e->search_acq_lineitem(
 421         {id => $needs_importing, queued_record => undef},
 422         {idlist => 1}
 423     );
 424
 425     # add the already-imported records to the response list
 426     push(@{$res->{li_ids}}, grep { $_ != @$needs_importing } @$li_ids);
 427
 428     $logger->info("acq-vl: processing recs via Vandelay with args: ".Dumper($vandelay));
 429
 430     my $vl_stat = test_vandelay_import_args($vandelay, scalar(@$non_queued));
 431     if ($vl_stat == 0) {
 432         $logger->error("acq-vl: invalid vandelay arguments for acq import (queue needed)");
 433         return $res;
 434     }
 435
 436     my $queue;
 437     if (@$non_queued) {
 438         # when any non-queued lineitems exist, their vandelay counterparts
 439         # require a place to live.
 440         $queue = find_or_create_vandelay_queue($e, $vandelay) or return $res;
 441
 442     } else {
 443         # if all lineitems are already queued, the queue reported to the user
 444         # is purely for information / convenience.  pick a random queue.
 445         $queue = $e->retrieve_acq_lineitem([
 446             $needs_importing->[0], {
 447                 flesh => 2,
 448                 flesh_fields => {
 449                     jub => ['queued_record'],
 450                     vqbr => ['queue']
 451                 }
 452             }
 453         ])->queued_record->queue;
 454     }
 455
 456     $mgr->{args}->{queue} = $queue;
 457
 458     # load the lineitems into the queue for merge processing
 459     my @vqbr_ids;
 460     my @lis;
 461     for my $li_id (@$needs_importing) {
 462
 463         my $li = $e->retrieve_acq_lineitem($li_id) or return $res;
 464
 465         if ($li->queued_record) {
 466             $logger->info("acq-vl: $li_id already linked to a vandelay record");
 467             push(@vqbr_ids, $li->queued_record);
 468
 469         } else {
 470             $logger->info("acq-vl: creating new vandelay record for lineitem $li_id");
 471
 472             # create a new VL queued record and link it up
 473             my $vqbr = Fieldmapper::vandelay::queued_bib_record->new;
 474             $vqbr->marc($li->marc);
 475             $vqbr->queue($queue->id);
 476             $vqbr->bib_source($vandelay->{bib_source} || undef); # avoid ''
 477             $vqbr = $e->create_vandelay_queued_bib_record($vqbr) or return $res;
 478             push(@vqbr_ids, $vqbr->id);
 479
 480             # tell the acq record which vandelay record it's linked to
 481             $li->queued_record($vqbr->id);
 482             $e->update_acq_lineitem($li) or return $res;
 483         }
 484
 485         $mgr->add_vqbr;
 486         $mgr->respond;
 487         push(@lis, $li);
 488     }
 489
 490     $logger->info("acq-vl: created vandelay records [@vqbr_ids]");
 491
 492     # we have to commit the transaction now since
 493     # vandelay uses its own transactions.
 494     $e->commit;
 495
 496     return $res if $vl_stat == 1; # queue only
 497
 498     # Import the bibs via vandelay.  Note: Vandely will
 499     # update acq.lineitem.eg_bib_id on successful import.
 500
 501     $vandelay->{report_all} = 1;
 502     my $ses = OpenSRF::AppSession->create('open-ils.vandelay');
 503     my $req = $ses->request(
 504         'open-ils.vandelay.bib_record.list.import',
 505         $e->authtoken, \@vqbr_ids, $vandelay);
 506
 507     # pull the responses, noting all that were successfully imported
 508     my @success_lis;
 509     while (my $resp = $req->recv(timeout => 600)) {
 510         my $stat = $resp->content;
 511
 512         if(!$stat or $U->event_code($stat)) { # import failure
 513             $logger->error("acq-vl: error importing vandelay record " . Dumper($stat));
 514             next;
 515         }
 516
 517         # "imported" refers to the vqbr id, not the
 518         # success/failure of the vqbr merge attempt
 519         next unless $stat->{imported};
 520
 521         my ($imported) = grep {$_->queued_record eq $stat->{imported}} @lis;
 522         my $li_id = $imported->id;
 523
 524         if ($stat->{no_import}) {
 525             $logger->info("acq-vl: acq lineitem $li_id did not import");
 526
 527         } else { # successful import
 528
 529             push(@success_lis, $li_id);
 530             $mgr->add_bib;
 531             $mgr->respond;
 532             $logger->info("acq-vl: acq lineitem $li_id successfully merged/imported");
 533         }
 534     }
 535
 536     $ses->kill_me;
 537     $logger->info("acq-vl: successfully imported lineitems [@success_lis]");
 538
 539     # add the successfully imported lineitems to the already-imported lineitems
 540     push (@{$res->{li_ids}}, @success_lis);
 541
 542     return $res;
 543 }
 544
 545 # returns event on error, undef on success
 546 sub check_import_li_marc_perms {
 547     my($mgr, $li_ids) = @_;
 548
 549     # if there are any order records that are not linked to
 550     # in-db bib records, verify staff has perms to import order records
 551     my $order_li = $mgr->editor->search_acq_lineitem(
 552         [{id => $li_ids, eg_bib_id => undef}, {limit => 1}], {idlist => 1})->[0];
 553
 554     if($order_li) {
 555         return $mgr->editor->die_event unless
 556             $mgr->editor->allowed('IMPORT_ACQ_LINEITEM_BIB_RECORD');
 557     }
 558
 559     return undef;
 560 }
 561
 562
 563 # ----------------------------------------------------------------------------
 564 # if all of the lineitem details for this lineitem have
 565 # been received, mark the lineitem as received
 566 # returns 1 on non-received, li on received, 0 on error
 567 # ----------------------------------------------------------------------------
 568
 569 sub describe_affected_po {
 570     my ($e, $po) = @_;
 571
 572     my ($enc, $spent) =
 573         OpenILS::Application::Acq::Financials::build_price_summary(
 574             $e, $po->id
 575         );
 576
 577     +{$po->id => {
 578             "state" => $po->state,
 579             "amount_encumbered" => $enc,
 580             "amount_spent" => $spent
 581         }
 582     };
 583 }
 584
 585 sub check_lineitem_received {
 586     my($mgr, $li_id) = @_;
 587
 588     my $non_recv = $mgr->editor->search_acq_lineitem_detail(
 589         {recv_time => undef, lineitem => $li_id}, {idlist=>1});
 590
 591     return 1 if @$non_recv;
 592
 593     my $li = $mgr->editor->retrieve_acq_lineitem($li_id);
 594     $li->state('received');
 595     return update_lineitem($mgr, $li);
 596 }
 597
 598 sub receive_lineitem {
 599     my($mgr, $li_id, $skip_complete_check) = @_;
 600     my $li = $mgr->editor->retrieve_acq_lineitem($li_id) or return 0;
 601
 602     return 0 unless $li->state eq 'on-order' or $li->state eq 'cancelled'; # sic
 603
 604     $li->clear_cancel_reason; # un-cancel on receive
 605
 606     my $lid_ids = $mgr->editor->search_acq_lineitem_detail(
 607         {lineitem => $li_id, recv_time => undef}, {idlist => 1});
 608
 609     for my $lid_id (@$lid_ids) {
 610        receive_lineitem_detail($mgr, $lid_id, 1) or return 0;
 611     }
 612
 613     $mgr->add_li;
 614     $li->state('received');
 615
 616     $li = update_lineitem($mgr, $li) or return 0;
 617     $mgr->post_process( sub { create_lineitem_status_events($mgr, $li_id, 'aur.received'); });
 618
 619     my $po;
 620     return 0 unless
 621         $skip_complete_check or (
 622             $po = check_purchase_order_received($mgr, $li->purchase_order)
 623         );
 624
 625     my $result = {"li" => {$li->id => {"state" => $li->state}}};
 626     $result->{"po"} = describe_affected_po($mgr->editor, $po) if ref $po;
 627     return $result;
 628 }
 629
 630 sub rollback_receive_lineitem {
 631     my($mgr, $li_id) = @_;
 632     my $li = $mgr->editor->retrieve_acq_lineitem($li_id) or return 0;
 633
 634     my $lid_ids = $mgr->editor->search_acq_lineitem_detail(
 635         {lineitem => $li_id, recv_time => {'!=' => undef}}, {idlist => 1});
 636
 637     for my $lid_id (@$lid_ids) {
 638        rollback_receive_lineitem_detail($mgr, $lid_id, 1) or return 0;
 639     }
 640
 641     $mgr->add_li;
 642     $li->state('on-order');
 643     return update_lineitem($mgr, $li);
 644 }
 645
 646
 647 sub create_lineitem_status_events {
 648     my($mgr, $li_id, $hook) = @_;
 649
 650     my $ses = OpenSRF::AppSession->create('open-ils.trigger');
 651     $ses->connect;
 652     my $user_reqs = $mgr->editor->search_acq_user_request([
 653         {lineitem => $li_id},
 654         {flesh => 1, flesh_fields => {aur => ['usr']}}
 655     ]);
 656
 657     for my $user_req (@$user_reqs) {
 658         my $req = $ses->request('open-ils.trigger.event.autocreate', $hook, $user_req, $user_req->usr->home_ou);
 659         $req->recv;
 660     }
 661
 662     $ses->disconnect;
 663     return undef;
 664 }
 665
 666 # ----------------------------------------------------------------------------
 667 # Lineitem Detail
 668 # ----------------------------------------------------------------------------
 669 sub create_lineitem_detail {
 670     my($mgr, %args) = @_;
 671     my $lid = Fieldmapper::acq::lineitem_detail->new;
 672     $lid->$_($args{$_}) for keys %args;
 673     $lid->clear_id;
 674     $mgr->add_lid;
 675     return $mgr->editor->create_acq_lineitem_detail($lid);
 676 }
 677
 678
 679 # flesh out any required data with default values where appropriate
 680 sub complete_lineitem_detail {
 681     my($mgr, $lid) = @_;
 682     unless($lid->barcode) {
 683         my $pfx = $U->ou_ancestor_setting_value($lid->owning_lib, 'acq.tmp_barcode_prefix') || 'ACQ';
 684         $lid->barcode($pfx.$lid->id);
 685     }
 686
 687     unless($lid->cn_label) {
 688         my $pfx = $U->ou_ancestor_setting_value($lid->owning_lib, 'acq.tmp_callnumber_prefix') || 'ACQ';
 689         $lid->cn_label($pfx.$lid->id);
 690     }
 691
 692     if(!$lid->location and my $loc = $U->ou_ancestor_setting_value($lid->owning_lib, 'acq.default_copy_location')) {
 693         $lid->location($loc);
 694     }
 695
 696     $lid->circ_modifier(get_default_circ_modifier($mgr, $lid->owning_lib))
 697         unless defined $lid->circ_modifier;
 698
 699     $mgr->editor->update_acq_lineitem_detail($lid) or return 0;
 700     return $lid;
 701 }
 702
 703 sub get_default_circ_modifier {
 704     my($mgr, $org) = @_;
 705     my $code = $mgr->cache($org, 'def_circ_mod');
 706     $code = $U->ou_ancestor_setting_value($org, 'acq.default_circ_modifier') unless defined $code;
 707     return $mgr->cache($org, 'def_circ_mod', $code) if defined $code;
 708     return undef;
 709 }
 710
 711 sub delete_lineitem_detail {
 712     my($mgr, $lid) = @_;
 713     $lid = $mgr->editor->retrieve_acq_lineitem_detail($lid) unless ref $lid;
 714     return $mgr->editor->delete_acq_lineitem_detail($lid);
 715 }
 716
 717
 718 sub receive_lineitem_detail {
 719     my($mgr, $lid_id, $skip_complete_check) = @_;
 720     my $e = $mgr->editor;
 721
 722     my $lid = $e->retrieve_acq_lineitem_detail([
 723         $lid_id,
 724         {   flesh => 1,
 725             flesh_fields => {
 726                 acqlid => ['fund_debit']
 727             }
 728         }
 729     ]) or return 0;
 730
 731     return 1 if $lid->recv_time;
 732
 733     # if the LID is marked as canceled, remove the cancel reason,
 734     # and reinstate fund debits where deleted by cancelation.
 735     if ($lid->cancel_reason) {
 736         my $cr = $e->retrieve_acq_cancel_reason($lid->cancel_reason);
 737
 738         if (!$U->is_true($cr->keep_debits)) {
 739             # debits were removed during cancelation.
 740             create_lineitem_detail_debit(
 741                 $mgr, $lid->lineitem, $lid) or return 0;
 742         }
 743         $lid->clear_cancel_reason;
 744     }
 745
 746     $lid->receiver($e->requestor->id);
 747     $lid->recv_time('now');
 748     $e->update_acq_lineitem_detail($lid) or return 0;
 749
 750     if ($lid->eg_copy_id) {
 751         my $copy = $e->retrieve_asset_copy($lid->eg_copy_id) or return 0;
 752         # only update status if it hasn't already been updated
 753         $copy->status(OILS_COPY_STATUS_IN_PROCESS) if $copy->status == OILS_COPY_STATUS_ON_ORDER;
 754         $copy->edit_date('now');
 755         $copy->editor($e->requestor->id);
 756         $copy->creator($e->requestor->id) if $U->ou_ancestor_setting_value(
 757             $e->requestor->ws_ou, 'acq.copy_creator_uses_receiver', $e);
 758         $e->update_asset_copy($copy) or return 0;
 759     }
 760
 761     $mgr->add_lid;
 762
 763     return 1 if $skip_complete_check;
 764
 765     my $li = check_lineitem_received($mgr, $lid->lineitem) or return 0;
 766     return 1 if $li == 1; # li not received
 767
 768     return check_purchase_order_received($mgr, $li->purchase_order) or return 0;
 769 }
 770
 771
 772 sub rollback_receive_lineitem_detail {
 773     my($mgr, $lid_id) = @_;
 774     my $e = $mgr->editor;
 775
 776     my $lid = $e->retrieve_acq_lineitem_detail([
 777         $lid_id,
 778         {   flesh => 1,
 779             flesh_fields => {
 780                 acqlid => ['fund_debit']
 781             }
 782         }
 783     ]) or return 0;
 784
 785     return 1 unless $lid->recv_time;
 786
 787     $lid->clear_receiver;
 788     $lid->clear_recv_time;
 789     $e->update_acq_lineitem_detail($lid) or return 0;
 790
 791     if ($lid->eg_copy_id) {
 792         my $copy = $e->retrieve_asset_copy($lid->eg_copy_id) or return 0;
 793         $copy->status(OILS_COPY_STATUS_ON_ORDER);
 794         $copy->edit_date('now');
 795         $copy->editor($e->requestor->id);
 796         $e->update_asset_copy($copy) or return 0;
 797     }
 798
 799     $mgr->add_lid;
 800     return $lid;
 801 }
 802
 803 # ----------------------------------------------------------------------------
 804 # Lineitem Attr
 805 # ----------------------------------------------------------------------------
 806 sub set_lineitem_attr {
 807     my($mgr, %args) = @_;
 808     my $attr_type = $args{attr_type};
 809
 810     # first, see if it's already set.  May just need to overwrite it
 811     my $attr = $mgr->editor->search_acq_lineitem_attr({
 812         lineitem => $args{lineitem},
 813         attr_type => $args{attr_type},
 814         attr_name => $args{attr_name}
 815     })->[0];
 816
 817     if($attr) {
 818         $attr->attr_value($args{attr_value});
 819         return $attr if $mgr->editor->update_acq_lineitem_attr($attr);
 820         return undef;
 821
 822     } else {
 823
 824         $attr = Fieldmapper::acq::lineitem_attr->new;
 825         $attr->$_($args{$_}) for keys %args;
 826
 827         unless($attr->definition) {
 828             my $find = "search_acq_$attr_type";
 829             my $attr_def_id = $mgr->editor->$find({code => $attr->attr_name}, {idlist=>1})->[0] or return 0;
 830             $attr->definition($attr_def_id);
 831         }
 832         return $mgr->editor->create_acq_lineitem_attr($attr);
 833     }
 834 }
 835
 836 # ----------------------------------------------------------------------------
 837 # Lineitem Debits
 838 # ----------------------------------------------------------------------------
 839 sub create_lineitem_debits {
 840     my ($mgr, $li, $options) = @_;
 841     $options ||= {};
 842     my $dry_run = $options->{dry_run};
 843
 844     unless($li->estimated_unit_price) {
 845         $mgr->editor->event(OpenILS::Event->new('ACQ_LINEITEM_NO_PRICE', payload => $li->id));
 846         $mgr->editor->rollback;
 847         return 0;
 848     }
 849
 850     unless($li->provider) {
 851         $mgr->editor->event(OpenILS::Event->new('ACQ_LINEITEM_NO_PROVIDER', payload => $li->id));
 852         $mgr->editor->rollback;
 853         return 0;
 854     }
 855
 856     my $lid_ids = $mgr->editor->search_acq_lineitem_detail(
 857         {lineitem => $li->id},
 858         {idlist=>1}
 859     );
 860
 861     if (@$lid_ids == 0 and !$options->{zero_copy_activate}) {
 862         $mgr->editor->event(OpenILS::Event->new('ACQ_LINEITEM_NO_COPIES', payload => $li->id));
 863         $mgr->editor->rollback;
 864         return 0;
 865     }
 866
 867     for my $lid_id (@$lid_ids) {
 868
 869         my $lid = $mgr->editor->retrieve_acq_lineitem_detail([
 870             $lid_id,
 871             {   flesh => 1,
 872                 flesh_fields => {acqlid => ['fund']}
 873             }
 874         ]);
 875
 876         create_lineitem_detail_debit($mgr, $li, $lid, $dry_run) or return 0;
 877     }
 878
 879     return 1;
 880 }
 881
 882
 883 # flesh li->provider
 884 # flesh lid->fund
 885 sub create_lineitem_detail_debit {
 886     my ($mgr, $li, $lid, $dry_run, $no_translate) = @_;
 887
 888     # don't create the debit if one already exists
 889     return $mgr->editor->retrieve_acq_fund_debit($lid->fund_debit) if $lid->fund_debit;
 890
 891     my $li_id = ref($li) ? $li->id : $li;
 892
 893     unless(ref $li and ref $li->provider) {
 894        $li = $mgr->editor->retrieve_acq_lineitem([
 895             $li_id,
 896             {   flesh => 1,
 897                 flesh_fields => {jub => ['provider']},
 898             }
 899         ]);
 900     }
 901
 902     if(ref $lid) {
 903         $lid->fund($mgr->editor->retrieve_acq_fund($lid->fund)) unless(ref $lid->fund);
 904     } else {
 905         $lid = $mgr->editor->retrieve_acq_lineitem_detail([
 906             $lid,
 907             {   flesh => 1,
 908                 flesh_fields => {acqlid => ['fund']}
 909             }
 910         ]);
 911     }
 912
 913     unless ($lid->fund) {
 914         $mgr->editor->event(
 915             new OpenILS::Event("ACQ_FUND_NOT_FOUND") # close enough
 916         );
 917         return 0;
 918     }
 919
 920     my $amount = $li->estimated_unit_price;
 921     if($li->provider->currency_type ne $lid->fund->currency_type and !$no_translate) {
 922
 923         # At Fund debit creation time, translate into the currency of the fund
 924         # TODO: org setting to disable automatic currency conversion at debit create time?
 925
 926         $amount = $mgr->editor->json_query({
 927             from => [
 928                 'acq.exchange_ratio',
 929                 $li->provider->currency_type, # source currency
 930                 $lid->fund->currency_type, # destination currency
 931                 $li->estimated_unit_price # source amount
 932             ]
 933         })->[0]->{'acq.exchange_ratio'};
 934     }
 935
 936     my $debit = create_fund_debit(
 937         $mgr,
 938         $dry_run,
 939         fund => $lid->fund->id,
 940         origin_amount => $li->estimated_unit_price,
 941         origin_currency_type => $li->provider->currency_type,
 942         amount => $amount
 943     ) or return 0;
 944
 945     $lid->fund_debit($debit->id);
 946     $lid->fund($lid->fund->id);
 947     $mgr->editor->update_acq_lineitem_detail($lid) or return 0;
 948     return $debit;
 949 }
 950
 951
 952 __PACKAGE__->register_method(
 953     "method" => "fund_exceeds_balance_percent_api",
 954     "api_name" => "open-ils.acq.fund.check_balance_percentages",
 955     "signature" => {
 956         "desc" => q/Determine whether a given fund exceeds its defined
 957             "balance stop and warning percentages"/,
 958         "params" => [
 959             {"desc" => "Authentication token", "type" => "string"},
 960             {"desc" => "Fund ID", "type" => "number"},
 961             {"desc" => "Theoretical debit amount (optional)",
 962                 "type" => "number"}
 963         ],
 964         "return" => {"desc" => q/An array of two values, for stop and warning,
 965             in that order: 1 if fund exceeds that balance percentage, else 0/}
 966     }
 967 );
 968
 969 sub fund_exceeds_balance_percent_api {
 970     my ($self, $conn, $auth, $fund_id, $debit_amount) = @_;
 971
 972     $debit_amount ||= 0;
 973
 974     my $e = new_editor("authtoken" => $auth);
 975     return $e->die_event unless $e->checkauth;
 976
 977     my $fund = $e->retrieve_acq_fund($fund_id) or return $e->die_event;
 978     return $e->die_event unless $e->allowed("VIEW_FUND", $fund->org);
 979
 980     my $result = [
 981         fund_exceeds_balance_percent($fund, $debit_amount, $e, "stop"),
 982         fund_exceeds_balance_percent($fund, $debit_amount, $e, "warning")
 983     ];
 984
 985     $e->disconnect;
 986     return $result;
 987 }
 988
 989 sub fund_exceeds_balance_percent {
 990     my ($fund, $debit_amount, $e, $which) = @_;
 991
 992     my ($method_name, $event_name) = @{{
 993         "warning" => [
 994             "balance_warning_percent", "ACQ_FUND_EXCEEDS_WARN_PERCENT"
 995         ],
 996         "stop" => [
 997             "balance_stop_percent", "ACQ_FUND_EXCEEDS_STOP_PERCENT"
 998         ]
 999     }->{$which}};
1000
1001     if ($fund->$method_name) {
1002         my $balance =
1003             $e->search_acq_fund_combined_balance({"fund" => $fund->id})->[0];
1004         my $allocations =
1005             $e->search_acq_fund_allocation_total({"fund" => $fund->id})->[0];
1006
1007         $balance = ($balance) ? $balance->amount : 0;
1008         $allocations = ($allocations) ? $allocations->amount : 0;
1009
1010         if (
1011             $allocations == 0 || # if no allocations were ever made, assume we have hit the stop percent
1012             ((($allocations - $balance + $debit_amount) / $allocations) * 100) > $fund->$method_name
1013         ) {
1014             $logger->info("fund would hit a limit: " . $fund->id . ", $balance, $debit_amount, $allocations, $method_name");
1015             $e->event(
1016                 new OpenILS::Event(
1017                     $event_name,
1018                     "payload" => {
1019                         "fund" => $fund, "debit_amount" => $debit_amount
1020                     }
1021                 )
1022             );
1023             return 1;
1024         }
1025     }
1026     return 0;
1027 }
1028
1029 # ----------------------------------------------------------------------------
1030 # Fund Debit
1031 # ----------------------------------------------------------------------------
1032 sub create_fund_debit {
1033     my($mgr, $dry_run, %args) = @_;
1034
1035     # Verify the fund is not being spent beyond the hard stop amount
1036     my $fund = $mgr->editor->retrieve_acq_fund($args{fund}) or return 0;
1037
1038     return 0 if
1039         fund_exceeds_balance_percent(
1040             $fund, $args{"amount"}, $mgr->editor, "stop"
1041         );
1042     return 0 if
1043         $dry_run and fund_exceeds_balance_percent(
1044             $fund, $args{"amount"}, $mgr->editor, "warning"
1045         );
1046
1047     my $debit = Fieldmapper::acq::fund_debit->new;
1048     $debit->debit_type('purchase');
1049     $debit->encumbrance('t');
1050     $debit->$_($args{$_}) for keys %args;
1051     $debit->clear_id;
1052     $mgr->add_debit($debit->amount);
1053     return $mgr->editor->create_acq_fund_debit($debit);
1054 }
1055
1056
1057 # ----------------------------------------------------------------------------
1058 # Picklist
1059 # ----------------------------------------------------------------------------
1060 sub create_picklist {
1061     my($mgr, %args) = @_;
1062     my $picklist = Fieldmapper::acq::picklist->new;
1063     $picklist->creator($mgr->editor->requestor->id);
1064     $picklist->owner($picklist->creator);
1065     $picklist->editor($picklist->creator);
1066     $picklist->create_time('now');
1067     $picklist->edit_time('now');
1068     $picklist->org_unit($mgr->editor->requestor->ws_ou);
1069     $picklist->owner($mgr->editor->requestor->id);
1070     $picklist->$_($args{$_}) for keys %args;
1071     $picklist->clear_id;
1072     $mgr->picklist($picklist);
1073     return $mgr->editor->create_acq_picklist($picklist);
1074 }
1075
1076 sub update_picklist {
1077     my($mgr, $picklist) = @_;
1078     $picklist = $mgr->editor->retrieve_acq_picklist($picklist) unless ref $picklist;
1079     $picklist->edit_time('now');
1080     $picklist->editor($mgr->editor->requestor->id);
1081     if ($mgr->editor->update_acq_picklist($picklist)) {
1082         $picklist = $mgr->editor->retrieve_acq_picklist($mgr->editor->data);
1083         $mgr->picklist($picklist);
1084         return $picklist;
1085     } else {
1086         return undef;
1087     }
1088 }
1089
1090 sub delete_picklist {
1091     my($mgr, $picklist) = @_;
1092     $picklist = $mgr->editor->retrieve_acq_picklist($picklist) unless ref $picklist;
1093
1094     # delete all 'new' lineitems
1095     my $li_ids = $mgr->editor->search_acq_lineitem(
1096         {
1097             picklist => $picklist->id,
1098             "-or" => {state => "new", purchase_order => undef}
1099         },
1100         {idlist => 1}
1101     );
1102     for my $li_id (@$li_ids) {
1103         my $li = $mgr->editor->retrieve_acq_lineitem($li_id);
1104         return 0 unless delete_lineitem($mgr, $li);
1105         $mgr->respond;
1106     }
1107
1108     # detach all non-'new' lineitems
1109     $li_ids = $mgr->editor->search_acq_lineitem({picklist => $picklist->id, state => {'!=' => 'new'}}, {idlist => 1});
1110     for my $li_id (@$li_ids) {
1111         my $li = $mgr->editor->retrieve_acq_lineitem($li_id);
1112         $li->clear_picklist;
1113         return 0 unless update_lineitem($mgr, $li);
1114         $mgr->respond;
1115     }
1116
1117     # remove any picklist-specific object perms
1118     my $ops = $mgr->editor->search_permission_usr_object_perm_map({object_type => 'acqpl', object_id => ''.$picklist->id});
1119     for my $op (@$ops) {
1120         return 0 unless $mgr->editor->delete_usr_object_perm_map($op);
1121     }
1122
1123     return $mgr->editor->delete_acq_picklist($picklist);
1124 }
1125
1126 # ----------------------------------------------------------------------------
1127 # Purchase Order
1128 # ----------------------------------------------------------------------------
1129 sub update_purchase_order {
1130     my($mgr, $po) = @_;
1131     $po = $mgr->editor->retrieve_acq_purchase_order($po) unless ref $po;
1132     $po->editor($mgr->editor->requestor->id);
1133     $po->edit_time('now');
1134     $mgr->purchase_order($po);
1135     return $mgr->editor->retrieve_acq_purchase_order($mgr->editor->data)
1136         if $mgr->editor->update_acq_purchase_order($po);
1137     return undef;
1138 }
1139
1140 sub create_purchase_order {
1141     my($mgr, %args) = @_;
1142
1143     # verify the chosen provider is still active
1144     my $provider = $mgr->editor->retrieve_acq_provider($args{provider}) or return 0;
1145     unless($U->is_true($provider->active)) {
1146         $logger->error("provider is not active.  cannot create PO");
1147         $mgr->editor->event(OpenILS::Event->new('ACQ_PROVIDER_INACTIVE'));
1148         return 0;
1149     }
1150
1151     my $po = Fieldmapper::acq::purchase_order->new;
1152     $po->creator($mgr->editor->requestor->id);
1153     $po->editor($mgr->editor->requestor->id);
1154     $po->owner($mgr->editor->requestor->id);
1155     $po->edit_time('now');
1156     $po->create_time('now');
1157     $po->state('pending');
1158     $po->ordering_agency($mgr->editor->requestor->ws_ou);
1159     $po->$_($args{$_}) for keys %args;
1160     $po->clear_id;
1161     $mgr->purchase_order($po);
1162     return $mgr->editor->create_acq_purchase_order($po);
1163 }
1164
1165 # ----------------------------------------------------------------------------
1166 # if all of the lineitems for this PO are received,
1167 # mark the PO as received
1168 # ----------------------------------------------------------------------------
1169 sub check_purchase_order_received {
1170     my($mgr, $po_id) = @_;
1171
1172     my $non_recv_li = $mgr->editor->search_acq_lineitem(
1173         {   purchase_order => $po_id,
1174             state => {'!=' => 'received'}
1175         }, {idlist=>1});
1176
1177     my $po = $mgr->editor->retrieve_acq_purchase_order($po_id);
1178     return $po if @$non_recv_li;
1179
1180     $po->state('received');
1181     return update_purchase_order($mgr, $po);
1182 }
1183
1184
1185 # ----------------------------------------------------------------------------
1186 # Bib, Callnumber, and Copy data
1187 # ----------------------------------------------------------------------------
1188
1189 sub create_lineitem_assets {
1190     my($mgr, $li_id) = @_;
1191     my $evt;
1192
1193     my $li = $mgr->editor->retrieve_acq_lineitem([
1194         $li_id,
1195         {   flesh => 1,
1196             flesh_fields => {jub => ['purchase_order', 'attributes']}
1197         }
1198     ]) or return 0;
1199
1200     # note: at this point, the bib record this LI links to should already be created
1201
1202     # -----------------------------------------------------------------
1203     # The lineitem is going live, promote user request holds to real holds
1204     # -----------------------------------------------------------------
1205     promote_lineitem_holds($mgr, $li) or return 0;
1206
1207     my $li_details = $mgr->editor->search_acq_lineitem_detail({lineitem => $li_id}, {idlist=>1});
1208
1209     # -----------------------------------------------------------------
1210     # for each lineitem_detail, create the volume if necessary, create
1211     # a copy, and link them all together.
1212     # -----------------------------------------------------------------
1213     my $first_cn;
1214     for my $lid_id (@{$li_details}) {
1215
1216         my $lid = $mgr->editor->retrieve_acq_lineitem_detail($lid_id) or return 0;
1217         next if $lid->eg_copy_id;
1218
1219         # use the same callnumber label for all items within this lineitem
1220         $lid->cn_label($first_cn) if $first_cn and not $lid->cn_label;
1221
1222         # apply defaults if necessary
1223         return 0 unless complete_lineitem_detail($mgr, $lid);
1224
1225         $first_cn = $lid->cn_label unless $first_cn;
1226
1227         my $org = $lid->owning_lib;
1228         my $label = $lid->cn_label;
1229         my $bibid = $li->eg_bib_id;
1230
1231         my $volume = $mgr->cache($org, "cn.$bibid.$label");
1232         unless($volume) {
1233             $volume = create_volume($mgr, $li, $lid) or return 0;
1234             $mgr->cache($org, "cn.$bibid.$label", $volume);
1235         }
1236         create_copy($mgr, $volume, $lid, $li) or return 0;
1237     }
1238
1239     return { li => $li };
1240 }
1241
1242 sub create_volume {
1243     my($mgr, $li, $lid) = @_;
1244
1245     my ($volume, $evt) =
1246         OpenILS::Application::Cat::AssetCommon->find_or_create_volume(
1247             $mgr->editor,
1248             $lid->cn_label,
1249             $li->eg_bib_id,
1250             $lid->owning_lib
1251         );
1252
1253     if($evt) {
1254         $mgr->editor->event($evt);
1255         return 0;
1256     }
1257
1258     return $volume;
1259 }
1260
1261 sub create_copy {
1262     my($mgr, $volume, $lid, $li) = @_;
1263     my $copy = Fieldmapper::asset::copy->new;
1264     $copy->isnew(1);
1265     $copy->loan_duration(2);
1266     $copy->fine_level(2);
1267     $copy->status(($lid->recv_time) ? OILS_COPY_STATUS_IN_PROCESS : OILS_COPY_STATUS_ON_ORDER);
1268     $copy->barcode($lid->barcode);
1269     $copy->location($lid->location);
1270     $copy->call_number($volume->id);
1271     $copy->circ_lib($volume->owning_lib);
1272     $copy->circ_modifier($lid->circ_modifier);
1273
1274     # AKA list price.  We might need a $li->list_price field since
1275     # estimated price is not necessarily the same as list price
1276     $copy->price($li->estimated_unit_price);
1277
1278     my $evt = OpenILS::Application::Cat::AssetCommon->create_copy($mgr->editor, $volume, $copy);
1279     if($evt) {
1280         $mgr->editor->event($evt);
1281         return 0;
1282     }
1283
1284     $mgr->add_copy;
1285     $lid->eg_copy_id($copy->id);
1286     $mgr->editor->update_acq_lineitem_detail($lid) or return 0;
1287 }
1288
1289
1290
1291
1292
1293
1294 # ----------------------------------------------------------------------------
1295 # Workflow: Build a selection list from a Z39.50 search
1296 # ----------------------------------------------------------------------------
1297
1298 __PACKAGE__->register_method(
1299     method => 'zsearch',
1300     api_name => 'open-ils.acq.picklist.search.z3950',
1301     stream => 1,
1302     signature => {
1303         desc => 'Performs a z3950 federated search and creates a picklist and associated lineitems',
1304         params => [
1305             {desc => 'Authentication token', type => 'string'},
1306             {desc => 'Search definition', type => 'object'},
1307             {desc => 'Picklist name, optional', type => 'string'},
1308         ]
1309     }
1310 );
1311
1312 sub zsearch {
1313     my($self, $conn, $auth, $search, $name, $options) = @_;
1314     my $e = new_editor(authtoken=>$auth);
1315     return $e->event unless $e->checkauth;
1316     return $e->event unless $e->allowed('CREATE_PICKLIST');
1317
1318     $search->{limit} ||= 10;
1319     $options ||= {};
1320
1321     my $ses = OpenSRF::AppSession->create('open-ils.search');
1322     my $req = $ses->request('open-ils.search.z3950.search_class', $auth, $search);
1323
1324     my $first = 1;
1325     my $picklist;
1326     my $mgr;
1327     while(my $resp = $req->recv(timeout=>60)) {
1328
1329         if($first) {
1330             my $e = new_editor(requestor=>$e->requestor, xact=>1);
1331             $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
1332             $picklist = zsearch_build_pl($mgr, $name);
1333             $first = 0;
1334         }
1335
1336         my $result = $resp->content;
1337         my $count = $result->{count} || 0;
1338         $mgr->total( (($count < $search->{limit}) ? $count : $search->{limit})+1 );
1339
1340         for my $rec (@{$result->{records}}) {
1341
1342             my $li = create_lineitem($mgr,
1343                 picklist => $picklist->id,
1344                 source_label => $result->{service},
1345                 marc => $rec->{marcxml},
1346                 eg_bib_id => $rec->{bibid}
1347             );
1348
1349             if($$options{respond_li}) {
1350                 $li->attributes($mgr->editor->search_acq_lineitem_attr({lineitem => $li->id}))
1351                     if $$options{flesh_attrs};
1352                 $li->clear_marc if $$options{clear_marc};
1353                 $mgr->respond(lineitem => $li);
1354             } else {
1355                 $mgr->respond;
1356             }
1357         }
1358     }
1359
1360     $mgr->editor->commit;
1361     return $mgr->respond_complete;
1362 }
1363
1364 sub zsearch_build_pl {
1365     my($mgr, $name) = @_;
1366     $name ||= '';
1367
1368     my $picklist = $mgr->editor->search_acq_picklist({
1369         owner => $mgr->editor->requestor->id,
1370         name => $name
1371     })->[0];
1372
1373     if($name eq '' and $picklist) {
1374         return 0 unless delete_picklist($mgr, $picklist);
1375         $picklist = undef;
1376     }
1377
1378     return update_picklist($mgr, $picklist) if $picklist;
1379     return create_picklist($mgr, name => $name);
1380 }
1381
1382
1383 # ----------------------------------------------------------------------------
1384 # Workflow: Build a selection list / PO by importing a batch of MARC records
1385 # ----------------------------------------------------------------------------
1386
1387 __PACKAGE__->register_method(
1388     method   => 'upload_records',
1389     api_name => 'open-ils.acq.process_upload_records',
1390     stream   => 1,
1391     max_chunk_count => 1
1392 );
1393
1394 sub upload_records {
1395     my($self, $conn, $auth, $key, $args) = @_;
1396     $args ||= {};
1397
1398     my $e = new_editor(authtoken => $auth, xact => 1);
1399     return $e->die_event unless $e->checkauth;
1400     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
1401
1402     my $cache = OpenSRF::Utils::Cache->new;
1403
1404     my $data = $cache->get_cache("vandelay_import_spool_$key");
1405     my $filename        = $data->{path};
1406     my $provider        = $args->{provider};
1407     my $picklist        = $args->{picklist};
1408     my $create_po       = $args->{create_po};
1409     my $activate_po     = $args->{activate_po};
1410     my $vandelay        = $args->{vandelay};
1411     my $ordering_agency = $args->{ordering_agency} || $e->requestor->ws_ou;
1412     my $fiscal_year     = $args->{fiscal_year};
1413
1414     # if the user provides no fiscal year, find the
1415     # current fiscal year for the ordering agency.
1416     $fiscal_year ||= $U->simplereq(
1417         'open-ils.acq',
1418         'open-ils.acq.org_unit.current_fiscal_year',
1419         $auth,
1420         $ordering_agency
1421     );
1422
1423     my $po;
1424     my $evt;
1425
1426     unless(-r $filename) {
1427         $logger->error("unable to read MARC file $filename");
1428         $e->rollback;
1429         return OpenILS::Event->new('FILE_UPLOAD_ERROR', payload => {filename => $filename});
1430     }
1431
1432     $provider = $e->retrieve_acq_provider($provider) or return $e->die_event;
1433
1434     if($picklist) {
1435         $picklist = $e->retrieve_acq_picklist($picklist) or return $e->die_event;
1436         if($picklist->owner != $e->requestor->id) {
1437             return $e->die_event unless
1438                 $e->allowed('CREATE_PICKLIST', $picklist->org_unit, $picklist);
1439         }
1440         $mgr->picklist($picklist);
1441     }
1442
1443     if($create_po) {
1444         return $e->die_event unless
1445             $e->allowed('CREATE_PURCHASE_ORDER', $ordering_agency);
1446
1447         $po = create_purchase_order($mgr,
1448             ordering_agency => $ordering_agency,
1449             provider => $provider->id,
1450             state => 'pending' # will be updated later if activated
1451         ) or return $mgr->editor->die_event;
1452     }
1453
1454     $logger->info("acq processing MARC file=$filename");
1455
1456     my $batch = new MARC::Batch ('USMARC', $filename);
1457     $batch->strict_off;
1458
1459     my $count = 0;
1460     my @li_list;
1461
1462     while(1) {
1463
1464         my ($err, $xml, $r);
1465         $count++;
1466
1467         try {
1468             $r = $batch->next;
1469         } catch Error with {
1470             $err = shift;
1471             $logger->warn("Proccessing of record $count in set $key failed with error $err.  Skipping this record");
1472         };
1473
1474         next if $err;
1475         last unless $r;
1476
1477         try {
1478             $xml = clean_marc($r);
1479         } catch Error with {
1480             $err = shift;
1481             $logger->warn("Proccessing XML of record $count in set $key failed with error $err.  Skipping this record");
1482         };
1483
1484         next if $err or not $xml;
1485
1486         my %args = (
1487             source_label => $provider->code,
1488             provider => $provider->id,
1489             marc => $xml,
1490         );
1491
1492         $args{picklist} = $picklist->id if $picklist;
1493         if($po) {
1494             $args{purchase_order} = $po->id;
1495             $args{state} = 'pending-order';
1496         }
1497
1498         my $li = create_lineitem($mgr, %args) or return $mgr->editor->die_event;
1499         $mgr->respond;
1500         $li->provider($provider); # flesh it, we'll need it later
1501
1502         import_lineitem_details($mgr, $ordering_agency, $li, $fiscal_year)
1503             or return $mgr->editor->die_event;
1504         $mgr->respond;
1505
1506         push(@li_list, $li->id);
1507         $mgr->respond;
1508     }
1509
1510     if ($po) {
1511         $evt = extract_po_name($mgr, $po, \@li_list);
1512         return $evt if $evt;
1513     }
1514
1515     $e->commit;
1516     unlink($filename);
1517     $cache->delete_cache('vandelay_import_spool_' . $key);
1518
1519     if ($po and $activate_po) {
1520         my $die_event = activate_purchase_order_impl($mgr, $po->id, $vandelay);
1521         return $die_event if $die_event;
1522
1523     } elsif ($vandelay) {
1524         $vandelay->{new_rec_perm} = 'IMPORT_ACQ_LINEITEM_BIB_RECORD_UPLOAD';
1525         create_lineitem_list_assets($mgr, \@li_list, $vandelay,
1526             !$vandelay->{create_assets}) or return $e->die_event;
1527     }
1528
1529     return $mgr->respond_complete;
1530 }
1531
1532 # see if the PO name is encoded in the newly imported records
1533 sub extract_po_name {
1534     my ($mgr, $po, $li_ids) = @_;
1535     my $e = $mgr->editor;
1536
1537     # find the first instance of the name
1538     my $attr = $e->search_acq_lineitem_attr([
1539         {   lineitem => $li_ids,
1540             attr_type => 'lineitem_provider_attr_definition',
1541             attr_name => 'purchase_order'
1542         }, {
1543             order_by => {aqlia => 'id'},
1544             limit => 1
1545         }
1546     ])->[0] or return undef;
1547
1548     my $name = $attr->attr_value;
1549
1550     # see if another PO already has the name, provider, and org
1551     my $existing = $e->search_acq_purchase_order(
1552         {   name => $name,
1553             ordering_agency => $po->ordering_agency,
1554             provider => $po->provider
1555         },
1556         {idlist => 1}
1557     )->[0];
1558
1559     # if a PO exists with the same name (and provider/org)
1560     # tack the po ID into the name to differentiate
1561     $name = sprintf("$name (%s)", $po->id) if $existing;
1562
1563     $logger->info("Extracted PO name: $name");
1564
1565     $po->name($name);
1566     update_purchase_order($mgr, $po) or return $e->die_event;
1567     return undef;
1568 }
1569
1570 sub import_lineitem_details {
1571     my($mgr, $ordering_agency, $li, $fiscal_year) = @_;
1572
1573     my $holdings = $mgr->editor->json_query({from => ['acq.extract_provider_holding_data', $li->id]});
1574     return 1 unless @$holdings;
1575     my $org_path = $U->get_org_ancestors($ordering_agency);
1576     $org_path = [ reverse (@$org_path) ];
1577     my $price;
1578
1579
1580     my $idx = 1;
1581     while(1) {
1582         # create a lineitem detail for each copy in the data
1583
1584         my $compiled = extract_lineitem_detail_data($mgr, $org_path, $holdings, $idx, $fiscal_year);
1585         last unless defined $compiled;
1586         return 0 unless $compiled;
1587
1588         # this takes the price of the last copy and uses it as the lineitem price
1589         # need to determine if a given record would include different prices for the same item
1590         $price = $$compiled{estimated_price};
1591
1592         last unless $$compiled{quantity};
1593
1594         for(1..$$compiled{quantity}) {
1595             my $lid = create_lineitem_detail(
1596                 $mgr,
1597                 lineitem        => $li->id,
1598                 owning_lib      => $$compiled{owning_lib},
1599                 cn_label        => $$compiled{call_number},
1600                 fund            => $$compiled{fund},
1601                 circ_modifier   => $$compiled{circ_modifier},
1602                 note            => $$compiled{note},
1603                 location        => $$compiled{copy_location},
1604                 collection_code => $$compiled{collection_code},
1605                 barcode         => $$compiled{barcode}
1606             ) or return 0;
1607         }
1608
1609         $mgr->respond;
1610         $idx++;
1611     }
1612
1613     $li->estimated_unit_price($price);
1614     update_lineitem($mgr, $li) or return 0;
1615     return 1;
1616 }
1617
1618 # return hash on success, 0 on error, undef on no more holdings
1619 sub extract_lineitem_detail_data {
1620     my($mgr, $org_path, $holdings, $index, $fiscal_year) = @_;
1621
1622     my @data_list = grep { $_->{holding} eq $index } @$holdings;
1623     return undef unless @data_list;
1624
1625     my %compiled = map { $_->{attr} => $_->{data} } @data_list;
1626     my $base_org = $$org_path[0];
1627
1628     my $killme = sub {
1629         my $msg = shift;
1630         $logger->error("Item import extraction error: $msg");
1631         $logger->error('Holdings Data: ' . OpenSRF::Utils::JSON->perl2JSON(\%compiled));
1632         $mgr->editor->rollback;
1633         $mgr->editor->event(OpenILS::Event->new('ACQ_IMPORT_ERROR', payload => $msg));
1634         return 0;
1635     };
1636
1637     # ---------------------------------------------------------------------
1638     # Fund
1639     if(my $code = $compiled{fund_code}) {
1640
1641         my $fund = $mgr->cache($base_org, "fund.$code");
1642         unless($fund) {
1643             # search up the org tree for the most appropriate fund
1644             for my $org (@$org_path) {
1645                 $fund = $mgr->editor->search_acq_fund(
1646                     {org => $org, code => $code, year => $fiscal_year}, {idlist => 1})->[0];
1647                 last if $fund;
1648             }
1649         }
1650         return $killme->("no fund with code $code at orgs [@$org_path]") unless $fund;
1651         $compiled{fund} = $fund;
1652         $mgr->cache($base_org, "fund.$code", $fund);
1653     }
1654
1655
1656     # ---------------------------------------------------------------------
1657     # Owning lib
1658     if(my $sn = $compiled{owning_lib}) {
1659         my $org_id = $mgr->cache($base_org, "orgsn.$sn") ||
1660             $mgr->editor->search_actor_org_unit({shortname => $sn}, {idlist => 1})->[0];
1661         return $killme->("invalid owning_lib defined: $sn") unless $org_id;
1662         $compiled{owning_lib} = $org_id;
1663         $mgr->cache($$org_path[0], "orgsn.$sn", $org_id);
1664     }
1665
1666
1667     # ---------------------------------------------------------------------
1668     # Circ Modifier
1669     my $code = $compiled{circ_modifier};
1670
1671     if(defined $code) {
1672
1673         # verify this is a valid circ modifier
1674         return $killme->("invlalid circ_modifier $code") unless
1675             defined $mgr->cache($base_org, "mod.$code") or
1676             $mgr->editor->retrieve_config_circ_modifier($code);
1677
1678             # if valid, cache for future tests
1679             $mgr->cache($base_org, "mod.$code", $code);
1680
1681     } else {
1682         $compiled{circ_modifier} = get_default_circ_modifier($mgr, $base_org);
1683     }
1684
1685
1686     # ---------------------------------------------------------------------
1687     # Shelving Location
1688     if( my $name = $compiled{copy_location}) {
1689
1690         my $cp_base_org = $base_org;
1691
1692         if ($compiled{owning_lib}) {
1693             # start looking for copy locations at the copy
1694             # owning lib instaed of the upload context org
1695             $cp_base_org = $compiled{owning_lib};
1696         }
1697
1698         my $loc = $mgr->cache($cp_base_org, "copy_loc.$name");
1699         unless($loc) {
1700             my $org = $cp_base_org;
1701             while ($org) {
1702                 $loc = $mgr->editor->search_asset_copy_location(
1703                     {owning_lib => $org, name => $name}, {idlist => 1})->[0];
1704                 last if $loc;
1705                 $org = $mgr->editor->retrieve_actor_org_unit($org)->parent_ou;
1706             }
1707         }
1708         return $killme->("Invalid copy location $name") unless $loc;
1709         $compiled{copy_location} = $loc;
1710         $mgr->cache($cp_base_org, "copy_loc.$name", $loc);
1711     }
1712
1713     return \%compiled;
1714 }
1715
1716
1717
1718 # ----------------------------------------------------------------------------
1719 # Workflow: Given an existing purchase order, import/create the bibs,
1720 # callnumber and copy objects
1721 # ----------------------------------------------------------------------------
1722
1723 __PACKAGE__->register_method(
1724     method => 'create_po_assets',
1725     api_name    => 'open-ils.acq.purchase_order.assets.create',
1726     signature => {
1727         desc => q/Creates assets for each lineitem in the purchase order/,
1728         params => [
1729             {desc => 'Authentication token', type => 'string'},
1730             {desc => 'The purchase order id', type => 'number'},
1731         ],
1732         return => {desc => 'Streams a total versus completed counts object, event on error'}
1733     },
1734     max_chunk_count => 1
1735 );
1736
1737 sub create_po_assets {
1738     my($self, $conn, $auth, $po_id, $args) = @_;
1739     $args ||= {};
1740
1741     my $e = new_editor(authtoken=>$auth, xact=>1);
1742     return $e->die_event unless $e->checkauth;
1743     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
1744
1745     my $po = $e->retrieve_acq_purchase_order($po_id) or return $e->die_event;
1746
1747     my $li_ids = $e->search_acq_lineitem({purchase_order => $po_id}, {idlist => 1});
1748
1749     # it's ugly, but it's fast.  Get the total count of lineitem detail objects to process
1750     my $lid_total = $e->json_query({
1751         select => { acqlid => [{aggregate => 1, transform => 'count', column => 'id'}] },
1752         from => {
1753             acqlid => {
1754                 jub => {
1755                     fkey => 'lineitem',
1756                     field => 'id',
1757                     join => {acqpo => {fkey => 'purchase_order', field => 'id'}}
1758                 }
1759             }
1760         },
1761         where => {'+acqpo' => {id => $po_id}}
1762     })->[0]->{id};
1763
1764     $mgr->total(scalar(@$li_ids) + $lid_total);
1765
1766     create_lineitem_list_assets($mgr, $li_ids, $args->{vandelay})
1767         or return $e->die_event;
1768
1769     $e->xact_begin;
1770     update_purchase_order($mgr, $po) or return $e->die_event;
1771     $e->commit;
1772
1773     return $mgr->respond_complete;
1774 }
1775
1776
1777
1778 __PACKAGE__->register_method(
1779     method    => 'create_purchase_order_api',
1780     api_name  => 'open-ils.acq.purchase_order.create',
1781     signature => {
1782         desc   => 'Creates a new purchase order',
1783         params => [
1784             {desc => 'Authentication token', type => 'string'},
1785             {desc => 'purchase_order to create', type => 'object'}
1786         ],
1787         return => {desc => 'The purchase order id, Event on failure'}
1788     },
1789     max_chunk_count => 1
1790 );
1791
1792 sub create_purchase_order_api {
1793     my($self, $conn, $auth, $po, $args) = @_;
1794     $args ||= {};
1795
1796     my $e = new_editor(xact=>1, authtoken=>$auth);
1797     return $e->die_event unless $e->checkauth;
1798     return $e->die_event unless $e->allowed('CREATE_PURCHASE_ORDER', $po->ordering_agency);
1799     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
1800
1801     # create the PO
1802     my %pargs = (ordering_agency => $e->requestor->ws_ou); # default
1803     $pargs{provider}            = $po->provider            if $po->provider;
1804     $pargs{ordering_agency}     = $po->ordering_agency     if $po->ordering_agency;
1805     $pargs{prepayment_required} = $po->prepayment_required if $po->prepayment_required;
1806     $pargs{name}                = $po->name                 if $po->name;
1807     my $vandelay = $args->{vandelay};
1808
1809     $po = create_purchase_order($mgr, %pargs) or return $e->die_event;
1810
1811     my $li_ids = $$args{lineitems};
1812
1813     if($li_ids) {
1814
1815         for my $li_id (@$li_ids) {
1816
1817             my $li = $e->retrieve_acq_lineitem([
1818                 $li_id,
1819                 {flesh => 1, flesh_fields => {jub => ['attributes']}}
1820             ]) or return $e->die_event;
1821
1822             return $e->die_event(
1823                 new OpenILS::Event(
1824                     "BAD_PARAMS", payload => $li,
1825                         note => "acq.lineitem #" . $li->id .
1826                         ": purchase_order #" . $li->purchase_order
1827                 )
1828             ) if $li->purchase_order;
1829
1830             $li->provider($po->provider);
1831             $li->purchase_order($po->id);
1832             $li->state('pending-order');
1833             update_lineitem($mgr, $li) or return $e->die_event;
1834             $mgr->respond;
1835         }
1836     }
1837
1838     # see if we have a PO name encoded in any of our lineitems
1839     my $evt = extract_po_name($mgr, $po, $li_ids);
1840     return $evt if $evt;
1841
1842     # commit before starting the asset creation
1843     $e->xact_commit;
1844
1845     if($li_ids) {
1846
1847         if ($vandelay) {
1848             create_lineitem_list_assets(
1849                 $mgr, $li_ids, $vandelay, !$$args{create_assets})
1850                 or return $e->die_event;
1851         }
1852
1853         $e->xact_begin;
1854         apply_default_copies($mgr, $po) or return $e->die_event;
1855         $e->xact_commit;
1856     }
1857
1858     return $mgr->respond_complete;
1859 }
1860
1861 # !transaction must be managed by the caller
1862 # creates the default number of copies for each lineitem on the PO.
1863 # when a LI already has copies attached, no default copies are added.
1864 # without li_id, all lineitems are checked/applied
1865 # returns 1 on success, 0 on error
1866 sub apply_default_copies {
1867     my ($mgr, $po, $li_id) = @_;
1868
1869     my $e = $mgr->editor;
1870
1871     my $provider = ref($po->provider) ? $po->provider :
1872         $e->retrieve_acq_provider($po->provider);
1873
1874     my $copy_count = $provider->default_copy_count || return 1;
1875
1876     $logger->info("Applying $copy_count default copies for PO ".$po->id);
1877
1878     my $li_ids = $li_id ? [$li_id] :
1879         $e->search_acq_lineitem({
1880             purchase_order => $po->id,
1881             cancel_reason => undef
1882         },
1883         {idlist => 1}
1884     );
1885
1886     for my $li_id (@$li_ids) {
1887
1888         my $lid_ids = $e->search_acq_lineitem_detail(
1889             {lineitem => $li_id}, {idlist => 1});
1890
1891         # do not apply default copies when copies already exist
1892         next if @$lid_ids;
1893
1894         for (1 .. $copy_count) {
1895             create_lineitem_detail($mgr,
1896                 lineitem => $li_id,
1897                 owning_lib => $e->requestor->ws_ou
1898             ) or return 0;
1899         }
1900     }
1901
1902     return 1;
1903 }
1904
1905
1906
1907 __PACKAGE__->register_method(
1908     method   => 'update_lineitem_fund_batch',
1909     api_name => 'open-ils.acq.lineitem.fund.update.batch',
1910     stream   => 1,
1911     signature => {
1912         desc => q/Given a set of lineitem IDS, updates the fund for all attached lineitem details/
1913     }
1914 );
1915
1916 sub update_lineitem_fund_batch {
1917     my($self, $conn, $auth, $li_ids, $fund_id) = @_;
1918     my $e = new_editor(xact=>1, authtoken=>$auth);
1919     return $e->die_event unless $e->checkauth;
1920     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
1921     for my $li_id (@$li_ids) {
1922         my ($li, $evt) = fetch_and_check_li($e, $li_id, 'write');
1923         return $evt if $evt;
1924         my $li_details = $e->search_acq_lineitem_detail({lineitem => $li_id});
1925         $_->fund($fund_id) and $_->ischanged(1) for @$li_details;
1926         $evt = lineitem_detail_CUD_batch($mgr, $li_details);
1927         return $evt if $evt;
1928         $mgr->add_li;
1929         $mgr->respond;
1930     }
1931     $e->commit;
1932     return $mgr->respond_complete;
1933 }
1934
1935
1936
1937 __PACKAGE__->register_method(
1938     method    => 'lineitem_detail_CUD_batch_api',
1939     api_name  => 'open-ils.acq.lineitem_detail.cud.batch',
1940     stream    => 1,
1941     signature => {
1942         desc   => q/Creates a new purchase order line item detail. / .
1943                   q/Additionally creates the associated fund_debit/,
1944         params => [
1945             {desc => 'Authentication token', type => 'string'},
1946             {desc => 'List of lineitem_details to create', type => 'array'},
1947             {desc => 'Create Debits.  Used for creating post-po-asset-creation debits', type => 'bool'},
1948         ],
1949         return => {desc => 'Streaming response of current position in the array'}
1950     }
1951 );
1952
1953 __PACKAGE__->register_method(
1954     method    => 'lineitem_detail_CUD_batch_api',
1955     api_name  => 'open-ils.acq.lineitem_detail.cud.batch.dry_run',
1956     stream    => 1,
1957     signature => {
1958         desc => q/
1959             Dry run version of open-ils.acq.lineitem_detail.cud.batch.
1960             In dry_run mode, updated fund_debit's the exceed the warning
1961             percent return an event.
1962         /
1963     }
1964 );
1965
1966
1967 sub lineitem_detail_CUD_batch_api {
1968     my($self, $conn, $auth, $li_details, $create_debits) = @_;
1969     my $e = new_editor(xact=>1, authtoken=>$auth);
1970     return $e->die_event unless $e->checkauth;
1971     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
1972     my $dry_run = ($self->api_name =~ /dry_run/o);
1973     my $evt = lineitem_detail_CUD_batch($mgr, $li_details, $create_debits, $dry_run);
1974     return $evt if $evt;
1975     $e->commit;
1976     return $mgr->respond_complete;
1977 }
1978
1979
1980 sub lineitem_detail_CUD_batch {
1981     my($mgr, $li_details, $create_debits, $dry_run) = @_;
1982
1983     $mgr->total(scalar(@$li_details));
1984     my $e = $mgr->editor;
1985
1986     my $li;
1987     my %li_cache;
1988     my $fund_cache = {};
1989     my $evt;
1990
1991     for my $lid (@$li_details) {
1992
1993         unless($li = $li_cache{$lid->lineitem}) {
1994             ($li, $evt) = fetch_and_check_li($e, $lid->lineitem, 'write');
1995             return $evt if $evt;
1996         }
1997
1998         if($lid->isnew) {
1999             $lid = create_lineitem_detail($mgr, %{$lid->to_bare_hash}) or return $e->die_event;
2000             if($create_debits) {
2001                 $li->provider($e->retrieve_acq_provider($li->provider)) or return $e->die_event;
2002                 $lid->fund($e->retrieve_acq_fund($lid->fund)) or return $e->die_event;
2003                 create_lineitem_detail_debit($mgr, $li, $lid, 0, 1) or return $e->die_event;
2004             }
2005
2006         } elsif($lid->ischanged) {
2007             return $evt if $evt = handle_changed_lid($e, $lid, $dry_run, $fund_cache);
2008
2009         } elsif($lid->isdeleted) {
2010             delete_lineitem_detail($mgr, $lid) or return $e->die_event;
2011         }
2012
2013         $mgr->respond(li => $li);
2014         $li_cache{$lid->lineitem} = $li;
2015     }
2016
2017     return undef;
2018 }
2019
2020 sub handle_changed_lid {
2021     my($e, $lid, $dry_run, $fund_cache) = @_;
2022
2023     my $orig_lid = $e->retrieve_acq_lineitem_detail($lid->id) or return $e->die_event;
2024
2025     # updating the fund, so update the debit
2026     if($orig_lid->fund_debit and $orig_lid->fund != $lid->fund) {
2027
2028         my $debit = $e->retrieve_acq_fund_debit($orig_lid->fund_debit);
2029         my $new_fund = $$fund_cache{$lid->fund} =
2030             $$fund_cache{$lid->fund} || $e->retrieve_acq_fund($lid->fund);
2031
2032         # check the thresholds
2033         return $e->die_event if
2034             fund_exceeds_balance_percent($new_fund, $debit->amount, $e, "stop");
2035         return $e->die_event if $dry_run and
2036             fund_exceeds_balance_percent($new_fund, $debit->amount, $e, "warning");
2037
2038         $debit->fund($new_fund->id);
2039         $e->update_acq_fund_debit($debit) or return $e->die_event;
2040     }
2041
2042     $e->update_acq_lineitem_detail($lid) or return $e->die_event;
2043     return undef;
2044 }
2045
2046
2047 __PACKAGE__->register_method(
2048     method   => 'receive_po_api',
2049     api_name => 'open-ils.acq.purchase_order.receive'
2050 );
2051
2052 sub receive_po_api {
2053     my($self, $conn, $auth, $po_id) = @_;
2054     my $e = new_editor(xact => 1, authtoken => $auth);
2055     return $e->die_event unless $e->checkauth;
2056     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
2057
2058     my $po = $e->retrieve_acq_purchase_order($po_id) or return $e->die_event;
2059     return $e->die_event unless $e->allowed('RECEIVE_PURCHASE_ORDER', $po->ordering_agency);
2060
2061     my $li_ids = $e->search_acq_lineitem({purchase_order => $po_id}, {idlist => 1});
2062
2063     for my $li_id (@$li_ids) {
2064         receive_lineitem($mgr, $li_id) or return $e->die_event;
2065         $mgr->respond;
2066     }
2067
2068     $po->state('received');
2069     update_purchase_order($mgr, $po) or return $e->die_event;
2070
2071     $e->commit;
2072     return $mgr->respond_complete;
2073 }
2074
2075
2076 # At the moment there's a lack of parallelism between the receive and unreceive
2077 # API methods for POs and the API methods for LIs and LIDs.  The methods for
2078 # POs stream back objects as they act, whereas the methods for LIs and LIDs
2079 # atomically return an object that describes only what changed (in LIs and LIDs
2080 # themselves or in the objects to which to LIs and LIDs belong).
2081 #
2082 # The methods for LIs and LIDs work the way they do to faciliate the UI's
2083 # maintaining correct information about the state of these things when a user
2084 # wants to receive or unreceive these objects without refreshing their whole
2085 # display.  The UI feature for receiving and un-receiving a whole PO just
2086 # refreshes the whole display, so this absence of parallelism in the UI is also
2087 # relected in this module.
2088 #
2089 # This could be neatened in the future by making POs receive and unreceive in
2090 # the same way the LIs and LIDs do.
2091
2092 __PACKAGE__->register_method(
2093     method => 'receive_lineitem_detail_api',
2094     api_name    => 'open-ils.acq.lineitem_detail.receive',
2095     signature => {
2096         desc => 'Mark a lineitem_detail as received',
2097         params => [
2098             {desc => 'Authentication token', type => 'string'},
2099             {desc => 'lineitem detail ID', type => 'number'}
2100         ],
2101         return => {desc =>
2102             "on success, object describing changes to LID and possibly " .
2103             "to LI and PO; on error, Event"
2104         }
2105     }
2106 );
2107
2108 sub receive_lineitem_detail_api {
2109     my($self, $conn, $auth, $lid_id) = @_;
2110
2111     my $e = new_editor(xact=>1, authtoken=>$auth);
2112     return $e->die_event unless $e->checkauth;
2113     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
2114
2115     my $fleshing = {
2116         "flesh" => 2, "flesh_fields" => {
2117             "acqlid" => ["lineitem"], "jub" => ["purchase_order"]
2118         }
2119     };
2120
2121     my $lid = $e->retrieve_acq_lineitem_detail([$lid_id, $fleshing]);
2122
2123     return $e->die_event unless $e->allowed(
2124         'RECEIVE_PURCHASE_ORDER', $lid->lineitem->purchase_order->ordering_agency);
2125
2126     # update ...
2127     my $recvd = receive_lineitem_detail($mgr, $lid_id) or return $e->die_event;
2128
2129     # .. and re-retrieve
2130     $lid = $e->retrieve_acq_lineitem_detail([$lid_id, $fleshing]);
2131
2132     # Now build result data structure.
2133     my $result = {"lid" => {$lid->id => {"recv_time" => $lid->recv_time}}};
2134
2135     if (ref $recvd) {
2136         if ($recvd->class_name =~ /::purchase_order/) {
2137             $result->{"po"} = describe_affected_po($e, $recvd);
2138             $result->{"li"} = {
2139                 $lid->lineitem->id => {"state" => $lid->lineitem->state}
2140             };
2141         } elsif ($recvd->class_name =~ /::lineitem/) {
2142             $result->{"li"} = {$recvd->id => {"state" => $recvd->state}};
2143         }
2144     }
2145     $result->{"po"} ||=
2146         describe_affected_po($e, $lid->lineitem->purchase_order);
2147
2148     $e->commit;
2149     return $result;
2150 }
2151
2152 __PACKAGE__->register_method(
2153     method => 'receive_lineitem_api',
2154     api_name    => 'open-ils.acq.lineitem.receive',
2155     signature => {
2156         desc => 'Mark a lineitem as received',
2157         params => [
2158             {desc => 'Authentication token', type => 'string'},
2159             {desc => 'lineitem ID', type => 'number'}
2160         ],
2161         return => {desc =>
2162             "on success, object describing changes to LI and possibly PO; " .
2163             "on error, Event"
2164         }
2165     }
2166 );
2167
2168 sub receive_lineitem_api {
2169     my($self, $conn, $auth, $li_id) = @_;
2170
2171     my $e = new_editor(xact=>1, authtoken=>$auth);
2172     return $e->die_event unless $e->checkauth;
2173     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
2174
2175     my $li = $e->retrieve_acq_lineitem([
2176         $li_id, {
2177             flesh => 1,
2178             flesh_fields => {
2179                 jub => ['purchase_order']
2180             }
2181         }
2182     ]) or return $e->die_event;
2183
2184     return $e->die_event unless $e->allowed(
2185         'RECEIVE_PURCHASE_ORDER', $li->purchase_order->ordering_agency);
2186
2187     my $res = receive_lineitem($mgr, $li_id) or return $e->die_event;
2188     $e->commit;
2189     $conn->respond_complete($res);
2190     $mgr->run_post_response_hooks
2191 }
2192
2193
2194 __PACKAGE__->register_method(
2195     method => 'receive_lineitem_batch_api',
2196     api_name    => 'open-ils.acq.lineitem.receive.batch',
2197     stream => 1,
2198     signature => {
2199         desc => 'Mark lineitems as received',
2200         params => [
2201             {desc => 'Authentication token', type => 'string'},
2202             {desc => 'lineitem ID list', type => 'array'}
2203         ],
2204         return => {desc =>
2205             q/On success, stream of objects describing changes to LIs and
2206             possibly PO; onerror, Event.  Any event, even after lots of other
2207             objects, should mean general failure of whole batch operation./
2208         }
2209     }
2210 );
2211
2212 sub receive_lineitem_batch_api {
2213     my ($self, $conn, $auth, $li_idlist) = @_;
2214
2215     return unless ref $li_idlist eq 'ARRAY' and @$li_idlist;
2216
2217     my $e = new_editor(xact => 1, authtoken => $auth);
2218     return $e->die_event unless $e->checkauth;
2219
2220     my $mgr = new OpenILS::Application::Acq::BatchManager(
2221         editor => $e, conn => $conn
2222     );
2223
2224     for my $li_id (map { int $_ } @$li_idlist) {
2225         my $li = $e->retrieve_acq_lineitem([
2226             $li_id, {
2227                 flesh => 1,
2228                 flesh_fields => { jub => ['purchase_order'] }
2229             }
2230         ]) or return $e->die_event;
2231
2232         return $e->die_event unless $e->allowed(
2233             'RECEIVE_PURCHASE_ORDER', $li->purchase_order->ordering_agency
2234         );
2235
2236         receive_lineitem($mgr, $li_id) or return $e->die_event;
2237         $mgr->respond;
2238     }
2239
2240     $e->commit or return $e->die_event;
2241     $mgr->respond_complete;
2242     $mgr->run_post_response_hooks;
2243 }
2244
2245 __PACKAGE__->register_method(
2246     method   => 'rollback_receive_po_api',
2247     api_name => 'open-ils.acq.purchase_order.receive.rollback'
2248 );
2249
2250 sub rollback_receive_po_api {
2251     my($self, $conn, $auth, $po_id) = @_;
2252     my $e = new_editor(xact => 1, authtoken => $auth);
2253     return $e->die_event unless $e->checkauth;
2254     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
2255
2256     my $po = $e->retrieve_acq_purchase_order($po_id) or return $e->die_event;
2257     return $e->die_event unless $e->allowed('RECEIVE_PURCHASE_ORDER', $po->ordering_agency);
2258
2259     my $li_ids = $e->search_acq_lineitem({purchase_order => $po_id}, {idlist => 1});
2260
2261     for my $li_id (@$li_ids) {
2262         rollback_receive_lineitem($mgr, $li_id) or return $e->die_event;
2263         $mgr->respond;
2264     }
2265
2266     $po->state('on-order');
2267     update_purchase_order($mgr, $po) or return $e->die_event;
2268
2269     $e->commit;
2270     return $mgr->respond_complete;
2271 }
2272
2273
2274 __PACKAGE__->register_method(
2275     method    => 'rollback_receive_lineitem_detail_api',
2276     api_name  => 'open-ils.acq.lineitem_detail.receive.rollback',
2277     signature => {
2278         desc   => 'Mark a lineitem_detail as Un-received',
2279         params => [
2280             {desc => 'Authentication token', type => 'string'},
2281             {desc => 'lineitem detail ID', type => 'number'}
2282         ],
2283         return => {desc =>
2284             "on success, object describing changes to LID and possibly " .
2285             "to LI and PO; on error, Event"
2286         }
2287     }
2288 );
2289
2290 sub rollback_receive_lineitem_detail_api {
2291     my($self, $conn, $auth, $lid_id) = @_;
2292
2293     my $e = new_editor(xact=>1, authtoken=>$auth);
2294     return $e->die_event unless $e->checkauth;
2295     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
2296
2297     my $lid = $e->retrieve_acq_lineitem_detail([
2298         $lid_id, {
2299             flesh => 2,
2300             flesh_fields => {
2301                 acqlid => ['lineitem'],
2302                 jub => ['purchase_order']
2303             }
2304         }
2305     ]);
2306     my $li = $lid->lineitem;
2307     my $po = $li->purchase_order;
2308
2309     return $e->die_event unless $e->allowed('RECEIVE_PURCHASE_ORDER', $po->ordering_agency);
2310
2311     my $result = {};
2312
2313     my $recvd = rollback_receive_lineitem_detail($mgr, $lid_id)
2314         or return $e->die_event;
2315
2316     if (ref $recvd) {
2317         $result->{"lid"} = {$recvd->id => {"recv_time" => $recvd->recv_time}};
2318     } else {
2319         $result->{"lid"} = {$lid->id => {"recv_time" => $lid->recv_time}};
2320     }
2321
2322     if ($li->state eq "received") {
2323         $li->state("on-order");
2324         $li = update_lineitem($mgr, $li) or return $e->die_event;
2325         $result->{"li"} = {$li->id => {"state" => $li->state}};
2326     }
2327
2328     if ($po->state eq "received") {
2329         $po->state("on-order");
2330         $po = update_purchase_order($mgr, $po) or return $e->die_event;
2331     }
2332     $result->{"po"} = describe_affected_po($e, $po);
2333
2334     $e->commit and return $result or return $e->die_event;
2335 }
2336
2337 __PACKAGE__->register_method(
2338     method    => 'rollback_receive_lineitem_api',
2339     api_name  => 'open-ils.acq.lineitem.receive.rollback',
2340     signature => {
2341         desc   => 'Mark a lineitem as Un-received',
2342         params => [
2343             {desc => 'Authentication token', type => 'string'},
2344             {desc => 'lineitem ID',          type => 'number'}
2345         ],
2346         return => {desc =>
2347             "on success, object describing changes to LI and possibly PO; " .
2348             "on error, Event"
2349         }
2350     }
2351 );
2352
2353 sub rollback_receive_lineitem_api {
2354     my($self, $conn, $auth, $li_id) = @_;
2355
2356     my $e = new_editor(xact=>1, authtoken=>$auth);
2357     return $e->die_event unless $e->checkauth;
2358     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
2359
2360     my $li = $e->retrieve_acq_lineitem([
2361         $li_id, {
2362             "flesh" => 1, "flesh_fields" => {"jub" => ["purchase_order"]}
2363         }
2364     ]);
2365     my $po = $li->purchase_order;
2366
2367     return $e->die_event unless $e->allowed('RECEIVE_PURCHASE_ORDER', $po->ordering_agency);
2368
2369     $li = rollback_receive_lineitem($mgr, $li_id) or return $e->die_event;
2370
2371     my $result = {"li" => {$li->id => {"state" => $li->state}}};
2372     if ($po->state eq "received") {
2373         $po->state("on-order");
2374         $po = update_purchase_order($mgr, $po) or return $e->die_event;
2375     }
2376     $result->{"po"} = describe_affected_po($e, $po);
2377
2378     $e->commit and return $result or return $e->die_event;
2379 }
2380
2381 __PACKAGE__->register_method(
2382     method    => 'rollback_receive_lineitem_batch_api',
2383     api_name  => 'open-ils.acq.lineitem.receive.rollback.batch',
2384     stream => 1,
2385     signature => {
2386         desc   => 'Mark a list of lineitems as Un-received',
2387         params => [
2388             {desc => 'Authentication token', type => 'string'},
2389             {desc => 'lineitem ID list',     type => 'array'}
2390         ],
2391         return => {desc =>
2392             q/on success, a stream of objects describing changes to LI and
2393             possibly PO; on error, Event. Any event means all previously
2394             returned objects indicate changes that didn't really happen./
2395         }
2396     }
2397 );
2398
2399 sub rollback_receive_lineitem_batch_api {
2400     my ($self, $conn, $auth, $li_idlist) = @_;
2401
2402     return unless ref $li_idlist eq 'ARRAY' and @$li_idlist;
2403
2404     my $e = new_editor(xact => 1, authtoken => $auth);
2405     return $e->die_event unless $e->checkauth;
2406
2407     my $mgr = new OpenILS::Application::Acq::BatchManager(
2408         editor => $e, conn => $conn
2409     );
2410
2411     for my $li_id (map { int $_ } @$li_idlist) {
2412         my $li = $e->retrieve_acq_lineitem([
2413             $li_id, {
2414                 "flesh" => 1,
2415                 "flesh_fields" => {"jub" => ["purchase_order"]}
2416             }
2417         ]);
2418
2419         my $po = $li->purchase_order;
2420
2421         return $e->die_event unless
2422             $e->allowed('RECEIVE_PURCHASE_ORDER', $po->ordering_agency);
2423
2424         $li = rollback_receive_lineitem($mgr, $li_id) or return $e->die_event;
2425
2426         my $result = {"li" => {$li->id => {"state" => $li->state}}};
2427         if ($po->state eq "received") { # should happen first time, not after
2428             $po->state("on-order");
2429             $po = update_purchase_order($mgr, $po) or return $e->die_event;
2430         }
2431         $result->{"po"} = describe_affected_po($e, $po);
2432
2433         $mgr->respond(%$result);
2434     }
2435
2436     $e->commit or return $e->die_event;
2437     $mgr->respond_complete;
2438     $mgr->run_post_response_hooks;
2439 }
2440
2441
2442 __PACKAGE__->register_method(
2443     method    => 'set_lineitem_price_api',
2444     api_name  => 'open-ils.acq.lineitem.price.set',
2445     signature => {
2446         desc   => 'Set lineitem price.  If debits already exist, update them as well',
2447         params => [
2448             {desc => 'Authentication token', type => 'string'},
2449             {desc => 'lineitem ID',          type => 'number'}
2450         ],
2451         return => {desc => 'status blob, Event on error'}
2452     }
2453 );
2454
2455 sub set_lineitem_price_api {
2456     my($self, $conn, $auth, $li_id, $price) = @_;
2457
2458     my $e = new_editor(xact=>1, authtoken=>$auth);
2459     return $e->die_event unless $e->checkauth;
2460     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
2461
2462     my ($li, $evt) = fetch_and_check_li($e, $li_id, 'write');
2463     return $evt if $evt;
2464
2465     $li->estimated_unit_price($price);
2466     update_lineitem($mgr, $li) or return $e->die_event;
2467
2468     my $lid_ids = $e->search_acq_lineitem_detail(
2469         {lineitem => $li_id, fund_debit => {'!=' => undef}},
2470         {idlist => 1}
2471     );
2472
2473     for my $lid_id (@$lid_ids) {
2474
2475         my $lid = $e->retrieve_acq_lineitem_detail([
2476             $lid_id, {
2477             flesh => 1, flesh_fields => {acqlid => ['fund', 'fund_debit']}}
2478         ]);
2479
2480         $lid->fund_debit->amount($price);
2481         $e->update_acq_fund_debit($lid->fund_debit) or return $e->die_event;
2482         $mgr->add_lid;
2483         $mgr->respond;
2484     }
2485
2486     $e->commit;
2487     return $mgr->respond_complete;
2488 }
2489
2490
2491 __PACKAGE__->register_method(
2492     method    => 'clone_picklist_api',
2493     api_name  => 'open-ils.acq.picklist.clone',
2494     signature => {
2495         desc   => 'Clones a picklist, including lineitem and lineitem details',
2496         params => [
2497             {desc => 'Authentication token', type => 'string'},
2498             {desc => 'Picklist ID', type => 'number'},
2499             {desc => 'New Picklist Name', type => 'string'}
2500         ],
2501         return => {desc => 'status blob, Event on error'}
2502     }
2503 );
2504
2505 sub clone_picklist_api {
2506     my($self, $conn, $auth, $pl_id, $name) = @_;
2507
2508     my $e = new_editor(xact=>1, authtoken=>$auth);
2509     return $e->die_event unless $e->checkauth;
2510     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
2511
2512     my $old_pl = $e->retrieve_acq_picklist($pl_id);
2513     my $new_pl = create_picklist($mgr, %{$old_pl->to_bare_hash}, name => $name) or return $e->die_event;
2514
2515     my $li_ids = $e->search_acq_lineitem({picklist => $pl_id}, {idlist => 1});
2516
2517     # get the current user
2518     my $cloner = $mgr->editor->requestor->id;
2519
2520     for my $li_id (@$li_ids) {
2521
2522         # copy the lineitems' MARC
2523         my $marc = ($e->retrieve_acq_lineitem($li_id))->marc;
2524
2525         # create a skeletal clone of the item
2526         my $li = Fieldmapper::acq::lineitem->new;
2527         $li->creator($cloner);
2528         $li->selector($cloner);
2529         $li->editor($cloner);
2530         $li->marc($marc);
2531
2532         my $new_li = create_lineitem($mgr, %{$li->to_bare_hash}, picklist => $new_pl->id) or return $e->die_event;
2533
2534         $mgr->respond;
2535     }
2536
2537     $e->commit;
2538     return $mgr->respond_complete;
2539 }
2540
2541
2542 __PACKAGE__->register_method(
2543     method    => 'merge_picklist_api',
2544     api_name  => 'open-ils.acq.picklist.merge',
2545     signature => {
2546         desc   => 'Merges 2 or more picklists into a single list',
2547         params => [
2548             {desc => 'Authentication token', type => 'string'},
2549             {desc => 'Lead Picklist ID', type => 'number'},
2550             {desc => 'List of subordinate picklist IDs', type => 'array'}
2551         ],
2552         return => {desc => 'status blob, Event on error'}
2553     }
2554 );
2555
2556 sub merge_picklist_api {
2557     my($self, $conn, $auth, $lead_pl, $pl_list) = @_;
2558
2559     my $e = new_editor(xact=>1, authtoken=>$auth);
2560     return $e->die_event unless $e->checkauth;
2561     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
2562
2563     # XXX perms on each picklist modified
2564
2565     $lead_pl = $e->retrieve_acq_picklist($lead_pl) or return $e->die_event;
2566     # point all of the lineitems at the lead picklist
2567     my $li_ids = $e->search_acq_lineitem({picklist => $pl_list}, {idlist => 1});
2568
2569     for my $li_id (@$li_ids) {
2570         my $li = $e->retrieve_acq_lineitem($li_id);
2571         $li->picklist($lead_pl);
2572         update_lineitem($mgr, $li) or return $e->die_event;
2573         $mgr->respond;
2574     }
2575
2576     # now delete the subordinate lists
2577     for my $pl_id (@$pl_list) {
2578         my $pl = $e->retrieve_acq_picklist($pl_id);
2579         $e->delete_acq_picklist($pl) or return $e->die_event;
2580     }
2581
2582     update_picklist($mgr, $lead_pl) or return $e->die_event;
2583
2584     $e->commit;
2585     return $mgr->respond_complete;
2586 }
2587
2588
2589 __PACKAGE__->register_method(
2590     method    => 'delete_picklist_api',
2591     api_name  => 'open-ils.acq.picklist.delete',
2592     signature => {
2593         desc   => q/Deletes a picklist.  It also deletes any lineitems in the "new" state. / .
2594                   q/Other attached lineitems are detached/,
2595         params => [
2596             {desc => 'Authentication token',  type => 'string'},
2597             {desc => 'Picklist ID to delete', type => 'number'}
2598         ],
2599         return => {desc => '1 on success, Event on error'}
2600     }
2601 );
2602
2603 sub delete_picklist_api {
2604     my($self, $conn, $auth, $picklist_id) = @_;
2605     my $e = new_editor(xact=>1, authtoken=>$auth);
2606     return $e->die_event unless $e->checkauth;
2607     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
2608     my $pl = $e->retrieve_acq_picklist($picklist_id) or return $e->die_event;
2609     delete_picklist($mgr, $pl) or return $e->die_event;
2610     $e->commit;
2611     return $mgr->respond_complete;
2612 }
2613
2614
2615
2616 __PACKAGE__->register_method(
2617     method   => 'activate_purchase_order',
2618     api_name => 'open-ils.acq.purchase_order.activate.dry_run'
2619 );
2620
2621 __PACKAGE__->register_method(
2622     method    => 'activate_purchase_order',
2623     api_name  => 'open-ils.acq.purchase_order.activate',
2624     signature => {
2625         desc => q/Activates a purchase order.  This updates the status of the PO / .
2626                 q/and Lineitems to 'on-order'.  Activated PO's are ready for EDI delivery if appropriate./,
2627         params => [
2628             {desc => 'Authentication token', type => 'string'},
2629             {desc => 'Purchase ID', type => 'number'}
2630         ],
2631         return => {desc => '1 on success, Event on error'}
2632     }
2633 );
2634
2635 sub activate_purchase_order {
2636     my($self, $conn, $auth, $po_id, $vandelay, $options) = @_;
2637     $options ||= {};
2638     $$options{dry_run} = ($self->api_name =~ /\.dry_run/) ? 1 : 0;
2639
2640     my $e = new_editor(authtoken=>$auth);
2641     return $e->die_event unless $e->checkauth;
2642     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
2643     my $die_event = activate_purchase_order_impl($mgr, $po_id, $vandelay, $options);
2644     return $e->die_event if $die_event;
2645     $conn->respond_complete(1);
2646     $mgr->run_post_response_hooks unless $$options{dry_run};
2647     return undef;
2648 }
2649
2650 # xacts managed within
2651 sub activate_purchase_order_impl {
2652     my ($mgr, $po_id, $vandelay, $options) = @_;
2653     $options ||= {};
2654     my $dry_run = $$options{dry_run};
2655     my $no_assets = $$options{no_assets};
2656
2657     # read-only until lineitem asset creation
2658     my $e = $mgr->editor;
2659     $e->xact_begin;
2660
2661     my $po = $e->retrieve_acq_purchase_order($po_id) or return $e->die_event;
2662     return $e->die_event unless $e->allowed('CREATE_PURCHASE_ORDER', $po->ordering_agency);
2663
2664     return $e->die_event(OpenILS::Event->new('PO_ALREADY_ACTIVATED'))
2665         if $po->order_date; # PO cannot be re-activated
2666
2667     my $provider = $e->retrieve_acq_provider($po->provider);
2668
2669     # find lineitems and create assets for all
2670
2671     my $query = {
2672         purchase_order => $po_id,
2673         state => [qw/pending-order new order-ready/]
2674     };
2675
2676     my $li_ids = $e->search_acq_lineitem($query, {idlist => 1});
2677
2678     my $vl_resp; # imported li's and the managing queue
2679     unless ($dry_run or $no_assets) {
2680         $e->rollback; # read-only thus far
2681
2682         # list_assets manages its own transactions
2683         $vl_resp = create_lineitem_list_assets($mgr, $li_ids, $vandelay)
2684             or return OpenILS::Event->new('ACQ_LI_IMPORT_FAILED');
2685         $e->xact_begin;
2686     }
2687
2688     # create fund debits for lineitems
2689
2690     for my $li_id (@$li_ids) {
2691         my $li = $e->retrieve_acq_lineitem($li_id);
2692
2693         unless ($li->eg_bib_id or $dry_run or $no_assets) {
2694             # we encountered a lineitem that was not successfully imported.
2695             # we cannot continue.  rollback and report.
2696             $e->rollback;
2697             return OpenILS::Event->new('ACQ_LI_IMPORT_FAILED', {queue => $vl_resp->{queue}});
2698         }
2699
2700         $li->state('on-order');
2701         $li->claim_policy($provider->default_claim_policy)
2702             if $provider->default_claim_policy and !$li->claim_policy;
2703         create_lineitem_debits($mgr, $li, $options) or return $e->die_event;
2704         update_lineitem($mgr, $li) or return $e->die_event;
2705         $mgr->post_process( sub { create_lineitem_status_events($mgr, $li->id, 'aur.ordered'); });
2706         $mgr->respond;
2707     }
2708
2709     # create po-item debits
2710
2711     for my $po_item (@{$e->search_acq_po_item({purchase_order => $po_id})}) {
2712
2713         my $debit = create_fund_debit(
2714             $mgr,
2715             $dry_run,
2716             debit_type => 'direct_charge', # to match invoicing
2717             origin_amount => $po_item->estimated_cost,
2718             origin_currency_type => $e->retrieve_acq_fund($po_item->fund)->currency_type,
2719             amount => $po_item->estimated_cost,
2720             fund => $po_item->fund
2721         ) or return $e->die_event;
2722         $po_item->fund_debit($debit->id);
2723         $e->update_acq_po_item($po_item) or return $e->die_event;
2724         $mgr->respond;
2725     }
2726
2727     # mark PO as ordered
2728
2729     $po->state('on-order');
2730     $po->order_date('now');
2731     update_purchase_order($mgr, $po) or return $e->die_event;
2732
2733     # clean up the xact
2734     $dry_run and $e->rollback or $e->commit;
2735
2736     # tell the world we activated a PO
2737     $U->create_events_for_hook('acqpo.activated', $po, $po->ordering_agency) unless $dry_run;
2738
2739     return undef;
2740 }
2741
2742
2743 __PACKAGE__->register_method(
2744     method    => 'split_purchase_order_by_lineitems',
2745     api_name  => 'open-ils.acq.purchase_order.split_by_lineitems',
2746     signature => {
2747         desc   => q/Splits a PO into many POs, 1 per lineitem.  Only works for / .
2748                   q/POs a) with more than one lineitems, and b) in the "pending" state./,
2749         params => [
2750             {desc => 'Authentication token', type => 'string'},
2751             {desc => 'Purchase order ID',    type => 'number'}
2752         ],
2753         return => {desc => 'list of new PO IDs on success, Event on error'}
2754     }
2755 );
2756
2757 sub split_purchase_order_by_lineitems {
2758     my ($self, $conn, $auth, $po_id) = @_;
2759
2760     my $e = new_editor("xact" => 1, "authtoken" => $auth);
2761     return $e->die_event unless $e->checkauth;
2762
2763     my $po = $e->retrieve_acq_purchase_order([
2764         $po_id, {
2765             "flesh" => 1,
2766             "flesh_fields" => {"acqpo" => [qw/lineitems notes/]}
2767         }
2768     ]) or return $e->die_event;
2769
2770     return $e->die_event
2771         unless $e->allowed("CREATE_PURCHASE_ORDER", $po->ordering_agency);
2772
2773     unless ($po->state eq "pending") {
2774         $e->rollback;
2775         return new OpenILS::Event("ACQ_PURCHASE_ORDER_TOO_LATE");
2776     }
2777
2778     unless (@{$po->lineitems} > 1) {
2779         $e->rollback;
2780         return new OpenILS::Event("ACQ_PURCHASE_ORDER_TOO_SHORT");
2781     }
2782
2783     # To split an existing PO into many, it seems unwise to just delete the
2784     # original PO, so we'll instead detach all of the original POs' lineitems
2785     # but the first, then create new POs for each of the remaining LIs, and
2786     # then attach the LIs to their new POs.
2787
2788     my @po_ids = ($po->id);
2789     my @moving_li = @{$po->lineitems};
2790     shift @moving_li;    # discard first LI
2791
2792     foreach my $li (@moving_li) {
2793         my $new_po = $po->clone;
2794         $new_po->clear_id;
2795         $new_po->clear_name;
2796         $new_po->creator($e->requestor->id);
2797         $new_po->editor($e->requestor->id);
2798         $new_po->owner($e->requestor->id);
2799         $new_po->edit_time("now");
2800         $new_po->create_time("now");
2801
2802         $new_po = $e->create_acq_purchase_order($new_po);
2803
2804         # Clone any notes attached to the old PO and attach to the new one.
2805         foreach my $note (@{$po->notes}) {
2806             my $new_note = $note->clone;
2807             $new_note->clear_id;
2808             $new_note->edit_time("now");
2809             $new_note->purchase_order($new_po->id);
2810             $e->create_acq_po_note($new_note);
2811         }
2812
2813         $li->edit_time("now");
2814         $li->purchase_order($new_po->id);
2815         $e->update_acq_lineitem($li);
2816
2817         push @po_ids, $new_po->id;
2818     }
2819
2820     $po->edit_time("now");
2821     $e->update_acq_purchase_order($po);
2822
2823     return \@po_ids if $e->commit;
2824     return $e->die_event;
2825 }
2826
2827
2828 sub not_cancelable {
2829     my $o = shift;
2830     (ref $o eq "HASH" and $o->{"textcode"} eq "ACQ_NOT_CANCELABLE");
2831 }
2832
2833 __PACKAGE__->register_method(
2834     method => "cancel_purchase_order_api",
2835     api_name    => "open-ils.acq.purchase_order.cancel",
2836     signature => {
2837         desc => q/Cancels an on-order purchase order/,
2838         params => [
2839             {desc => "Authentication token", type => "string"},
2840             {desc => "PO ID to cancel", type => "number"},
2841             {desc => "Cancel reason ID", type => "number"}
2842         ],
2843         return => {desc => q/Object describing changed POs, LIs and LIDs
2844             on success; Event on error./}
2845     }
2846 );
2847
2848 sub cancel_purchase_order_api {
2849     my ($self, $conn, $auth, $po_id, $cancel_reason) = @_;
2850
2851     my $e = new_editor("xact" => 1, "authtoken" => $auth);
2852     return $e->die_event unless $e->checkauth;
2853     my $mgr = new OpenILS::Application::Acq::BatchManager(
2854         "editor" => $e, "conn" => $conn
2855     );
2856
2857     $cancel_reason = $mgr->editor->retrieve_acq_cancel_reason($cancel_reason) or
2858         return new OpenILS::Event(
2859             "BAD_PARAMS", "note" => "Provide cancel reason ID"
2860         );
2861
2862     my $result = cancel_purchase_order($mgr, $po_id, $cancel_reason) or
2863         return $e->die_event;
2864     if (not_cancelable($result)) { # event not from CStoreEditor
2865         $e->rollback;
2866         return $result;
2867     } elsif ($result == -1) {
2868         $e->rollback;
2869         return new OpenILS::Event("ACQ_ALREADY_CANCELED");
2870     }
2871
2872     $e->commit or return $e->die_event;
2873
2874     # XXX create purchase order status events?
2875
2876     if ($mgr->{post_commit}) {
2877         foreach my $func (@{$mgr->{post_commit}}) {
2878             $func->();
2879         }
2880     }
2881
2882     return $result;
2883 }
2884
2885 sub cancel_purchase_order {
2886     my ($mgr, $po_id, $cancel_reason) = @_;
2887
2888     my $po = $mgr->editor->retrieve_acq_purchase_order($po_id) or return 0;
2889
2890     # XXX is "cancelled" a typo?  It's not correct US spelling, anyway.
2891     # Depending on context, this may not warrant an event.
2892     return -1 if $po->state eq "cancelled";
2893
2894     # But this always does.
2895     return new OpenILS::Event(
2896         "ACQ_NOT_CANCELABLE", "note" => "purchase_order $po_id"
2897     ) unless ($po->state eq "on-order" or $po->state eq "pending");
2898
2899     return 0 unless
2900         $mgr->editor->allowed("CREATE_PURCHASE_ORDER", $po->ordering_agency);
2901
2902     $po->state("cancelled");
2903     $po->cancel_reason($cancel_reason->id);
2904
2905     my $li_ids = $mgr->editor->search_acq_lineitem(
2906         {"purchase_order" => $po_id}, {"idlist" => 1}
2907     );
2908
2909     my $result = {"li" => {}, "lid" => {}};
2910     foreach my $li_id (@$li_ids) {
2911         my $li_result = cancel_lineitem($mgr, $li_id, $cancel_reason)
2912             or return 0;
2913
2914         next if $li_result == -1; # already canceled:skip.
2915         return $li_result if not_cancelable($li_result); # not cancelable:stop.
2916
2917         # Merge in each LI result (there's only going to be
2918         # one per call to cancel_lineitem).
2919         my ($k, $v) = each %{$li_result->{"li"}};
2920         $result->{"li"}->{$k} = $v;
2921
2922         # Merge in each LID result (there may be many per call to
2923         # cancel_lineitem).
2924         while (($k, $v) = each %{$li_result->{"lid"}}) {
2925             $result->{"lid"}->{$k} = $v;
2926         }
2927     }
2928
2929     # TODO who/what/where/how do we indicate this change for electronic orders?
2930     # TODO return changes to encumbered/spent
2931     # TODO maybe cascade up from smaller object to container object if last
2932     # smaller object in the container has been canceled?
2933
2934     update_purchase_order($mgr, $po) or return 0;
2935     $result->{"po"} = {
2936         $po_id => {"state" => $po->state, "cancel_reason" => $cancel_reason}
2937     };
2938     return $result;
2939 }
2940
2941
2942 __PACKAGE__->register_method(
2943     method => "cancel_lineitem_api",
2944     api_name    => "open-ils.acq.lineitem.cancel",
2945     signature => {
2946         desc => q/Cancels an on-order lineitem/,
2947         params => [
2948             {desc => "Authentication token", type => "string"},
2949             {desc => "Lineitem ID to cancel", type => "number"},
2950             {desc => "Cancel reason ID", type => "number"}
2951         ],
2952         return => {desc => q/Object describing changed LIs and LIDs on success;
2953             Event on error./}
2954     }
2955 );
2956
2957 __PACKAGE__->register_method(
2958     method => "cancel_lineitem_api",
2959     api_name    => "open-ils.acq.lineitem.cancel.batch",
2960     signature => {
2961         desc => q/Batched version of open-ils.acq.lineitem.cancel/,
2962         return => {desc => q/Object describing changed LIs and LIDs on success;
2963             Event on error./}
2964     }
2965 );
2966
2967 sub cancel_lineitem_api {
2968     my ($self, $conn, $auth, $li_id, $cancel_reason) = @_;
2969
2970     my $batched = $self->api_name =~ /\.batch/;
2971
2972     my $e = new_editor("xact" => 1, "authtoken" => $auth);
2973     return $e->die_event unless $e->checkauth;
2974     my $mgr = new OpenILS::Application::Acq::BatchManager(
2975         "editor" => $e, "conn" => $conn
2976     );
2977
2978     $cancel_reason = $mgr->editor->retrieve_acq_cancel_reason($cancel_reason) or
2979         return new OpenILS::Event(
2980             "BAD_PARAMS", "note" => "Provide cancel reason ID"
2981         );
2982
2983     my ($result, $maybe_event);
2984
2985     if ($batched) {
2986         $result = {"li" => {}, "lid" => {}};
2987         foreach my $one_li_id (@$li_id) {
2988             my $one = cancel_lineitem($mgr, $one_li_id, $cancel_reason) or
2989                 return $e->die_event;
2990             if (not_cancelable($one)) {
2991                 $maybe_event = $one;
2992             } elsif ($result == -1) {
2993                 $maybe_event = new OpenILS::Event("ACQ_ALREADY_CANCELED");
2994             } else {
2995                 my ($k, $v);
2996                 if ($one->{"li"}) {
2997                     while (($k, $v) = each %{$one->{"li"}}) {
2998                         $result->{"li"}->{$k} = $v;
2999                     }
3000                 }
3001                 if ($one->{"lid"}) {
3002                     while (($k, $v) = each %{$one->{"lid"}}) {
3003                         $result->{"lid"}->{$k} = $v;
3004                     }
3005                 }
3006             }
3007         }
3008     } else {
3009         $result = cancel_lineitem($mgr, $li_id, $cancel_reason) or
3010             return $e->die_event;
3011
3012         if (not_cancelable($result)) {
3013             $e->rollback;
3014             return $result;
3015         } elsif ($result == -1) {
3016             $e->rollback;
3017             return new OpenILS::Event("ACQ_ALREADY_CANCELED");
3018         }
3019     }
3020
3021     if ($batched and not scalar keys %{$result->{"li"}}) {
3022         $e->rollback;
3023         return $maybe_event;
3024     } else {
3025         $e->commit or return $e->die_event;
3026         # create_lineitem_status_events should handle array li_id ok
3027         create_lineitem_status_events($mgr, $li_id, "aur.cancelled");
3028
3029         if ($mgr->{post_commit}) {
3030             foreach my $func (@{$mgr->{post_commit}}) {
3031                 $func->();
3032             }
3033         }
3034
3035         return $result;
3036     }
3037 }
3038
3039 sub cancel_lineitem {
3040     my ($mgr, $li_id, $cancel_reason) = @_;
3041
3042     my $li = $mgr->editor->retrieve_acq_lineitem([
3043         $li_id, {flesh => 1,
3044             flesh_fields => {jub => ['purchase_order','cancel_reason']}}
3045     ]) or return 0;
3046
3047     return 0 unless $mgr->editor->allowed(
3048         "CREATE_PURCHASE_ORDER", $li->purchase_order->ordering_agency
3049     );
3050
3051     # Depending on context, this may not warrant an event.
3052     return -1 if $li->state eq "cancelled"
3053         and $li->cancel_reason->keep_debits eq 'f';
3054
3055     # But this always does.  Note that this used to be looser, but you can
3056     # no longer cancel lineitems that lack a PO or that are in "pending-order"
3057     # state (you could in the past).
3058     return new OpenILS::Event(
3059         "ACQ_NOT_CANCELABLE", "note" => "lineitem $li_id"
3060     ) unless $li->purchase_order and
3061         ($li->state eq "on-order" or $li->state eq "cancelled");
3062
3063     $li->state("cancelled");
3064     $li->cancel_reason($cancel_reason->id);
3065
3066     my $lids = $mgr->editor->search_acq_lineitem_detail([{
3067         "lineitem" => $li_id
3068     }, {
3069         flesh => 1,
3070         flesh_fields => { acqlid => ['eg_copy_id'] }
3071     }]);
3072
3073     my $result = {"lid" => {}};
3074     my $copies = [];
3075     foreach my $lid (@$lids) {
3076         my $lid_result = cancel_lineitem_detail($mgr, $lid->id, $cancel_reason)
3077             or return 0;
3078
3079         # gathering any real copies for deletion
3080         if ($lid->eg_copy_id) {
3081             $lid->eg_copy_id->isdeleted('t');
3082             push @$copies, $lid->eg_copy_id;
3083         }
3084
3085         next if $lid_result == -1; # already canceled: just skip it.
3086         return $lid_result if not_cancelable($lid_result); # not cxlable: stop.
3087
3088         # Merge in each LID result (there's only going to be one per call to
3089         # cancel_lineitem_detail).
3090         my ($k, $v) = each %{$lid_result->{"lid"}};
3091         $result->{"lid"}->{$k} = $v;
3092     }
3093
3094     # Attempt to delete the gathered copies (this will also handle volume deletion and bib deletion)
3095     # Delete empty bibs according org unit setting
3096     my $force_delete_empty_bib = $U->ou_ancestor_setting_value(
3097         $mgr->editor->requestor->ws_ou, 'cat.bib.delete_on_no_copy_via_acq_lineitem_cancel', $mgr->editor);
3098     if (scalar(@$copies)>0) {
3099         my $override = 1;
3100         my $delete_stats = undef;
3101         my $retarget_holds = [];
3102         my $cat_evt = OpenILS::Application::Cat::AssetCommon->update_fleshed_copies(
3103             $mgr->editor, $override, undef, $copies, $delete_stats, $retarget_holds,$force_delete_empty_bib);
3104
3105         if( $cat_evt ) {
3106             $logger->info("fleshed copy update failed with event: ".OpenSRF::Utils::JSON->perl2JSON($cat_evt));
3107             return new OpenILS::Event(
3108                 "ACQ_NOT_CANCELABLE", "note" => "lineitem $li_id", "payload" => $cat_evt
3109             );
3110         }
3111
3112         # We can't do the following and stay within the same transaction, but that's okay, the hold targeter will pick these up later.
3113         #my $ses = OpenSRF::AppSession->create('open-ils.circ');
3114         #$ses->request('open-ils.circ.hold.reset.batch', $auth, $retarget_holds);
3115     }
3116
3117     # if we have a bib, check to see whether it has been deleted.  if so, cancel any active holds targeting that bib
3118     if ($li->eg_bib_id) {
3119         my $bib = $mgr->editor->retrieve_biblio_record_entry($li->eg_bib_id) or return new OpenILS::Event(
3120             "ACQ_NOT_CANCELABLE", "note" => "Could not retrieve bib " . $li->eg_bib_id . " for lineitem $li_id"
3121         );
3122         if ($U->is_true($bib->deleted)) {
3123             my $holds = $mgr->editor->search_action_hold_request(
3124                 {   cancel_time => undef,
3125                     fulfillment_time => undef,
3126                     target => $li->eg_bib_id
3127                 }
3128             );
3129
3130             my %cached_usr_home_ou = ();
3131
3132             for my $hold (@$holds) {
3133
3134                 $logger->info("Cancelling hold ".$hold->id.
3135                     " due to acq lineitem cancellation.");
3136
3137                 $hold->cancel_time('now');
3138                 $hold->cancel_cause(5); # 'Staff forced'--we may want a new hold cancel cause reason for this
3139                 $hold->cancel_note('Corresponding Acquistion Lineitem/Purchase Order was cancelled.');
3140                 unless($mgr->editor->update_action_hold_request($hold)) {
3141                     my $evt = $mgr->editor->event;
3142                     $logger->error("Error updating hold ". $evt->textcode .":". $evt->desc .":". $evt->stacktrace);
3143                     return new OpenILS::Event(
3144                         "ACQ_NOT_CANCELABLE", "note" => "Could not cancel hold " . $hold->id . " for lineitem $li_id", "payload" => $evt
3145                     );
3146                 }
3147                 if (! defined $mgr->{post_commit}) { # we need a mechanism for creating trigger events, but only if the transaction gets committed
3148                     $mgr->{post_commit} = [];
3149                 }
3150                 push @{ $mgr->{post_commit} }, sub {
3151                     my $home_ou = $cached_usr_home_ou{$hold->usr};
3152                     if (! $home_ou) {
3153                         my $user = $mgr->editor->retrieve_actor_user($hold->usr); # FIXME: how do we want to handle failures here?
3154                         $home_ou = $user->home_ou;
3155                         $cached_usr_home_ou{$hold->usr} = $home_ou;
3156                     }
3157                     $U->create_events_for_hook('hold_request.cancel.cancelled_order', $hold, $home_ou);
3158                 };
3159             }
3160         }
3161     }
3162
3163     update_lineitem($mgr, $li) or return 0;
3164     $result->{"li"} = {
3165         $li_id => {
3166             "state" => $li->state,
3167             "cancel_reason" => $cancel_reason
3168         }
3169     };
3170     return $result;
3171 }
3172
3173
3174 __PACKAGE__->register_method(
3175     method => "cancel_lineitem_detail_api",
3176     api_name    => "open-ils.acq.lineitem_detail.cancel",
3177     signature => {
3178         desc => q/Cancels an on-order lineitem detail/,
3179         params => [
3180             {desc => "Authentication token", type => "string"},
3181             {desc => "Lineitem detail ID to cancel", type => "number"},
3182             {desc => "Cancel reason ID", type => "number"}
3183         ],
3184         return => {desc => q/Object describing changed LIDs on success;
3185             Event on error./}
3186     }
3187 );
3188
3189 sub cancel_lineitem_detail_api {
3190     my ($self, $conn, $auth, $lid_id, $cancel_reason) = @_;
3191
3192     my $e = new_editor("xact" => 1, "authtoken" => $auth);
3193     return $e->die_event unless $e->checkauth;
3194     my $mgr = new OpenILS::Application::Acq::BatchManager(
3195         "editor" => $e, "conn" => $conn
3196     );
3197
3198     $cancel_reason = $mgr->editor->retrieve_acq_cancel_reason($cancel_reason) or
3199         return new OpenILS::Event(
3200             "BAD_PARAMS", "note" => "Provide cancel reason ID"
3201         );
3202
3203     my $result = cancel_lineitem_detail($mgr, $lid_id, $cancel_reason) or
3204         return $e->die_event;
3205
3206     if (not_cancelable($result)) {
3207         $e->rollback;
3208         return $result;
3209     } elsif ($result == -1) {
3210         $e->rollback;
3211         return new OpenILS::Event("ACQ_ALREADY_CANCELED");
3212     }
3213
3214     $e->commit or return $e->die_event;
3215
3216     # XXX create lineitem detail status events?
3217     return $result;
3218 }
3219
3220 sub cancel_lineitem_detail {
3221     my ($mgr, $lid_id, $cancel_reason) = @_;
3222     my $lid = $mgr->editor->retrieve_acq_lineitem_detail([
3223         $lid_id, {
3224             "flesh" => 2,
3225             "flesh_fields" => {
3226                 "acqlid" => ["lineitem","cancel_reason"],
3227                 "jub" => ["purchase_order"]
3228             }
3229         }
3230     ]) or return 0;
3231
3232     # It's OK to cancel an already-canceled copy if the copy was
3233     # previously "delayed" -- keep_debits == true
3234     # Depending on context, this may not warrant an event.
3235     return -1 if $lid->cancel_reason
3236         and $lid->cancel_reason->keep_debits eq 'f';
3237
3238     # But this always does.
3239     return new OpenILS::Event(
3240         "ACQ_NOT_CANCELABLE", "note" => "lineitem_detail $lid_id"
3241     ) unless (
3242         (! $lid->lineitem->purchase_order) or
3243         (
3244             (not $lid->recv_time) and
3245             $lid->lineitem and
3246             $lid->lineitem->purchase_order and (
3247                 $lid->lineitem->state eq "on-order" or
3248                 $lid->lineitem->state eq "pending-order" or
3249                 $lid->lineitem->state eq "cancelled"
3250             )
3251         )
3252     );
3253
3254     return 0 unless $mgr->editor->allowed(
3255         "CREATE_PURCHASE_ORDER",
3256         $lid->lineitem->purchase_order->ordering_agency
3257     ) or (! $lid->lineitem->purchase_order);
3258
3259     $lid->cancel_reason($cancel_reason->id);
3260
3261     unless($U->is_true($cancel_reason->keep_debits)) {
3262         my $debit_id = $lid->fund_debit;
3263         $lid->clear_fund_debit;
3264
3265         if($debit_id) {
3266             # item is cancelled.  Remove the fund debit.
3267             my $debit = $mgr->editor->retrieve_acq_fund_debit($debit_id);
3268             if (!$U->is_true($debit->encumbrance)) {
3269                 $mgr->editor->rollback;
3270                 return OpenILS::Event->new('ACQ_NOT_CANCELABLE',
3271                     note => "Debit is marked as paid: $debit_id");
3272             }
3273             $mgr->editor->delete_acq_fund_debit($debit) or return $mgr->editor->die_event;
3274         }
3275     }
3276
3277     # XXX LIDs don't have either an editor or a edit_time field. Should we
3278     # update these on the LI when we alter an LID?
3279     $mgr->editor->update_acq_lineitem_detail($lid) or return 0;
3280
3281     return {"lid" => {$lid_id => {"cancel_reason" => $cancel_reason}}};
3282 }
3283
3284
3285 __PACKAGE__->register_method(
3286     method    => 'user_requests',
3287     api_name  => 'open-ils.acq.user_request.retrieve.by_user_id',
3288     stream    => 1,
3289     signature => {
3290         desc   => 'Retrieve fleshed user requests and related data for a given user.',
3291         params => [
3292             { desc => 'Authentication token',      type => 'string' },
3293             { desc => 'User ID of the owner, or array of IDs',      },
3294             { desc => 'Options hash (optional) with any of the keys: order_by, limit, offset, state (of the lineitem)',
3295               type => 'object'
3296             }
3297         ],
3298         return => {
3299             desc => 'Fleshed user requests and related data',
3300             type => 'object'
3301         }
3302     }
3303 );
3304
3305 __PACKAGE__->register_method(
3306     method    => 'user_requests',
3307     api_name  => 'open-ils.acq.user_request.retrieve.by_home_ou',
3308     stream    => 1,
3309     signature => {
3310         desc   => 'Retrieve fleshed user requests and related data for a given org unit or units.',
3311         params => [
3312             { desc => 'Authentication token',      type => 'string' },
3313             { desc => 'Org unit ID, or array of IDs',               },
3314             { desc => 'Options hash (optional) with any of the keys: order_by, limit, offset, state (of the lineitem)',
3315               type => 'object'
3316             }
3317         ],
3318         return => {
3319             desc => 'Fleshed user requests and related data',
3320             type => 'object'
3321         }
3322     }
3323 );
3324
3325 sub user_requests {
3326     my($self, $conn, $auth, $search_value, $options) = @_;
3327     my $e = new_editor(authtoken => $auth);
3328     return $e->event unless $e->checkauth;
3329     my $rid = $e->requestor->id;
3330     $options ||= {};
3331
3332     my $query = {
3333         "select"=>{"aur"=>["id"],"au"=>["home_ou", {column => 'id', alias => 'usr_id'} ]},
3334         "from"=>{ "aur" => { "au" => {}, "jub" => { "type" => "left" } } },
3335         "where"=>{
3336             "+jub"=> {
3337                 "-or" => [
3338                     {"id"=>undef}, # this with the left-join pulls in requests without lineitems
3339                     {"state"=>["new","on-order","pending-order"]} # FIXME - probably needs softcoding
3340                 ]
3341             }
3342         },
3343         "order_by"=>[{"class"=>"aur", "field"=>"request_date", "direction"=>"desc"}]
3344     };
3345
3346     foreach (qw/ order_by limit offset /) {
3347         $query->{$_} = $options->{$_} if defined $options->{$_};
3348     }
3349     if (defined $options->{'state'}) {
3350         $query->{'where'}->{'+jub'}->{'-or'}->[1]->{'state'} = $options->{'state'};
3351     }
3352
3353     if ($self->api_name =~ /by_user_id/) {
3354         $query->{'where'}->{'usr'} = $search_value;
3355     } else {
3356         $query->{'where'}->{'+au'} = { 'home_ou' => $search_value };
3357     }
3358
3359     my $pertinent_ids = $e->json_query($query);
3360
3361     my %perm_test = ();
3362     for my $id_blob (@$pertinent_ids) {
3363         if ($rid != $id_blob->{usr_id}) {
3364             if (!defined $perm_test{ $id_blob->{home_ou} }) {
3365                 $perm_test{ $id_blob->{home_ou} } = $e->allowed( ['user_request.view'], $id_blob->{home_ou} );
3366             }
3367             if (!$perm_test{ $id_blob->{home_ou} }) {
3368                 next; # failed test
3369             }
3370         }
3371         my $aur_obj = $e->retrieve_acq_user_request([
3372             $id_blob->{id},
3373             {flesh => 1, flesh_fields => { "aur" => [ 'lineitem' ] } }
3374         ]);
3375         if (! $aur_obj) { next; }
3376
3377         if ($aur_obj->lineitem()) {
3378             $aur_obj->lineitem()->clear_marc();
3379         }
3380         $conn->respond($aur_obj);
3381     }
3382
3383     return undef;
3384 }
3385
3386 __PACKAGE__->register_method (
3387     method    => 'update_user_request',
3388     api_name  => 'open-ils.acq.user_request.cancel.batch',
3389     stream    => 1,
3390     signature => {
3391         desc   => 'If given a cancel reason, will update the request with that reason, otherwise, this will delete the request altogether.  The '    .
3392                   'intention is for staff interfaces or processes to provide cancel reasons, and for patron interfaces to just delete the requests.' ,
3393         params => [
3394             { desc => 'Authentication token',              type => 'string' },
3395             { desc => 'ID or array of IDs for the user requests to cancel'  },
3396             { desc => 'Cancel Reason ID (optional)',       type => 'string' }
3397         ],
3398         return => {
3399             desc => 'progress object, event on error',
3400         }
3401     }
3402 );
3403 __PACKAGE__->register_method (
3404     method    => 'update_user_request',
3405     api_name  => 'open-ils.acq.user_request.set_no_hold.batch',
3406     stream    => 1,
3407     signature => {
3408         desc   => 'Remove the hold from a user request or set of requests',
3409         params => [
3410             { desc => 'Authentication token',              type => 'string' },
3411             { desc => 'ID or array of IDs for the user requests to modify'  }
3412         ],
3413         return => {
3414             desc => 'progress object, event on error',
3415         }
3416     }
3417 );
3418
3419 sub update_user_request {
3420     my($self, $conn, $auth, $aur_ids, $cancel_reason) = @_;
3421     my $e = new_editor(xact => 1, authtoken => $auth);
3422     return $e->die_event unless $e->checkauth;
3423     my $rid = $e->requestor->id;
3424
3425     my $x = 1;
3426     my %perm_test = ();
3427     for my $id (@$aur_ids) {
3428
3429         my $aur_obj = $e->retrieve_acq_user_request([
3430             $id,
3431             {   flesh => 1,
3432                 flesh_fields => { "aur" => ['lineitem', 'usr'] }
3433             }
3434         ]) or return $e->die_event;
3435
3436         my $context_org = $aur_obj->usr()->home_ou();
3437         $aur_obj->usr( $aur_obj->usr()->id() );
3438
3439         if ($rid != $aur_obj->usr) {
3440             if (!defined $perm_test{ $context_org }) {
3441                 $perm_test{ $context_org } = $e->allowed( ['user_request.update'], $context_org );
3442             }
3443             if (!$perm_test{ $context_org }) {
3444                 next; # failed test
3445             }
3446         }
3447
3448         if($self->api_name =~ /set_no_hold/) {
3449             if ($U->is_true($aur_obj->hold)) {
3450                 $aur_obj->hold(0);
3451                 $e->update_acq_user_request($aur_obj) or return $e->die_event;
3452             }
3453         }
3454
3455         if($self->api_name =~ /cancel/) {
3456             if ( $cancel_reason ) {
3457                 $aur_obj->cancel_reason( $cancel_reason );
3458                 $e->update_acq_user_request($aur_obj) or return $e->die_event;
3459                 create_user_request_events( $e, [ $aur_obj ], 'aur.rejected' );
3460             } else {
3461                 $e->delete_acq_user_request($aur_obj);
3462             }
3463         }
3464
3465         $conn->respond({maximum => scalar(@$aur_ids), progress => $x++});
3466     }
3467
3468     $e->commit;
3469     return {complete => 1};
3470 }
3471
3472 __PACKAGE__->register_method (
3473     method    => 'new_user_request',
3474     api_name  => 'open-ils.acq.user_request.create',
3475     signature => {
3476         desc   => 'Create a new user request object in the DB',
3477         param  => [
3478             { desc => 'Authentication token',   type => 'string' },
3479             { desc => 'User request data hash.  Hash keys match the fields for the "aur" object', type => 'object' }
3480         ],
3481         return => {
3482             desc => 'The created user request object, or event on error'
3483         }
3484     }
3485 );
3486
3487 sub new_user_request {
3488     my($self, $conn, $auth, $form_data) = @_;
3489     my $e = new_editor(xact => 1, authtoken => $auth);
3490     return $e->die_event unless $e->checkauth;
3491     my $rid = $e->requestor->id;
3492     my $target_user_fleshed;
3493     if (! defined $$form_data{'usr'}) {
3494         $$form_data{'usr'} = $rid;
3495     }
3496     if ($$form_data{'usr'} != $rid) {
3497         # See if the requestor can place the request on behalf of a different user.
3498         $target_user_fleshed = $e->retrieve_actor_user($$form_data{'usr'}) or return $e->die_event;
3499         $e->allowed('user_request.create', $target_user_fleshed->home_ou) or return $e->die_event;
3500     } else {
3501         $target_user_fleshed = $e->requestor;
3502         $e->allowed('CREATE_PURCHASE_REQUEST') or return $e->die_event;
3503     }
3504     if (! defined $$form_data{'pickup_lib'}) {
3505         if ($target_user_fleshed->ws_ou) {
3506             $$form_data{'pickup_lib'} = $target_user_fleshed->ws_ou;
3507         } else {
3508             $$form_data{'pickup_lib'} = $target_user_fleshed->home_ou;
3509         }
3510     }
3511     if (! defined $$form_data{'request_type'}) {
3512         $$form_data{'request_type'} = 1; # Books
3513     }
3514     my $aur_obj = new Fieldmapper::acq::user_request;
3515     $aur_obj->isnew(1);
3516     $aur_obj->usr( $$form_data{'usr'} );
3517     $aur_obj->request_date( 'now' );
3518     for my $field ( keys %$form_data ) {
3519         if (defined $$form_data{$field} and $field !~ /^(id|lineitem|eg_bib|request_date|cancel_reason)$/) {
3520             $aur_obj->$field( $$form_data{$field} );
3521         }
3522     }
3523
3524     $aur_obj = $e->create_acq_user_request($aur_obj) or return $e->die_event;
3525
3526     $e->commit and create_user_request_events( $e, [ $aur_obj ], 'aur.created' );
3527
3528     return $aur_obj;
3529 }
3530
3531 sub create_user_request_events {
3532     my($e, $user_reqs, $hook) = @_;
3533
3534     my $ses = OpenSRF::AppSession->create('open-ils.trigger');
3535     $ses->connect;
3536
3537     my %cached_usr_home_ou = ();
3538     for my $user_req (@$user_reqs) {
3539         my $home_ou = $cached_usr_home_ou{$user_req->usr};
3540         if (! $home_ou) {
3541             my $user = $e->retrieve_actor_user($user_req->usr) or return $e->die_event;
3542             $home_ou = $user->home_ou;
3543             $cached_usr_home_ou{$user_req->usr} = $home_ou;
3544         }
3545         my $req = $ses->request('open-ils.trigger.event.autocreate', $hook, $user_req, $home_ou);
3546         $req->recv;
3547     }
3548
3549     $ses->disconnect;
3550     return undef;
3551 }
3552
3553
3554 __PACKAGE__->register_method(
3555     method => "po_note_CUD_batch",
3556     api_name => "open-ils.acq.po_note.cud.batch",
3557     stream => 1,
3558     signature => {
3559         desc => q/Manage purchase order notes/,
3560         params => [
3561             {desc => "Authentication token", type => "string"},
3562             {desc => "List of po_notes to manage", type => "array"},
3563         ],
3564         return => {desc => "Stream of successfully managed objects"}
3565     }
3566 );
3567
3568 sub po_note_CUD_batch {
3569     my ($self, $conn, $auth, $notes) = @_;
3570
3571     my $e = new_editor("xact"=> 1, "authtoken" => $auth);
3572     return $e->die_event unless $e->checkauth;
3573     # XXX perms
3574
3575     my $total = @$notes;
3576     my $count = 0;
3577
3578     foreach my $note (@$notes) {
3579
3580         $note->editor($e->requestor->id);
3581         $note->edit_time("now");
3582
3583         if ($note->isnew) {
3584             $note->creator($e->requestor->id);
3585             $note = $e->create_acq_po_note($note) or return $e->die_event;
3586         } elsif ($note->isdeleted) {
3587             $e->delete_acq_po_note($note) or return $e->die_event;
3588         } elsif ($note->ischanged) {
3589             $e->update_acq_po_note($note) or return $e->die_event;
3590         }
3591
3592         unless ($note->isdeleted) {
3593             $note = $e->retrieve_acq_po_note($note->id) or
3594                 return $e->die_event;
3595         }
3596
3597         $conn->respond(
3598             {"maximum" => $total, "progress" => ++$count, "note" => $note}
3599         );
3600     }
3601
3602     $e->commit and $conn->respond_complete or return $e->die_event;
3603 }
3604
3605
3606 # retrieves a lineitem, fleshes its PO and PL, checks perms
3607 # returns ($li, $evt, $org)
3608 sub fetch_and_check_li {
3609     my $e = shift;
3610     my $li_id = shift;
3611     my $perm_mode = shift || 'read';
3612
3613     my $li = $e->retrieve_acq_lineitem([
3614         $li_id,
3615         {   flesh => 1,
3616             flesh_fields => {jub => ['purchase_order', 'picklist']}
3617         }
3618     ]) or return (undef, $e->die_event);
3619
3620     my $org;
3621     if(my $po = $li->purchase_order) {
3622         $org = $po->ordering_agency;
3623         my $perms = ($perm_mode eq 'read') ? 'VIEW_PURCHASE_ORDER' : 'CREATE_PURCHASE_ORDER';
3624         return ($li, $e->die_event) unless $e->allowed($perms, $org);
3625
3626     } elsif(my $pl = $li->picklist) {
3627         $org = $pl->org_unit;
3628         my $perms = ($perm_mode eq 'read') ? 'VIEW_PICKLIST' : 'CREATE_PICKLIST';
3629         return ($li, $e->die_event) unless $e->allowed($perms, $org);
3630     }
3631
3632     return ($li, undef, $org);
3633 }
3634
3635
3636 __PACKAGE__->register_method(
3637     method => "clone_distrib_form",
3638     api_name => "open-ils.acq.distribution_formula.clone",
3639     stream => 1,
3640     signature => {
3641         desc => q/Clone a distribution formula/,
3642         params => [
3643             {desc => "Authentication token", type => "string"},
3644             {desc => "Original formula ID", type => 'integer'},
3645             {desc => "Name of new formula", type => 'string'},
3646         ],
3647         return => {desc => "ID of newly created formula"}
3648     }
3649 );
3650
3651 sub clone_distrib_form {
3652     my($self, $client, $auth, $form_id, $new_name) = @_;
3653
3654     my $e = new_editor("xact"=> 1, "authtoken" => $auth);
3655     return $e->die_event unless $e->checkauth;
3656
3657     my $old_form = $e->retrieve_acq_distribution_formula($form_id) or return $e->die_event;
3658     return $e->die_event unless $e->allowed('ADMIN_ACQ_DISTRIB_FORMULA', $old_form->owner);
3659
3660     my $new_form = Fieldmapper::acq::distribution_formula->new;
3661
3662     $new_form->owner($old_form->owner);
3663     $new_form->name($new_name);
3664     $e->create_acq_distribution_formula($new_form) or return $e->die_event;
3665
3666     my $entries = $e->search_acq_distribution_formula_entry({formula => $form_id});
3667     for my $entry (@$entries) {
3668        my $new_entry = Fieldmapper::acq::distribution_formula_entry->new;
3669        $new_entry->$_($entry->$_()) for $entry->real_fields;
3670        $new_entry->formula($new_form->id);
3671        $new_entry->clear_id;
3672        $e->create_acq_distribution_formula_entry($new_entry) or return $e->die_event;
3673     }
3674
3675     $e->commit;
3676     return $new_form->id;
3677 }
3678
3679 __PACKAGE__->register_method(
3680     method => 'add_li_to_po',
3681     api_name    => 'open-ils.acq.purchase_order.add_lineitem',
3682     signature => {
3683         desc => q/Adds a lineitem to an existing purchase order/,
3684         params => [
3685             {desc => 'Authentication token', type => 'string'},
3686             {desc => 'The purchase order id', type => 'number'},
3687             {desc => 'The lineitem ID (or an array of them)', type => 'mixed'},
3688         ],
3689         return => {desc => 'Streams a total versus completed counts object, event on error'}
3690     }
3691 );
3692
3693 sub add_li_to_po {
3694     my($self, $conn, $auth, $po_id, $li_id) = @_;
3695
3696     my $e = new_editor(authtoken => $auth, xact => 1);
3697     return $e->die_event unless $e->checkauth;
3698
3699     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
3700
3701     my $po = $e->retrieve_acq_purchase_order($po_id)
3702         or return $e->die_event;
3703
3704     return $e->die_event unless
3705         $e->allowed('CREATE_PURCHASE_ORDER', $po->ordering_agency);
3706
3707     unless ($po->state =~ /new|pending/) {
3708         $e->rollback;
3709         return {success => 0, po => $po, error => 'bad-po-state'};
3710     }
3711
3712     my $lis;
3713
3714     if (ref $li_id eq "ARRAY") {
3715         $li_id = [ map { int($_) } @$li_id ];
3716         return $e->die_event(new OpenILS::Event("BAD_PARAMS")) unless @$li_id;
3717
3718         $lis = $e->search_acq_lineitem({id => $li_id})
3719             or return $e->die_event;
3720     } else {
3721         my $li = $e->retrieve_acq_lineitem(int($li_id))
3722             or return $e->die_event;
3723         $lis = [$li];
3724     }
3725
3726     foreach my $li (@$lis) {
3727         if ($li->state !~ /new|order-ready|pending-order/ or
3728             $li->purchase_order) {
3729             $e->rollback;
3730             return {success => 0, li => $li, error => 'bad-li-state'};
3731         }
3732
3733         $li->provider($po->provider);
3734         $li->purchase_order($po_id);
3735         $li->state('pending-order');
3736         apply_default_copies($mgr, $po, $li->id) or return $e->die_event;
3737         update_lineitem($mgr, $li) or return $e->die_event;
3738     }
3739
3740     $e->commit;
3741     return {success => 1};
3742 }
3743
3744 __PACKAGE__->register_method(
3745     method => 'po_lineitems_no_copies',
3746     api_name => 'open-ils.acq.purchase_order.no_copy_lineitems.id_list',
3747     stream => 1,
3748     authoritative => 1,
3749     signature => {
3750         desc => q/Returns the set of lineitem IDs for a given PO that have no copies attached/,
3751         params => [
3752             {desc => 'Authentication token', type => 'string'},
3753             {desc => 'The purchase order id', type => 'number'},
3754         ],
3755         return => {desc => 'Stream of lineitem IDs on success, event on error'}
3756     }
3757 );
3758
3759 sub po_lineitems_no_copies {
3760     my ($self, $conn, $auth, $po_id) = @_;
3761
3762     my $e = new_editor(authtoken => $auth);
3763     return $e->event unless $e->checkauth;
3764
3765     # first check the view perms for LI's attached to this PO
3766     my $po = $e->retrieve_acq_purchase_order($po_id) or return $e->event;
3767     return $e->event unless $e->allowed('VIEW_PURCHASE_ORDER', $po->ordering_agency);
3768
3769     my $ids = $e->json_query({
3770         select => {jub => ['id']},
3771         from => {jub => {acqlid => {type => 'left'}}},
3772         where => {
3773             '+jub' => {purchase_order => $po_id},
3774             '+acqlid' => {lineitem => undef}
3775         }
3776     });
3777
3778     $conn->respond($_->{id}) for @$ids;
3779     return undef;
3780 }
3781
3782 __PACKAGE__->register_method(
3783     method => 'set_li_order_ident',
3784     api_name => 'open-ils.acq.lineitem.order_identifier.set',
3785     signature => {
3786         desc => q/
3787             Given an existing lineitem_attr (typically a marc_attr), this will
3788             create a matching local_attr to store the name and value and mark
3789             the attr as the order_ident.  Any existing local_attr marked as
3790             order_ident is removed.
3791         /,
3792         params => [
3793             {desc => 'Authentication token', type => 'string'},
3794             {desc => q/Args object:
3795                 source_attr_id : ID of the existing lineitem_attr to use as
3796                     order ident.
3797                 lineitem_id : lineitem id
3798                 attr_name : name ('isbn', etc.) of a new marc_attr to add to
3799                     the lineitem to use for the order ident
3800                 attr_value : value for the new marc_attr
3801                 no_apply_bre : if set, newly added attrs will not be applied
3802                     to the lineitems' linked bib record/,
3803                 type => 'object'}
3804         ],
3805         return => {desc => q/Returns the attribute
3806             responsible for tracking the order identifier/}
3807     }
3808 );
3809
3810 sub set_li_order_ident {
3811     my ($self, $conn, $auth, $args) = @_;
3812     $args ||= {};
3813
3814     my $source_attr;
3815     my $source_attr_id = $args->{source_attr_id};
3816
3817     my $e = new_editor(authtoken => $auth, xact => 1);
3818     return $e->die_event unless $e->checkauth;
3819
3820     # fetch attr, LI, and check update permissions
3821
3822     my $li_id = $args->{lineitem_id};
3823
3824     if ($source_attr_id) {
3825         $source_attr = $e->retrieve_acq_lineitem_attr($source_attr_id)
3826             or return $e->die_event;
3827         $li_id = $source_attr->lineitem;
3828     }
3829
3830     my ($li, $evt, $perm_org) = fetch_and_check_li($e, $li_id, 'write');
3831     return $evt if $evt;
3832
3833     return $e->die_event unless
3834         $e->allowed('ACQ_SET_LINEITEM_IDENTIFIER', $perm_org);
3835
3836     # if needed, create a new marc attr for
3837     # the lineitem to represent the ident value
3838
3839     ($source_attr, $evt) = apply_new_li_ident_attr(
3840         $e, $li, $perm_org, $args->{attr_name}, $args->{attr_value})
3841         unless $source_attr;
3842
3843     return $evt if $evt;
3844
3845     # remove the existing order_ident attribute if present
3846
3847     my $old_attr = $e->search_acq_lineitem_attr({
3848         attr_type => 'lineitem_local_attr_definition',
3849         lineitem => $li->id,
3850         order_ident => 't'
3851     })->[0];
3852
3853     if ($old_attr) {
3854
3855         # if we already have an order_ident that matches the
3856         # source attr, there's nothing left to do.
3857
3858         if ($old_attr->attr_name eq $source_attr->attr_name and
3859             $old_attr->attr_value eq $source_attr->attr_value) {
3860
3861             $e->rollback;
3862             return $old_attr;
3863
3864         } else {
3865             # remove the old order_ident attribute
3866             $e->delete_acq_lineitem_attr($old_attr) or return $e->die_event;
3867         }
3868     }
3869
3870     # make sure we have a local_attr_def to match the source attr def
3871
3872     my $local_def = $e->search_acq_lineitem_local_attr_definition({
3873         code => $source_attr->attr_name
3874     })->[0];
3875
3876     if (!$local_def) {
3877         my $source_def =
3878             $e->retrieve_acq_lineitem_attr_definition($source_attr->definition);
3879         $local_def = Fieldmapper::acq::lineitem_local_attr_definition->new;
3880         $local_def->code($source_def->code);
3881         $local_def->description($source_def->description);
3882         $local_def = $e->create_acq_lineitem_local_attr_definition($local_def)
3883             or return $e->die_event;
3884     }
3885
3886     # create the new order_ident local attr
3887
3888     my $new_attr = Fieldmapper::acq::lineitem_attr->new;
3889     $new_attr->definition($local_def->id);
3890     $new_attr->attr_type('lineitem_local_attr_definition');
3891     $new_attr->lineitem($li->id);
3892     $new_attr->attr_name($source_attr->attr_name);
3893     $new_attr->attr_value($source_attr->attr_value);
3894     $new_attr->order_ident('t');
3895
3896     $new_attr = $e->create_acq_lineitem_attr($new_attr)
3897         or return $e->die_event;
3898
3899     $e->commit;
3900     return $new_attr;
3901 }
3902
3903
3904 # Given an isbn, issn, or upc, add the value to the lineitem marc.
3905 # Upon update, the value will be auto-magically represented as
3906 # a lineitem marc attr.
3907 # If the li is linked to a bib record and the user has the correct
3908 # permissions, update the bib record to match.
3909 sub apply_new_li_ident_attr {
3910     my ($e, $li, $perm_org, $attr_name, $attr_value) = @_;
3911
3912     my %tags = (
3913         isbn => '020',
3914         issn => '022',
3915         upc  => '024'
3916     );
3917
3918     my $marc_field = MARC::Field->new(
3919         $tags{$attr_name}, '', '','a' => $attr_value);
3920
3921     my $li_rec = MARC::Record->new_from_xml($li->marc, 'UTF-8', 'USMARC');
3922     $li_rec->insert_fields_ordered($marc_field);
3923
3924     $li->marc(clean_marc($li_rec));
3925     $li->editor($e->requestor->id);
3926     $li->edit_time('now');
3927
3928     $e->update_acq_lineitem($li) or return (undef, $e->die_event);
3929
3930     my $source_attr = $e->search_acq_lineitem_attr({
3931         attr_name => $attr_name,
3932         attr_value => $attr_value,
3933         attr_type => 'lineitem_marc_attr_definition'
3934     })->[0];
3935
3936     if (!$source_attr) {
3937         $logger->error("ACQ lineitem update failed to produce a matching ".
3938             " marc attribute for $attr_name => $attr_value");
3939         return (undef, OpenILS::Event->new('INTERNAL_SERVER_ERROR'));
3940     }
3941
3942     return ($source_attr) unless
3943         $li->eg_bib_id and
3944         $e->allowed('ACQ_ADD_LINEITEM_IDENTIFIER', $perm_org);
3945
3946     # li is linked to a bib record and user has the update perms
3947
3948     my $bre = $e->retrieve_biblio_record_entry($li->eg_bib_id);
3949     my $bre_marc = MARC::Record->new_from_xml($bre->marc, 'UTF-8', 'USMARC');
3950     $bre_marc->insert_fields_ordered($marc_field);
3951
3952     $bre->marc(clean_marc($bre_marc));
3953     $bre->editor($e->requestor->id);
3954     $bre->edit_date('now');
3955
3956     $e->update_biblio_record_entry($bre) or return (undef, $e->die_event);
3957
3958     return ($source_attr);
3959 }
3960
3961
3962 1;
3963