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