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

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