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