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

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