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