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

   1 package OpenILS::Application::Acq::BatchManager;
   2 use OpenSRF::AppSession;
   3 use OpenSRF::EX qw/:try/;
   4 use strict; use warnings;
   5
   6 sub new {
   7     my($class, %args) = @_;
   8     my $self = bless(\%args, $class);
   9     $self->{args} = {
  10         lid => 0,
  11         li => 0,
  12         copies => 0,
  13         bibs => 0,
  14         progress => 0,
  15         debits_accrued => 0,
  16         purchase_order => undef,
  17         picklist => undef,
  18         complete => 0,
  19         indexed => 0,
  20         total => 0
  21     };
  22     $self->{ingest_queue} = [];
  23     $self->{cache} = {};
  24     $self->throttle(5) unless $self->throttle;
  25     $self->{post_proc_queue} = [];
  26     $self->{last_respond_progress} = 0;
  27     return $self;
  28 }
  29
  30 sub conn {
  31     my($self, $val) = @_;
  32     $self->{conn} = $val if $val;
  33     return $self->{conn};
  34 }
  35 sub throttle {
  36     my($self, $val) = @_;
  37     $self->{throttle} = $val if $val;
  38     return $self->{throttle};
  39 }
  40 sub respond {
  41     my($self, %other_args) = @_;
  42     if($self->throttle and not %other_args) {
  43         return unless (
  44             ($self->{args}->{progress} - $self->{last_respond_progress}) >= $self->throttle
  45         );
  46     }
  47     $self->conn->respond({ %{$self->{args}}, %other_args });
  48     $self->{last_respond_progress} = $self->{args}->{progress};
  49 }
  50 sub respond_complete {
  51     my($self, %other_args) = @_;
  52     $self->complete;
  53     $self->conn->respond_complete({ %{$self->{args}}, %other_args });
  54     $self->run_post_response_hooks;
  55     return undef;
  56 }
  57
  58 # run the post response hook subs, shifting them off as we go
  59 sub run_post_response_hooks {
  60     my($self) = @_;
  61     (shift @{$self->{post_proc_queue}})->() while @{$self->{post_proc_queue}};
  62 }
  63
  64 # any subs passed to this method will be run after the call to respond_complete
  65 sub post_process {
  66     my($self, $sub) = @_;
  67     push(@{$self->{post_proc_queue}}, $sub);
  68 }
  69
  70 sub total {
  71     my($self, $val) = @_;
  72     $self->{args}->{total} = $val if defined $val;
  73     $self->{args}->{maximum} = $self->{args}->{total};
  74     return $self->{args}->{total};
  75 }
  76 sub purchase_order {
  77     my($self, $val) = @_;
  78     $self->{args}->{purchase_order} = $val if $val;
  79     return $self;
  80 }
  81 sub picklist {
  82     my($self, $val) = @_;
  83     $self->{args}->{picklist} = $val if $val;
  84     return $self;
  85 }
  86 sub add_lid {
  87     my $self = shift;
  88     $self->{args}->{lid} += 1;
  89     $self->{args}->{progress} += 1;
  90     return $self;
  91 }
  92 sub add_li {
  93     my $self = shift;
  94     $self->{args}->{li} += 1;
  95     $self->{args}->{progress} += 1;
  96     return $self;
  97 }
  98 sub add_copy {
  99     my $self = shift;
 100     $self->{args}->{copies} += 1;
 101     $self->{args}->{progress} += 1;
 102     return $self;
 103 }
 104 sub add_bib {
 105     my $self = shift;
 106     $self->{args}->{bibs} += 1;
 107     $self->{args}->{progress} += 1;
 108     return $self;
 109 }
 110 sub add_debit {
 111     my($self, $amount) = @_;
 112     $self->{args}->{debits_accrued} += $amount;
 113     $self->{args}->{progress} += 1;
 114     return $self;
 115 }
 116 sub editor {
 117     my($self, $editor) = @_;
 118     $self->{editor} = $editor if defined $editor;
 119     return $self->{editor};
 120 }
 121 sub complete {
 122     my $self = shift;
 123     $self->{args}->{complete} = 1;
 124     return $self;
 125 }
 126
 127 sub ingest_ses {
 128     my($self, $val) = @_;
 129     $self->{ingest_ses} = $val if $val;
 130     return $self->{ingest_ses};
 131 }
 132
 133 sub push_ingest_queue {
 134     my($self, $rec_id) = @_;
 135
 136     $self->ingest_ses(OpenSRF::AppSession->connect('open-ils.ingest'))
 137         unless $self->ingest_ses;
 138
 139     my $req = $self->ingest_ses->request('open-ils.ingest.full.biblio.record', $rec_id);
 140
 141     push(@{$self->{ingest_queue}}, $req);
 142 }
 143
 144 sub process_ingest_records {
 145     my $self = shift;
 146     return unless @{$self->{ingest_queue}};
 147
 148     for my $req (@{$self->{ingest_queue}}) {
 149
 150         try {
 151             $req->gather(1);
 152             $self->{args}->{indexed} += 1;
 153             $self->{args}->{progress} += 1;
 154         } otherwise {};
 155
 156         $self->respond;
 157     }
 158     $self->ingest_ses->disconnect;
 159 }
 160
 161
 162 sub cache {
 163     my($self, $org, $key, $val) = @_;
 164     $self->{cache}->{$org} = {} unless $self->{cache}->{org};
 165     $self->{cache}->{$org}->{$key} = $val if defined $val;
 166     return $self->{cache}->{$org}->{$key};
 167 }
 168
 169
 170 package OpenILS::Application::Acq::Order;
 171 use base qw/OpenILS::Application/;
 172 use strict; use warnings;
 173 # ----------------------------------------------------------------------------
 174 # Break up each component of the order process and pieces into managable
 175 # actions that can be shared across different workflows
 176 # ----------------------------------------------------------------------------
 177 use OpenILS::Event;
 178 use OpenSRF::Utils::Logger qw(:logger);
 179 use OpenSRF::Utils::JSON;
 180 use OpenSRF::AppSession;
 181 use OpenILS::Utils::Fieldmapper;
 182 use OpenILS::Utils::CStoreEditor q/:funcs/;
 183 use OpenILS::Const qw/:const/;
 184 use OpenSRF::EX q/:try/;
 185 use OpenILS::Application::AppUtils;
 186 use OpenILS::Application::Cat::BibCommon;
 187 use OpenILS::Application::Cat::AssetCommon;
 188 use MARC::Record;
 189 use MARC::Batch;
 190 use MARC::File::XML;
 191 my $U = 'OpenILS::Application::AppUtils';
 192
 193
 194 # ----------------------------------------------------------------------------
 195 # Lineitem
 196 # ----------------------------------------------------------------------------
 197 sub create_lineitem {
 198     my($mgr, %args) = @_;
 199     my $li = Fieldmapper::acq::lineitem->new;
 200     $li->creator($mgr->editor->requestor->id);
 201     $li->selector($li->creator);
 202     $li->editor($li->creator);
 203     $li->create_time('now');
 204     $li->edit_time('now');
 205     $li->state('new');
 206     $li->$_($args{$_}) for keys %args;
 207     $li->clear_id;
 208     $mgr->add_li;
 209     return $mgr->editor->create_acq_lineitem($li);
 210 }
 211
 212 sub update_lineitem {
 213     my($mgr, $li) = @_;
 214     $li->edit_time('now');
 215     $li->editor($mgr->editor->requestor->id);
 216     $mgr->add_li;
 217     return $li if $mgr->editor->update_acq_lineitem($li);
 218     return undef;
 219 }
 220
 221
 222 # ----------------------------------------------------------------------------
 223 # Create real holds from patron requests for a given lineitem
 224 # ----------------------------------------------------------------------------
 225 sub promote_lineitem_holds {
 226     my($mgr, $li) = @_;
 227
 228     my $requests = $mgr->editor->search_acq_user_request(
 229         { lineitem => $li->id,
 230           '-or' =>
 231             [ { need_before => {'>' => 'now'} },
 232               { need_before => undef }
 233             ]
 234         }
 235     );
 236
 237     for my $request ( @$requests ) {
 238
 239         $request->eg_bib( $li->eg_bib_id );
 240         $mgr->editor->update_acq_user_request( $request ) or return 0;
 241
 242         next unless ($U->is_true( $request->hold ));
 243
 244         my $hold = Fieldmapper::action::hold_request->new;
 245         $hold->usr( $request->usr );
 246         $hold->requestor( $request->usr );
 247         $hold->request_time( $request->request_date );
 248         $hold->pickup_lib( $request->pickup_lib );
 249         $hold->request_lib( $request->pickup_lib );
 250         $hold->selection_ou( $request->pickup_lib );
 251         $hold->phone_notify( $request->phone_notify );
 252         $hold->email_notify( $request->email_notify );
 253         $hold->expire_time( $request->need_before );
 254
 255         if ($request->holdable_formats) {
 256             my $mrm = $mgr->editor->search_metabib_metarecord_source_map( { source => $li->eg_bib_id } )->[0];
 257             if ($mrm) {
 258                 $hold->hold_type( 'M' );
 259                 $hold->holdable_formats( $request->holdable_formats );
 260                 $hold->target( $mrm->metarecord );
 261             }
 262         }
 263
 264         if (!$hold->target) {
 265             $hold->hold_type( 'T' );
 266             $hold->target( $li->eg_bib_id );
 267         }
 268
 269         $mgr->editor->create_actor_hold_request( $hold ) or return 0;
 270     }
 271
 272     return $li;
 273 }
 274
 275 sub delete_lineitem {
 276     my($mgr, $li) = @_;
 277     $li = $mgr->editor->retrieve_acq_lineitem($li) unless ref $li;
 278
 279     # delete the attached lineitem_details
 280     my $lid_ids = $mgr->editor->search_acq_lineitem_detail({lineitem => $li->id}, {idlist=>1});
 281     for my $lid_id (@$lid_ids) {
 282         return 0 unless delete_lineitem_detail($mgr, $lid_id);
 283     }
 284
 285     $mgr->add_li;
 286     return $mgr->editor->delete_acq_lineitem($li);
 287 }
 288
 289 # begins and commit transactions as it goes
 290 sub create_lineitem_list_assets {
 291     my($mgr, $li_ids) = @_;
 292     return undef if check_import_li_marc_perms($mgr, $li_ids);
 293
 294     # create the bibs/volumes/copies and ingest the records
 295     for my $li_id (@$li_ids) {
 296         $mgr->editor->xact_begin;
 297         my $data = create_lineitem_assets($mgr, $li_id) or return undef;
 298         $mgr->editor->xact_commit;
 299         # XXX ingest is in-db now
 300         #$mgr->push_ingest_queue($data->{li}->eg_bib_id) if $data->{new_bib};
 301         $mgr->respond;
 302     }
 303     $mgr->process_ingest_records;
 304     return 1;
 305 }
 306
 307 # returns event on error, undef on success
 308 sub check_import_li_marc_perms {
 309     my($mgr, $li_ids) = @_;
 310
 311     # if there are any order records that are not linked to
 312     # in-db bib records, verify staff has perms to import order records
 313     my $order_li = $mgr->editor->search_acq_lineitem(
 314         [{id => $li_ids, eg_bib_id => undef}, {limit => 1}], {idlist => 1})->[0];
 315
 316     if($order_li) {
 317         return $mgr->editor->die_event unless
 318             $mgr->editor->allowed('IMPORT_ACQ_LINEITEM_BIB_RECORD');
 319     }
 320
 321     return undef;
 322 }
 323
 324
 325 # ----------------------------------------------------------------------------
 326 # if all of the lineitem details for this lineitem have
 327 # been received, mark the lineitem as received
 328 # returns 1 on non-received, li on received, 0 on error
 329 # ----------------------------------------------------------------------------
 330 sub check_lineitem_received {
 331     my($mgr, $li_id) = @_;
 332
 333     my $non_recv = $mgr->editor->search_acq_lineitem_detail(
 334         {recv_time => undef, lineitem => $li_id}, {idlist=>1});
 335
 336     return 1 if @$non_recv;
 337
 338     my $li = $mgr->editor->retrieve_acq_lineitem($li_id);
 339     $li->state('received');
 340     return update_lineitem($mgr, $li);
 341 }
 342
 343 sub receive_lineitem {
 344     my($mgr, $li_id, $skip_complete_check) = @_;
 345     my $li = $mgr->editor->retrieve_acq_lineitem($li_id) or return 0;
 346
 347     my $lid_ids = $mgr->editor->search_acq_lineitem_detail(
 348         {lineitem => $li_id, recv_time => undef}, {idlist => 1});
 349
 350     for my $lid_id (@$lid_ids) {
 351        receive_lineitem_detail($mgr, $lid_id, 1) or return 0;
 352     }
 353
 354     $mgr->add_li;
 355     $li->state('received');
 356     update_lineitem($mgr, $li) or return 0;
 357
 358     $mgr->post_process( sub { create_lineitem_status_events($mgr, $li_id, 'aur.received'); });
 359
 360     return 1 if $skip_complete_check;
 361
 362     return check_purchase_order_received($mgr, $li->purchase_order);
 363 }
 364
 365 sub rollback_receive_lineitem {
 366     my($mgr, $li_id) = @_;
 367     my $li = $mgr->editor->retrieve_acq_lineitem($li_id) or return 0;
 368
 369     my $lid_ids = $mgr->editor->search_acq_lineitem_detail(
 370         {lineitem => $li_id, recv_time => {'!=' => undef}}, {idlist => 1});
 371
 372     for my $lid_id (@$lid_ids) {
 373        rollback_receive_lineitem_detail($mgr, $lid_id, 1) or return 0;
 374     }
 375
 376     $mgr->add_li;
 377     $li->state('on-order');
 378     return update_lineitem($mgr, $li);
 379 }
 380
 381
 382 sub create_lineitem_status_events {
 383     my($mgr, $li_id, $hook) = @_;
 384
 385     my $ses = OpenSRF::AppSession->create('open-ils.trigger');
 386     $ses->connect;
 387     my $user_reqs = $mgr->editor->search_acq_user_request([
 388         {lineitem => $li_id},
 389         {flesh => 1, flesh_fields => {aur => ['usr']}}
 390     ]);
 391
 392     for my $user_req (@$user_reqs) {
 393         my $req = $ses->request('open-ils.trigger.event.autocreate', $hook, $user_req, $user_req->usr->home_ou);
 394         $req->recv;
 395     }
 396
 397     $ses->disconnect;
 398     return undef;
 399 }
 400
 401 # ----------------------------------------------------------------------------
 402 # Lineitem Detail
 403 # ----------------------------------------------------------------------------
 404 sub create_lineitem_detail {
 405     my($mgr, %args) = @_;
 406     my $lid = Fieldmapper::acq::lineitem_detail->new;
 407     $lid->$_($args{$_}) for keys %args;
 408     $lid->clear_id;
 409     $mgr->add_lid;
 410     return $mgr->editor->create_acq_lineitem_detail($lid);
 411 }
 412
 413
 414 # flesh out any required data with default values where appropriate
 415 sub complete_lineitem_detail {
 416     my($mgr, $lid) = @_;
 417     unless($lid->barcode) {
 418         my $pfx = $U->ou_ancestor_setting_value($lid->owning_lib, 'acq.tmp_barcode_prefix') || 'ACQ';
 419         $lid->barcode($pfx.$lid->id);
 420     }
 421
 422     unless($lid->cn_label) {
 423         my $pfx = $U->ou_ancestor_setting_value($lid->owning_lib, 'acq.tmp_callnumber_prefix') || 'ACQ';
 424         $lid->cn_label($pfx.$lid->id);
 425     }
 426
 427     if(!$lid->location and my $loc = $U->ou_ancestor_setting_value($lid->owning_lib, 'acq.default_copy_location')) {
 428         $lid->location($loc);
 429     }
 430
 431     if(!$lid->circ_modifier and my $mod = get_default_circ_modifier($mgr, $lid->owning_lib)) {
 432         $lid->circ_modifier($mod);
 433     }
 434
 435     $mgr->editor->update_acq_lineitem_detail($lid) or return 0;
 436     return $lid;
 437 }
 438
 439 sub get_default_circ_modifier {
 440     my($mgr, $org) = @_;
 441     my $mod = $mgr->cache($org, 'def_circ_mod');
 442     return $mod if $mod;
 443     $mod = $U->ou_ancestor_setting_value($org, 'acq.default_circ_modifier');
 444     return $mgr->cache($org, 'def_circ_mod', $mod) if $mod;
 445     return undef;
 446 }
 447
 448 sub delete_lineitem_detail {
 449     my($mgr, $lid) = @_;
 450     $lid = $mgr->editor->retrieve_acq_lineitem_detail($lid) unless ref $lid;
 451     return $mgr->editor->delete_acq_lineitem_detail($lid);
 452 }
 453
 454
 455 sub receive_lineitem_detail {
 456     my($mgr, $lid_id, $skip_complete_check) = @_;
 457     my $e = $mgr->editor;
 458
 459     my $lid = $e->retrieve_acq_lineitem_detail([
 460         $lid_id,
 461         {   flesh => 1,
 462             flesh_fields => {
 463                 acqlid => ['fund_debit']
 464             }
 465         }
 466     ]) or return 0;
 467
 468     return 1 if $lid->recv_time;
 469
 470     $lid->recv_time('now');
 471     $e->update_acq_lineitem_detail($lid) or return 0;
 472
 473     my $copy = $e->retrieve_asset_copy($lid->eg_copy_id) or return 0;
 474     $copy->status(OILS_COPY_STATUS_IN_PROCESS);
 475     $copy->edit_date('now');
 476     $copy->editor($e->requestor->id);
 477     $e->update_asset_copy($copy) or return 0;
 478
 479     if($lid->fund_debit) {
 480         $lid->fund_debit->encumbrance('f');
 481         $e->update_acq_fund_debit($lid->fund_debit) or return 0;
 482     }
 483
 484     $mgr->add_lid;
 485
 486     return 1 if $skip_complete_check;
 487
 488     my $li = check_lineitem_received($mgr, $lid->lineitem) or return 0;
 489     return 1 if $li == 1; # li not received
 490
 491     return check_purchase_order_received($mgr, $li->purchase_order);
 492 }
 493
 494
 495 sub rollback_receive_lineitem_detail {
 496     my($mgr, $lid_id) = @_;
 497     my $e = $mgr->editor;
 498
 499     my $lid = $e->retrieve_acq_lineitem_detail([
 500         $lid_id,
 501         {   flesh => 1,
 502             flesh_fields => {
 503                 acqlid => ['fund_debit']
 504             }
 505         }
 506     ]) or return 0;
 507
 508     return 1 unless $lid->recv_time;
 509
 510     $lid->clear_recv_time;
 511     $e->update_acq_lineitem_detail($lid) or return 0;
 512
 513     my $copy = $e->retrieve_asset_copy($lid->eg_copy_id) or return 0;
 514     $copy->status(OILS_COPY_STATUS_ON_ORDER);
 515     $copy->edit_date('now');
 516     $copy->editor($e->requestor->id);
 517     $e->update_asset_copy($copy) or return 0;
 518
 519     if($lid->fund_debit) {
 520         $lid->fund_debit->encumbrance('t');
 521         $e->update_acq_fund_debit($lid->fund_debit) or return 0;
 522     }
 523
 524     $mgr->add_lid;
 525     return $lid;
 526 }
 527
 528 # ----------------------------------------------------------------------------
 529 # Lineitem Attr
 530 # ----------------------------------------------------------------------------
 531 sub set_lineitem_attr {
 532     my($mgr, %args) = @_;
 533     my $attr_type = $args{attr_type};
 534
 535     # first, see if it's already set.  May just need to overwrite it
 536     my $attr = $mgr->editor->search_acq_lineitem_attr({
 537         lineitem => $args{lineitem},
 538         attr_type => $args{attr_type},
 539         attr_name => $args{attr_name}
 540     })->[0];
 541
 542     if($attr) {
 543         $attr->attr_value($args{attr_value});
 544         return $attr if $mgr->editor->update_acq_lineitem_attr($attr);
 545         return undef;
 546
 547     } else {
 548
 549         $attr = Fieldmapper::acq::lineitem_attr->new;
 550         $attr->$_($args{$_}) for keys %args;
 551
 552         unless($attr->definition) {
 553             my $find = "search_acq_$attr_type";
 554             my $attr_def_id = $mgr->editor->$find({code => $attr->attr_name}, {idlist=>1})->[0] or return 0;
 555             $attr->definition($attr_def_id);
 556         }
 557         return $mgr->editor->create_acq_lineitem_attr($attr);
 558     }
 559 }
 560
 561 sub get_li_price {
 562     my $li = shift;
 563     my $attrs = $li->attributes;
 564     my ($marc_estimated, $local_estimated, $local_actual, $prov_estimated, $prov_actual);
 565
 566     for my $attr (@$attrs) {
 567         if($attr->attr_name eq 'estimated_price') {
 568             $local_estimated = $attr->attr_value
 569                 if $attr->attr_type eq 'lineitem_local_attr_definition';
 570             $prov_estimated = $attr->attr_value
 571                 if $attr->attr_type eq 'lineitem_prov_attr_definition';
 572             $marc_estimated = $attr->attr_value
 573                 if $attr->attr_type eq 'lineitem_marc_attr_definition';
 574
 575         } elsif($attr->attr_name eq 'actual_price') {
 576             $local_actual = $attr->attr_value
 577                 if $attr->attr_type eq 'lineitem_local_attr_definition';
 578             $prov_actual = $attr->attr_value
 579                 if $attr->attr_type eq 'lineitem_prov_attr_definition';
 580         }
 581     }
 582
 583     return ($local_actual, 1) if $local_actual;
 584     return ($prov_actual, 2) if $prov_actual;
 585     return ($local_estimated, 1) if $local_estimated;
 586     return ($prov_estimated, 2) if $prov_estimated;
 587     return ($marc_estimated, 3);
 588 }
 589
 590
 591 # ----------------------------------------------------------------------------
 592 # Lineitem Debits
 593 # ----------------------------------------------------------------------------
 594 sub create_lineitem_debits {
 595     my($mgr, $li, $price, $ptype) = @_;
 596
 597     ($price, $ptype) = get_li_price($li) unless $price;
 598
 599     unless($price) {
 600         $mgr->editor->event(OpenILS::Event->new('ACQ_LINEITEM_NO_PRICE', payload => $li->id));
 601         $mgr->editor->rollback;
 602         return 0;
 603     }
 604
 605     unless($li->provider) {
 606         $mgr->editor->event(OpenILS::Event->new('ACQ_LINEITEM_NO_PROVIDER', payload => $li->id));
 607         $mgr->editor->rollback;
 608         return 0;
 609     }
 610
 611     my $lid_ids = $mgr->editor->search_acq_lineitem_detail(
 612         {lineitem => $li->id},
 613         {idlist=>1}
 614     );
 615
 616     for my $lid_id (@$lid_ids) {
 617
 618         my $lid = $mgr->editor->retrieve_acq_lineitem_detail([
 619             $lid_id,
 620             {   flesh => 1,
 621                 flesh_fields => {acqlid => ['fund']}
 622             }
 623         ]);
 624
 625         create_lineitem_detail_debit($mgr, $li, $lid, $price, $ptype) or return 0;
 626     }
 627
 628     return 1;
 629 }
 630
 631
 632 # flesh li->provider
 633 # flesh lid->fund
 634 # ptype 1=local, 2=provider, 3=marc
 635 sub create_lineitem_detail_debit {
 636     my($mgr, $li, $lid, $price, $ptype) = @_;
 637
 638     my $li_id = ref($li) ? $li->id : $li;
 639
 640     unless(ref $li and ref $li->provider) {
 641        $li = $mgr->editor->retrieve_acq_lineitem([
 642             $li_id,
 643             {   flesh => 1,
 644                 flesh_fields => {jub => ['provider']},
 645             }
 646         ]);
 647     }
 648
 649     unless(ref $lid and ref $lid->fund) {
 650         $lid = $mgr->editor->retrieve_acq_lineitem_detail([
 651             $lid,
 652             {   flesh => 1,
 653                 flesh_fields => {acqlid => ['fund']}
 654             }
 655         ]);
 656     }
 657
 658     my $ctype = $lid->fund->currency_type;
 659     my $amount = $price;
 660
 661     if($ptype == 2) { # price from vendor
 662         $ctype = $li->provider->currency_type;
 663         $amount = currency_conversion($mgr, $ctype, $lid->fund->currency_type, $price);
 664     }
 665
 666     my $debit = create_fund_debit(
 667         $mgr,
 668         fund => $lid->fund->id,
 669         origin_amount => $price,
 670         origin_currency_type => $ctype,
 671         amount => $amount
 672     ) or return 0;
 673
 674     $lid->fund_debit($debit->id);
 675     $lid->fund($lid->fund->id);
 676     $mgr->editor->update_acq_lineitem_detail($lid) or return 0;
 677     return $debit;
 678 }
 679
 680
 681 # ----------------------------------------------------------------------------
 682 # Fund Debit
 683 # ----------------------------------------------------------------------------
 684 sub create_fund_debit {
 685     my($mgr, %args) = @_;
 686
 687     # Verify the fund is not being spent beyond the hard stop amount
 688     my $fund = $mgr->editor->retrieve_acq_fund($args{fund}) or return 0;
 689
 690     if($fund->balance_stop_percent) {
 691
 692         my $balance = $mgr->editor->search_acq_fund_combined_balance({fund => $fund->id})->[0];
 693         my $allocations = $mgr->editor->search_acq_fund_allocation_total({fund => $fund->id})->[0];
 694         $balance = ($balance) ? $balance->amount : 0;
 695         $allocations = ($allocations) ? $allocations->amount : 0;
 696
 697         if(
 698             $allocations == 0 || # if no allocations were ever made, assume we have hit the stop percent
 699             ( ( ( ($balance - $args{amount}) / $allocations ) * 100 ) < $fund->balance_stop_percent))
 700         {
 701                 $mgr->editor->event(OpenILS::Event->new(
 702                     'FUND_EXCEEDS_STOP_PERCENT',
 703                     payload => {fund => $fund->id, debit_amount => $args{amount}}
 704                 ));
 705                 return 0;
 706         }
 707     }
 708
 709     my $debit = Fieldmapper::acq::fund_debit->new;
 710     $debit->debit_type('purchase');
 711     $debit->encumbrance('t');
 712     $debit->$_($args{$_}) for keys %args;
 713     $debit->clear_id;
 714     $mgr->add_debit($debit->amount);
 715     return $mgr->editor->create_acq_fund_debit($debit);
 716 }
 717
 718 sub currency_conversion {
 719     my($mgr, $src_currency, $dest_currency, $amount) = @_;
 720     my $result = $mgr->editor->json_query(
 721         {from => ['acq.exchange_ratio', $src_currency, $dest_currency, $amount]});
 722     return $result->[0]->{'acq.exchange_ratio'};
 723 }
 724
 725
 726 # ----------------------------------------------------------------------------
 727 # Picklist
 728 # ----------------------------------------------------------------------------
 729 sub create_picklist {
 730     my($mgr, %args) = @_;
 731     my $picklist = Fieldmapper::acq::picklist->new;
 732     $picklist->creator($mgr->editor->requestor->id);
 733     $picklist->owner($picklist->creator);
 734     $picklist->editor($picklist->creator);
 735     $picklist->create_time('now');
 736     $picklist->edit_time('now');
 737     $picklist->org_unit($mgr->editor->requestor->ws_ou);
 738     $picklist->owner($mgr->editor->requestor->id);
 739     $picklist->$_($args{$_}) for keys %args;
 740     $picklist->clear_id;
 741     $mgr->picklist($picklist);
 742     return $mgr->editor->create_acq_picklist($picklist);
 743 }
 744
 745 sub update_picklist {
 746     my($mgr, $picklist) = @_;
 747     $picklist = $mgr->editor->retrieve_acq_picklist($picklist) unless ref $picklist;
 748     $picklist->edit_time('now');
 749     $picklist->editor($mgr->editor->requestor->id);
 750     $mgr->picklist($picklist);
 751     return $picklist if $mgr->editor->update_acq_picklist($picklist);
 752     return undef;
 753 }
 754
 755 sub delete_picklist {
 756     my($mgr, $picklist) = @_;
 757     $picklist = $mgr->editor->retrieve_acq_picklist($picklist) unless ref $picklist;
 758
 759     # delete all 'new' lineitems
 760     my $li_ids = $mgr->editor->search_acq_lineitem({picklist => $picklist->id, state => 'new'}, {idlist => 1});
 761     for my $li_id (@$li_ids) {
 762         my $li = $mgr->editor->retrieve_acq_lineitem($li_id);
 763         return 0 unless delete_lineitem($mgr, $li);
 764         $mgr->respond;
 765     }
 766
 767     # detach all non-'new' lineitems
 768     $li_ids = $mgr->editor->search_acq_lineitem({picklist => $picklist->id, state => {'!=' => 'new'}}, {idlist => 1});
 769     for my $li_id (@$li_ids) {
 770         my $li = $mgr->editor->retrieve_acq_lineitem($li_id);
 771         $li->clear_picklist;
 772         return 0 unless update_lineitem($mgr, $li);
 773         $mgr->respond;
 774     }
 775
 776     # remove any picklist-specific object perms
 777     my $ops = $mgr->editor->search_permission_usr_object_perm_map({object_type => 'acqpl', object_id => ''.$picklist->id});
 778     for my $op (@$ops) {
 779         return 0 unless $mgr->editor->delete_usr_object_perm_map($op);
 780     }
 781
 782     return $mgr->editor->delete_acq_picklist($picklist);
 783 }
 784
 785 # ----------------------------------------------------------------------------
 786 # Purchase Order
 787 # ----------------------------------------------------------------------------
 788 sub update_purchase_order {
 789     my($mgr, $po) = @_;
 790     $po = $mgr->editor->retrieve_acq_purchase_order($po) unless ref $po;
 791     $po->editor($mgr->editor->requestor->id);
 792     $po->edit_time('now');
 793     $mgr->purchase_order($po);
 794     return $po if $mgr->editor->update_acq_purchase_order($po);
 795     return undef;
 796 }
 797
 798 sub create_purchase_order {
 799     my($mgr, %args) = @_;
 800
 801     # verify the chosen provider is still active
 802     my $provider = $mgr->editor->retrieve_acq_provider($args{provider}) or return 0;
 803     unless($U->is_true($provider->active)) {
 804         $logger->error("provider is not active.  cannot create PO");
 805         $mgr->editor->event(OpenILS::Event->new('ACQ_PROVIDER_INACTIVE'));
 806         return 0;
 807     }
 808
 809     my $po = Fieldmapper::acq::purchase_order->new;
 810     $po->creator($mgr->editor->requestor->id);
 811     $po->editor($mgr->editor->requestor->id);
 812     $po->owner($mgr->editor->requestor->id);
 813     $po->edit_time('now');
 814     $po->create_time('now');
 815     $po->state('pending');
 816     $po->ordering_agency($mgr->editor->requestor->ws_ou);
 817     $po->$_($args{$_}) for keys %args;
 818     $po->clear_id;
 819     $mgr->purchase_order($po);
 820     return $mgr->editor->create_acq_purchase_order($po);
 821 }
 822
 823 # ----------------------------------------------------------------------------
 824 # if all of the lineitems for this PO are received,
 825 # mark the PO as received
 826 # ----------------------------------------------------------------------------
 827 sub check_purchase_order_received {
 828     my($mgr, $po_id) = @_;
 829
 830     my $non_recv_li = $mgr->editor->search_acq_lineitem(
 831         {   purchase_order => $po_id,
 832             state => {'!=' => 'received'}
 833         }, {idlist=>1});
 834
 835     return 1 if @$non_recv_li;
 836
 837     my $po = $mgr->editor->retrieve_acq_purchase_order($po_id);
 838     $po->state('received');
 839     return update_purchase_order($mgr, $po);
 840 }
 841
 842
 843 # ----------------------------------------------------------------------------
 844 # Bib, Callnumber, and Copy data
 845 # ----------------------------------------------------------------------------
 846
 847 sub create_lineitem_assets {
 848     my($mgr, $li_id) = @_;
 849     my $evt;
 850
 851     my $li = $mgr->editor->retrieve_acq_lineitem([
 852         $li_id,
 853         {   flesh => 1,
 854             flesh_fields => {jub => ['purchase_order', 'attributes']}
 855         }
 856     ]) or return 0;
 857
 858     # -----------------------------------------------------------------
 859     # first, create the bib record if necessary
 860     # -----------------------------------------------------------------
 861     my $new_bib = 0;
 862     unless($li->eg_bib_id) {
 863         create_bib($mgr, $li) or return 0;
 864         $new_bib = 1;
 865     }
 866
 867
 868     # -----------------------------------------------------------------
 869     # The lineitem is going live, promote user request holds to real holds
 870     # -----------------------------------------------------------------
 871     promote_lineitem_holds($mgr, $li) or return 0;
 872
 873     my $li_details = $mgr->editor->search_acq_lineitem_detail({lineitem => $li_id}, {idlist=>1});
 874
 875     # -----------------------------------------------------------------
 876     # for each lineitem_detail, create the volume if necessary, create
 877     # a copy, and link them all together.
 878     # -----------------------------------------------------------------
 879     my $first_cn;
 880     for my $lid_id (@{$li_details}) {
 881
 882         my $lid = $mgr->editor->retrieve_acq_lineitem_detail($lid_id) or return 0;
 883         next if $lid->eg_copy_id;
 884
 885         # use the same callnumber label for all items within this lineitem
 886         $lid->cn_label($first_cn) if $first_cn and not $lid->cn_label;
 887
 888         # apply defaults if necessary
 889         return 0 unless complete_lineitem_detail($mgr, $lid);
 890
 891         $first_cn = $lid->cn_label unless $first_cn;
 892
 893         my $org = $lid->owning_lib;
 894         my $label = $lid->cn_label;
 895         my $bibid = $li->eg_bib_id;
 896
 897         my $volume = $mgr->cache($org, "cn.$bibid.$label");
 898         unless($volume) {
 899             $volume = create_volume($mgr, $li, $lid) or return 0;
 900             $mgr->cache($org, "cn.$bibid.$label", $volume);
 901         }
 902         create_copy($mgr, $volume, $lid) or return 0;
 903     }
 904
 905     return { li => $li, new_bib => $new_bib };
 906 }
 907
 908 sub create_bib {
 909     my($mgr, $li) = @_;
 910
 911     my $record = OpenILS::Application::Cat::BibCommon->biblio_record_xml_import(
 912         $mgr->editor,
 913         $li->marc,
 914         undef, # bib source
 915         undef,
 916         1, # override tcn collisions
 917     );
 918
 919     if($U->event_code($record)) {
 920         $mgr->editor->event($record);
 921         $mgr->editor->rollback;
 922         return 0;
 923     }
 924
 925     $li->eg_bib_id($record->id);
 926     $mgr->add_bib;
 927     return update_lineitem($mgr, $li);
 928 }
 929
 930 sub create_volume {
 931     my($mgr, $li, $lid) = @_;
 932
 933     my ($volume, $evt) =
 934         OpenILS::Application::Cat::AssetCommon->find_or_create_volume(
 935             $mgr->editor,
 936             $lid->cn_label,
 937             $li->eg_bib_id,
 938             $lid->owning_lib
 939         );
 940
 941     if($evt) {
 942         $mgr->editor->event($evt);
 943         return 0;
 944     }
 945
 946     return $volume;
 947 }
 948
 949 sub create_copy {
 950     my($mgr, $volume, $lid) = @_;
 951     my $copy = Fieldmapper::asset::copy->new;
 952     $copy->isnew(1);
 953     $copy->loan_duration(2);
 954     $copy->fine_level(2);
 955     $copy->status(OILS_COPY_STATUS_ON_ORDER);
 956     $copy->barcode($lid->barcode);
 957     $copy->location($lid->location);
 958     $copy->call_number($volume->id);
 959     $copy->circ_lib($volume->owning_lib);
 960     $copy->circ_modifier($lid->circ_modifier);
 961
 962     my $evt = OpenILS::Application::Cat::AssetCommon->create_copy($mgr->editor, $volume, $copy);
 963     if($evt) {
 964         $mgr->editor->event($evt);
 965         return 0;
 966     }
 967
 968     $mgr->add_copy;
 969     $lid->eg_copy_id($copy->id);
 970     $mgr->editor->update_acq_lineitem_detail($lid) or return 0;
 971 }
 972
 973
 974
 975
 976
 977
 978 # ----------------------------------------------------------------------------
 979 # Workflow: Build a selection list from a Z39.50 search
 980 # ----------------------------------------------------------------------------
 981
 982 __PACKAGE__->register_method(
 983         method => 'zsearch',
 984         api_name => 'open-ils.acq.picklist.search.z3950',
 985     stream => 1,
 986         signature => {
 987         desc => 'Performs a z3950 federated search and creates a picklist and associated lineitems',
 988         params => [
 989             {desc => 'Authentication token', type => 'string'},
 990             {desc => 'Search definition', type => 'object'},
 991             {desc => 'Picklist name, optional', type => 'string'},
 992         ]
 993     }
 994 );
 995
 996 sub zsearch {
 997     my($self, $conn, $auth, $search, $name, $options) = @_;
 998     my $e = new_editor(authtoken=>$auth);
 999     return $e->event unless $e->checkauth;
1000     return $e->event unless $e->allowed('CREATE_PICKLIST');
1001
1002     $search->{limit} ||= 10;
1003     $options ||= {};
1004
1005     my $ses = OpenSRF::AppSession->create('open-ils.search');
1006     my $req = $ses->request('open-ils.search.z3950.search_class', $auth, $search);
1007
1008     my $first = 1;
1009     my $picklist;
1010     my $mgr;
1011     while(my $resp = $req->recv(timeout=>60)) {
1012
1013         if($first) {
1014             my $e = new_editor(requestor=>$e->requestor, xact=>1);
1015             $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
1016             $picklist = zsearch_build_pl($mgr, $name);
1017             $first = 0;
1018         }
1019
1020         my $result = $resp->content;
1021         my $count = $result->{count} || 0;
1022         $mgr->total( (($count < $search->{limit}) ? $count : $search->{limit})+1 );
1023
1024         for my $rec (@{$result->{records}}) {
1025
1026             my $li = create_lineitem($mgr,
1027                 picklist => $picklist->id,
1028                 source_label => $result->{service},
1029                 marc => $rec->{marcxml},
1030                 eg_bib_id => $rec->{bibid}
1031             );
1032
1033             if($$options{respond_li}) {
1034                 $li->attributes($mgr->editor->search_acq_lineitem_attr({lineitem => $li->id}))
1035                     if $$options{flesh_attrs};
1036                 $li->clear_marc if $$options{clear_marc};
1037                 $mgr->respond(lineitem => $li);
1038             } else {
1039                 $mgr->respond;
1040             }
1041         }
1042     }
1043
1044     $mgr->editor->commit;
1045     return $mgr->respond_complete;
1046 }
1047
1048 sub zsearch_build_pl {
1049     my($mgr, $name) = @_;
1050     $name ||= '';
1051
1052     my $picklist = $mgr->editor->search_acq_picklist({
1053         owner => $mgr->editor->requestor->id,
1054         name => $name
1055     })->[0];
1056
1057     if($name eq '' and $picklist) {
1058         return 0 unless delete_picklist($mgr, $picklist);
1059         $picklist = undef;
1060     }
1061
1062     return update_picklist($mgr, $picklist) if $picklist;
1063     return create_picklist($mgr, name => $name);
1064 }
1065
1066
1067 # ----------------------------------------------------------------------------
1068 # Workflow: Build a selection list / PO by importing a batch of MARC records
1069 # ----------------------------------------------------------------------------
1070
1071 __PACKAGE__->register_method(
1072     method => 'upload_records',
1073     api_name => 'open-ils.acq.process_upload_records',
1074     stream => 1,
1075 );
1076
1077 sub upload_records {
1078     my($self, $conn, $auth, $key) = @_;
1079
1080         my $e = new_editor(authtoken => $auth, xact => 1);
1081     return $e->die_event unless $e->checkauth;
1082     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
1083
1084     my $cache = OpenSRF::Utils::Cache->new;
1085
1086     my $data = $cache->get_cache("vandelay_import_spool_$key");
1087         my $purpose = $data->{purpose};
1088     my $filename = $data->{path};
1089     my $provider = $data->{provider};
1090     my $picklist = $data->{picklist};
1091     my $create_po = $data->{create_po};
1092     my $ordering_agency = $data->{ordering_agency};
1093     my $create_assets = $data->{create_assets};
1094     my $po;
1095     my $evt;
1096
1097     unless(-r $filename) {
1098         $logger->error("unable to read MARC file $filename");
1099         $e->rollback;
1100         return OpenILS::Event->new('FILE_UPLOAD_ERROR', payload => {filename => $filename});
1101     }
1102
1103     $provider = $e->retrieve_acq_provider($provider) or return $e->die_event;
1104
1105     if($picklist) {
1106         $picklist = $e->retrieve_acq_picklist($picklist) or return $e->die_event;
1107         if($picklist->owner != $e->requestor->id) {
1108             return $e->die_event unless
1109                 $e->allowed('CREATE_PICKLIST', $picklist->org_unit, $picklist);
1110         }
1111         $mgr->picklist($picklist);
1112     }
1113
1114     if($create_po) {
1115
1116         $po = create_purchase_order($mgr,
1117             ordering_agency => $ordering_agency,
1118             provider => $provider->id,
1119             state => 'on-order'
1120         ) or return $mgr->editor->die_event;
1121     }
1122
1123     $logger->info("acq processing MARC file=$filename");
1124
1125     my $marctype = 'USMARC'; # ?
1126         my $batch = new MARC::Batch ($marctype, $filename);
1127         $batch->strict_off;
1128
1129         my $count = 0;
1130     my @li_list;
1131
1132         while(1) {
1133
1134             my $err;
1135         my $xml;
1136                 $count++;
1137         my $r;
1138
1139                 try {
1140             $r = $batch->next;
1141         } catch Error with {
1142             $err = shift;
1143                         $logger->warn("Proccessing of record $count in set $key failed with error $err.  Skipping this record");
1144         };
1145
1146         next if $err;
1147         last unless $r;
1148
1149                 try {
1150             ($xml = $r->as_xml_record()) =~ s/\n//sog;
1151             $xml =~ s/^<\?xml.+\?\s*>//go;
1152             $xml =~ s/>\s+</></go;
1153             $xml =~ s/\p{Cc}//go;
1154             $xml = $U->entityize($xml);
1155             $xml =~ s/[\x00-\x1f]//go;
1156
1157                 } catch Error with {
1158                         $err = shift;
1159                         $logger->warn("Proccessing XML of record $count in set $key failed with error $err.  Skipping this record");
1160                 };
1161
1162         next if $err or not $xml;
1163
1164         my %args = (
1165             source_label => $provider->code,
1166             provider => $provider->id,
1167             marc => $xml,
1168         );
1169
1170         $args{picklist} = $picklist->id if $picklist;
1171         if($po) {
1172             $args{purchase_order} = $po->id;
1173             $args{state} = 'on-order';
1174         }
1175
1176         my $li = create_lineitem($mgr, %args) or return $mgr->editor->die_event;
1177         $mgr->respond;
1178         $li->provider($provider); # flesh it, we'll need it later
1179
1180         import_lineitem_details($mgr, $ordering_agency, $li) or return $mgr->editor->die_event;
1181         $mgr->respond;
1182
1183         push(@li_list, $li->id);
1184         $mgr->respond;
1185         }
1186
1187         $e->commit;
1188     unlink($filename);
1189     $cache->delete_cache('vandelay_import_spool_' . $key);
1190
1191     if($create_assets) {
1192         create_lineitem_list_assets($mgr, \@li_list) or return $e->die_event;
1193     }
1194
1195     return $mgr->respond_complete;
1196 }
1197
1198 sub import_lineitem_details {
1199     my($mgr, $ordering_agency, $li) = @_;
1200
1201     my $holdings = $mgr->editor->json_query({from => ['acq.extract_provider_holding_data', $li->id]});
1202     return 1 unless @$holdings;
1203     my $org_path = $U->get_org_ancestors($ordering_agency);
1204     $org_path = [ reverse (@$org_path) ];
1205     my $price;
1206
1207     my $idx = 1;
1208     while(1) {
1209         # create a lineitem detail for each copy in the data
1210
1211         my $compiled = extract_lineitem_detail_data($mgr, $org_path, $holdings, $idx);
1212         last unless defined $compiled;
1213         return 0 unless $compiled;
1214
1215         # this takes the price of the last copy and uses it as the lineitem price
1216         # need to determine if a given record would include different prices for the same item
1217         $price = $$compiled{price};
1218
1219         for(1..$$compiled{quantity}) {
1220             my $lid = create_lineitem_detail($mgr,
1221                 lineitem => $li->id,
1222                 owning_lib => $$compiled{owning_lib},
1223                 cn_label => $$compiled{call_number},
1224                 fund => $$compiled{fund},
1225                 circ_modifier => $$compiled{circ_modifier},
1226                 note => $$compiled{note},
1227                 location => $$compiled{copy_location},
1228                 collection_code => $$compiled{collection_code}
1229             ) or return 0;
1230         }
1231
1232         $mgr->respond;
1233         $idx++;
1234     }
1235
1236     # set the price attr so we'll know the source of the price
1237     set_lineitem_attr(
1238         $mgr,
1239         attr_name => 'estimated_price',
1240         attr_type => 'lineitem_local_attr_definition',
1241         attr_value => $price,
1242         lineitem => $li->id
1243     ) or return 0;
1244
1245     # if we're creating a purchase order, create the debits
1246     if($li->purchase_order) {
1247         create_lineitem_debits($mgr, $li, $price, 2) or return 0;
1248         $mgr->respond;
1249     }
1250
1251     return 1;
1252 }
1253
1254 # return hash on success, 0 on error, undef on no more holdings
1255 sub extract_lineitem_detail_data {
1256     my($mgr, $org_path, $holdings, $index) = @_;
1257
1258     my @data_list = grep { $_->{holding} eq $index } @$holdings;
1259     return undef unless @data_list;
1260
1261     my %compiled = map { $_->{attr} => $_->{data} } @data_list;
1262     my $base_org = $$org_path[0];
1263
1264     my $killme = sub {
1265         my $msg = shift;
1266         $logger->error("Item import extraction error: $msg");
1267         $logger->error('Holdings Data: ' . OpenSRF::Utils::JSON->perl2JSON(\%compiled));
1268         $mgr->editor->rollback;
1269         $mgr->editor->event(OpenILS::Event->new('ACQ_IMPORT_ERROR', payload => $msg));
1270         return 0;
1271     };
1272
1273     $compiled{quantity} ||= 1;
1274
1275     # ---------------------------------------------------------------------
1276     # Fund
1277     my $code = $compiled{fund_code};
1278     return $killme->('no fund code provided') unless $code;
1279
1280     my $fund = $mgr->cache($base_org, "fund.$code");
1281     unless($fund) {
1282         # search up the org tree for the most appropriate fund
1283         for my $org (@$org_path) {
1284             $fund = $mgr->editor->search_acq_fund(
1285                 {org => $org, code => $code, year => DateTime->now->year}, {idlist => 1})->[0];
1286             last if $fund;
1287         }
1288     }
1289     return $killme->("no fund with code $code at orgs [@$org_path]") unless $fund;
1290     $compiled{fund} = $fund;
1291     $mgr->cache($base_org, "fund.$code", $fund);
1292
1293
1294     # ---------------------------------------------------------------------
1295     # Owning lib
1296     my $sn = $compiled{owning_lib};
1297     return $killme->('no owning_lib defined') unless $sn;
1298     my $org_id =
1299         $mgr->cache($base_org, "orgsn.$sn") ||
1300             $mgr->editor->search_actor_org_unit({shortname => $sn}, {idlist => 1})->[0];
1301     return $killme->("invalid owning_lib defined: $sn") unless $org_id;
1302     $compiled{owning_lib} = $org_id;
1303     $mgr->cache($$org_path[0], "orgsn.$sn", $org_id);
1304
1305
1306     # ---------------------------------------------------------------------
1307     # Circ Modifier
1308     my $mod;
1309     $code = $compiled{circ_modifier};
1310
1311     if($code) {
1312
1313         $mod = $mgr->cache($base_org, "mod.$code") ||
1314             $mgr->editor->retrieve_config_circ_modifier($code);
1315         return $killme->("invlalid circ_modifier $code") unless $mod;
1316         $mgr->cache($base_org, "mod.$code", $mod);
1317
1318     } else {
1319         # try the default
1320         $mod = get_default_circ_modifier($mgr, $base_org)
1321             or return $killme->('no circ_modifier defined');
1322     }
1323
1324     $compiled{circ_modifier} = $mod;
1325
1326
1327     # ---------------------------------------------------------------------
1328     # Shelving Location
1329     my $name = $compiled{copy_location};
1330     if($name) {
1331         my $loc = $mgr->cache($base_org, "copy_loc.$name");
1332         unless($loc) {
1333             for my $org (@$org_path) {
1334                 $loc = $mgr->editor->search_asset_copy_location(
1335                     {owning_lib => $org, name => $name}, {idlist => 1})->[0];
1336                 last if $loc;
1337             }
1338         }
1339         return $killme->("Invalid copy location $name") unless $loc;
1340         $compiled{copy_location} = $loc;
1341         $mgr->cache($base_org, "copy_loc.$name", $loc);
1342     }
1343
1344     return \%compiled;
1345 }
1346
1347
1348
1349 # ----------------------------------------------------------------------------
1350 # Workflow: Given an existing purchase order, import/create the bibs,
1351 # callnumber and copy objects
1352 # ----------------------------------------------------------------------------
1353
1354 __PACKAGE__->register_method(
1355         method => 'create_po_assets',
1356         api_name        => 'open-ils.acq.purchase_order.assets.create',
1357         signature => {
1358         desc => q/Creates assets for each lineitem in the purchase order/,
1359         params => [
1360             {desc => 'Authentication token', type => 'string'},
1361             {desc => 'The purchase order id', type => 'number'},
1362         ],
1363         return => {desc => 'Streams a total versus completed counts object, event on error'}
1364     }
1365 );
1366
1367 sub create_po_assets {
1368     my($self, $conn, $auth, $po_id) = @_;
1369
1370     my $e = new_editor(authtoken=>$auth, xact=>1);
1371     return $e->die_event unless $e->checkauth;
1372     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
1373
1374     my $po = $e->retrieve_acq_purchase_order($po_id) or return $e->die_event;
1375
1376     my $li_ids = $e->search_acq_lineitem({purchase_order => $po_id}, {idlist => 1});
1377
1378     # it's ugly, but it's fast.  Get the total count of lineitem detail objects to process
1379     my $lid_total = $e->json_query({
1380         select => { acqlid => [{aggregate => 1, transform => 'count', column => 'id'}] },
1381         from => {
1382             acqlid => {
1383                 jub => {
1384                     fkey => 'lineitem',
1385                     field => 'id',
1386                     join => {acqpo => {fkey => 'purchase_order', field => 'id'}}
1387                 }
1388             }
1389         },
1390         where => {'+acqpo' => {id => $po_id}}
1391     })->[0]->{id};
1392
1393     $mgr->total(scalar(@$li_ids) + $lid_total);
1394
1395     create_lineitem_list_assets($mgr, $li_ids) or return $e->die_event;
1396
1397     $e->xact_begin;
1398     update_purchase_order($mgr, $po) or return $e->die_event;
1399     $e->commit;
1400
1401     return $mgr->respond_complete;
1402 }
1403
1404
1405
1406 __PACKAGE__->register_method(
1407         method => 'create_purchase_order_api',
1408         api_name        => 'open-ils.acq.purchase_order.create',
1409         signature => {
1410         desc => 'Creates a new purchase order',
1411         params => [
1412             {desc => 'Authentication token', type => 'string'},
1413             {desc => 'purchase_order to create', type => 'object'}
1414         ],
1415         return => {desc => 'The purchase order id, Event on failure'}
1416     }
1417 );
1418
1419 sub create_purchase_order_api {
1420     my($self, $conn, $auth, $po, $args) = @_;
1421     $args ||= {};
1422
1423     my $e = new_editor(xact=>1, authtoken=>$auth);
1424     return $e->die_event unless $e->checkauth;
1425     return $e->die_event unless $e->allowed('CREATE_PURCHASE_ORDER', $po->ordering_agency);
1426     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
1427
1428     # create the PO
1429     my %pargs = (ordering_agency => $e->requestor->ws_ou); # default
1430     $pargs{provider} = $po->provider if $po->provider;
1431     $pargs{ordering_agency} = $po->ordering_agency if $po->ordering_agency;
1432     $po = create_purchase_order($mgr, %pargs) or return $e->die_event;
1433
1434     my $li_ids = $$args{lineitems};
1435
1436     if($li_ids) {
1437
1438         for my $li_id (@$li_ids) {
1439
1440             my $li = $e->retrieve_acq_lineitem([
1441                 $li_id,
1442                 {flesh => 1, flesh_fields => {jub => ['attributes']}}
1443             ]) or return $e->die_event;
1444
1445             $li->provider($po->provider);
1446             $li->purchase_order($po->id);
1447             $li->state('pending-order');
1448             update_lineitem($mgr, $li) or return $e->die_event;
1449             $mgr->respond;
1450
1451             create_lineitem_debits($mgr, $li) or return $e->die_event;
1452         }
1453     }
1454
1455     # commit before starting the asset creation
1456     $e->xact_commit;
1457
1458     if($li_ids and $$args{create_assets}) {
1459         create_lineitem_list_assets($mgr, $li_ids) or return $e->die_event;
1460     }
1461
1462     return $mgr->respond_complete;
1463 }
1464
1465
1466 __PACKAGE__->register_method(
1467         method => 'lineitem_detail_CUD_batch',
1468         api_name => 'open-ils.acq.lineitem_detail.cud.batch',
1469     stream => 1,
1470         signature => {
1471         desc => q/Creates a new purchase order line item detail.
1472             Additionally creates the associated fund_debit/,
1473         params => [
1474             {desc => 'Authentication token', type => 'string'},
1475             {desc => 'List of lineitem_details to create', type => 'array'},
1476         ],
1477         return => {desc => 'Streaming response of current position in the array'}
1478     }
1479 );
1480
1481 sub lineitem_detail_CUD_batch {
1482     my($self, $conn, $auth, $li_details) = @_;
1483
1484     my $e = new_editor(xact=>1, authtoken=>$auth);
1485     return $e->die_event unless $e->checkauth;
1486     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
1487
1488     # XXX perms
1489
1490     $mgr->total(scalar(@$li_details));
1491
1492     my %li_cache;
1493
1494     for my $lid (@$li_details) {
1495
1496         my $li = $li_cache{$lid->lineitem} || $e->retrieve_acq_lineitem($lid->lineitem);
1497
1498         if($lid->isnew) {
1499             create_lineitem_detail($mgr, %{$lid->to_bare_hash}) or return $e->die_event;
1500
1501         } elsif($lid->ischanged) {
1502             $e->update_acq_lineitem_detail($lid) or return $e->die_event;
1503
1504         } elsif($lid->isdeleted) {
1505             delete_lineitem_detail($mgr, $lid) or return $e->die_event;
1506         }
1507
1508         $mgr->respond(li => $li);
1509         $li_cache{$lid->lineitem} = $li;
1510     }
1511
1512     $e->commit;
1513     return $mgr->respond_complete;
1514 }
1515
1516
1517 __PACKAGE__->register_method(
1518         method => 'receive_po_api',
1519         api_name        => 'open-ils.acq.purchase_order.receive'
1520 );
1521
1522 sub receive_po_api {
1523     my($self, $conn, $auth, $po_id) = @_;
1524     my $e = new_editor(xact => 1, authtoken => $auth);
1525     return $e->die_event unless $e->checkauth;
1526     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
1527
1528     my $po = $e->retrieve_acq_purchase_order($po_id) or return $e->die_event;
1529     return $e->die_event unless $e->allowed('RECEIVE_PURCHASE_ORDER', $po->ordering_agency);
1530
1531     my $li_ids = $e->search_acq_lineitem({purchase_order => $po_id}, {idlist => 1});
1532
1533     for my $li_id (@$li_ids) {
1534         receive_lineitem($mgr, $li_id) or return $e->die_event;
1535         $mgr->respond;
1536     }
1537
1538     $po->state('received');
1539     update_purchase_order($mgr, $po) or return $e->die_event;
1540
1541     $e->commit;
1542     return $mgr->respond_complete;
1543 }
1544
1545
1546 __PACKAGE__->register_method(
1547         method => 'receive_lineitem_detail_api',
1548         api_name        => 'open-ils.acq.lineitem_detail.receive',
1549         signature => {
1550         desc => 'Mark a lineitem_detail as received',
1551         params => [
1552             {desc => 'Authentication token', type => 'string'},
1553             {desc => 'lineitem detail ID', type => 'number'}
1554         ],
1555         return => {desc => '1 on success, Event on error'}
1556     }
1557 );
1558
1559 sub receive_lineitem_detail_api {
1560     my($self, $conn, $auth, $lid_id) = @_;
1561
1562     my $e = new_editor(xact=>1, authtoken=>$auth);
1563     return $e->die_event unless $e->checkauth;
1564     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
1565
1566     my $lid = $e->retrieve_acq_lineitem_detail([
1567         $lid_id, {
1568             flesh => 2,
1569             flesh_fields => {
1570                 acqlid => ['lineitem'],
1571                 jub => ['purchase_order']
1572             }
1573         }
1574     ]);
1575
1576     return $e->die_event unless $e->allowed(
1577         'RECEIVE_PURCHASE_ORDER', $lid->lineitem->purchase_order->ordering_agency);
1578
1579     receive_lineitem_detail($mgr, $lid_id) or return $e->die_event;
1580     $e->commit;
1581     return 1;
1582 }
1583
1584 __PACKAGE__->register_method(
1585         method => 'receive_lineitem_api',
1586         api_name        => 'open-ils.acq.lineitem.receive',
1587         signature => {
1588         desc => 'Mark a lineitem as received',
1589         params => [
1590             {desc => 'Authentication token', type => 'string'},
1591             {desc => 'lineitem detail ID', type => 'number'}
1592         ],
1593         return => {desc => '1 on success, Event on error'}
1594     }
1595 );
1596
1597 sub receive_lineitem_api {
1598     my($self, $conn, $auth, $li_id) = @_;
1599
1600     my $e = new_editor(xact=>1, authtoken=>$auth);
1601     return $e->die_event unless $e->checkauth;
1602     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
1603
1604     my $li = $e->retrieve_acq_lineitem([
1605         $li_id, {
1606             flesh => 1,
1607             flesh_fields => {
1608                 jub => ['purchase_order']
1609             }
1610         }
1611     ]) or return $e->die_event;
1612
1613     return $e->die_event unless $e->allowed(
1614         'RECEIVE_PURCHASE_ORDER', $li->purchase_order->ordering_agency);
1615
1616     receive_lineitem($mgr, $li_id) or return $e->die_event;
1617
1618     $e->commit;
1619     $conn->respond_complete(1);
1620     $mgr->run_post_response_hooks;
1621     return undef;
1622 }
1623
1624
1625 __PACKAGE__->register_method(
1626         method => 'rollback_receive_po_api',
1627         api_name        => 'open-ils.acq.purchase_order.receive.rollback'
1628 );
1629
1630 sub rollback_receive_po_api {
1631     my($self, $conn, $auth, $po_id) = @_;
1632     my $e = new_editor(xact => 1, authtoken => $auth);
1633     return $e->die_event unless $e->checkauth;
1634     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
1635
1636     my $po = $e->retrieve_acq_purchase_order($po_id) or return $e->die_event;
1637     return $e->die_event unless $e->allowed('RECEIVE_PURCHASE_ORDER', $po->ordering_agency);
1638
1639     my $li_ids = $e->search_acq_lineitem({purchase_order => $po_id}, {idlist => 1});
1640
1641     for my $li_id (@$li_ids) {
1642         rollback_receive_lineitem($mgr, $li_id) or return $e->die_event;
1643         $mgr->respond;
1644     }
1645
1646     $po->state('on-order');
1647     update_purchase_order($mgr, $po) or return $e->die_event;
1648
1649     $e->commit;
1650     return $mgr->respond_complete;
1651 }
1652
1653
1654 __PACKAGE__->register_method(
1655         method => 'rollback_receive_lineitem_detail_api',
1656         api_name        => 'open-ils.acq.lineitem_detail.receive.rollback',
1657         signature => {
1658         desc => 'Mark a lineitem_detail as received',
1659         params => [
1660             {desc => 'Authentication token', type => 'string'},
1661             {desc => 'lineitem detail ID', type => 'number'}
1662         ],
1663         return => {desc => '1 on success, Event on error'}
1664     }
1665 );
1666
1667 sub rollback_receive_lineitem_detail_api {
1668     my($self, $conn, $auth, $lid_id) = @_;
1669
1670     my $e = new_editor(xact=>1, authtoken=>$auth);
1671     return $e->die_event unless $e->checkauth;
1672     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
1673
1674     my $lid = $e->retrieve_acq_lineitem_detail([
1675         $lid_id, {
1676             flesh => 2,
1677             flesh_fields => {
1678                 acqlid => ['lineitem'],
1679                 jub => ['purchase_order']
1680             }
1681         }
1682     ]);
1683     my $li = $lid->lineitem;
1684     my $po = $li->purchase_order;
1685
1686     return $e->die_event unless $e->allowed('RECEIVE_PURCHASE_ORDER', $po->ordering_agency);
1687     rollback_receive_lineitem_detail($mgr, $lid_id) or return $e->die_event;
1688
1689     $li->state('on-order');
1690     $po->state('on-order');
1691     udpate_lineitem($mgr, $li) or return $e->die_event;
1692     udpate_purchase_order($mgr, $po) or return $e->die_event;
1693
1694     $e->commit;
1695     return 1;
1696 }
1697
1698 __PACKAGE__->register_method(
1699         method => 'rollback_receive_lineitem_api',
1700         api_name        => 'open-ils.acq.lineitem.receive.rollback',
1701         signature => {
1702         desc => 'Mark a lineitem as received',
1703         params => [
1704             {desc => 'Authentication token', type => 'string'},
1705             {desc => 'lineitem detail ID', type => 'number'}
1706         ],
1707         return => {desc => '1 on success, Event on error'}
1708     }
1709 );
1710
1711 sub rollback_receive_lineitem_api {
1712     my($self, $conn, $auth, $li_id) = @_;
1713
1714     my $e = new_editor(xact=>1, authtoken=>$auth);
1715     return $e->die_event unless $e->checkauth;
1716     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
1717
1718     my $li = $e->retrieve_acq_lineitem_detail([
1719         $li_id, {
1720             flesh => 1,
1721             flesh_fields => {
1722                 jub => ['purchase_order']
1723             }
1724         }
1725     ]);
1726     my $po = $li->purchase_order;
1727
1728     return $e->die_event unless $e->allowed('RECEIVE_PURCHASE_ORDER', $po->ordering_agency);
1729
1730     rollback_receive_lineitem($mgr, $li_id) or return $e->die_event;
1731
1732     $po->state('on-order');
1733     update_purchase_order($mgr, $po) or return $e->die_event;
1734
1735     $e->commit;
1736     return 1;
1737 }
1738
1739
1740 __PACKAGE__->register_method(
1741         method => 'set_lineitem_price_api',
1742         api_name        => 'open-ils.acq.lineitem.price.set',
1743         signature => {
1744         desc => 'Set lineitem price.  If debits already exist, update them as well',
1745         params => [
1746             {desc => 'Authentication token', type => 'string'},
1747             {desc => 'lineitem ID', type => 'number'}
1748         ],
1749         return => {desc => 'status blob, Event on error'}
1750     }
1751 );
1752
1753 sub set_lineitem_price_api {
1754     my($self, $conn, $auth, $li_id, $price, $currency) = @_;
1755
1756     my $e = new_editor(xact=>1, authtoken=>$auth);
1757     return $e->die_event unless $e->checkauth;
1758     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
1759
1760     # XXX perms
1761
1762     my $li = $e->retrieve_acq_lineitem($li_id) or return $e->die_event;
1763
1764     # update the local attr for estimated price
1765     set_lineitem_attr(
1766         $mgr,
1767         attr_name => 'estimated_price',
1768         attr_type => 'lineitem_local_attr_definition',
1769         attr_value => $price,
1770         lineitem => $li_id
1771     ) or return $e->die_event;
1772
1773     my $lid_ids = $e->search_acq_lineitem_detail(
1774         {lineitem => $li_id, fund_debit => {'!=' => undef}},
1775         {idlist => 1}
1776     );
1777
1778     for my $lid_id (@$lid_ids) {
1779
1780         my $lid = $e->retrieve_acq_lineitem_detail([
1781             $lid_id, {
1782             flesh => 1, flesh_fields => {acqlid => ['fund', 'fund_debit']}}
1783         ]);
1784
1785         # onless otherwise specified, assume currency of new price is same as currency type of the fund
1786         $currency ||= $lid->fund->currency_type;
1787         my $amount = $price;
1788
1789         if($lid->fund->currency_type ne $currency) {
1790             $amount = currency_conversion($mgr, $currency, $lid->fund->currency_type, $price);
1791         }
1792
1793         $lid->fund_debit->origin_currency_type($currency);
1794         $lid->fund_debit->origin_amount($price);
1795         $lid->fund_debit->amount($amount);
1796
1797         $e->update_acq_fund_debit($lid->fund_debit) or return $e->die_event;
1798         $mgr->add_lid;
1799         $mgr->respond;
1800     }
1801
1802     $e->commit;
1803     return $mgr->respond_complete;
1804 }
1805
1806
1807 __PACKAGE__->register_method(
1808         method => 'clone_picklist_api',
1809         api_name        => 'open-ils.acq.picklist.clone',
1810         signature => {
1811         desc => 'Clones a picklist, including lineitem and lineitem details',
1812         params => [
1813             {desc => 'Authentication token', type => 'string'},
1814             {desc => 'Picklist ID', type => 'number'},
1815             {desc => 'New Picklist Name', type => 'string'}
1816         ],
1817         return => {desc => 'status blob, Event on error'}
1818     }
1819 );
1820
1821 sub clone_picklist_api {
1822     my($self, $conn, $auth, $pl_id, $name) = @_;
1823
1824     my $e = new_editor(xact=>1, authtoken=>$auth);
1825     return $e->die_event unless $e->checkauth;
1826     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
1827
1828     my $old_pl = $e->retrieve_acq_picklist($pl_id);
1829     my $new_pl = create_picklist($mgr, %{$old_pl->to_bare_hash}, name => $name) or return $e->die_event;
1830
1831     my $li_ids = $e->search_acq_lineitem({picklist => $pl_id}, {idlist => 1});
1832
1833     for my $li_id (@$li_ids) {
1834
1835         # copy the lineitems
1836         my $li = $e->retrieve_acq_lineitem($li_id);
1837         my $new_li = create_lineitem($mgr, %{$li->to_bare_hash}, picklist => $new_pl->id) or return $e->die_event;
1838
1839         my $lid_ids = $e->search_acq_lineitem_detail({lineitem => $li_id}, {idlist => 1});
1840         for my $lid_id (@$lid_ids) {
1841
1842             # copy the lineitem details
1843             my $lid = $e->retrieve_acq_lineitem_detail($lid_id);
1844             create_lineitem_detail($mgr, %{$lid->to_bare_hash}, lineitem => $new_li->id) or return $e->die_event;
1845         }
1846
1847         $mgr->respond;
1848     }
1849
1850     $e->commit;
1851     return $mgr->respond_complete;
1852 }
1853
1854
1855 __PACKAGE__->register_method(
1856         method => 'merge_picklist_api',
1857         api_name        => 'open-ils.acq.picklist.merge',
1858         signature => {
1859         desc => 'Merges 2 or more picklists into a single list',
1860         params => [
1861             {desc => 'Authentication token', type => 'string'},
1862             {desc => 'Lead Picklist ID', type => 'number'},
1863             {desc => 'List of subordinate picklist IDs', type => 'array'}
1864         ],
1865         return => {desc => 'status blob, Event on error'}
1866     }
1867 );
1868
1869 sub merge_picklist_api {
1870     my($self, $conn, $auth, $lead_pl, $pl_list) = @_;
1871
1872     my $e = new_editor(xact=>1, authtoken=>$auth);
1873     return $e->die_event unless $e->checkauth;
1874     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
1875
1876     # XXX perms on each picklist modified
1877
1878     # point all of the lineitems at the lead picklist
1879     my $li_ids = $e->search_acq_lineitem({picklist => $pl_list}, {idlist => 1});
1880
1881     for my $li_id (@$li_ids) {
1882         my $li = $e->retrieve_acq_lineitem($li_id);
1883         $li->picklist($lead_pl);
1884         update_lineitem($mgr, $li) or return $e->die_event;
1885         $mgr->respond;
1886     }
1887
1888     # now delete the subordinate lists
1889     for my $pl_id (@$pl_list) {
1890         my $pl = $e->retrieve_acq_picklist($pl_id);
1891         $e->delete_acq_picklist($pl) or return $e->die_event;
1892     }
1893
1894     $e->commit;
1895     return $mgr->respond_complete;
1896 }
1897
1898
1899 __PACKAGE__->register_method(
1900         method => 'delete_picklist_api',
1901         api_name        => 'open-ils.acq.picklist.delete',
1902         signature => {
1903         desc => q/Deletes a picklist.  It also deletes any lineitems in the "new" state.
1904             Other attached lineitems are detached'/,
1905         params => [
1906             {desc => 'Authentication token', type => 'string'},
1907             {desc => 'Picklist ID to delete', type => 'number'}
1908         ],
1909         return => {desc => '1 on success, Event on error'}
1910     }
1911 );
1912
1913 sub delete_picklist_api {
1914     my($self, $conn, $auth, $picklist_id) = @_;
1915     my $e = new_editor(xact=>1, authtoken=>$auth);
1916     return $e->die_event unless $e->checkauth;
1917     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
1918     my $pl = $e->retrieve_acq_picklist($picklist_id) or return $e->die_event;
1919     delete_picklist($mgr, $pl) or return $e->die_event;
1920     $e->commit;
1921     return $mgr->respond_complete;
1922 }
1923
1924
1925
1926 __PACKAGE__->register_method(
1927         method => 'activate_purchase_order',
1928         api_name        => 'open-ils.acq.purchase_order.activate',
1929         signature => {
1930         desc => q/Activates a purchase order.  This updates the status of the PO
1931             and Lineitems to 'on-order'.  Activated PO's are ready for EDI delivery
1932             if appropriate./,
1933         params => [
1934             {desc => 'Authentication token', type => 'string'},
1935             {desc => 'Purchase ID', type => 'number'}
1936         ],
1937         return => {desc => '1 on success, Event on error'}
1938     }
1939 );
1940
1941 sub activate_purchase_order {
1942     my($self, $conn, $auth, $po_id) = @_;
1943     my $e = new_editor(xact=>1, authtoken=>$auth);
1944     return $e->die_event unless $e->checkauth;
1945     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
1946
1947     my $po = $e->retrieve_acq_purchase_order($po_id) or return $e->die_event;
1948     return $e->die_event unless $e->allowed('CREATE_PURCHASE_ORDER', $po->ordering_agency);
1949
1950     $po->state('on-order');
1951     update_purchase_order($mgr, $po) or return $e->die_event;
1952
1953     my $query = [
1954         {purchase_order => $po_id, state => 'pending-order'},
1955         {limit => 1}
1956     ];
1957
1958     while( my $li = $e->search_acq_lineitem($query)->[0] ) {
1959         $li->state('on-order');
1960         update_lineitem($mgr, $li) or return $e->die_event;
1961         $mgr->post_process( sub { create_lineitem_status_events($mgr, $li->id, 'aur.ordered'); });
1962         $mgr->respond;
1963     }
1964
1965     $e->commit;
1966     $conn->respond_complete(1);
1967     $mgr->run_post_response_hooks;
1968     return undef;
1969 }
1970
1971
1972 __PACKAGE__->register_method(
1973         method => 'split_purchase_order_by_lineitems',
1974         api_name        => 'open-ils.acq.purchase_order.split_by_lineitems',
1975         signature => {
1976         desc => q/Splits a PO into many POs, 1 per lineitem.  Only works for
1977         POs a) with more than one lineitems, and b) in the "pending" state./,
1978         params => [
1979             {desc => 'Authentication token', type => 'string'},
1980             {desc => 'Purchase order ID', type => 'number'}
1981         ],
1982         return => {desc => 'list of new PO IDs on success, Event on error'}
1983     }
1984 );
1985
1986 sub split_purchase_order_by_lineitems {
1987     my ($self, $conn, $auth, $po_id) = @_;
1988
1989     my $e = new_editor("xact" => 1, "authtoken" => $auth);
1990     return $e->die_event unless $e->checkauth;
1991
1992     my $po = $e->retrieve_acq_purchase_order([
1993         $po_id, {
1994             "flesh" => 1,
1995             "flesh_fields" => {"acqpo" => [qw/lineitems notes/]}
1996         }
1997     ]) or return $e->die_event;
1998
1999     return $e->die_event
2000         unless $e->allowed("CREATE_PURCHASE_ORDER", $po->ordering_agency);
2001
2002     unless ($po->state eq "pending") {
2003         $e->rollback;
2004         return new OpenILS::Event("ACQ_PURCHASE_ORDER_TOO_LATE");
2005     }
2006
2007     unless (@{$po->lineitems} > 1) {
2008         $e->rollback;
2009         return new OpenILS::Event("ACQ_PURCHASE_ORDER_TOO_SHORT");
2010     }
2011
2012     # To split an existing PO into many, it seems unwise to just delete the
2013     # original PO, so we'll instead detach all of the original POs' lineitems
2014     # but the first, then create new POs for each of the remaining LIs, and
2015     # then attach the LIs to their new POs.
2016
2017     my @po_ids = ($po->id);
2018     my @moving_li = @{$po->lineitems};
2019     shift @moving_li;    # discard first LI
2020
2021     foreach my $li (@moving_li) {
2022         my $new_po = $po->clone;
2023         $new_po->clear_id;
2024         $new_po->clear_name;
2025         $new_po->creator($e->requestor->id);
2026         $new_po->editor($e->requestor->id);
2027         $new_po->owner($e->requestor->id);
2028         $new_po->edit_time("now");
2029         $new_po->create_time("now");
2030
2031         $new_po = $e->create_acq_purchase_order($new_po);
2032
2033         # Clone any notes attached to the old PO and attach to the new one.
2034         foreach my $note (@{$po->notes}) {
2035             my $new_note = $note->clone;
2036             $new_note->clear_id;
2037             $new_note->edit_time("now");
2038             $new_note->purchase_order($new_po->id);
2039             $e->create_acq_po_note($new_note);
2040         }
2041
2042         $li->edit_time("now");
2043         $li->purchase_order($new_po->id);
2044         $e->update_acq_lineitem($li);
2045
2046         push @po_ids, $new_po->id;
2047     }
2048
2049     $po->edit_time("now");
2050     $e->update_acq_purchase_order($po);
2051
2052     return \@po_ids if $e->commit;
2053     return $e->die_event;
2054 }
2055
2056
2057 __PACKAGE__->register_method(
2058         method => 'cancel_lineitem_api',
2059         api_name        => 'open-ils.acq.lineitem.cancel',
2060         signature => {
2061         desc => q/Cancels an on-order lineitem/,
2062         params => [
2063             {desc => 'Authentication token', type => 'string'},
2064             {desc => 'Lineitem ID to cancel', type => 'number'},
2065             {desc => 'Cancel Cause ID', type => 'number'}
2066         ],
2067         return => {desc => '1 on success, Event on error'}
2068     }
2069 );
2070
2071 sub cancel_lineitem_api {
2072     my($self, $conn, $auth, $li_id, $cancel_cause) = @_;
2073
2074     my $e = new_editor(xact=>1, authtoken=>$auth);
2075     return $e->die_event unless $e->checkauth;
2076     my $mgr = OpenILS::Application::Acq::BatchManager->new(editor => $e, conn => $conn);
2077
2078     my $li = $e->retrieve_acq_lineitem([$li_id,
2079         {flesh => 1, flesh_fields => {jub => [q/purchase_order/]}}]);
2080
2081     unless( $li->purchase_order and ($li->state eq 'on-order' or $li->state eq 'pending-order') ) {
2082         $e->rollback;
2083         return OpenILS::Event->new('BAD_PARAMS')
2084     }
2085
2086     return $e->die_event unless
2087         $e->allowed('CREATE_PURCHASE_ORDER', $li->purchase_order->ordering_agency);
2088
2089     $li->state('cancelled');
2090
2091     # TODO delete the associated fund debits?
2092     # TODO add support for cancel reasons
2093     # TODO who/what/where/how do we indicate this change for electronic orders?
2094
2095     update_lineitem($mgr, $li) or return $e->die_event;
2096     $e->commit;
2097
2098     $conn->respond_complete($li);
2099     create_lineitem_status_events($mgr, $li_id, 'aur.cancelled');
2100     return undef;
2101 }
2102
2103
2104 1;