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