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