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