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