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

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