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

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