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