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