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