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
  19 use OpenILS::Utils::LooseEDI;
  20 use Business::EDI;
  21
  22 use Data::Dumper;
  23 our $verbose = 0;
  24
  25 sub new {
  26     my($class, %args) = @_;
  27     my $self = bless(\%args, $class);
  28     # $self->{args} = {};
  29     return $self;
  30 }
  31
  32 # our $reasons = {};   # cache for acq.cancel_reason rows ?
  33
  34 our $translator;
  35
  36 sub translator {
  37     return $translator ||= OpenILS::Application::Acq::EDI::Translator->new(@_);
  38 }
  39
  40 my %map = (
  41     host     => 'remote_host',
  42     username => 'remote_user',
  43     password => 'remote_password',
  44     account  => 'remote_account',
  45     # in_dir   => 'remote_path',   # field_map overrides path with in_dir
  46     path     => 'remote_path',
  47 );
  48
  49
  50 ## Just for debugging stuff:
  51 sub add_a_msg {
  52     my ($self, $conn) = @_;
  53     my $e = new_editor(xact=>1);
  54     my $incoming = Fieldmapper::acq::edi_message->new;
  55     $incoming->edi("This is content");
  56     $incoming->account(1);
  57     $incoming->remote_file('in/some_file.edi');
  58     $e->create_acq_edi_message($incoming);;
  59     $e->commit;
  60 }
  61 # __PACKAGE__->register_method( method => 'add_a_msg', api_name => 'open-ils.acq.edi.add_a_msg');  # debugging
  62
  63 __PACKAGE__->register_method(
  64         method    => 'retrieve',
  65         api_name  => 'open-ils.acq.edi.retrieve',
  66     authoritative => 1,
  67         signature => {
  68         desc   => 'Fetch incoming message(s) from EDI accounts.  ' .
  69                   'Optional arguments to restrict to one vendor and/or a max number of messages.  ' .
  70                   'Note that messages are not parsed or processed here, just fetched and translated.',
  71         params => [
  72             {desc => 'Authentication token',        type => 'string'},
  73             {desc => 'Vendor ID (undef for "all")', type => 'number'},
  74             {desc => 'Date Inactive Since',         type => 'string'},
  75             {desc => 'Max Messages Retrieved',      type => 'number'}
  76         ],
  77         return => {
  78             desc => 'List of new message IDs (empty if none)',
  79             type => 'array'
  80         }
  81     }
  82 );
  83
  84 sub retrieve_core {
  85     my ($self, $set, $max, $e, $test) = @_;    # $e is a working editor
  86
  87     $e   ||= new_editor();
  88     $set ||= __PACKAGE__->retrieve_vendors($e);
  89
  90     my @return = ();
  91     my $vcount = 0;
  92     foreach my $account (@$set) {
  93         my $count = 0;
  94         my $server;
  95         $logger->info("EDI check for vendor " . ++$vcount . " of " . scalar(@$set) . ": " . $account->host);
  96         unless ($server = __PACKAGE__->remote_account($account)) {   # assignment, not comparison
  97             $logger->err(sprintf "Failed remote account mapping for %s (%s)", $account->host, $account->id);
  98             next;
  99         };
 100 #       my $rf_starter = './';  # default to current dir
 101         if ($account->in_dir) {
 102             if ($account->in_dir =~ /\*+.*\//) {
 103                 $logger->err("EDI in_dir has a slash after an asterisk in value: '" . $account->in_dir . "'.  Skipping account with indeterminate target dir!");
 104                 next;
 105             }
 106 #           $rf_starter = $account->in_dir;
 107 #           $rf_starter =~ s/((\/)?[^\/]*)\*+[^\/]*$//;  # kill up to the first (possible) slash before the asterisk: keep the preceeding static dir
 108 #           $rf_starter .= '/' if $rf_starter or $2;   # recap the dir, or replace leading "/" if there was one (but don't add if empty)
 109         }
 110         my @files    = ($server->ls({remote_file => ($account->in_dir || './')}));
 111         my @ok_files = grep {$_ !~ /\/\.?\.$/ and $_ ne '0'} @files;
 112         $logger->info(sprintf "%s of %s files at %s/%s", scalar(@ok_files), scalar(@files), $account->host, $account->in_dir);
 113         # $server->remote_path(undef);
 114         foreach my $remote_file (@ok_files) {
 115             # my $remote_file = $rf_starter . $_;
 116             my $description = sprintf "%s/%s", $account->host, $remote_file;
 117
 118             # deduplicate vs. acct/filenames already in DB
 119             my $hits = $e->search_acq_edi_message([
 120                 {
 121                     account     => $account->id,
 122                     remote_file => $remote_file,
 123                     status      => {'in' => [qw/ processed /]},     # if it never got processed, go ahead and get the new one (try again)
 124                     # create_time => 'NOW() - 60 DAYS',     # if we wanted to allow filenames to be reused after a certain time
 125                     # ideally we would also use the date from FTP, but that info isn't available via RemoteAccount
 126                 }
 127                 # { flesh => 1, flesh_fields => {...}, }
 128             ]);
 129             if (scalar(@$hits)) {
 130                 $logger->debug("EDI: $remote_file already retrieved.  Skipping");
 131                 warn "EDI: $remote_file already retrieved.  Skipping";
 132                 next;
 133             }
 134
 135             ++$count;
 136             $max and $count > $max and last;
 137             $logger->info(sprintf "%s of %s targets: %s", $count, scalar(@ok_files), $description);
 138             print sprintf "%s of %s targets: %s\n", $count, scalar(@ok_files), $description;
 139             if ($test) {
 140                 push @return, "test_$count";
 141                 next;
 142             }
 143             my $content;
 144             my $io = IO::Scalar->new(\$content);
 145             unless ( $server->get({remote_file => $remote_file, local_file => $io}) ) {
 146                 $logger->error("(S)FTP get($description) failed");
 147                 next;
 148             }
 149             my $incoming = __PACKAGE__->process_retrieval($content, $remote_file, $server, $account->id, $e);
 150 #           $server->delete(remote_file => $_);   # delete remote copies of saved message
 151             push @return, $incoming->id;
 152         }
 153     }
 154     return \@return;
 155 }
 156
 157 # my $in = OpenILS::Application::Acq::EDI->process_retrieval($file_content, $remote_filename, $server, $account_id, $editor);
 158
 159 sub process_retrieval {
 160     my $incoming = Fieldmapper::acq::edi_message->new;
 161     my ($class, $content, $remote, $server, $account_or_id, $e) = @_;
 162     $content or return;
 163     $e ||= new_editor;
 164
 165     my $account = __PACKAGE__->record_activity( $account_or_id, $e );
 166
 167     my $z;  # must predeclare
 168     $z = ( $content =~ s/('UNH\+\d+\+ORDRSP:)0(:96A:UN')/$1D$2/g )
 169         and $logger->warn("Patching bogus spec reference ORDRSP:0:96A:UN => ORDRSP:D:96A:UN ($z times)");  # Hack/fix some faulty "0" in (B&T) data
 170
 171     $incoming->remote_file($remote);
 172     $incoming->account($account->id);
 173     $incoming->edi($content);
 174     $incoming->message_type(($content =~ /'UNH\+\d+\+(\S{6}):/) ? $1 : 'ORDRSP');   # cheap sniffing, ORDRSP fallback
 175     __PACKAGE__->attempt_translation($incoming);
 176     $e->xact_begin;
 177     $e->create_acq_edi_message($incoming);
 178     $e->xact_commit;
 179     # refresh: send process_jedi the updated row
 180     $e->xact_begin;
 181
 182     # LFW: I really don't understand in what sense you could call this
 183     # message 'outgoing', except from the vendor's point of view?
 184     my $outgoing = $e->retrieve_acq_edi_message($incoming->id);  # refresh again!
 185     $e->xact_rollback;
 186     my $res = __PACKAGE__->process_jedi($outgoing, $server, $account, $e);
 187     $e->xact_begin;
 188     $outgoing = $e->retrieve_acq_edi_message($incoming->id);  # refresh again!
 189     $e->xact_rollback;
 190     $outgoing->status($res ? 'processed' : 'proc_error');
 191     if ($res) {
 192         $e->xact_begin;
 193         $e->update_acq_edi_message($outgoing);
 194         $e->xact_commit;
 195     }
 196     return $outgoing;
 197 }
 198
 199 # ->send_core
 200 # $account     is a Fieldmapper object for acq.edi_account row
 201 # $messageset  is an arrayref with acq.edi_message.id values
 202 # $e           is optional editor object
 203 sub send_core {
 204     my ($class, $account, $message_ids, $e) = @_;    # $e is a working editor
 205
 206     ($account and scalar @$message_ids) or return;
 207     $e ||= new_editor();
 208
 209     $e->xact_begin;
 210     my @messageset = map {$e->retrieve_acq_edi_message($_)} @$message_ids;
 211     $e->xact_rollback;
 212     my $m_count = scalar(@messageset);
 213     (scalar(@$message_ids) == $m_count) or
 214         $logger->warn(scalar(@$message_ids) - $m_count . " bad IDs passed to send_core (ignored)");
 215
 216     my $log_str = sprintf "EDI send to edi_account %s (%s)", $account->id, $account->host;
 217     $logger->info("$log_str: $m_count message(s)");
 218     $m_count or return;
 219
 220     my $server;
 221     my $server_error;
 222     unless ($server = __PACKAGE__->remote_account($account, 1)) {   # assignment, not comparison
 223         $logger->error("Failed remote account connection for $log_str");
 224         $server_error = 1;
 225     };
 226     foreach (@messageset) {
 227         $_ or next;     # we already warned about bum ids
 228         my ($res, $error);
 229         if ($server_error) {
 230             $error = "Server error: Failed remote account connection for $log_str"; # already told $logger, this is to update object below
 231         } elsif (! $_->edi) {
 232             $logger->error("Message (id " . $_->id. ") for $log_str has no EDI content");
 233             $error = "EDI empty!";
 234         } elsif ($res = $server->put({remote_path => $account->path, content => $_->edi, single_ext => 1})) {
 235             #  This is the successful case!
 236             $_->remote_file($res);
 237             $_->status('complete');
 238             $_->process_time('NOW');    # For outbound files, sending is the end of processing on the EG side.
 239             $logger->info("Sent message (id " . $_->id. ") via $log_str");
 240         } else {
 241             $logger->error("(S)FTP put to $log_str FAILED: " . ($server->error || 'UNKOWNN'));
 242             $error = "put FAILED: " . ($server->error || 'UNKOWNN');
 243         }
 244         if ($error) {
 245             $_->error($error);
 246             $_->error_time('NOW');
 247         }
 248         $logger->info("Calling update_acq_edi_message");
 249         $e->xact_begin;
 250         unless ($e->update_acq_edi_message($_)) {
 251              $logger->error("EDI send_core update_acq_edi_message failed for message object: " . Dumper($_));
 252              OpenILS::Application::Acq::EDI::Translator->debug_file(Dumper($_              ), '/tmp/update_acq_edi_message.FAIL');
 253              OpenILS::Application::Acq::EDI::Translator->debug_file(Dumper($_->to_bare_hash), '/tmp/update_acq_edi_message.FAIL.to_bare_hash');
 254         }
 255         # There's always an update, even if we failed.
 256         $e->xact_commit;
 257         __PACKAGE__->record_activity($account, $e);  # There's always an update, even if we failed.
 258     }
 259     return \@messageset;
 260 }
 261
 262 #  attempt_translation does not touch the DB, just the object.
 263 sub attempt_translation {
 264     my ($class, $edi_message, $to_edi) = @_;
 265     my $tran  = translator();
 266     my $ret   = $to_edi ? $tran->json2edi($edi_message->jedi) : $tran->edi2json($edi_message->edi);
 267 #   $logger->error("json: " . Dumper($json)); # debugging
 268     if (not $ret or (! ref($ret)) or $ret->is_fault) {      # RPC::XML::fault on failure
 269         $edi_message->status('trans_error');
 270         $edi_message->error_time('NOW');
 271         my $pre = "EDI Translator " . ($to_edi ? 'json2edi' : 'edi2json') . " failed";
 272         my $message = ref($ret) ?
 273                       ("$pre, Error " . $ret->code . ": " . __PACKAGE__->nice_string($ret->string)) :
 274                       ("$pre: "                           . __PACKAGE__->nice_string($ret)        ) ;
 275         $edi_message->error($message);
 276         $logger->error(  $message);
 277         return;
 278     }
 279     $edi_message->status('translated');
 280     $edi_message->translate_time('NOW');
 281     if ($to_edi) {
 282         $edi_message->edi($ret->value);    # translator returns an object
 283     } else {
 284         $edi_message->jedi($ret->value);   # translator returns an object
 285     }
 286     return $edi_message;
 287 }
 288
 289 sub retrieve_vendors {
 290     my ($self, $e, $vendor_id, $last_activity) = @_;    # $e is a working editor
 291
 292     $e ||= new_editor();
 293
 294     my $criteria = {'+acqpro' => {active => 't'}};
 295     $criteria->{'+acqpro'}->{id} = $vendor_id if $vendor_id;
 296     return $e->search_acq_edi_account([
 297         $criteria, {
 298             'join' => 'acqpro',
 299             flesh => 1,
 300             flesh_fields => {
 301                 acqedi => ['provider']
 302             }
 303         }
 304     ]);
 305 #   {"id":{"!=":null},"+acqpro":{"active":"t"}}, {"join":"acqpro", "flesh_fields":{"acqedi":["provider"]},"flesh":1}
 306 }
 307
 308 # This is the SRF-exposed call, so it does checkauth
 309
 310 sub retrieve {
 311     my ($self, $conn, $auth, $vendor_id, $last_activity, $max) = @_;
 312
 313     my $e = new_editor(authtoken=>$auth);
 314     unless ($e and $e->checkauth()) {
 315         $logger->warn("checkauth failed for authtoken '$auth'");
 316         return ();
 317     }
 318     # return $e->die_event unless $e->allowed('RECEIVE_PURCHASE_ORDER', $li->purchase_order->ordering_agency);  # add permission here ?
 319
 320     my $set = __PACKAGE__->retrieve_vendors($e, $vendor_id, $last_activity) or return $e->die_event;
 321     return __PACKAGE__->retrieve_core($e, $set, $max);
 322 }
 323
 324
 325 # field_map takes the hashref of vendor data with fields from acq.edi_account and
 326 # maps them to the argument style needed for RemoteAccount.  It also extrapolates
 327 # data from the remote_host string for type and port, when available.
 328
 329 sub field_map {
 330     my $self   = shift;
 331     my $vendor = shift or return;
 332     my $no_override = @_ ? shift : 0;
 333     my %args = ();
 334     $verbose and $logger->warn("vendor: " . Dumper($vendor));
 335     foreach (keys %map) {
 336         $args{$map{$_}} = $vendor->$_ if defined $vendor->$_;
 337     }
 338     unless ($no_override) {
 339         $args{remote_path} = $vendor->in_dir;    # override "path" with "in_dir"
 340     }
 341     my $host = $args{remote_host} || '';
 342     ($host =~ s/^(S?FTP)://i    and $args{type} = uc($1)) or
 343     ($host =~ s/^(SSH|SCP)://i  and $args{type} = 'SCP' ) ;
 344      $host =~ s/:(\d+)$//       and $args{port} = $1;
 345     ($args{remote_host} = $host) =~ s#/+##;
 346     $verbose and $logger->warn("field_map: " . Dumper(\%args));
 347     return %args;
 348 }
 349
 350
 351 # The point of remote_account is to get the RemoteAccount object with args from the DB
 352
 353 sub remote_account {
 354     my ($self, $vendor, $outbound, $e) = @_;
 355
 356     unless (ref($vendor)) {     # It's not a hashref/object.
 357         $vendor or return;      # If in fact it's nothing: abort!
 358                                 # else it's a vendor_id string, so get the full vendor data
 359         $e ||= new_editor();
 360         my $set_of_one = $self->retrieve_vendors($e, $vendor) or return;
 361         $vendor = shift @$set_of_one;
 362     }
 363
 364     return OpenILS::Utils::RemoteAccount->new(
 365         $self->field_map($vendor, $outbound)
 366     );
 367 }
 368
 369 # takes account ID or account Fieldmapper object
 370
 371 sub record_activity {
 372     my ($class, $account_or_id, $e) = @_;
 373     $account_or_id or return;
 374     $e ||= new_editor();
 375     my $account = ref($account_or_id) ? $account_or_id : $e->retrieve_acq_edi_account($account_or_id);
 376     $logger->info("EDI record_activity calling update_acq_edi_account");
 377     $account->last_activity('NOW') or return;
 378     $e->xact_begin;
 379     $e->update_acq_edi_account($account) or $logger->warn("EDI: in record_activity, update_acq_edi_account FAILED");
 380     $e->xact_commit;
 381     return $account;
 382 }
 383
 384 sub nice_string {
 385     my $class = shift;
 386     my $string = shift or return '';
 387     chomp($string);
 388     my $head   = @_ ? shift : 100;
 389     my $tail   = @_ ? shift :  25;
 390     (length($string) < $head + $tail) and return $string;
 391     my $h = substr($string,0,$head);
 392     my $t = substr($string, -1*$tail);
 393     $h =~s/\s*$//o;
 394     $t =~s/\s*$//o;
 395     return "$h ... $t";
 396     # return substr($string,0,$head) . "... " . substr($string, -1*$tail);
 397 }
 398
 399 sub jedi2perl {
 400     my ($class, $jedi) = @_;
 401     $jedi or return;
 402     my $msg = OpenSRF::Utils::JSON->JSON2perl( $jedi );
 403     open (FOO, ">>/tmp/JSON2perl_dump.txt");
 404     print FOO Dumper($msg), "\n\n";
 405     close FOO;
 406     $logger->warn("Dumped JSON2perl to /tmp/JSON2perl_dump.txt");
 407     return $msg;
 408 }
 409
 410 our @datecodes = (35, 359, 17, 191, 69, 76, 75, 79, 85, 74, 84, 223);
 411 our @noop_6063 = (21);
 412
 413 # ->process_jedi($message, $server, $remote, $e)
 414 # $message is an edi_message object
 415 #
 416 # This method has lots of logic to process ORDRSP messages (and theoretically
 417 # OSTRPT messages) and to make changes based on those to EG acq objects.
 418 # If it gets an INVOIC message, it hands that off to
 419 # create_acq_invoice_from_edi() following a new model (this code all wants
 420 # cleaned-up/refactored).
 421 #
 422 # This method currently returns an array of message objects, but no callers use
 423 # that except in a boolean evaluation to test for success.  So don't count on
 424 # that array being there or containing anything specific in the future: it
 425 # might get changed.
 426 sub process_jedi {
 427     my ($class, $message, $server, $remote, $e) = @_;
 428     $message or return;
 429     $server ||= {};  # context
 430     $remote ||= {};  # context
 431     $e ||= new_editor;
 432     my $jedi;
 433     unless (ref($message) and $jedi = $message->jedi) {     # assignment, not comparison
 434         $logger->warn("EDI process_jedi missing required argument (edi_message object with jedi)!");
 435         return;
 436     }
 437     my $perl  = __PACKAGE__->jedi2perl($jedi);
 438     my $error = '';
 439     if (ref($message) and not $perl) {
 440         $error = ($message->error || '') . " JSON2perl (jedi2perl) FAILED to convert jedi";
 441     }
 442     elsif (! $perl->{body}) {
 443         $error = "EDI interchange body not found!";
 444     }
 445     elsif (! $perl->{body}->[0]) {
 446         $error = "EDI interchange body not a populated arrayref!";
 447     }
 448     if ($error) {
 449         $logger->warn($error);
 450         $message->error($error);
 451         $message->error_time('NOW');
 452         $e->xact_begin;
 453         $e->update_acq_edi_message($message) or $logger->warn("EDI update_acq_edi_message failed! $!");
 454         $e->xact_commit;
 455         return;
 456     }
 457
 458 # Crazy data structure.  Most of the arrays will be 1 element... we think.
 459 # JEDI looks like:
 460 # {'body' => [{'ORDERS' => [['UNH',{'0062' => '4635','S009' => {'0057' => 'EAN008','0051' => 'UN','0052' => 'D','0065' => 'ORDERS', ...
 461 #
 462 # So you might access it like:
 463 #   $obj->{body}->[0]->{ORDERS}->[0]->[0] eq 'UNH'
 464
 465     $logger->info("EDI interchange body has " . scalar(@{$perl->{body}}) . " message(s)");
 466     my @ok_msg_codes = qw/ORDRSP OSTRPT INVOIC/;
 467     my @messages;
 468     my $i = 0;
 469     foreach my $part (@{$perl->{body}}) {
 470         $i++;
 471         unless (ref $part and scalar keys %$part) {
 472             $logger->warn("EDI interchange message $i lacks structure.  Skipping it.");
 473             next;
 474         }
 475         foreach my $key (keys %$part) {
 476             if (! grep {$_ eq $key} @ok_msg_codes) {     # We only do one type for now.  TODO: other types here
 477                 $logger->warn("EDI interchange $i contains unhandled '$key' message.  Ignoring it.");
 478                 next;
 479             }
 480             if ($key eq 'INVOIC') {
 481                 # XXX TODO Maybe subclass O::U::LooseEDI::Message as
 482                 # something like OpenILS::Acq::{VendorInvoice,OrderReponse},
 483                 # each one knowing how to read itself and update EG acq
 484                 # objects (not under OpenILS::Application perhaps).
 485                 my $invoice_message =
 486                     new OpenILS::Utils::LooseEDI::Message($part->{$key});
 487                 push @messages, $invoice_message if
 488                     $class->create_acq_invoice_from_edi(
 489                         $e, $invoice_message, $remote->provider
 490                     );
 491                 next;
 492             }
 493
 494             my $msg = __PACKAGE__->message_object($part->{$key}) or next;
 495             push @messages, $msg;
 496
 497             my $bgm = $msg->xpath('BGM') or $logger->warn("EDI No BGM segment found?!");
 498             my $tag4343 = $msg->xpath('BGM/4343');
 499             my $tag1225 = $msg->xpath('BGM/1225');
 500             if (ref $tag4343) {
 501                 $logger->info(sprintf "EDI $key BGM/4343 Response Type: %s - %s", $tag4343->value, $tag4343->label)
 502             } else {
 503                 $logger->warn("EDI $key BGM/4343 Response Type Code unrecognized"); # next; #?
 504             }
 505             if (ref $tag1225) {
 506                 $logger->info(sprintf "EDI $key BGM/1225 Message Function: %s - %s", $tag1225->value, $tag1225->label);
 507             } else {
 508                 $logger->warn("EDI $key BGM/1225 Message Function Code unrecognized"); # next; #?
 509             }
 510
 511             # TODO: currency check, just to be paranoid
 512             # *should* be unnecessary (vendor should reply in currency we send in ORDERS)
 513             # That begs a policy question: how to handle mismatch?  convert (bad accuracy), reject, or ignore?  I say ignore.
 514
 515             # ALL those codes below are basically some form of (lastest) delivery date/time
 516             # see, e.g.: http://www.stylusstudio.com/edifact/D04B/2005.htm
 517             # The order is the order of definitiveness (first match wins)
 518             # Note: if/when we do serials via EDI, dates (and ranges/periods) will need massive special handling
 519             my @dates;
 520             my $ddate;
 521
 522             foreach my $date ($msg->xpath('delivery_schedule')) {
 523                 my $val_2005 = $date->xpath_value('DTM/2005') or next;
 524                 (grep {$val_2005 eq $_} @datecodes) or next; # no match means some other kind of date we don't care about
 525                 push @dates, $date;
 526             }
 527             if (@dates) {
 528                 DATECODE: foreach my $dcode (@datecodes) {   # now cycle back through hits in order of dcode definitiveness
 529                     foreach my $date (@dates) {
 530                         $date->xpath_value('DTM/2005') == $dcode or next;
 531                         $ddate = $date->xpath_value('DTM/2380') and last DATECODE;
 532                         # TODO: conversion based on format specified in DTM/2379 (best encapsulated in Business::EDI)
 533                     }
 534                 }
 535             }
 536             foreach my $detail ($msg->part('line_detail')) {
 537                 my $eg_line = __PACKAGE__->eg_li($detail, $remote, $server->{remote_host}, $e) or next;
 538                 my $li_date = $detail->xpath_value('DTM/2380') || $ddate;
 539                 my $price   = $detail->xpath_value('line_price/PRI/5118') || '';
 540                 $eg_line->expected_recv_time($li_date) if $li_date;
 541                 $eg_line->estimated_unit_price($price) if $price;
 542                 if (not $message->purchase_order) {                     # first good lineitem sets the message PO link
 543                     $message->purchase_order($eg_line->purchase_order); # EG $message object NOT Business::EDI $msg object
 544                     $e->xact_begin;
 545                     $e->update_acq_edi_message($message) or $logger->warn("EDI update_acq_edi_message (for PO number) failed! $!");
 546                     $e->xact_commit;
 547                 }
 548                 # $e->search_acq_edi_account([]);
 549                 my $touches = 0;
 550                 my $eg_lids = $e->search_acq_lineitem_detail({lineitem => $eg_line->id}); # should be the same as $eg_line->lineitem_details
 551                 my $lidcount = scalar(@$eg_lids);
 552                 $lidcount == $eg_line->item_count or $logger->warn(
 553                     sprintf "EDI: LI %s itemcount (%d) mismatch, %d LIDs found", $eg_line->id, $eg_line->item_count, $lidcount
 554                 );
 555                 foreach my $qty ($detail->part('all_QTY')) {
 556                     my $ubound   = $qty->xpath_value('6060') or next;   # nothing to do if qty is 0
 557                     my $val_6063 = $qty->xpath_value('6063');
 558                     $ubound > 0 or next; # don't be crazy!
 559                     if (! $val_6063) {
 560                         $logger->warn("EDI: Response for LI " . $eg_line->id . " specifies quantity $ubound with no 6063 code! Contact vendor to resolve.");
 561                         next;
 562                     }
 563
 564                     my $eg_reason = $e->retrieve_acq_cancel_reason(1200 + $val_6063);  # DB populated w/ 6063 keys in 1200's
 565                     if (! $eg_reason) {
 566                         $logger->warn("EDI: Unhandled quantity code '$val_6063' (LI " . $eg_line->id . ") $ubound items unprocessed");
 567                         next;
 568                     } elsif (grep {$val_6063 == $_} @noop_6063) {      # an FYI like "ordered quantity"
 569                         $ubound eq $lidcount
 570                             or $logger->warn("EDI: LI " . $eg_line->id . " -- Vendor says we ordered $ubound, but we have $lidcount LIDs!)");
 571                         next;
 572                     }
 573                     # elsif ($val_6063 == 83) { # backorder
 574                    #} elsif ($val_6063 == 85) { # cancel
 575                    #} elsif ($val_6063 == 12 or $val_6063 == 57 or $val_6063 == 84 or $val_6063 == 118) {
 576                             # despatched, in transit, urgent delivery, or quantity manifested
 577                    #}
 578                     if ($touches >= $lidcount) {
 579                         $logger->warn("EDI: LI "  . $eg_line->id . ", We already updated $touches of $lidcount LIDS, " .
 580                                       "but message wants QTY $ubound more set to " . $eg_reason->label . ".  Ignoring!");
 581                         next;
 582                     }
 583                     $e->xact_begin;
 584                     foreach (1 .. $ubound) {
 585                         my $eg_lid = shift @$eg_lids or $logger->warn("EDI: Used up all $lidcount LIDs!  Ignoring extra status " . $eg_reason->label);
 586                         $eg_lid or next;
 587                         $logger->debug(sprintf "Updating LID %s to %s", $eg_lid->id, $eg_reason->label);
 588                         $eg_lid->cancel_reason($eg_reason->id);
 589                         $e->update_acq_lineitem_detail($eg_lid);
 590                         $touches++;
 591                     }
 592                     $e->xact_commit;
 593                     if ($ubound == $eg_line->item_count) {
 594                         $eg_line->cancel_reason($eg_reason->id);    # if ALL the items have the same cancel_reason, the PO gets it too
 595                     }
 596                 }
 597                 $eg_line->edit_time('NOW'); # TODO: have this field automatically updated via ON UPDATE trigger.
 598                 $e->xact_begin;
 599                 $e->update_acq_lineitem($eg_line) or $logger->warn("EDI: update_acq_lineitem FAILED");
 600                 $e->xact_commit;
 601                 # print STDERR "Lineitem update: ", Dumper($eg_line);
 602             }
 603         }
 604     }
 605     return \@messages;
 606 }
 607
 608
 609 # create_acq_invoice_from_edi() does what it sounds like it does for INVOIC
 610 # messages.  For similar operation on ORDRSP messages, see the guts of
 611 # process_jedi().
 612 # Return boolean success indicator.
 613 sub create_acq_invoice_from_edi {
 614     my ($class, $e, $invoice, $provider, $message) = @_;
 615     # $invoice is O::U::LooseEDI::Message, representing the EDI invoice message.
 616     # $provider is only a pkey
 617     # $message is Fieldmapper::acq::edi_message
 618
 619     my $log_prefix = "create_acq_invoice_from_edi(..., <acq.edi_message #" .
 620         $message->id . ">): ";
 621
 622     my $eg_inv = Fieldmapper::acq::invoice->new;
 623
 624     $eg_inv->provider($provider);
 625     $eg_inv->shipper($provider);    # XXX Do we really have a meaningful way to
 626                                     # distinguish provider and shipper?
 627     $eg_inv->recv_method("EDI");
 628
 629     # Find the buyer's identifier in the invoice.
 630     my $buyer_san;
 631     foreach (@{$invoice->{SG2}}) {
 632         my $nad = $_->{NAD}[0];
 633         if ($nad->{3035} eq 'BY' and $nad->{C082}{3055} eq '91') {
 634             $buyer_san = $nad->{C082}{3039};
 635         }
 636     }
 637
 638     if (not $buyer_san) {
 639         $logger->error($log_prefix . "could not find buyer SAN in INVOIC");
 640         return 0;
 641     }
 642
 643     # Find the matching org unit based on SAN via 'aoa' table.
 644     my $addrs =
 645         $e->search_actor_org_address({valid => "t", san => $buyer_san});
 646
 647     if (not $addrs or not @$addrs) {
 648         $logger->error(
 649             $log_prefix . "couldn't find OU unit matching buyer SAN in INVOIC:".
 650             $e->event
 651         );
 652         return 0;
 653     }
 654
 655     # XXX Should we verify that this matches PO ordering agency later?
 656     $eg_inv->receiver($addrs->[0]->org_unit);
 657
 658     try {
 659         $eg_inv->inv_ident($invoice->{BGM}[0]{1004});
 660     } catch Error with {
 661         $logger->error(
 662             $log_prefix . "no invoice ID # in INVOIC message; " . shift
 663         );
 664     }
 665     return 0 unless $eg_inv->inv_ident;
 666
 667     my @eg_inv_entries;
 668
 669     # The invoice message will have once instance of segment group 25
 670     # per lineitem.
 671     foreach my $sg25 (@{ $invoice->{SG25} }) {
 672         # quantity
 673         my $c186 = $sg25->{QTY}[0]{C186};
 674         my $quantity = $c186->{6060};
 675         # $c186->{6411} will probably say 'PCE', but need we check it?
 676
 677         # identifiers (typically ISBN for us, and we may not need these)
 678         my @identifiers = ();
 679         #   from LIN...
 680         try {
 681             my $c212 = $sg25->{LIN}[0]{C212};
 682             push @identifiers, [$c212->{7143}, $c212->{7140}] if
 683                 $c212 and ref $c212 eq 'HASH';
 684         } catch Error with {
 685             # move on
 686         };
 687
 688         #   from PIA...
 689         try {
 690             foreach my $pia (@{ $sg25->{PIA} }) {
 691                 foreach my $h (@{$pia->{C212}}) {
 692                     push @identifiers, [$h->{7143}, $h->{7140}];
 693                 }
 694             }
 695         } catch Error with {
 696             # move on
 697         };
 698
 699         # @identifiers now contains lists of, say,
 700         # ['IB',   '0786222735'], # ISBN 10
 701         # ['EN','9780786222735']  # ISBN 13
 702
 703         # Segment Group 26-47 are all descendants of SG25.
 704
 705         # Segment Group 26 concerns *lineitem* price (i.e, total for all copies
 706         # on this lineitem).
 707
 708         my $lineitem_price = $sg25->{SG26}[0]{MOA}[0]{C516}{5004};
 709
 710         # Segment Group 28 concerns *unit* (lineitem detail) price.  We may
 711         # not actually use this.  TBD.
 712         my $per_unit_price;
 713         foreach my $sg28 (@{$sg25->{SG28}}) {
 714             my $c509 = $sg28->{PRI}[0]{C509};
 715             my ($price_qualifier, $price_qualifier_type);
 716             ($per_unit_price, $price_qualifier, $price_qualifier_type) = (
 717                 $c509->{5118}, $c509->{5125}, $c509->{5387}
 718             );
 719
 720             # price_qualifier=AAA seems to be the price to use.  Otherwise,
 721             # take what we can get.
 722             last if $price_qualifier eq 'AAA';
 723         }
 724
 725         # Segment Group 29 will have references to LI and PO numbers
 726         my $acq_identifiers = {};
 727         foreach my $sg29 (@{$sg25->{SG29}}) {
 728             foreach my $rff (@{$sg29->{RFF}}) {
 729                 my $c506 = $rff->{C506};
 730                 if ($c506->{1153} eq 'ON') {
 731                     $acq_identifiers->{po} = $c506->{1154};
 732                 } elsif ($c506->{1153} eq 'LI') {
 733                     my ($po, $li) = split m./., $c506->{1154};
 734                     if ($po and $li) {
 735                         if ($acq_identifiers->{po}) {
 736                             $logger->warn(
 737                                 $log_prefix .
 738                                 "RFFs within lineitem disagree on PO # ?"
 739                             ) unless $acq_identifiers->{po} eq $po;
 740                         }
 741                         $acq_identifiers->{li} = $li;
 742                         $acq_identifiers->{po} = $po;
 743                     } else {
 744                         $logger->warn(
 745                             $log_prefix .
 746                             "RFF 1154 doesn't match expectations (.+/.+) " .
 747                             "where 1153 is 'LI'"
 748                         );
 749                     }
 750                 }
 751             }
 752         }
 753
 754         if ($acq_identifiers->{po}) {
 755             # First PO number seen in INVOIC sets the purchase_order field for
 756             # the entry in acq.edi_message (which model may need a rethink).
 757
 758             $message->purchase_order($acq_identifiers->{po}) unless
 759                 $message->purchase_order;
 760         } else {
 761             $logger->warn(
 762                 $log_prefix .
 763                 "SG29 missing or refers to no purchase order that we can tell"
 764             );
 765         }
 766         if (not $acq_identifiers->{li}) {
 767             $logger->warn(
 768                 $log_prefix .
 769                 "SG29 missing or refers to no lineitem that we can tell"
 770             );
 771         }
 772
 773         my $eg_inv_entry = Fieldmapper::acq::invoice_entry->new;
 774         $eg_inv_entry->inv_item_count($quantity);
 775
 776         # XXX Validate by making sure the LI is on-order and belongs to
 777         # the right provider and ordering agency and all that.
 778         $eg_inv_entry->lineitem($acq_identifiers->{li});
 779
 780         # XXX Do we actually need to link to PO directly here?
 781         $eg_inv_entry->purchase_order($acq_identifiers->{po});
 782
 783         # This is the total price for all units billed, not per-unit.
 784         $eg_inv_entry->cost_billed($lineitem_price);
 785
 786         push @eg_inv_entries, $eg_inv_entry;
 787     }
 788
 789     my @eg_inv_items;
 790
 791     # Find any taxes applied to the whole invoice.
 792     try {
 793         if ($invoice->{SG50}) {
 794             foreach my $sg50 (@{ $invoice->{SG50} }) {
 795                 if ($sg50->{TAX} and $sg50->{MOA}) {
 796                     my $tax_amount = $sg50->{MOA}[0]{C516}{5004};
 797
 798                     my $eg_inv_item = Fieldmapper::acq::invoice_item->new;
 799                     $eg_inv_item->inv_item_type('TAX');
 800                     $eg_inv_item->cost_billed($tax_amount);
 801                     # XXX i18n somehow? or maybe omit the note.
 802                     $eg_inv_item->note('Tax from electronic invoice');
 803
 804                     push @eg_inv_items, $eg_inv_item;
 805                 }
 806             }
 807         }
 808     } catch Error with {
 809         # move on
 810     };
 811
 812     $e->xact_begin;
 813
 814     # save changes to acq.edi_message row
 815     if (not $e->update_acq_edi_message($message)) {
 816         $logger->error(
 817             $log_prefix . "couldn't update edi_message " . $message->id
 818         );
 819         return 0;
 820     }
 821
 822     # create EG invoice
 823     if (not $e->create_acq_invoice($eg_inv)) {
 824         $logger->error($log_prefix . "couldn't create invoice: " . $e->event);
 825         return 0;
 826     }
 827
 828     # Now we have a pkey for our EG invoice, so set the invoice field on all
 829     # our entries according and create those too.
 830     my $eg_inv_id = $e->data->id;
 831     foreach (@eg_inv_entries) {
 832         $_->invoice($eg_inv_id);
 833         if (not $e->create_acq_invoice_entry($_)) {
 834             $logger->error(
 835                 $log_prefix . "couldn't create entry against lineitem " .
 836                 $_->lineitem . ": " . $e->event
 837             );
 838             return 0;
 839         }
 840     }
 841
 842     # Create any invoice items (taxes)
 843     foreach (@eg_inv_items) {
 844         $_->invoice($eg_inv_id);
 845         if (not $e->create_acq_invoice_item($_)) {
 846             $logger->error(
 847                 $log_prefix . "couldn't create inv item: " . $e->event
 848             );
 849             return 0;
 850         }
 851     }
 852
 853     $e->xact_commit;
 854     return 1;
 855 }
 856
 857 # returns message object if processing should continue
 858 # returns false/undef value if processing should abort
 859
 860 sub message_object {
 861     my $class = shift;
 862     my $body  = shift or return;
 863     my $key   = shift if @_;
 864     my $keystring = $key || 'UNSPECIFIED';
 865
 866     my $msg = Business::EDI::Message->new($body);
 867     unless ($msg) {
 868         $logger->error("EDI interchange message: $keystring body failed Business::EDI constructor. Skipping it.");
 869         return;
 870     }
 871     $key = $msg->code if ! $key;  # Now we set the key for reference if it wasn't specified
 872     my $val_0065 = $msg->xpath_value('UNH/S009/0065') || '';
 873     unless ($val_0065 eq $key) {
 874         $logger->error("EDI $key UNH/S009/0065 ('$val_0065') conflicts w/ message type $key.  Aborting");
 875         return;
 876     }
 877     my $val_0051 = $msg->xpath_value('UNH/S009/0051') || '';
 878     unless ($val_0051 eq 'UN') {
 879         $logger->warn("EDI $key UNH/S009/0051 designates '$val_0051', not 'UN' as controlling agency.  Attempting to process anyway");
 880     }
 881     my $val_0054 = $msg->xpath_value('UNH/S009/0054') || '';
 882     if ($val_0054) {
 883         $logger->info("EDI $key UNH/S009/0054 uses Spec revision version '$val_0054'");
 884         # Possible Spec Version limitation
 885         # my $yy = $tag_0054 ? substr($val_0054,0,2) : '';
 886         # unless ($yy eq '00' or $yy > 94 ...) {
 887         #     $logger->warn("EDI $key UNH/S009/0051 Spec revision version '$val_0054' not supported");
 888         # }
 889     } else {
 890         $logger->warn("EDI $key UNH/S009/0054 does not reference a known Spec revision version");
 891     }
 892     return $msg;
 893 }
 894
 895 =head2 ->eg_li($lineitem_object, [$remote, $server_log_string, $editor])
 896
 897 my $line_item = OpenILS::Application::Acq::EDI->eg_li($edi_line, $remote, "test_server_01", $e);
 898
 899  $remote is a acq.edi_account Fieldmapper object.
 900  $server_log_string is an arbitrary string use to identify the remote host in potential log messages.
 901
 902 Updates:
 903  acq.lineitem.estimated_unit_price,
 904  acq.lineitem.state (dependent on mapping codes),
 905  acq.lineitem.expected_recv_time,
 906  acq.lineitem.edit_time (consequently)
 907
 908 =cut
 909
 910 sub eg_li {
 911     my ($class, $line, $server, $server_log_string, $e) = @_;
 912     $line or return;
 913     $e ||= new_editor();
 914
 915     my $id;
 916     # my $rff      = $line->part('line_reference/RFF') or $logger->warn("EDI ORDRSP line_detail/RFF missing!");
 917     my $val_1153 = $line->xpath_value('line_reference/RFF/1153') || '';
 918     my $val_1154 = $line->xpath_value('line_reference/RFF/1154') || '';
 919     my $val_1082 = $line->xpath_value('LIN/1082') || '';
 920
 921     my @po_nums;
 922
 923     $val_1154 =~ s#^(.*)\/##;   # Many sources send the ID as 'order_ID/LI_ID'
 924     $1 and push @po_nums, $1;
 925     $val_1082 =~ s#^(.*)\/##;   # Many sources send the ID as 'order_ID/LI_ID'
 926     $1 and push @po_nums, $1;
 927
 928     # TODO: possible check of po_nums
 929     # now do a lot of checking
 930
 931     if ($val_1153 eq 'LI') {
 932         $id = $val_1154 or $logger->warn("EDI ORDRSP RFF/1154 reference to LI empty.  Attempting failover to LIN/1082");
 933     } else {
 934         $logger->warn("EDI ORDRSP RFF/1153 unexpected value ('$val_1153', not 'LI').  Attempting failover to LIN/1082");
 935     }
 936
 937     # FIXME - the line item ID in LIN/1082 ought to match RFF/1154, but
 938     # not all materials vendors obey this.  Commenting out check for now
 939     # as being too strict.
 940     #if ($id and $val_1082 and $val_1082 ne $id) {
 941     #    $logger->warn("EDI ORDRSP LIN/1082 Line Item ID mismatch ($id vs. $val_1082): cannot target update");
 942     #    return;
 943     #}
 944
 945     $id ||= $val_1082 || '';
 946     if ($id eq '') {
 947         $logger->warn('Cannot identify line item from EDI message');
 948         return;
 949     }
 950
 951     $logger->info("EDI retrieve/update lineitem $id");
 952
 953     my $li = OpenILS::Application::Acq::Lineitem::retrieve_lineitem_impl($e, $id, {
 954         flesh_li_details => 1,
 955     }, 1); # Could send more {options}.  The 1 is for no_auth.
 956
 957     if (! $li or ref($li) ne 'Fieldmapper::acq::lineitem') {
 958         $logger->error("EDI failed to retrieve lineitem by id '$id' for server $server_log_string");
 959         return;
 960     }
 961     unless ((! $server) or (! $server->provider)) {     # but here we want $server to be acq.edi_account instead of RemoteAccount
 962         if ($server->provider != $li->provider) {
 963             # links go both ways: acq.provider.edi_default and acq.edi_account.provider
 964             $logger->info("EDI acct provider (" . $server->provider. ") doesn't match lineitem provider("
 965                             . $li->provider . ").  Checking acq.provider.edi_default...");
 966             my $provider = $e->retrieve_acq_provider($li->provider);
 967             if ($provider->edi_default != $server->id) {
 968                 $logger->error(sprintf "EDI provider/acct %s/%s (%s) is blocked from updating lineitem $id belonging to provider/edi_default %s/%s",
 969                                 $server->provider, $server->id, $server->label, $li->provider, $provider->edi_default);
 970                 return;
 971             }
 972         }
 973     }
 974
 975     my @lin_1229 = $line->xpath('LIN/1229') or $logger->warn("EDI LIN/1229 Action Code missing!");
 976     my $key = $lin_1229[0] or return;
 977
 978     my $eg_reason = $e->retrieve_acq_cancel_reason(1000 + $key->value);  # DB populated w/ spec keys in 1000's
 979     $eg_reason or $logger->warn(sprintf "EDI LIN/1229 Action Code '%s' (%s) not recognized in acq.cancel_reason", $key->value, $key->label);
 980     $eg_reason or return;
 981
 982     $li->cancel_reason($eg_reason->id);
 983     unless ($eg_reason->keep_debits) {
 984         $logger->warn("EDI LIN/1229 Action Code '%s' (%s) has keep_debits=0", $key->value, $key->label);
 985     }
 986
 987     my @prices = $line->xpath_value("line_price/PRI/5118");
 988     $li->estimated_unit_price($prices[0]) if @prices;
 989
 990     return $li;
 991 }
 992
 993 # caching not needed for now (edi_fetcher is asynchronous)
 994 # sub get_reason {
 995 #     my ($class, $key, $e) = @_;
 996 #     $reasons->{$key} and return $reasons->{$key};
 997 #     $e ||= new_editor();
 998 #     $reasons->{$key} = $e->retrieve_acq_cancel_reason($key);
 999 #     return $reasons->{$key};
1000 # }
1001
1002 1;
1003
1004 __END__
1005
1006 Example JSON data.
1007
1008 Note the pseudo-hash 2-element arrays.
1009
1010 [
1011   'SG26',
1012   [
1013     [
1014       'LIN',
1015       {
1016         '1229' => '5',
1017         '1082' => 1,
1018         'C212' => {
1019           '7140' => '9780446360272',
1020           '7143' => 'EN'
1021         }
1022       }
1023     ],
1024     [
1025       'IMD',
1026       {
1027         '7081' => 'BST',
1028         '7077' => 'F',
1029         'C273' => {
1030           '7008' => [
1031             'NOT APPLIC WEBSTERS NEW WORLD THESA'
1032           ]
1033         }
1034       }
1035     ],
1036     [
1037       'QTY',
1038       {
1039         'C186' => {
1040           '6063' => '21',
1041           '6060' => 10
1042         }
1043       }
1044     ],
1045     [
1046       'QTY',
1047       {
1048         'C186' => {
1049           '6063' => '12',
1050           '6060' => 10
1051         }
1052       }
1053     ],
1054     [
1055       'QTY',
1056       {
1057         'C186' => {
1058           '6063' => '85',
1059           '6060' => 0
1060         }
1061       }
1062     ],
1063     [
1064       'FTX',
1065       {
1066         '4451' => 'LIN',
1067         'C107' => {
1068           '4441' => '01',
1069           '3055' => '28',
1070           '1131' => '8B'
1071         }
1072       }
1073     ],
1074     [
1075       'SG30',
1076       [
1077         [
1078           'PRI',
1079           {
1080             'C509' => {
1081               '5118' => '4.5',
1082               '5387' => 'SRP',
1083               '5125' => 'AAB'
1084             }
1085           }
1086         ]
1087       ]
1088     ],
1089     [
1090       'SG31',
1091       [
1092         [
1093           'RFF',
1094           {
1095             'C506' => {
1096               '1154' => '8/1',
1097               '1153' => 'LI'
1098             }
1099           }
1100         ]
1101       ]
1102     ]
1103   ]
1104 ],
1105