Open-ILS/src/perlmods/lib/OpenILS/Application/Acq/EDI.pm

   1 package OpenILS::Application::Acq::EDI;
   2 use base qw/OpenILS::Application/;
   3
   4 use strict; use warnings;
   5
   6 use IO::Scalar;
   7
   8 use OpenSRF::AppSession;
   9 use OpenSRF::EX qw/:try/;
  10 use OpenSRF::Utils::Logger qw(:logger);
  11 use OpenSRF::Utils::JSON;
  12
  13 use OpenILS::Application::Acq::Lineitem;
  14 use OpenILS::Utils::RemoteAccount;
  15 use OpenILS::Utils::CStoreEditor q/new_editor/;
  16 use OpenILS::Utils::Fieldmapper;
  17 use OpenILS::Application::Acq::EDI::Translator;
  18 use OpenILS::Application::AppUtils;
  19 my $U = 'OpenILS::Application::AppUtils';
  20
  21 use OpenILS::Utils::EDIReader;
  22
  23 use Data::Dumper;
  24 our $verbose = 0;
  25
  26 sub new {
  27     my($class, %args) = @_;
  28     my $self = bless(\%args, $class);
  29     # $self->{args} = {};
  30     return $self;
  31 }
  32
  33 # our $reasons = {};   # cache for acq.cancel_reason rows ?
  34
  35 our $translator;
  36
  37 sub translator {
  38     return $translator ||= OpenILS::Application::Acq::EDI::Translator->new(@_);
  39 }
  40
  41 my %map = (
  42     host     => 'remote_host',
  43     username => 'remote_user',
  44     password => 'remote_password',
  45     account  => 'remote_account',
  46     # in_dir   => 'remote_path',   # field_map overrides path with in_dir
  47     path     => 'remote_path',
  48 );
  49
  50
  51 ## Just for debugging stuff:
  52 sub add_a_msg {
  53     my ($self, $conn) = @_;
  54     my $e = new_editor(xact=>1);
  55     my $incoming = Fieldmapper::acq::edi_message->new;
  56     $incoming->edi("This is content");
  57     $incoming->account(1);
  58     $incoming->remote_file('in/some_file.edi');
  59     $e->create_acq_edi_message($incoming);;
  60     $e->commit;
  61 }
  62 # __PACKAGE__->register_method( method => 'add_a_msg', api_name => 'open-ils.acq.edi.add_a_msg');  # debugging
  63
  64 __PACKAGE__->register_method(
  65         method    => 'retrieve',
  66         api_name  => 'open-ils.acq.edi.retrieve',
  67     authoritative => 1,
  68         signature => {
  69         desc   => 'Fetch incoming message(s) from EDI accounts.  ' .
  70                   'Optional arguments to restrict to one vendor and/or a max number of messages.  ' .
  71                   'Note that messages are not parsed or processed here, just fetched and translated.',
  72         params => [
  73             {desc => 'Authentication token',        type => 'string'},
  74             {desc => 'Vendor ID (undef for "all")', type => 'number'},
  75             {desc => 'Date Inactive Since',         type => 'string'},
  76             {desc => 'Max Messages Retrieved',      type => 'number'}
  77         ],
  78         return => {
  79             desc => 'List of new message IDs (empty if none)',
  80             type => 'array'
  81         }
  82     }
  83 );
  84
  85 sub retrieve_core {
  86     my ($self, $set, $max, $e, $test) = @_;    # $e is a working editor
  87
  88     $e   ||= new_editor();
  89     $set ||= __PACKAGE__->retrieve_vendors($e);
  90
  91     my @return = ();
  92     my $vcount = 0;
  93     foreach my $account (@$set) {
  94         my $count = 0;
  95         my $server;
  96         $logger->info("EDI check for vendor " . ++$vcount . " of " . scalar(@$set) . ": " . $account->host);
  97         unless ($server = __PACKAGE__->remote_account($account)) {   # assignment, not comparison
  98             $logger->err(sprintf "Failed remote account mapping for %s (%s)", $account->host, $account->id);
  99             next;
 100         };
 101 #       my $rf_starter = './';  # default to current dir
 102         if ($account->in_dir) {
 103             if ($account->in_dir =~ /\*+.*\//) {
 104                 $logger->err("EDI in_dir has a slash after an asterisk in value: '" . $account->in_dir . "'.  Skipping account with indeterminate target dir!");
 105                 next;
 106             }
 107 #           $rf_starter = $account->in_dir;
 108 #           $rf_starter =~ s/((\/)?[^\/]*)\*+[^\/]*$//;  # kill up to the first (possible) slash before the asterisk: keep the preceeding static dir
 109 #           $rf_starter .= '/' if $rf_starter or $2;   # recap the dir, or replace leading "/" if there was one (but don't add if empty)
 110         }
 111         my @files    = ($server->ls({remote_file => ($account->in_dir || './')}));
 112         my @ok_files = grep {$_ !~ /\/\.?\.$/ and $_ ne '0'} @files;
 113         $logger->info(sprintf "%s of %s files at %s/%s", scalar(@ok_files), scalar(@files), $account->host, $account->in_dir);
 114         # $server->remote_path(undef);
 115         foreach my $remote_file (@ok_files) {
 116             # my $remote_file = $rf_starter . $_;
 117             my $description = sprintf "%s/%s", $account->host, $remote_file;
 118
 119             # deduplicate vs. acct/filenames already in DB
 120             my $hits = $e->search_acq_edi_message([
 121                 {
 122                     account     => $account->id,
 123                     remote_file => $remote_file,
 124                     status      => {'in' => [qw/ processed /]},     # if it never got processed, go ahead and get the new one (try again)
 125                     # create_time => 'NOW() - 60 DAYS',     # if we wanted to allow filenames to be reused after a certain time
 126                     # ideally we would also use the date from FTP, but that info isn't available via RemoteAccount
 127                 }
 128                 # { flesh => 1, flesh_fields => {...}, }
 129             ]);
 130             if (scalar(@$hits)) {
 131                 $logger->debug("EDI: $remote_file already retrieved.  Skipping");
 132                 warn "EDI: $remote_file already retrieved.  Skipping";
 133                 next;
 134             }
 135
 136             ++$count;
 137             $max and $count > $max and last;
 138             $logger->info(sprintf "%s of %s targets: %s", $count, scalar(@ok_files), $description);
 139             print sprintf "%s of %s targets: %s\n", $count, scalar(@ok_files), $description;
 140             if ($test) {
 141                 push @return, "test_$count";
 142                 next;
 143             }
 144             my $content;
 145             my $io = IO::Scalar->new(\$content);
 146             unless ( $server->get({remote_file => $remote_file, local_file => $io}) ) {
 147                 $logger->error("(S)FTP get($description) failed");
 148                 next;
 149             }
 150             my $incoming = __PACKAGE__->process_retrieval($content, $remote_file, $server, $account->id);
 151 #           $server->delete(remote_file => $_);   # delete remote copies of saved message
 152             push @return, @$incoming;
 153         }
 154     }
 155     return \@return;
 156 }
 157
 158 # my $msg_ids = OpenILS::Application::Acq::EDI->process_retrieval(
 159 #   $file_content, $remote_filename, $server, $account_id, $editor);
 160
 161 sub process_retrieval {
 162     my ($class, $content, $filename, $server, $account_or_id) = @_;
 163     $content or return;
 164
 165     my $e = new_editor;
 166     my $account = __PACKAGE__->record_activity($account_or_id, $e);
 167
 168     # a single EDI blob can contain multiple messages
 169     # create one edi_message per included message
 170
 171     my $messages = OpenILS::Utils::EDIReader->new->read($content);
 172     my @return;
 173
 174     for my $msg_hash (@$messages) {
 175
 176         my $incoming = Fieldmapper::acq::edi_message->new;
 177
 178         $incoming->remote_file($filename);
 179         $incoming->account($account->id);
 180         $incoming->edi($content);
 181         $incoming->message_type($msg_hash->{message_type});
 182         $incoming->jedi(OpenSRF::Utils::JSON->perl2JSON($msg_hash)); # jedi-2.0
 183         $incoming->status('translated');
 184         $incoming->translate_time('NOW');
 185
 186         if ($msg_hash->{purchase_order}) {
 187             $logger->info("EDI: processing message for PO " . $msg_hash->{purchase_order});
 188             $incoming->purchase_order($msg_hash->{purchase_order});
 189             unless ($e->retrieve_acq_purchase_order($incoming->purchase_order)) {
 190                 $logger->warn("EDI: received order response for nonexistent PO.  Skipping...");
 191                 next;
 192             }
 193         }
 194
 195         $e->xact_begin;
 196         unless($e->create_acq_edi_message($incoming)) {
 197             $logger->error("EDI: unable to create edi_message " . $e->die_event);
 198             next;
 199         }
 200         # refresh to pickup create_date, etc.
 201         $incoming = $e->retrieve_acq_edi_message($incoming->id);
 202         $e->xact_commit;
 203
 204         # since there's a fair chance of unhandled problems
 205         # cropping up, particularly with new vendors, wrap w/ eval.
 206         eval { $class->process_parsed_msg($account, $incoming, $msg_hash) };
 207
 208         $e->xact_begin;
 209         $incoming = $e->retrieve_acq_edi_message($incoming->id);
 210         if ($@) {
 211             $incoming->status('proc_error');
 212             $incoming->error($@);
 213         } else {
 214             $incoming->status('processed');
 215         }
 216         $e->update_acq_edi_message($incoming);
 217         $e->xact_commit;
 218
 219         push(@return, $incoming->id);
 220     }
 221
 222     return \@return;
 223 }
 224
 225 # ->send_core
 226 # $account     is a Fieldmapper object for acq.edi_account row
 227 # $messageset  is an arrayref with acq.edi_message.id values
 228 # $e           is optional editor object
 229 sub send_core {
 230     my ($class, $account, $message_ids, $e) = @_;    # $e is a working editor
 231
 232     ($account and scalar @$message_ids) or return;
 233     $e ||= new_editor();
 234
 235     $e->xact_begin;
 236     my @messageset = map {$e->retrieve_acq_edi_message($_)} @$message_ids;
 237     $e->xact_rollback;
 238     my $m_count = scalar(@messageset);
 239     (scalar(@$message_ids) == $m_count) or
 240         $logger->warn(scalar(@$message_ids) - $m_count . " bad IDs passed to send_core (ignored)");
 241
 242     my $log_str = sprintf "EDI send to edi_account %s (%s)", $account->id, $account->host;
 243     $logger->info("$log_str: $m_count message(s)");
 244     $m_count or return;
 245
 246     my $server;
 247     my $server_error;
 248     unless ($server = __PACKAGE__->remote_account($account, 1)) {   # assignment, not comparison
 249         $logger->error("Failed remote account connection for $log_str");
 250         $server_error = 1;
 251     };
 252     foreach (@messageset) {
 253         $_ or next;     # we already warned about bum ids
 254         my ($res, $error);
 255         if ($server_error) {
 256             $error = "Server error: Failed remote account connection for $log_str"; # already told $logger, this is to update object below
 257         } elsif (! $_->edi) {
 258             $logger->error("Message (id " . $_->id. ") for $log_str has no EDI content");
 259             $error = "EDI empty!";
 260         } elsif ($res = $server->put({remote_path => $account->path, content => $_->edi, single_ext => 1})) {
 261             #  This is the successful case!
 262             $_->remote_file($res);
 263             $_->status('complete');
 264             $_->process_time('NOW');    # For outbound files, sending is the end of processing on the EG side.
 265             $logger->info("Sent message (id " . $_->id. ") via $log_str");
 266         } else {
 267             $logger->error("(S)FTP put to $log_str FAILED: " . ($server->error || 'UNKOWNN'));
 268             $error = "put FAILED: " . ($server->error || 'UNKOWNN');
 269         }
 270         if ($error) {
 271             $_->error($error);
 272             $_->error_time('NOW');
 273         }
 274         $logger->info("Calling update_acq_edi_message");
 275         $e->xact_begin;
 276         unless ($e->update_acq_edi_message($_)) {
 277              $logger->error("EDI send_core update_acq_edi_message failed for message object: " . Dumper($_));
 278              OpenILS::Application::Acq::EDI::Translator->debug_file(Dumper($_              ), '/tmp/update_acq_edi_message.FAIL');
 279              OpenILS::Application::Acq::EDI::Translator->debug_file(Dumper($_->to_bare_hash), '/tmp/update_acq_edi_message.FAIL.to_bare_hash');
 280         }
 281         # There's always an update, even if we failed.
 282         $e->xact_commit;
 283         __PACKAGE__->record_activity($account, $e);  # There's always an update, even if we failed.
 284     }
 285     return \@messageset;
 286 }
 287
 288 #  attempt_translation does not touch the DB, just the object.
 289 sub attempt_translation {
 290     my ($class, $edi_message, $to_edi) = @_;
 291     my $tran  = translator();
 292     my $ret   = $to_edi ? $tran->json2edi($edi_message->jedi) : $tran->edi2json($edi_message->edi);
 293 #   $logger->error("json: " . Dumper($json)); # debugging
 294
 295     if (not $ret or (! ref($ret)) or $ret->is_fault) {      # RPC::XML::fault on failure
 296         $edi_message->status('trans_error');
 297         $edi_message->error_time('NOW');
 298         my $pre = "EDI Translator " . ($to_edi ? 'json2edi' : 'edi2json') . " failed";
 299         my $message = ref($ret) ?
 300                       ("$pre, Error " . $ret->code . ": " . __PACKAGE__->nice_string($ret->string)) :
 301                       ("$pre: "                           . __PACKAGE__->nice_string($ret)        ) ;
 302         $edi_message->error($message);
 303         $logger->error($message);
 304         return;
 305     }
 306
 307     $edi_message->status('translated');
 308     $edi_message->translate_time('NOW');
 309
 310     if ($to_edi) {
 311         $edi_message->edi($ret->value);    # translator returns an object
 312     } else {
 313         $edi_message->jedi($ret->value);   # translator returns an object
 314     }
 315     return $edi_message;
 316 }
 317
 318 sub retrieve_vendors {
 319     my ($self, $e, $vendor_id, $last_activity) = @_;    # $e is a working editor
 320
 321     $e ||= new_editor();
 322
 323     my $criteria = {'+acqpro' => {active => 't'}};
 324     $criteria->{'+acqpro'}->{id} = $vendor_id if $vendor_id;
 325     return $e->search_acq_edi_account([
 326         $criteria, {
 327             'join' => 'acqpro',
 328             flesh => 1,
 329             flesh_fields => {
 330                 acqedi => ['provider']
 331             }
 332         }
 333     ]);
 334 #   {"id":{"!=":null},"+acqpro":{"active":"t"}}, {"join":"acqpro", "flesh_fields":{"acqedi":["provider"]},"flesh":1}
 335 }
 336
 337 # This is the SRF-exposed call, so it does checkauth
 338
 339 sub retrieve {
 340     my ($self, $conn, $auth, $vendor_id, $last_activity, $max) = @_;
 341
 342     my $e = new_editor(authtoken=>$auth);
 343     unless ($e and $e->checkauth()) {
 344         $logger->warn("checkauth failed for authtoken '$auth'");
 345         return ();
 346     }
 347     # return $e->die_event unless $e->allowed('RECEIVE_PURCHASE_ORDER', $li->purchase_order->ordering_agency);  # add permission here ?
 348
 349     my $set = __PACKAGE__->retrieve_vendors($e, $vendor_id, $last_activity) or return $e->die_event;
 350     return __PACKAGE__->retrieve_core($e, $set, $max);
 351 }
 352
 353
 354 # field_map takes the hashref of vendor data with fields from acq.edi_account and
 355 # maps them to the argument style needed for RemoteAccount.  It also extrapolates
 356 # data from the remote_host string for type and port, when available.
 357
 358 sub field_map {
 359     my $self   = shift;
 360     my $vendor = shift or return;
 361     my $no_override = @_ ? shift : 0;
 362     my %args = ();
 363     $verbose and $logger->warn("vendor: " . Dumper($vendor));
 364     foreach (keys %map) {
 365         $args{$map{$_}} = $vendor->$_ if defined $vendor->$_;
 366     }
 367     unless ($no_override) {
 368         $args{remote_path} = $vendor->in_dir;    # override "path" with "in_dir"
 369     }
 370     my $host = $args{remote_host} || '';
 371     ($host =~ s/^(S?FTP)://i    and $args{type} = uc($1)) or
 372     ($host =~ s/^(SSH|SCP)://i  and $args{type} = 'SCP' ) ;
 373      $host =~ s/:(\d+)$//       and $args{port} = $1;
 374     ($args{remote_host} = $host) =~ s#/+##;
 375     $verbose and $logger->warn("field_map: " . Dumper(\%args));
 376     return %args;
 377 }
 378
 379
 380 # The point of remote_account is to get the RemoteAccount object with args from the DB
 381
 382 sub remote_account {
 383     my ($self, $vendor, $outbound, $e) = @_;
 384
 385     unless (ref($vendor)) {     # It's not a hashref/object.
 386         $vendor or return;      # If in fact it's nothing: abort!
 387                                 # else it's a vendor_id string, so get the full vendor data
 388         $e ||= new_editor();
 389         my $set_of_one = $self->retrieve_vendors($e, $vendor) or return;
 390         $vendor = shift @$set_of_one;
 391     }
 392
 393     return OpenILS::Utils::RemoteAccount->new(
 394         $self->field_map($vendor, $outbound)
 395     );
 396 }
 397
 398 # takes account ID or account Fieldmapper object
 399
 400 sub record_activity {
 401     my ($class, $account_or_id, $e) = @_;
 402     $account_or_id or return;
 403     $e ||= new_editor();
 404     my $account = ref($account_or_id) ? $account_or_id : $e->retrieve_acq_edi_account($account_or_id);
 405     $logger->info("EDI record_activity calling update_acq_edi_account");
 406     $account->last_activity('NOW') or return;
 407     $e->xact_begin;
 408     $e->update_acq_edi_account($account) or $logger->warn("EDI: in record_activity, update_acq_edi_account FAILED");
 409     $e->xact_commit;
 410     return $account;
 411 }
 412
 413 sub nice_string {
 414     my $class = shift;
 415     my $string = shift or return '';
 416     chomp($string);
 417     my $head   = @_ ? shift : 100;
 418     my $tail   = @_ ? shift :  25;
 419     (length($string) < $head + $tail) and return $string;
 420     my $h = substr($string,0,$head);
 421     my $t = substr($string, -1*$tail);
 422     $h =~s/\s*$//o;
 423     $t =~s/\s*$//o;
 424     return "$h ... $t";
 425     # return substr($string,0,$head) . "... " . substr($string, -1*$tail);
 426 }
 427
 428 # parts of this process can fail without the entire
 429 # thing failing.  If a catastrophic error occurs,
 430 # it will occur via die.
 431 sub process_parsed_msg {
 432     my ($class, $account, $incoming, $msg_hash) = @_;
 433
 434     if ($incoming->message_type eq 'INVOIC') {
 435         return $class->create_acq_invoice_from_edi(
 436             $msg_hash, $account->provider, $incoming);
 437     }
 438
 439     # ORDRSP
 440     for my $li_hash (@{$msg_hash->{lineitems}}) {
 441         my $e = new_editor(xact => 1);
 442
 443         my $li_id = $li_hash->{id};
 444         my $li = $e->retrieve_acq_lineitem($li_id);
 445
 446         if (!$li) {
 447             $logger->error("EDI: request for invalid lineitem ID '$li_id'");
 448             $e->rollback;
 449             next;
 450         }
 451
 452          $li->expected_recv_time(
 453             $class->edi_date_to_iso($li_hash->{expected_date}));
 454
 455         $li->estimated_unit_price($li_hash->{unit_price});
 456
 457         if (not $incoming->purchase_order) {
 458             # PO should come from the EDI message, but if not...
 459
 460             # fetch the latest copy
 461             $incoming = $e->retrieve_acq_edi_message($incoming->id);
 462             $incoming->purchase_order($li->purchase_order);
 463
 464             unless($e->update_acq_edi_message($incoming)) {
 465                 $logger->error("EDI: unable to update edi_message " . $e->die_event);
 466                 next;
 467             }
 468         }
 469
 470         my $lids = $e->json_query({
 471             select => {acqlid => ['id']},
 472             from => 'acqlid',
 473             where => {lineitem => $li->id}
 474         });
 475
 476         my @lids = map { $_->{id} } @$lids;
 477         my $lid_count = scalar(@lids);
 478         my $lids_covered = 0;
 479         my $lids_cancelled = 0;
 480         my $order_qty;
 481         my $dispatch_qty;
 482
 483         for my $qty (@{$li_hash->{quantities}}) {
 484
 485             my $qty_count = $qty->{quantity};
 486             my $qty_code = $qty->{code};
 487
 488             next unless defined $qty_count;
 489
 490             if (!$qty_code) {
 491                 $logger->warn("EDI: Response for LI $li_id specifies quantity ".
 492                     "$qty_count with no 6063 code! Contact vendor to resolve.");
 493                 next;
 494             }
 495
 496             $logger->info("EDI: LI $li_id processing quantity count=$qty_count / code=$qty_code");
 497
 498             if ($qty_code eq '21') { # "ordered quantity"
 499                 $order_qty = $qty_count;
 500                 $logger->info("EDI: LI $li_id -- vendor confirms $qty_count ordered");
 501                 $logger->warn("EDI: LI $li_id -- order count $qty_count ".
 502                     "does not match LID count $lid_count") unless $qty_count == $lid_count;
 503                 next;
 504             }
 505
 506             $lids_covered += $qty_count;
 507
 508             if ($qty_code eq '12') {
 509                 $dispatch_qty = $qty_count;
 510                 $logger->info("EDI: LI $li_id -- vendor dispatched $qty_count");
 511                 next;
 512
 513             } elsif ($qty_code eq '57') {
 514                 $logger->info("EDI: LI $li_id -- $qty_count in transit");
 515                 next;
 516             }
 517             # 84: urgent delivery
 518             # 118: quantity manifested
 519             # ...
 520
 521             # -------------------------------------------------------------------------
 522             # All of the remaining quantity types require that we apply a cancel_reason
 523             # DB populated w/ 6063 keys in 1200's
 524
 525             my $eg_reason = $e->retrieve_acq_cancel_reason(1200 + $qty_code);
 526
 527             if (!$eg_reason) {
 528                 $logger->warn("EDI: Unhandled quantity qty_code '$qty_code' ".
 529                     "for li $li_id.  $qty_count items unprocessed");
 530                 next;
 531             }
 532
 533             my ($cancel_count, $fatal) =
 534                 $class->cancel_lids($e, $eg_reason, $qty_count, $lid_count, \@lids);
 535
 536             last if $fatal;
 537
 538             $lids_cancelled += $cancel_count;
 539
 540             # if ALL the items have the same cancel_reason, the LI gets it too
 541             if ($qty_count == $lid_count) {
 542                 $li->cancel_reason($eg_reason->id);
 543                 $li->state("cancelled");
 544             }
 545
 546             $li->edit_time('now');
 547             unless ($e->update_acq_lineitem($li)) {
 548                 $logger->error("EDI: update_acq_lineitem failed " . $e->die_event);
 549                 last;
 550             }
 551         }
 552
 553         # in case the provider neglected to echo back the order count
 554         $order_qty = $lid_count unless defined $order_qty;
 555
 556         # it may be necessary to change the logic here to look for lineitem
 557         # order status / availability status instead of dispatch_qty and
 558         # assume that dispatch_qty simply equals the number of unaccounted-for copies
 559         if (defined $dispatch_qty) {
 560             # provider is telling us how may copies were delivered
 561
 562             # number of copies neither cancelled or delivered
 563             my $remaining_lids = $order_qty - ($dispatch_qty + $lids_cancelled);
 564
 565             if ($remaining_lids > 0) {
 566
 567                 # the vendor did not ship all items and failed to provide cancellation
 568                 # quantities for some or all of the items to be cancelled.  When this
 569                 # happens, we cancel the remaining un-delivered copies using the
 570                 # lineitem order status to determine the cancel reason.
 571
 572                 my $reason_id;
 573                 my $stat;
 574
 575                 if ($stat = $li_hash->{order_status}) {
 576                     $logger->info("EDI: lineitem has order status $stat");
 577
 578                     if ($stat eq '200') {
 579                         $reason_id = 1007; # not accepted
 580
 581                     } elsif ($stat eq '400') {
 582                         $reason_id = 1283; # back-order
 583                     }
 584
 585                 } elsif ($stat = $li_hash->{avail_status}) {
 586                     $logger->info("EDI: lineitem has availability status $stat");
 587
 588                     if ($stat eq 'NP') {
 589                         # not yet published
 590                         # TODO: needs cancellation?
 591                     }
 592                 }
 593
 594                 if ($reason_id) {
 595                     my $reason = $e->retrieve_acq_cancel_reason($reason_id);
 596
 597                     my ($cancel_count, $fatal) =
 598                         $class->cancel_lids($e, $reason, $remaining_lids, $lid_count, \@lids);
 599
 600                     last if $fatal;
 601                     $lids_cancelled += $cancel_count;
 602
 603                     # All LIDs cancelled with same reason, apply
 604                     # the same cancel reason to the lineitem
 605                     if ($remaining_lids == $order_qty) {
 606                         $li->cancel_reason($reason->id);
 607                         $li->state("cancelled");
 608                     }
 609
 610                     $li->edit_time('now');
 611                     unless ($e->update_acq_lineitem($li)) {
 612                         $logger->error("EDI: update_acq_lineitem failed " . $e->die_event);
 613                         last;
 614                     }
 615
 616                 } else {
 617                     $logger->warn("EDI: vendor says we ordered $order_qty and cancelled ".
 618                         "$lids_cancelled, but only shipped $dispatch_qty");
 619                 }
 620             }
 621         }
 622
 623         # LI and LIDs updated, let's wrap this one up.
 624         # this is a no-op if the xact has already been rolled back
 625         $e->commit;
 626
 627         $logger->info("EDI: LI $li_id -- $order_qty LIDs ordered; ".
 628             "$lids_cancelled LIDs cancelled");
 629     }
 630 }
 631
 632 sub cancel_lids {
 633     my ($class, $e, $reason, $count, $lid_count, $lid_ids) = @_;
 634
 635     my $cancel_count = 0;
 636
 637     foreach (1 .. $count) {
 638
 639         my $lid_id = shift @$lid_ids;
 640
 641         if (!$lid_id) {
 642             $logger->warn("EDI: Used up all $lid_count LIDs. ".
 643                 "Ignoring extra status '" . $reason->label . "'");
 644             last;
 645         }
 646
 647         my $lid = $e->retrieve_acq_lineitem_detail($lid_id);
 648         $lid->cancel_reason($reason->id);
 649
 650         # item is cancelled.  Remove the fund debit.
 651         unless ($U->is_true($reason->keep_debits)) {
 652
 653             if (my $debit_id = $lid->fund_debit) {
 654
 655                 $lid->clear_fund_debit;
 656                 my $debit = $e->retrieve_acq_fund_debit($debit_id);
 657
 658                 if ($U->is_true($debit->encumbrance)) {
 659                     $logger->info("EDI: deleting debit $debit_id for cancelled LID $lid_id");
 660
 661                     unless ($e->delete_acq_fund_debit($debit)) {
 662                         $logger->error("EDI: unable to update fund_debit " . $e->die_event);
 663                         return (0, 1);
 664                     }
 665                 } else {
 666                     # do not delete a paid-for debit
 667                     $logger->warn("EDI: cannot delete invoiced debit $debit_id");
 668                 }
 669             }
 670         }
 671
 672         $e->update_acq_lineitem_detail($lid);
 673         $cancel_count++;
 674     }
 675
 676     return ($cancel_count);
 677 }
 678
 679 sub edi_date_to_iso {
 680     my ($class, $date) = @_;
 681     return undef unless $date and $date =~ /\d+/;
 682     my ($iso, $m, $d) = $date =~ /^(\d{4})(\d{2})(\d{2})/g;
 683     $iso .= "-$m" if $m;
 684     $iso .= "-$d" if $d;
 685     return $iso;
 686 }
 687
 688
 689 # create_acq_invoice_from_edi() does what it sounds like it does for INVOIC
 690 # messages.  For similar operation on ORDRSP messages, see the guts of
 691 # process_jedi().
 692 # Return boolean success indicator.
 693 sub create_acq_invoice_from_edi {
 694     my ($class, $invoice, $provider, $message) = @_;
 695     # $invoice is O::U::EDIReader hash
 696     # $provider is only a pkey
 697     # $message is Fieldmapper::acq::edi_message
 698
 699     my $e = new_editor();
 700
 701     my $log_prefix = "create_acq_invoice_from_edi(..., <acq.edi_message #" .
 702         $message->id . ">): ";
 703
 704     my $eg_inv = Fieldmapper::acq::invoice->new;
 705
 706     $eg_inv->provider($provider);
 707     $eg_inv->shipper($provider);    # XXX Do we really have a meaningful way to
 708                                     # distinguish provider and shipper?
 709     $eg_inv->recv_method("EDI");
 710
 711     $eg_inv->recv_date(
 712         $class->edi_date_to_iso($invoice->{invoice_date}));
 713
 714
 715     # some vendors encode the account number as the SAN.
 716     # starting with the san value, then the account value,
 717     # treat each as a san, then an acct number until the first success
 718     for my $buyer ( ($invoice->{buyer_san}, $invoice->{buyer_acct}) ) {
 719         next unless $buyer;
 720
 721         # some vendors encode the SAN as "$SAN $vendcode"
 722         $buyer =~ s/\s.*//g;
 723
 724         my $addr = $e->search_actor_org_address(
 725             {valid => "t", san => $buyer})->[0];
 726
 727         if ($addr) {
 728
 729             $eg_inv->receiver($addr->org_unit);
 730             last;
 731
 732         } else {
 733
 734             my $acct = $e->search_acq_edi_account({vendacct => $buyer})->[0];
 735
 736             if ($acct) {
 737                 $eg_inv->receiver($acct->owner);
 738                 last;
 739             }
 740         }
 741     }
 742
 743     if (!$eg_inv->receiver) {
 744         $logger->error($log_prefix .
 745             sprintf("unable to determine buyer (org unit) in invoice; ".
 746                 "buyer_san=%s; buyer_acct=%s",
 747                 ($invoice->{buyer_san} || ''),
 748                 ($invoice->{buyer_acct} || '')
 749             )
 750         );
 751         return 0;
 752     }
 753
 754     $eg_inv->inv_ident($invoice->{invoice_ident});
 755
 756     if (!$eg_inv->inv_ident) {
 757         $logger->error(
 758             $log_prefix . "no invoice ID # in INVOIC message; " . shift
 759         );
 760         return 0;
 761     }
 762
 763     my @eg_inv_entries;
 764     my @eg_inv_cancel_lis;
 765
 766     $message->purchase_order($invoice->{purchase_order});
 767
 768     for my $lineitem (@{$invoice->{lineitems}}) {
 769         my $li_id = $lineitem->{id};
 770
 771         if (!$li_id) {
 772             $logger->warn($log_prefix . "no lineitem ID");
 773             next;
 774         }
 775
 776         my $li = $e->retrieve_acq_lineitem($li_id);
 777
 778         if (!$li) {
 779             $logger->warn($log_prefix .
 780                 "no LI found with ID: $li_id : " . $e->event);
 781             return 0;
 782         }
 783
 784         my ($quant) = grep {$_->{code} eq '47'} @{$lineitem->{quantities}};
 785         my $quantity = ($quant) ? $quant->{quantity} : 0;
 786
 787         if (!$quantity) {
 788             $logger->warn($log_prefix .
 789                 "no invoice quantity specified for LI $li_id");
 790             next;
 791         }
 792
 793         # NOTE: if needed, we also have $lineitem->{net_unit_price}
 794         # and $lineitem->{gross_unit_price}
 795         my $lineitem_price = $lineitem->{amount_billed};
 796
 797         # if the top-level PO value is unset, get it from the first LI
 798         $message->purchase_order($li->purchase_order)
 799             unless $message->purchase_order;
 800
 801         my $eg_inv_entry = Fieldmapper::acq::invoice_entry->new;
 802         $eg_inv_entry->inv_item_count($quantity);
 803
 804         # amount staff agree to pay for
 805         $eg_inv_entry->phys_item_count($quantity);
 806
 807         # XXX Validate by making sure the LI is on-order and belongs to
 808         # the right provider and ordering agency and all that.
 809         $eg_inv_entry->lineitem($li_id);
 810
 811         # XXX Do we actually need to link to PO directly here?
 812         $eg_inv_entry->purchase_order($li->purchase_order);
 813
 814         # This is the total price for all units billed, not per-unit.
 815         $eg_inv_entry->cost_billed($lineitem_price);
 816
 817         # amount staff agree to pay
 818         $eg_inv_entry->amount_paid($lineitem_price);
 819
 820         push @eg_inv_entries, $eg_inv_entry;
 821         push @eg_inv_cancel_lis,
 822             {lineitem => $li, quantity => $quantity}
 823             if $li->cancel_reason;
 824     }
 825
 826     my @eg_inv_items;
 827
 828     my %charge_type_map = (
 829         'TX' => ['TAX', 'Tax from electronic invoice'],
 830         'CA' => ['PRO', 'Cataloging services'],
 831         'DL' => ['SHP', 'Delivery']
 832     );
 833
 834     for my $charge (@{$invoice->{misc_charges}}) {
 835         my $eg_inv_item = Fieldmapper::acq::invoice_item->new;
 836
 837         my $amount = $charge->{charge_amount};
 838
 839         if (!$amount) {
 840             $logger->warn($log_prefix . "charge with no amount");
 841             next;
 842         }
 843
 844         my $map = $charge_type_map{$charge->{charge_type}};
 845
 846         if (!$map) {
 847             $map = [
 848                 'PRO',
 849                 'Unknown charge type ' .  $charge->{charge_type}
 850             ];
 851         }
 852
 853         $eg_inv_item->inv_item_type($$map[0]);
 854         $eg_inv_item->note($$map[1]);
 855         $eg_inv_item->cost_billed($amount);
 856
 857         push @eg_inv_items, $eg_inv_item;
 858     }
 859
 860     $logger->info($log_prefix .
 861         sprintf("creating invoice with %d entries and %d items.",
 862             scalar(@eg_inv_entries), scalar(@eg_inv_items)));
 863
 864     $e->xact_begin;
 865
 866     # save changes to acq.edi_message row
 867     if (not $e->update_acq_edi_message($message)) {
 868         $logger->error(
 869             $log_prefix . "couldn't update edi_message " . $message->id
 870         );
 871         return 0;
 872     }
 873
 874     # create EG invoice
 875     if (not $e->create_acq_invoice($eg_inv)) {
 876         $logger->error($log_prefix . "couldn't create invoice: " . $e->event);
 877         return 0;
 878     }
 879
 880     # Now we have a pkey for our EG invoice, so set the invoice field on all
 881     # our entries according and create those too.
 882     my $eg_inv_id = $e->data->id;
 883     foreach (@eg_inv_entries) {
 884         $_->invoice($eg_inv_id);
 885         if (not $e->create_acq_invoice_entry($_)) {
 886             $logger->error(
 887                 $log_prefix . "couldn't create entry against lineitem " .
 888                 $_->lineitem . ": " . $e->event
 889             );
 890             return 0;
 891         }
 892     }
 893
 894     # Create any invoice items (taxes)
 895     foreach (@eg_inv_items) {
 896         $_->invoice($eg_inv_id);
 897         if (not $e->create_acq_invoice_item($_)) {
 898             $logger->error(
 899                 $log_prefix . "couldn't create inv item: " . $e->event
 900             );
 901             return 0;
 902         }
 903     }
 904
 905     # if an invoiced lineitem is marked as cancelled
 906     # (e.g. back-order), invoicing the lineitem implies
 907     # we need to un-cancel it
 908     for my $li_chunk (@eg_inv_cancel_lis) {
 909         my $li = $li_chunk->{lineitem};
 910         my $quantity = $li_chunk->{quantity};
 911
 912         $logger->info($log_prefix .
 913             "un-cancelling invoiced lineitem ". $li->id);
 914
 915         # collect the LIDs, starting with those that are
 916         # not cancelled (should not happen), followed by
 917         # those that have keep-debits cancel_reasons,
 918         # followed by non-keep-debit cancel reasons.
 919
 920         my $lid_ids = $e->json_query({
 921             select => {acqlid => ['id']},
 922             from => {
 923                 acqlid => {
 924                     acqcr => {type => 'left'},
 925                     acqfdeb => {type => 'left'}
 926                 }
 927             },
 928             where => {
 929                 '+acqlid' => {lineitem => $li->id},
 930                 # not-yet invoiced copies
 931                 '+acqfdeb' => {encumbrance => 't'}
 932             },
 933             order_by => [{
 934                 class => 'acqcr',
 935                 field => 'keep_debits',
 936                 direction => 'desc'
 937             }],
 938             limit => $quantity
 939         });
 940
 941         for my $lid_id (map {$_->{id}} @$lid_ids) {
 942             my $lid = $e->retrieve_acq_lineitem_detail($lid_id);
 943             next unless $lid->cancel_reason;
 944
 945             $lid->clear_cancel_reason;
 946             unless ($e->update_acq_lineitem_detail($lid)) {
 947                 $logger->error($log_prefix .
 948                     "couldn't clear lid cancel reason: ". $e->die_event
 949                 );
 950                 return 0;
 951             }
 952         }
 953
 954         $li->clear_cancel_reason;
 955         $li->state("on-order");
 956         $li->edit_time('now');
 957
 958         unless ($e->update_acq_lineitem($li)) {
 959             $logger->error($log_prefix .
 960                 "couldn't clear li cancel reason: ". $e->die_event
 961             );
 962             return 0;
 963         }
 964     }
 965
 966
 967     $e->xact_commit;
 968     return 1;
 969 }
 970
 971 1;
 972