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