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