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

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