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