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 sub autocancel_lineitem {
3257     my $mgr = shift;
3258     my $lid_id = shift;
3259     my $candidate_cancel_reason = shift;
3260
3261     my $lid = $mgr->editor->search_acq_lineitem_detail({id => $lid_id});
3262     my $li_id = $lid->[0]->lineitem;
3263
3264     my $all_lids = $mgr->editor->search_acq_lineitem_detail([{
3265         lineitem => $li_id
3266     },{
3267         flesh => 1,
3268         flesh_fields => { acqlid => ['cancel_reason'] }
3269     }]);
3270
3271     my $all_lids_are_canceled = 1;
3272     foreach my $lid ( @{ $all_lids } ) {
3273         if (! $lid->cancel_reason ) {
3274             $all_lids_are_canceled = 0;
3275         } elsif (
3276             !$U->is_true($candidate_cancel_reason->keep_debits) &&
3277              $U->is_true($lid->cancel_reason->keep_debits)) {
3278                 $candidate_cancel_reason = $lid->cancel_reason;
3279         }
3280     }
3281     my $cancel_result;
3282     if ($all_lids_are_canceled) {
3283         $cancel_result = cancel_lineitem($mgr, $li_id, $candidate_cancel_reason);
3284     }
3285     return $cancel_result;
3286 }
3287
3288 __PACKAGE__->register_method(
3289     method => "cancel_lineitem_detail_api",
3290     api_name    => "open-ils.acq.lineitem_detail.cancel",
3291     signature => {
3292         desc => q/Cancels an on-order lineitem detail/,
3293         params => [
3294             {desc => "Authentication token", type => "string"},
3295             {desc => "Lineitem detail ID to cancel", type => "number"},
3296             {desc => "Cancel reason ID", type => "number"}
3297         ],
3298         return => {desc => q/Object describing changed LIDs on success;
3299             Event on error./}
3300     }
3301 );
3302
3303 sub cancel_lineitem_detail_api {
3304     my ($self, $conn, $auth, $lid_id, $cancel_reason) = @_;
3305
3306     my $e = new_editor("xact" => 1, "authtoken" => $auth);
3307     return $e->die_event unless $e->checkauth;
3308     my $mgr = new OpenILS::Application::Acq::BatchManager(
3309         "editor" => $e, "conn" => $conn
3310     );
3311
3312     $cancel_reason = $mgr->editor->retrieve_acq_cancel_reason($cancel_reason) or
3313         return new OpenILS::Event(
3314             "BAD_PARAMS", "note" => "Provide cancel reason ID"
3315         );
3316
3317     my $result = cancel_lineitem_detail($mgr, $lid_id, $cancel_reason) or
3318         return $e->die_event;
3319
3320     if (not_cancelable($result)) {
3321         $e->rollback;
3322         return $result;
3323     } elsif ($result == -1) {
3324         $e->rollback;
3325         return new OpenILS::Event("ACQ_ALREADY_CANCELED");
3326     }
3327
3328     if (defined autocancel_lineitem($mgr,$lid_id,$cancel_reason)) {
3329         $$result{'li_update_needed'} = 1;
3330     }
3331
3332     $e->commit or return $e->die_event;
3333
3334     # XXX create lineitem detail status events?
3335     return $result;
3336 }
3337
3338 sub cancel_lineitem_detail {
3339     my ($mgr, $lid_id, $cancel_reason) = @_;
3340     my $lid = $mgr->editor->retrieve_acq_lineitem_detail([
3341         $lid_id, {
3342             "flesh" => 2,
3343             "flesh_fields" => {
3344                 "acqlid" => ["lineitem","cancel_reason"],
3345                 "jub" => ["purchase_order"]
3346             }
3347         }
3348     ]) or return 0;
3349
3350     # It's OK to cancel an already-canceled copy if the copy was
3351     # previously "delayed" -- keep_debits == true
3352     # Depending on context, this may not warrant an event.
3353     return -1 if $lid->cancel_reason
3354         and $lid->cancel_reason->keep_debits eq 'f';
3355
3356     # But this always does.
3357     return new OpenILS::Event(
3358         "ACQ_NOT_CANCELABLE", "note" => "lineitem_detail $lid_id"
3359     ) unless (
3360         (! $lid->lineitem->purchase_order) or
3361         (
3362             (not $lid->recv_time) and
3363             $lid->lineitem and
3364             $lid->lineitem->purchase_order and (
3365                 $lid->lineitem->state eq "on-order" or
3366                 $lid->lineitem->state eq "pending-order" or
3367                 $lid->lineitem->state eq "cancelled"
3368             )
3369         )
3370     );
3371
3372     return 0 unless $mgr->editor->allowed(
3373         "CREATE_PURCHASE_ORDER",
3374         $lid->lineitem->purchase_order->ordering_agency
3375     ) or (! $lid->lineitem->purchase_order);
3376
3377     $lid->cancel_reason($cancel_reason->id);
3378
3379     unless($U->is_true($cancel_reason->keep_debits)) {
3380         my $debit_id = $lid->fund_debit;
3381         $lid->clear_fund_debit;
3382
3383         if($debit_id) {
3384             # item is cancelled.  Remove the fund debit.
3385             my $debit = $mgr->editor->retrieve_acq_fund_debit($debit_id);
3386             if (!$U->is_true($debit->encumbrance)) {
3387                 $mgr->editor->rollback;
3388                 return OpenILS::Event->new('ACQ_NOT_CANCELABLE',
3389                     note => "Debit is marked as paid: $debit_id");
3390             }
3391             $mgr->editor->delete_acq_fund_debit($debit) or return $mgr->editor->die_event;
3392         }
3393     }
3394
3395     # XXX LIDs don't have either an editor or a edit_time field. Should we
3396     # update these on the LI when we alter an LID?
3397     $mgr->editor->update_acq_lineitem_detail($lid) or return 0;
3398
3399     return {"lid" => {$lid_id => {"cancel_reason" => $cancel_reason}}};
3400 }
3401
3402 __PACKAGE__->register_method(
3403     method => "delete_po_item_api",
3404     api_name    => "open-ils.acq.po_item.delete",
3405     signature => {
3406         desc => q/Deletes a po_item and removes its debit/,
3407         params => [
3408             {desc => "Authentication token", type => "string"},
3409             {desc => "po_item ID to delete", type => "number"},
3410         ],
3411         return => {desc => q/1 on success, Event on error/}
3412     }
3413 );
3414
3415 sub delete_po_item_api {
3416     my($self, $client, $auth, $po_item_id) = @_;
3417     my $e = new_editor(authtoken => $auth, xact => 1);
3418     return $e->die_event unless $e->checkauth;
3419
3420     my $po_item = $e->retrieve_acq_po_item([
3421         $po_item_id, {
3422             flesh => 1,
3423             flesh_fields => {acqpoi => ['purchase_order', 'fund_debit']}
3424         }
3425     ]) or return $e->die_event;
3426
3427     return $e->die_event unless
3428         $e->allowed('CREATE_PURCHASE_ORDER',
3429             $po_item->purchase_order->ordering_agency);
3430
3431     # remove debit, delete item
3432     my $result = clear_po_item($e, $po_item, 1);
3433
3434     if ($result) {
3435         $e->rollback;
3436         return $result;
3437     }
3438
3439     $e->commit;
3440     return 1;
3441 }
3442
3443
3444 # 1. Removes linked fund debit from a PO item if present and still encumbered.
3445 # 2. Optionally also deletes the po_item object
3446 # po_item is fleshed with purchase_order and fund_debit
3447 sub clear_po_item {
3448     my ($e, $po_item, $delete_item) = @_;
3449
3450     if ($po_item->fund_debit) {
3451
3452         if (!$U->is_true($po_item->fund_debit->encumbrance)) {
3453             # debit has been paid.  We cannot delete it.
3454             return OpenILS::Event->new('ACQ_NOT_CANCELABLE',
3455                note => "Debit is marked as paid: ".$po_item->fund_debit->id);
3456         }
3457
3458         # fund_debit is OK to delete.
3459         $e->delete_acq_fund_debit($po_item->fund_debit)
3460             or return $e->die_event;
3461     }
3462
3463     if ($delete_item) {
3464         $e->delete_acq_po_item($po_item) or return $e->die_event;
3465     } else {
3466         # remove our link to the now-deleted fund_debit.
3467         $po_item->clear_fund_debit;
3468         $e->update_acq_po_item($po_item) or return $e->die_event;
3469     }
3470
3471     return undef;
3472 }
3473
3474
3475 __PACKAGE__->register_method(
3476     method    => 'user_requests',
3477     api_name  => 'open-ils.acq.user_request.retrieve.by_user_id',
3478     stream    => 1,
3479     signature => {
3480         desc   => 'Retrieve fleshed user requests and related data for a given user.',
3481         params => [
3482             { desc => 'Authentication token',      type => 'string' },
3483             { desc => 'User ID of the owner, or array of IDs',      },
3484             { desc => 'Options hash (optional) with any of the keys: order_by, limit, offset, state (of the lineitem)',
3485               type => 'object'
3486             }
3487         ],
3488         return => {
3489             desc => 'Fleshed user requests and related data',
3490             type => 'object'
3491         }
3492     }
3493 );
3494
3495 __PACKAGE__->register_method(
3496     method    => 'user_requests',
3497     api_name  => 'open-ils.acq.user_request.retrieve.by_home_ou',
3498     stream    => 1,
3499     signature => {
3500         desc   => 'Retrieve fleshed user requests and related data for a given org unit or units.',
3501         params => [
3502             { desc => 'Authentication token',      type => 'string' },
3503             { desc => 'Org unit ID, or array of IDs',               },
3504             { desc => 'Options hash (optional) with any of the keys: order_by, limit, offset, state (of the lineitem)',
3505               type => 'object'
3506             }
3507         ],
3508         return => {
3509             desc => 'Fleshed user requests and related data',
3510             type => 'object'
3511         }
3512     }
3513 );
3514
3515 sub user_requests {
3516     my($self, $conn, $auth, $search_value, $options) = @_;
3517     my $e = new_editor(authtoken => $auth);
3518     return $e->event unless $e->checkauth;
3519     my $rid = $e->requestor->id;
3520     $options ||= {};
3521
3522     my $query = {
3523         "select"=>{"aur"=>["id"],"au"=>["home_ou", {column => 'id', alias => 'usr_id'} ]},
3524         "from"=>{ "aur" => { "au" => {}, "jub" => { "type" => "left" } } },
3525         "where"=>{
3526             "+jub"=> {
3527                 "-or" => [
3528                     {"id"=>undef}, # this with the left-join pulls in requests without lineitems
3529                     {"state"=>["new","on-order","pending-order"]} # FIXME - probably needs softcoding
3530                 ]
3531             }
3532         },
3533         "order_by"=>[{"class"=>"aur", "field"=>"request_date", "direction"=>"desc"}]
3534     };
3535
3536     foreach (qw/ order_by limit offset /) {
3537         $query->{$_} = $options->{$_} if defined $options->{$_};
3538     }
3539     if (defined $options->{'state'}) {
3540         $query->{'where'}->{'+jub'}->{'-or'}->[1]->{'state'} = $options->{'state'};
3541     }
3542
3543     if ($self->api_name =~ /by_user_id/) {
3544         $query->{'where'}->{'usr'} = $search_value;
3545     } else {
3546         $query->{'where'}->{'+au'} = { 'home_ou' => $search_value };
3547     }
3548
3549     my $pertinent_ids = $e->json_query($query);
3550
3551     my %perm_test = ();
3552     for my $id_blob (@$pertinent_ids) {
3553         if ($rid != $id_blob->{usr_id}) {
3554             if (!defined $perm_test{ $id_blob->{home_ou} }) {
3555                 $perm_test{ $id_blob->{home_ou} } = $e->allowed( ['user_request.view'], $id_blob->{home_ou} );
3556             }
3557             if (!$perm_test{ $id_blob->{home_ou} }) {
3558                 next; # failed test
3559             }
3560         }
3561         my $aur_obj = $e->retrieve_acq_user_request([
3562             $id_blob->{id},
3563             {flesh => 1, flesh_fields => { "aur" => [ 'lineitem' ] } }
3564         ]);
3565         if (! $aur_obj) { next; }
3566
3567         if ($aur_obj->lineitem()) {
3568             $aur_obj->lineitem()->clear_marc();
3569         }
3570         $conn->respond($aur_obj);
3571     }
3572
3573     return undef;
3574 }
3575
3576 __PACKAGE__->register_method (
3577     method    => 'update_user_request',
3578     api_name  => 'open-ils.acq.user_request.cancel.batch',
3579     stream    => 1,
3580     signature => {
3581         desc   => 'If given a cancel reason, will update the request with that reason, otherwise, this will delete the request altogether.  The '    .
3582                   'intention is for staff interfaces or processes to provide cancel reasons, and for patron interfaces to just delete the requests.' ,
3583         params => [
3584             { desc => 'Authentication token',              type => 'string' },
3585             { desc => 'ID or array of IDs for the user requests to cancel'  },
3586             { desc => 'Cancel Reason ID (optional)',       type => 'string' }
3587         ],
3588         return => {
3589             desc => 'progress object, event on error',
3590         }
3591     }
3592 );
3593 __PACKAGE__->register_method (
3594     method    => 'update_user_request',
3595     api_name  => 'open-ils.acq.user_request.set_no_hold.batch',
3596     stream    => 1,
3597     signature => {
3598         desc   => 'Remove the hold from a user request or set of requests',
3599         params => [
3600             { desc => 'Authentication token',              type => 'string' },
3601             { desc => 'ID or array of IDs for the user requests to modify'  }
3602         ],
3603         return => {
3604             desc => 'progress object, event on error',
3605         }
3606     }
3607 );
3608
3609 sub update_user_request {
3610     my($self, $conn, $auth, $aur_ids, $cancel_reason) = @_;
3611     my $e = new_editor(xact => 1, authtoken => $auth);
3612     return $e->die_event unless $e->checkauth;
3613     my $rid = $e->requestor->id;
3614
3615     my $x = 1;
3616     my %perm_test = ();
3617     for my $id (@$aur_ids) {
3618
3619         my $aur_obj = $e->retrieve_acq_user_request([
3620             $id,
3621             {   flesh => 1,
3622                 flesh_fields => { "aur" => ['lineitem', 'usr'] }
3623             }
3624         ]) or return $e->die_event;
3625
3626         my $context_org = $aur_obj->usr()->home_ou();
3627         $aur_obj->usr( $aur_obj->usr()->id() );
3628
3629         if ($rid != $aur_obj->usr) {
3630             if (!defined $perm_test{ $context_org }) {
3631                 $perm_test{ $context_org } = $e->allowed( ['user_request.update'], $context_org );
3632             }
3633             if (!$perm_test{ $context_org }) {
3634                 next; # failed test
3635             }
3636         }
3637
3638         if($self->api_name =~ /set_no_hold/) {
3639             if ($U->is_true($aur_obj->hold)) {
3640                 $aur_obj->hold(0);
3641                 $e->update_acq_user_request($aur_obj) or return $e->die_event;
3642             }
3643         }
3644
3645         if($self->api_name =~ /cancel/) {
3646             if ( $cancel_reason ) {
3647                 $aur_obj->cancel_reason( $cancel_reason );
3648                 $e->update_acq_user_request($aur_obj) or return $e->die_event;
3649                 create_user_request_events( $e, [ $aur_obj ], 'aur.rejected' );
3650             } else {
3651                 $e->delete_acq_user_request($aur_obj);
3652             }
3653         }
3654
3655         $conn->respond({maximum => scalar(@$aur_ids), progress => $x++});
3656     }
3657
3658     $e->commit;
3659     return {complete => 1};
3660 }
3661
3662 __PACKAGE__->register_method (
3663     method    => 'new_user_request',
3664     api_name  => 'open-ils.acq.user_request.create',
3665     signature => {
3666         desc   => 'Create a new user request object in the DB',
3667         param  => [
3668             { desc => 'Authentication token',   type => 'string' },
3669             { desc => 'User request data hash.  Hash keys match the fields for the "aur" object', type => 'object' }
3670         ],
3671         return => {
3672             desc => 'The created user request object, or event on error'
3673         }
3674     }
3675 );
3676
3677 sub new_user_request {
3678     my($self, $conn, $auth, $form_data) = @_;
3679     my $e = new_editor(xact => 1, authtoken => $auth);
3680     return $e->die_event unless $e->checkauth;
3681     my $rid = $e->requestor->id;
3682     my $target_user_fleshed;
3683     if (! defined $$form_data{'usr'}) {
3684         $$form_data{'usr'} = $rid;
3685     }
3686     if ($$form_data{'usr'} != $rid) {
3687         # See if the requestor can place the request on behalf of a different user.
3688         $target_user_fleshed = $e->retrieve_actor_user($$form_data{'usr'}) or return $e->die_event;
3689         $e->allowed('user_request.create', $target_user_fleshed->home_ou) or return $e->die_event;
3690     } else {
3691         $target_user_fleshed = $e->requestor;
3692         $e->allowed('CREATE_PURCHASE_REQUEST') or return $e->die_event;
3693     }
3694     if (! defined $$form_data{'pickup_lib'}) {
3695         if ($target_user_fleshed->ws_ou) {
3696             $$form_data{'pickup_lib'} = $target_user_fleshed->ws_ou;
3697         } else {
3698             $$form_data{'pickup_lib'} = $target_user_fleshed->home_ou;
3699         }
3700     }
3701     if (! defined $$form_data{'request_type'}) {
3702         $$form_data{'request_type'} = 1; # Books
3703     }
3704     my $aur_obj = new Fieldmapper::acq::user_request;
3705     $aur_obj->isnew(1);
3706     $aur_obj->usr( $$form_data{'usr'} );
3707     $aur_obj->request_date( 'now' );
3708     for my $field ( keys %$form_data ) {
3709         if (defined $$form_data{$field} and $field !~ /^(id|lineitem|eg_bib|request_date|cancel_reason)$/) {
3710             $aur_obj->$field( $$form_data{$field} );
3711         }
3712     }
3713
3714     $aur_obj = $e->create_acq_user_request($aur_obj) or return $e->die_event;
3715
3716     $e->commit and create_user_request_events( $e, [ $aur_obj ], 'aur.created' );
3717
3718     return $aur_obj;
3719 }
3720
3721 sub create_user_request_events {
3722     my($e, $user_reqs, $hook) = @_;
3723
3724     my $ses = OpenSRF::AppSession->create('open-ils.trigger');
3725     $ses->connect;
3726
3727     my %cached_usr_home_ou = ();
3728     for my $user_req (@$user_reqs) {
3729         my $home_ou = $cached_usr_home_ou{$user_req->usr};
3730         if (! $home_ou) {
3731             my $user = $e->retrieve_actor_user($user_req->usr) or return $e->die_event;
3732             $home_ou = $user->home_ou;
3733             $cached_usr_home_ou{$user_req->usr} = $home_ou;
3734         }
3735         my $req = $ses->request('open-ils.trigger.event.autocreate', $hook, $user_req, $home_ou);
3736         $req->recv;
3737     }
3738
3739     $ses->disconnect;
3740     return undef;
3741 }
3742
3743
3744 __PACKAGE__->register_method(
3745     method => "po_note_CUD_batch",
3746     api_name => "open-ils.acq.po_note.cud.batch",
3747     stream => 1,
3748     signature => {
3749         desc => q/Manage purchase order notes/,
3750         params => [
3751             {desc => "Authentication token", type => "string"},
3752             {desc => "List of po_notes to manage", type => "array"},
3753         ],
3754         return => {desc => "Stream of successfully managed objects"}
3755     }
3756 );
3757
3758 sub po_note_CUD_batch {
3759     my ($self, $conn, $auth, $notes) = @_;
3760
3761     my $e = new_editor("xact"=> 1, "authtoken" => $auth);
3762     return $e->die_event unless $e->checkauth;
3763     # XXX perms
3764
3765     my $total = @$notes;
3766     my $count = 0;
3767
3768     foreach my $note (@$notes) {
3769
3770         $note->editor($e->requestor->id);
3771         $note->edit_time("now");
3772
3773         if ($note->isnew) {
3774             $note->creator($e->requestor->id);
3775             $note = $e->create_acq_po_note($note) or return $e->die_event;
3776         } elsif ($note->isdeleted) {
3777             $e->delete_acq_po_note($note) or return $e->die_event;
3778         } elsif ($note->ischanged) {
3779             $e->update_acq_po_note($note) or return $e->die_event;
3780         }
3781
3782         unless ($note->isdeleted) {
3783             $note = $e->retrieve_acq_po_note($note->id) or
3784                 return $e->die_event;
3785         }
3786
3787         $conn->respond(
3788             {"maximum" => $total, "progress" => ++$count, "note" => $note}
3789         );
3790     }
3791
3792     $e->commit and $conn->respond_complete or return $e->die_event;
3793 }
3794
3795
3796 # retrieves a lineitem, fleshes its PO and PL, checks perms
3797 # returns ($li, $evt, $org)
3798 sub fetch_and_check_li {
3799     my $e = shift;
3800     my $li_id = shift;
3801     my $perm_mode = shift || 'read';
3802
3803     my $li = $e->retrieve_acq_lineitem([
3804         $li_id,
3805         {   flesh => 1,
3806             flesh_fields => {jub => ['purchase_order', 'picklist']}
3807         }
3808     ]) or return (undef, $e->die_event);
3809
3810     my $org;
3811     if(my $po = $li->purchase_order) {
3812         $org = $po->ordering_agency;
3813         my $perms = ($perm_mode eq 'read') ? 'VIEW_PURCHASE_ORDER' : 'CREATE_PURCHASE_ORDER';
3814         return ($li, $e->die_event) unless $e->allowed($perms, $org);
3815
3816     } elsif(my $pl = $li->picklist) {
3817         $org = $pl->org_unit;
3818         my $perms = ($perm_mode eq 'read') ? 'VIEW_PICKLIST' : 'CREATE_PICKLIST';
3819         return ($li, $e->die_event) unless $e->allowed($perms, $org);
3820     }
3821
3822     return ($li, undef, $org);
3823 }
3824
3825
3826 __PACKAGE__->register_method(
3827     method => "clone_distrib_form",
3828     api_name => "open-ils.acq.distribution_formula.clone",
3829     stream => 1,
3830     signature => {
3831         desc => q/Clone a distribution formula/,
3832         params => [
3833             {desc => "Authentication token", type => "string"},
3834             {desc => "Original formula ID", type => 'integer'},
3835             {desc => "Name of new formula", type => 'string'},
3836         ],
3837         return => {desc => "ID of newly created formula"}
3838     }
3839 );
3840
3841 sub clone_distrib_form {
3842     my($self, $client, $auth, $form_id, $new_name) = @_;
3843
3844     my $e = new_editor("xact"=> 1, "authtoken" => $auth);
3845     return $e->die_event unless $e->checkauth;
3846
3847     my $old_form = $e->retrieve_acq_distribution_formula($form_id) or return $e->die_event;
3848     return $e->die_event unless $e->allowed('ADMIN_ACQ_DISTRIB_FORMULA', $old_form->owner);
3849
3850     my $new_form = Fieldmapper::acq::distribution_formula->new;
3851
3852     $new_form->owner($old_form->owner);
3853     $new_form->name($new_name);
3854     $e->create_acq_distribution_formula($new_form) or return $e->die_event;
3855
3856     my $entries = $e->search_acq_distribution_formula_entry({formula => $form_id});
3857     for my $entry (@$entries) {
3858        my $new_entry = Fieldmapper::acq::distribution_formula_entry->new;
3859        $new_entry->$_($entry->$_()) for $entry->real_fields;
3860        $new_entry->formula($new_form->id);
3861        $new_entry->clear_id;
3862        $e->create_acq_distribution_formula_entry($new_entry) or return $e->die_event;
3863     }
3864
3865     $e->commit;
3866     return $new_form->id;
3867 }
3868
3869 __PACKAGE__->register_method(
3870     method => 'add_li_to_po',
3871     api_name    => 'open-ils.acq.purchase_order.add_lineitem',
3872     signature => {
3873         desc => q/Adds a lineitem to an existing purchase order/,
3874         params => [
3875             {desc => 'Authentication token', type => 'string'},
3876             {desc => 'The purchase order id', type => 'number'},
3877             {desc => 'The lineitem ID (or an array of them)', type => 'mixed'},
3878         ],
3879         return => {desc => 'Streams a total versus completed counts object, event on error'}
3880     }
3881 );
3882
3883 sub add_li_to_po {
3884     my($self, $conn, $auth, $po_id, $li_id) = @_;
3885
3886     my $e = new_editor(authtoken => $auth, xact => 1);
3887     return $e->die_event unless $e->checkauth;
3888
3889     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
3890
3891     my $po = $e->retrieve_acq_purchase_order($po_id)
3892         or return $e->die_event;
3893
3894     return $e->die_event unless
3895         $e->allowed('CREATE_PURCHASE_ORDER', $po->ordering_agency);
3896
3897     unless ($po->state =~ /new|pending/) {
3898         $e->rollback;
3899         return {success => 0, po => $po, error => 'bad-po-state'};
3900     }
3901
3902     my $lis;
3903
3904     if (ref $li_id eq "ARRAY") {
3905         $li_id = [ map { int($_) } @$li_id ];
3906         return $e->die_event(new OpenILS::Event("BAD_PARAMS")) unless @$li_id;
3907
3908         $lis = $e->search_acq_lineitem({id => $li_id})
3909             or return $e->die_event;
3910     } else {
3911         my $li = $e->retrieve_acq_lineitem(int($li_id))
3912             or return $e->die_event;
3913         $lis = [$li];
3914     }
3915
3916     foreach my $li (@$lis) {
3917         if ($li->state !~ /new|order-ready|pending-order/ or
3918             $li->purchase_order) {
3919             $e->rollback;
3920             return {success => 0, li => $li, error => 'bad-li-state'};
3921         }
3922
3923         $li->provider($po->provider);
3924         $li->purchase_order($po_id);
3925         $li->state('pending-order');
3926         apply_default_copies($mgr, $po, $li->id) or return $e->die_event;
3927         update_lineitem($mgr, $li) or return $e->die_event;
3928     }
3929
3930     $e->commit;
3931     return {success => 1};
3932 }
3933
3934 __PACKAGE__->register_method(
3935     method => 'po_lineitems_no_copies',
3936     api_name => 'open-ils.acq.purchase_order.no_copy_lineitems.id_list',
3937     stream => 1,
3938     authoritative => 1,
3939     signature => {
3940         desc => q/Returns the set of lineitem IDs for a given PO that have no copies attached/,
3941         params => [
3942             {desc => 'Authentication token', type => 'string'},
3943             {desc => 'The purchase order id', type => 'number'},
3944         ],
3945         return => {desc => 'Stream of lineitem IDs on success, event on error'}
3946     }
3947 );
3948
3949 sub po_lineitems_no_copies {
3950     my ($self, $conn, $auth, $po_id) = @_;
3951
3952     my $e = new_editor(authtoken => $auth);
3953     return $e->event unless $e->checkauth;
3954
3955     # first check the view perms for LI's attached to this PO
3956     my $po = $e->retrieve_acq_purchase_order($po_id) or return $e->event;
3957     return $e->event unless $e->allowed('VIEW_PURCHASE_ORDER', $po->ordering_agency);
3958
3959     my $ids = $e->json_query({
3960         select => {jub => ['id']},
3961         from => {jub => {acqlid => {type => 'left'}}},
3962         where => {
3963             '+jub' => {purchase_order => $po_id},
3964             '+acqlid' => {lineitem => undef}
3965         }
3966     });
3967
3968     $conn->respond($_->{id}) for @$ids;
3969     return undef;
3970 }
3971
3972 __PACKAGE__->register_method(
3973     method => 'set_li_order_ident',
3974     api_name => 'open-ils.acq.lineitem.order_identifier.set',
3975     signature => {
3976         desc => q/
3977             Given an existing lineitem_attr (typically a marc_attr), this will
3978             create a matching local_attr to store the name and value and mark
3979             the attr as the order_ident.  Any existing local_attr marked as
3980             order_ident is removed.
3981         /,
3982         params => [
3983             {desc => 'Authentication token', type => 'string'},
3984             {desc => q/Args object:
3985                 source_attr_id : ID of the existing lineitem_attr to use as
3986                     order ident.
3987                 lineitem_id : lineitem id
3988                 attr_name : name ('isbn', etc.) of a new marc_attr to add to
3989                     the lineitem to use for the order ident
3990                 attr_value : value for the new marc_attr
3991                 no_apply_bre : if set, newly added attrs will not be applied
3992                     to the lineitems' linked bib record/,
3993                 type => 'object'}
3994         ],
3995         return => {desc => q/Returns the attribute
3996             responsible for tracking the order identifier/}
3997     }
3998 );
3999
4000 sub set_li_order_ident {
4001     my ($self, $conn, $auth, $args) = @_;
4002     $args ||= {};
4003
4004     my $source_attr;
4005     my $source_attr_id = $args->{source_attr_id};
4006
4007     my $e = new_editor(authtoken => $auth, xact => 1);
4008     return $e->die_event unless $e->checkauth;
4009
4010     # fetch attr, LI, and check update permissions
4011
4012     my $li_id = $args->{lineitem_id};
4013
4014     if ($source_attr_id) {
4015         $source_attr = $e->retrieve_acq_lineitem_attr($source_attr_id)
4016             or return $e->die_event;
4017         $li_id = $source_attr->lineitem;
4018     }
4019
4020     my ($li, $evt, $perm_org) = fetch_and_check_li($e, $li_id, 'write');
4021     return $evt if $evt;
4022
4023     return $e->die_event unless
4024         $e->allowed('ACQ_SET_LINEITEM_IDENTIFIER', $perm_org);
4025
4026     # if needed, create a new marc attr for
4027     # the lineitem to represent the ident value
4028
4029     ($source_attr, $evt) = apply_new_li_ident_attr(
4030         $e, $li, $perm_org, $args->{attr_name}, $args->{attr_value})
4031         unless $source_attr;
4032
4033     return $evt if $evt;
4034
4035     # remove the existing order_ident attribute if present
4036
4037     my $old_attr = $e->search_acq_lineitem_attr({
4038         attr_type => 'lineitem_local_attr_definition',
4039         lineitem => $li->id,
4040         order_ident => 't'
4041     })->[0];
4042
4043     if ($old_attr) {
4044
4045         # if we already have an order_ident that matches the
4046         # source attr, there's nothing left to do.
4047
4048         if ($old_attr->attr_name eq $source_attr->attr_name and
4049             $old_attr->attr_value eq $source_attr->attr_value) {
4050
4051             $e->rollback;
4052             return $old_attr;
4053
4054         } else {
4055             # remove the old order_ident attribute
4056             $e->delete_acq_lineitem_attr($old_attr) or return $e->die_event;
4057         }
4058     }
4059
4060     # make sure we have a local_attr_def to match the source attr def
4061
4062     my $local_def = $e->search_acq_lineitem_local_attr_definition({
4063         code => $source_attr->attr_name
4064     })->[0];
4065
4066     if (!$local_def) {
4067         my $source_def =
4068             $e->retrieve_acq_lineitem_attr_definition($source_attr->definition);
4069         $local_def = Fieldmapper::acq::lineitem_local_attr_definition->new;
4070         $local_def->code($source_def->code);
4071         $local_def->description($source_def->description);
4072         $local_def = $e->create_acq_lineitem_local_attr_definition($local_def)
4073             or return $e->die_event;
4074     }
4075
4076     # create the new order_ident local attr
4077
4078     my $new_attr = Fieldmapper::acq::lineitem_attr->new;
4079     $new_attr->definition($local_def->id);
4080     $new_attr->attr_type('lineitem_local_attr_definition');
4081     $new_attr->lineitem($li->id);
4082     $new_attr->attr_name($source_attr->attr_name);
4083     $new_attr->attr_value($source_attr->attr_value);
4084     $new_attr->order_ident('t');
4085
4086     $new_attr = $e->create_acq_lineitem_attr($new_attr)
4087         or return $e->die_event;
4088
4089     $e->commit;
4090     return $new_attr;
4091 }
4092
4093
4094 # Given an isbn, issn, or upc, add the value to the lineitem marc.
4095 # Upon update, the value will be auto-magically represented as
4096 # a lineitem marc attr.
4097 # If the li is linked to a bib record and the user has the correct
4098 # permissions, update the bib record to match.
4099 sub apply_new_li_ident_attr {
4100     my ($e, $li, $perm_org, $attr_name, $attr_value) = @_;
4101
4102     my %tags = (
4103         isbn => '020',
4104         issn => '022',
4105         upc  => '024'
4106     );
4107
4108     my $marc_field = MARC::Field->new(
4109         $tags{$attr_name}, '', '','a' => $attr_value);
4110
4111     my $li_rec = MARC::Record->new_from_xml($li->marc, 'UTF-8', 'USMARC');
4112     $li_rec->insert_fields_ordered($marc_field);
4113
4114     $li->marc(clean_marc($li_rec));
4115     $li->editor($e->requestor->id);
4116     $li->edit_time('now');
4117
4118     $e->update_acq_lineitem($li) or return (undef, $e->die_event);
4119
4120     my $source_attr = $e->search_acq_lineitem_attr({
4121         attr_name => $attr_name,
4122         attr_value => $attr_value,
4123         attr_type => 'lineitem_marc_attr_definition'
4124     })->[0];
4125
4126     if (!$source_attr) {
4127         $logger->error("ACQ lineitem update failed to produce a matching ".
4128             " marc attribute for $attr_name => $attr_value");
4129         return (undef, OpenILS::Event->new('INTERNAL_SERVER_ERROR'));
4130     }
4131
4132     return ($source_attr) unless
4133         $li->eg_bib_id and
4134         $e->allowed('ACQ_ADD_LINEITEM_IDENTIFIER', $perm_org);
4135
4136     # li is linked to a bib record and user has the update perms
4137
4138     my $bre = $e->retrieve_biblio_record_entry($li->eg_bib_id);
4139     my $bre_marc = MARC::Record->new_from_xml($bre->marc, 'UTF-8', 'USMARC');
4140     $bre_marc->insert_fields_ordered($marc_field);
4141
4142     $bre->marc(clean_marc($bre_marc));
4143     $bre->editor($e->requestor->id);
4144     $bre->edit_date('now');
4145
4146     $e->update_biblio_record_entry($bre) or return (undef, $e->die_event);
4147
4148     return ($source_attr);
4149 }
4150
4151 __PACKAGE__->register_method(
4152     method => 'li_existing_copies',
4153     api_name => 'open-ils.acq.lineitem.existing_copies.count',
4154     authoritative => 1,
4155     signature => {
4156         desc => q/
4157             Returns the number of catalog copies (acp) which are children of
4158             the same bib record linked to by the given lineitem and which
4159             are owned at or below the lineitem context org unit.
4160             Copies with the following statuses are not counted:
4161             Lost, Missing, Discard Weed, and Lost and Paid.
4162         /,
4163         params => [
4164             {desc => 'Authentication token', type => 'string'},
4165             {desc => 'Lineitem ID', type => 'number'}
4166         ],
4167         return => {desc => q/Count or event on error/}
4168     }
4169 );
4170
4171 sub li_existing_copies {
4172     my ($self, $client, $auth, $li_id) = @_;
4173     my $e = new_editor("authtoken" => $auth);
4174     return $e->die_event unless $e->checkauth;
4175
4176     my ($li, $evt, $org) = fetch_and_check_li($e, $li_id);
4177     return 0 if $evt;
4178
4179     # No fuzzy matching here (e.g. on ISBN).  Only exact matches are supported.
4180     return 0 unless $li->eg_bib_id;
4181
4182     my $counts = $e->json_query({
4183         select => {acp => [{
4184             column => 'id',
4185             transform => 'count',
4186             aggregate => 1
4187         }]},
4188         from => {
4189             acp => {
4190                 acqlid => {
4191                     fkey => 'id',
4192                     field => 'eg_copy_id',
4193                     type => 'left'
4194                 },
4195                 acn => {join => {bre => {}}}
4196             }
4197         },
4198         where => {
4199             '+bre' => {id => $li->eg_bib_id},
4200             # don't count copies linked to the lineitem in question
4201             '+acqlid' => {
4202                 '-or' => [
4203                     {lineitem => undef},
4204                     {lineitem => {'<>' => $li_id}}
4205                 ]
4206             },
4207             '+acn' => {
4208                 owning_lib => $U->get_org_descendants($org)
4209             },
4210             # NOTE: should the excluded copy statuses be an AOUS?
4211             '+acp' => {status => {'not in' => [3, 4, 13, 17]}}
4212         }
4213     });
4214
4215     return $counts->[0]->{id};
4216 }
4217
4218
4219 1;
4220