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