Open-ILS/src/perlmods/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 Business::EDI;
  20
  21 use Data::Dumper;
  22 our $verbose = 0;
  23
  24 sub new {
  25     my($class, %args) = @_;
  26     my $self = bless(\%args, $class);
  27     # $self->{args} = {};
  28     return $self;
  29 }
  30
  31 # our $reasons = {};   # cache for acq.cancel_reason rows ?
  32
  33 our $translator;
  34
  35 sub translator {
  36     return $translator ||= OpenILS::Application::Acq::EDI::Translator->new(@_);
  37 }
  38
  39 my %map = (
  40     host     => 'remote_host',
  41     username => 'remote_user',
  42     password => 'remote_password',
  43     account  => 'remote_account',
  44     # in_dir   => 'remote_path',   # field_map overrides path with in_dir
  45     path     => 'remote_path',
  46 );
  47
  48
  49 ## Just for debugging stuff:
  50 sub add_a_msg {
  51     my ($self, $conn) = @_;
  52     my $e = new_editor(xact=>1);
  53     my $incoming = Fieldmapper::acq::edi_message->new;
  54     $incoming->edi("This is content");
  55     $incoming->account(1);
  56     $incoming->remote_file('in/some_file.edi');
  57     $e->create_acq_edi_message($incoming);;
  58     $e->commit;
  59 }
  60 # __PACKAGE__->register_method( method => 'add_a_msg', api_name => 'open-ils.acq.edi.add_a_msg');  # debugging
  61
  62 __PACKAGE__->register_method(
  63         method    => 'retrieve',
  64         api_name  => 'open-ils.acq.edi.retrieve',
  65         signature => {
  66         desc   => 'Fetch incoming message(s) from EDI accounts.  ' .
  67                   'Optional arguments to restrict to one vendor and/or a max number of messages.  ' .
  68                   'Note that messages are not parsed or processed here, just fetched and translated.',
  69         params => [
  70             {desc => 'Authentication token',        type => 'string'},
  71             {desc => 'Vendor ID (undef for "all")', type => 'number'},
  72             {desc => 'Date Inactive Since',         type => 'string'},
  73             {desc => 'Max Messages Retrieved',      type => 'number'}
  74         ],
  75         return => {
  76             desc => 'List of new message IDs (empty if none)',
  77             type => 'array'
  78         }
  79     }
  80 );
  81
  82 sub retrieve_core {
  83     my ($self, $set, $max, $e, $test) = @_;    # $e is a working editor
  84
  85     $e   ||= new_editor();
  86     $set ||= __PACKAGE__->retrieve_vendors($e);
  87
  88     my @return = ();
  89     my $vcount = 0;
  90     foreach my $account (@$set) {
  91         my $count = 0;
  92         my $server;
  93         $logger->info("EDI check for vendor " . ++$vcount . " of " . scalar(@$set) . ": " . $account->host);
  94         unless ($server = __PACKAGE__->remote_account($account)) {   # assignment, not comparison
  95             $logger->err(sprintf "Failed remote account mapping for %s (%s)", $account->host, $account->id);
  96             next;
  97         };
  98 #       my $rf_starter = './';  # default to current dir
  99         if ($account->in_dir) {
 100             if ($account->in_dir =~ /\*+.*\//) {
 101                 $logger->err("EDI in_dir has a slash after an asterisk in value: '" . $account->in_dir . "'.  Skipping account with indeterminate target dir!");
 102                 next;
 103             }
 104 #           $rf_starter = $account->in_dir;
 105 #           $rf_starter =~ s/((\/)?[^\/]*)\*+[^\/]*$//;  # kill up to the first (possible) slash before the asterisk: keep the preceeding static dir
 106 #           $rf_starter .= '/' if $rf_starter or $2;   # recap the dir, or replace leading "/" if there was one (but don't add if empty)
 107         }
 108         my @files    = ($server->ls({remote_file => ($account->in_dir || './')}));
 109         my @ok_files = grep {$_ !~ /\/\.?\.$/ and $_ ne '0'} @files;
 110         $logger->info(sprintf "%s of %s files at %s/%s", scalar(@ok_files), scalar(@files), $account->host, $account->in_dir);
 111         # $server->remote_path(undef);
 112         foreach my $remote_file (@ok_files) {
 113             # my $remote_file = $rf_starter . $_;
 114             my $description = sprintf "%s/%s", $account->host, $remote_file;
 115
 116             # deduplicate vs. acct/filenames already in DB
 117             my $hits = $e->search_acq_edi_message([
 118                 {
 119                     account     => $account->id,
 120                     remote_file => $remote_file,
 121                     status      => {'in' => [qw/ processed /]},     # if it never got processed, go ahead and get the new one (try again)
 122                     # create_time => 'NOW() - 60 DAYS',     # if we wanted to allow filenames to be reused after a certain time
 123                     # ideally we would also use the date from FTP, but that info isn't available via RemoteAccount
 124                 }
 125                 # { flesh => 1, flesh_fields => {...}, }
 126             ]);
 127             if (scalar(@$hits)) {
 128                 $logger->debug("EDI: $remote_file already retrieved.  Skipping");
 129                 print ("EDI: $remote_file already retrieved.  Skipping");
 130                 next;
 131             }
 132
 133             ++$count;
 134             $max and $count > $max and last;
 135             $logger->info(sprintf "%s of %s targets: %s", $count, scalar(@ok_files), $description);
 136             print sprintf "%s of %s targets: %s\n", $count, scalar(@ok_files), $description;
 137             if ($test) {
 138                 push @return, "test_$count";
 139                 next;
 140             }
 141             my $content;
 142             my $io = IO::Scalar->new(\$content);
 143             unless ( $server->get({remote_file => $remote_file, local_file => $io}) ) {
 144                 $logger->error("(S)FTP get($description) failed");
 145                 next;
 146             }
 147             my $incoming = __PACKAGE__->process_retrieval($content, $remote_file, $server, $account->id, $e);
 148 #           $server->delete(remote_file => $_);   # delete remote copies of saved message
 149             push @return, $incoming->id;
 150         }
 151     }
 152     return \@return;
 153 }
 154
 155 # my $in = OpenILS::Application::Acq::EDI->process_retrieval($file_content, $remote_filename, $server, $account_id, $editor);
 156
 157 sub process_retrieval {
 158     my $incoming = Fieldmapper::acq::edi_message->new;
 159     my ($class, $content, $remote, $server, $account_or_id, $e) = @_;
 160     $content or return;
 161     $e ||= new_editor;
 162
 163     my $account = __PACKAGE__->record_activity( $account_or_id, $e );
 164
 165     my $z;  # must predeclare
 166     $z = ( $content =~ s/('UNH\+\d+\+ORDRSP:)0(:96A:UN')/$1D$2/g )
 167         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
 168
 169     $incoming->remote_file($remote);
 170     $incoming->account($account->id);
 171     $incoming->edi($content);
 172     $incoming->message_type(($content =~ /'UNH\+\d+\+(\S{6}):/) ? $1 : 'ORDRSP');   # cheap sniffing, ORDRSP fallback
 173     __PACKAGE__->attempt_translation($incoming);
 174     $e->xact_begin;
 175     $e->create_acq_edi_message($incoming);
 176     $e->xact_commit;
 177     my $res = __PACKAGE__->process_jedi($incoming, $server, $e);
 178     $incoming->status($res ? 'processed' : 'proc_error');
 179     if ($res) {
 180         $e->xact_begin;
 181         $e->update_acq_edi_message($incoming);
 182         $e->xact_commit;
 183     }
 184     return $incoming;
 185 }
 186
 187 # ->send_core
 188 # $account     is a Fieldmapper object for acq.edi_account row
 189 # $messageset  is an arrayref with acq.edi_message.id values
 190 # $e           is optional editor object
 191 sub send_core {
 192     my ($class, $account, $message_ids, $e) = @_;    # $e is a working editor
 193
 194     ($account and scalar @$message_ids) or return;
 195     $e ||= new_editor();
 196
 197     my @messageset = map {$e->retrieve_acq_edi_message($_)} @$message_ids;
 198     my $m_count = scalar(@messageset);
 199     (scalar(@$message_ids) == $m_count) or
 200         $logger->warn(scalar(@$message_ids) - $m_count . " bad IDs passed to send_core (ignored)");
 201
 202     my $log_str = sprintf "EDI send to edi_account %s (%s)", $account->id, $account->host;
 203     $logger->info("$log_str: $m_count message(s)");
 204     $m_count or return;
 205
 206     my $server;
 207     my $server_error;
 208     unless ($server = __PACKAGE__->remote_account($account, 1)) {   # assignment, not comparison
 209         $logger->error("Failed remote account connection for $log_str");
 210         $server_error = 1;
 211     };
 212     foreach (@messageset) {
 213         $_ or next;     # we already warned about bum ids
 214         my ($res, $error);
 215         if ($server_error) {
 216             $error = "Server error: Failed remote account connection for $log_str"; # already told $logger, this is to update object below
 217         } elsif (! $_->edi) {
 218             $logger->error("Message (id " . $_->id. ") for $log_str has no EDI content");
 219             $error = "EDI empty!";
 220         } elsif ($res = $server->put({remote_path => $account->path, content => $_->edi, single_ext => 1})) {
 221             #  This is the successful case!
 222             $_->remote_file($res);
 223             $_->status('complete');
 224             $_->process_time('NOW');    # For outbound files, sending is the end of processing on the EG side.
 225             $logger->info("Sent message (id " . $_->id. ") via $log_str");
 226         } else {
 227             $logger->error("(S)FTP put to $log_str FAILED: " . ($server->error || 'UNKOWNN'));
 228             $error = "put FAILED: " . ($server->error || 'UNKOWNN');
 229         }
 230         if ($error) {
 231             $_->error($error);
 232             $_->error_time('NOW');
 233         }
 234         $logger->info("Calling update_acq_edi_message");
 235         $e->xact_begin;
 236         unless ($e->update_acq_edi_message($_)) {
 237              $logger->error("EDI send_core update_acq_edi_message failed for message object: " . Dumper($_));
 238              OpenILS::Application::Acq::EDI::Translator->debug_file(Dumper($_              ), '/tmp/update_acq_edi_message.FAIL');
 239              OpenILS::Application::Acq::EDI::Translator->debug_file(Dumper($_->to_bare_hash), '/tmp/update_acq_edi_message.FAIL.to_bare_hash');
 240         }
 241         # There's always an update, even if we failed.
 242         $e->xact_commit;
 243         __PACKAGE__->record_activity($account, $e);  # There's always an update, even if we failed.
 244     }
 245     return \@messageset;
 246 }
 247
 248 #  attempt_translation does not touch the DB, just the object.
 249 sub attempt_translation {
 250     my ($class, $edi_message, $to_edi) = @_;
 251     my $tran  = translator();
 252     my $ret   = $to_edi ? $tran->json2edi($edi_message->jedi) : $tran->edi2json($edi_message->edi);
 253 #   $logger->error("json: " . Dumper($json)); # debugging
 254     if (not $ret or (! ref($ret)) or $ret->is_fault) {      # RPC::XML::fault on failure
 255         $edi_message->status('trans_error');
 256         $edi_message->error_time('NOW');
 257         my $pre = "EDI Translator " . ($to_edi ? 'json2edi' : 'edi2json') . " failed";
 258         my $message = ref($ret) ?
 259                       ("$pre, Error " . $ret->code . ": " . __PACKAGE__->nice_string($ret->string)) :
 260                       ("$pre: "                           . __PACKAGE__->nice_string($ret)        ) ;
 261         $edi_message->error($message);
 262         $logger->error(  $message);
 263         return;
 264     }
 265     $edi_message->status('translated');
 266     $edi_message->translate_time('NOW');
 267     if ($to_edi) {
 268         $edi_message->edi($ret->value);    # translator returns an object
 269     } else {
 270         $edi_message->jedi($ret->value);   # translator returns an object
 271     }
 272     return $edi_message;
 273 }
 274
 275 sub retrieve_vendors {
 276     my ($self, $e, $vendor_id, $last_activity) = @_;    # $e is a working editor
 277
 278     $e ||= new_editor();
 279
 280     my $criteria = {'+acqpro' => {active => 't'}};
 281     $criteria->{'+acqpro'}->{id} = $vendor_id if $vendor_id;
 282     return $e->search_acq_edi_account([
 283         $criteria, {
 284             'join' => 'acqpro',
 285             flesh => 1,
 286             flesh_fields => {
 287                 acqedi => ['provider']
 288             }
 289         }
 290     ]);
 291 #   {"id":{"!=":null},"+acqpro":{"active":"t"}}, {"join":"acqpro", "flesh_fields":{"acqedi":["provider"]},"flesh":1}
 292 }
 293
 294 # This is the SRF-exposed call, so it does checkauth
 295
 296 sub retrieve {
 297     my ($self, $conn, $auth, $vendor_id, $last_activity, $max) = @_;
 298
 299     my $e = new_editor(authtoken=>$auth);
 300     unless ($e and $e->checkauth()) {
 301         $logger->warn("checkauth failed for authtoken '$auth'");
 302         return ();
 303     }
 304     # return $e->die_event unless $e->allowed('RECEIVE_PURCHASE_ORDER', $li->purchase_order->ordering_agency);  # add permission here ?
 305
 306     my $set = __PACKAGE__->retrieve_vendors($e, $vendor_id, $last_activity) or return $e->die_event;
 307     return __PACKAGE__->retrieve_core($e, $set, $max);
 308 }
 309
 310
 311 # field_map takes the hashref of vendor data with fields from acq.edi_account and
 312 # maps them to the argument style needed for RemoteAccount.  It also extrapolates
 313 # data from the remote_host string for type and port, when available.
 314
 315 sub field_map {
 316     my $self   = shift;
 317     my $vendor = shift or return;
 318     my $no_override = @_ ? shift : 0;
 319     my %args = ();
 320     $verbose and $logger->warn("vendor: " . Dumper($vendor));
 321     foreach (keys %map) {
 322         $args{$map{$_}} = $vendor->$_ if defined $vendor->$_;
 323     }
 324     unless ($no_override) {
 325         $args{remote_path} = $vendor->in_dir;    # override "path" with "in_dir"
 326     }
 327     my $host = $args{remote_host} || '';
 328     ($host =~ s/^(S?FTP)://i    and $args{type} = uc($1)) or
 329     ($host =~ s/^(SSH|SCP)://i  and $args{type} = 'SCP' ) ;
 330      $host =~ s/:(\d+)$//       and $args{port} = $1;
 331     ($args{remote_host} = $host) =~ s#/+##;
 332     $verbose and $logger->warn("field_map: " . Dumper(\%args));
 333     return %args;
 334 }
 335
 336
 337 # The point of remote_account is to get the RemoteAccount object with args from the DB
 338
 339 sub remote_account {
 340     my ($self, $vendor, $outbound, $e) = @_;
 341
 342     unless (ref($vendor)) {     # It's not a hashref/object.
 343         $vendor or return;      # If in fact it's nothing: abort!
 344                                 # else it's a vendor_id string, so get the full vendor data
 345         $e ||= new_editor();
 346         my $set_of_one = $self->retrieve_vendors($e, $vendor) or return;
 347         $vendor = shift @$set_of_one;
 348     }
 349
 350     return OpenILS::Utils::RemoteAccount->new(
 351         $self->field_map($vendor, $outbound)
 352     );
 353 }
 354
 355 # takes account ID or account Fieldmapper object
 356
 357 sub record_activity {
 358     my ($class, $account_or_id, $e) = @_;
 359     $account_or_id or return;
 360     $e ||= new_editor();
 361     my $account = ref($account_or_id) ? $account_or_id : $e->retrieve_acq_edi_account($account_or_id);
 362     $logger->info("EDI record_activity calling update_acq_edi_account");
 363     $account->last_activity('NOW') or return;
 364     $e->xact_begin;
 365     $e->update_acq_edi_account($account) or $logger->warn("EDI: in record_activity, update_acq_edi_account FAILED");
 366     $e->xact_commit;
 367     return $account;
 368 }
 369
 370 sub nice_string {
 371     my $class = shift;
 372     my $string = shift or return '';
 373     chomp($string);
 374     my $head   = @_ ? shift : 100;
 375     my $tail   = @_ ? shift :  25;
 376     (length($string) < $head + $tail) and return $string;
 377     my $h = substr($string,0,$head);
 378     my $t = substr($string, -1*$tail);
 379     $h =~s/\s*$//o;
 380     $t =~s/\s*$//o;
 381     return "$h ... $t";
 382     # return substr($string,0,$head) . "... " . substr($string, -1*$tail);
 383 }
 384
 385 sub jedi2perl {
 386     my ($class, $jedi) = @_;
 387     $jedi or return;
 388     my $msg = OpenSRF::Utils::JSON->JSON2perl( $jedi );
 389     open (FOO, ">>/tmp/JSON2perl_dump.txt");
 390     print FOO Dumper($msg), "\n\n";
 391     close FOO;
 392     $logger->warn("Dumped JSON2perl to /tmp/JSON2perl_dump.txt");
 393     return $msg;
 394 }
 395
 396 our @datecodes = (35, 359, 17, 191, 69, 76, 75, 79, 85, 74, 84, 223);
 397 our @noop_6063 = (21);
 398
 399 # ->process_jedi($message, $server, $e)
 400 sub process_jedi {
 401     my $class    = shift;
 402     my $message  = shift or return;
 403     my $server   = shift || {};  # context
 404     my $jedi     = ref($message) ? $message->jedi : $message;  # If we got an object, it's an edi_message.  A string is the jedi content itself.
 405     unless ($jedi) {
 406         $logger->warn("EDI process_jedi missing required argument (edi_message object with jedi or jedi scalar)!");
 407         return;
 408     }
 409     my $e = @_ ? shift : new_editor();
 410     my $perl  = __PACKAGE__->jedi2perl($jedi);
 411     my $error = '';
 412     if (ref($message) and not $perl) {
 413         $error = ($message->error || '') . " JSON2perl (jedi2perl) FAILED to convert jedi";
 414     }
 415     elsif (! $perl->{body}) {
 416         $error = "EDI interchange body not found!";
 417     }
 418     elsif (! $perl->{body}->[0]) {
 419         $error = "EDI interchange body not a populated arrayref!";
 420     }
 421     if ($error) {
 422         $logger->warn($error);
 423         $message->error($error);
 424         $message->error_time('NOW');
 425         $e->xact_begin;
 426         $e->udpate_acq_edi_message($message) or $logger->warn("EDI update_acq_edi_message failed! $!");
 427         $e->xact_commit;
 428         return;
 429     }
 430
 431 # Crazy data structure.  Most of the arrays will be 1 element... we think.
 432 # JEDI looks like:
 433 # {'body' => [{'ORDERS' => [['UNH',{'0062' => '4635','S009' => {'0057' => 'EAN008','0051' => 'UN','0052' => 'D','0065' => 'ORDERS', ...
 434 #
 435 # So you might access it like:
 436 #   $obj->{body}->[0]->{ORDERS}->[0]->[0] eq 'UNH'
 437
 438     $logger->info("EDI interchange body has " . scalar(@{$perl->{body}}) . " message(s)");
 439     my @ok_msg_codes = qw/ORDERS OSTRPT/;
 440     my @messages;
 441     my $i = 0;
 442     foreach my $part (@{$perl->{body}}) {
 443         $i++;
 444         unless (ref $part and scalar keys %$part) {
 445             $logger->warn("EDI interchange message $i lacks structure.  Skipping it.");
 446             next;
 447         }
 448         foreach my $key (keys %$part) {
 449             if ($key ne 'ORDRSP') {     # We only do one type for now.  TODO: other types here
 450                 $logger->warn("EDI interchange $i contains unhandled '$key' message.  Ignoring it.");
 451                 next;
 452             }
 453             my $msg = __PACKAGE__->message_object($part->{$key}) or next;
 454             push @messages, $msg;
 455
 456             my $bgm = $msg->xpath('BGM') or $logger->warn("EDI No BGM segment found?!");
 457             my $tag4343 = $msg->xpath('BGM/4343');
 458             my $tag1225 = $msg->xpath('BGM/1225');
 459             if (ref $tag4343) {
 460                 $logger->info(sprintf "EDI $key BGM/4343 Response Type: %s - %s", $tag4343->value, $tag4343->label)
 461             } else {
 462                 $logger->warn("EDI $key BGM/4343 Response Type Code unrecognized"); # next; #?
 463             }
 464             if (ref $tag1225) {
 465                 $logger->info(sprintf "EDI $key BGM/1225 Message Function: %s - %s", $tag1225->value, $tag1225->label);
 466             } else {
 467                 $logger->warn("EDI $key BGM/1225 Message Function Code unrecognized"); # next; #?
 468             }
 469
 470             # TODO: currency check, just to be paranoid
 471             # *should* be unnecessary (vendor should reply in currency we send in ORDERS)
 472             # That begs a policy question: how to handle mismatch?  convert (bad accuracy), reject, or ignore?  I say ignore.
 473
 474             # ALL those codes below are basically some form of (lastest) delivery date/time
 475             # see, e.g.: http://www.stylusstudio.com/edifact/D04B/2005.htm
 476             # The order is the order of definitiveness (first match wins)
 477             # Note: if/when we do serials via EDI, dates (and ranges/periods) will need massive special handling
 478             my @dates;
 479             my $ddate;
 480
 481             foreach my $date ($msg->xpath('delivery_schedule')) {
 482                 my $val_2005 = $date->xpath_value('DTM/2005') or next;
 483                 (grep {$val_2005 eq $_} @datecodes) or next; # no match means some other kind of date we don't care about
 484                 push @dates, $date;
 485             }
 486             if (@dates) {
 487                 DATECODE: foreach my $dcode (@datecodes) {   # now cycle back through hits in order of dcode definitiveness
 488                     foreach my $date (@dates) {
 489                         $date->xpath_value('DTM/2005') == $dcode or next;
 490                         $ddate = $date->xpath_value('DTM/2380') and last DATECODE;
 491                         # TODO: conversion based on format specified in DTM/2379 (best encapsulated in Business::EDI)
 492                     }
 493                 }
 494             }
 495
 496             foreach my $detail ($msg->part('line_detail')) {
 497                 my $eg_line = __PACKAGE__->eg_li($detail, $server, $e) or next;
 498                 my $li_date = $detail->xpath_value('DTM/2380') || $ddate;
 499                 my $price   = $detail->xpath_value('line_price/PRI/5118') || '';
 500                 $detail->expected_recv_time($li_date) if $li_date;
 501                 $detail->estimated_unit_price($price) if $price;
 502                 # $e->search_acq_edi_account([]);
 503                 my $touches = 0;
 504                 my $eg_lids = $e->retrieve_acq_lineitem_detail({lineitem => $eg_line->id}); # should be the same as $eg_line->lineitem_details
 505                 my $lidcount = scalar(@$eg_lids);
 506                 $lidcount == $eg_line->item_count or $logger->warn(
 507                     sprintf "EDI: LI %s itemcount (%d) mismatch, %d LIDs found", $eg_line->id, $eg_line->item_count, $lidcount
 508                 );
 509                 foreach my $qty ($detail->part('all_QTY')) {
 510                     my $ubound   = $qty->xpath_value('6060') or next;   # nothing to do if qty is 0
 511                     my $val_6063 = $qty->xpath_value('6063');
 512                     $ubound > 0 or next; # don't be crazy!
 513                     if (! $val_6063) {
 514                         $logger->warn("EDI: Response for LI " . $eg_line->id . " specifies quantity $ubound with no 6063 code! Contact vendor to resolve.");
 515                         next;
 516                     }
 517
 518                     my $eg_reason = $e->retrieve_acq_cancel_reason(1200 + $val_6063);  # DB populated w/ 6063 keys in 1200's
 519                     if (! $eg_reason) {
 520                         $logger->warn("EDI: Unhandled quantity code '$val_6063' (LI " . $eg_line->id . ") $ubound items unprocessed");
 521                         next;
 522                     } elsif (grep {$val_6063 == $_} @noop_6063) {      # an FYI like "ordered quantity"
 523                         $ubound eq $lidcount
 524                             or $logger->warn("EDI: LI " . $eg_line->id . " -- Vendor says we ordered $ubound, but we have $lidcount LIDs!)");
 525                         next;
 526                     }
 527                     # elsif ($val_6063 == 83) { # backorder
 528                    #} elsif ($val_6063 == 85) { # cancel
 529                    #} elsif ($val_6063 == 12 or $val_6063 == 57 or $val_6063 == 84 or $val_6063 == 118) {
 530                             # despatched, in transit, urgent delivery, or quantity manifested
 531                    #}
 532                     if ($touches >= $lidcount) {
 533                         $logger->warn("EDI: LI "  . $eg_line->id . ", We already updated $touches of $lidcount LIDS, " .
 534                                       "but message wants QTY $ubound more set to " . $eg_reason->label . ".  Ignoring!");
 535                         next;
 536                     }
 537                     $e->xact_begin;
 538                     foreach (1 .. $ubound) {
 539                         my $eg_lid = shift @$eg_lids or $logger->warn("EDI: Used up all $lidcount LIDs!  Ignoring extra status " . $eg_reason->label);
 540                         $eg_lid or next;
 541                         $logger->debug(sprintf "Updating LID %s to %s", $eg_lid->id, $eg_reason->label);
 542                         $eg_lid->cancel_reason($eg_reason->id);
 543                         $e->update_acq_lineitem_detail($eg_lid);
 544                         $touches++;
 545                     }
 546                     $e->xact_commit;
 547                     if ($ubound == $eg_line->item_count) {
 548                         $eg_line->cancel_reason($eg_reason->id);    # if ALL the items have the same cancel_reason, the PO gets it too
 549                     }
 550                 }
 551                 $e->xact_begin;
 552                 $e->update_acq_lineitem($eg_line) or $logger->warn("EDI: update_acq_lineitem FAILED");
 553                 $e->xact_commit;
 554                 # print STDERR "Lineitem update: ", Dumper($eg_line);
 555             }
 556         }
 557     }
 558     return \@messages;
 559 }
 560
 561 # returns message object if processing should continue
 562 # returns false/undef value if processing should abort
 563
 564 sub message_object {
 565     my $class = shift;
 566     my $body  = shift or return;
 567     my $key   = shift if @_;
 568     my $keystring = $key || 'UNSPECIFIED';
 569
 570     my $msg = Business::EDI::Message->new($body);
 571     unless ($msg) {
 572         $logger->error("EDI interchange message: $keystring body failed Business::EDI constructor. Skipping it.");
 573         return;
 574     }
 575     $key = $msg->code if ! $key;  # Now we set the key for reference if it wasn't specified
 576     my $val_0065 = $msg->xpath_value('UNH/S009/0065') || '';
 577     unless ($val_0065 eq $key) {
 578         $logger->error("EDI $key UNH/S009/0065 ('$val_0065') conflicts w/ message type $key.  Aborting");
 579         return;
 580     }
 581     my $val_0051 = $msg->xpath_value('UNH/S009/0051') || '';
 582     unless ($val_0051 eq 'UN') {
 583         $logger->warn("EDI $key UNH/S009/0051 designates '$val_0051', not 'UN' as controlling agency.  Attempting to process anyway");
 584     }
 585     my $val_0054 = $msg->xpath_value('UNH/S009/0054') || '';
 586     if ($val_0054) {
 587         $logger->info("EDI $key UNH/S009/0054 uses Spec revision version '$val_0054'");
 588         # Possible Spec Version limitation
 589         # my $yy = $tag_0054 ? substr($val_0054,0,2) : '';
 590         # unless ($yy eq '00' or $yy > 94 ...) {
 591         #     $logger->warn("EDI $key UNH/S009/0051 Spec revision version '$val_0054' not supported");
 592         # }
 593     } else {
 594         $logger->warn("EDI $key UNH/S009/0054 does not reference a known Spec revision version");
 595     }
 596     return $msg;
 597 }
 598
 599 =head2 ->eg_li($lineitem_object, [$server, $editor])
 600
 601 my $line_item = OpenILS::Application::Acq::EDI->eg_li($edi_line, $server, $e);
 602
 603 $server is a RemoteAccount object
 604
 605 Updates:
 606  acq.lineitem.estimated_unit_price,
 607  acq.lineitem.state (dependent on mapping codes),
 608  acq.lineitem.expected_recv_time,
 609  acq.lineitem.edit_time (consequently)
 610
 611 =cut
 612
 613 sub eg_li {
 614     my ($class, $line, $server, $e) = @_;
 615     $line or return;
 616     $e ||= new_editor();
 617
 618     my $id;
 619     # my $rff      = $line->part('line_reference/RFF') or $logger->warn("EDI ORDRSP line_detail/RFF missing!");
 620     my $val_1153 = $line->xpath_value('line_reference/RFF/1153') || '';
 621     my $val_1154 = $line->xpath_value('line_reference/RFF/1154') || '';
 622     my $val_1082 = $line->xpath_value('LIN/1082') || '';
 623
 624     my @po_nums;
 625
 626     $val_1154 =~ s#^(.*)\/##;   # Many sources send the ID as 'order_ID/LI_ID'
 627     $1 and push @po_nums, $1;
 628     $val_1082 =~ s#^(.*)\/##;   # Many sources send the ID as 'order_ID/LI_ID'
 629     $1 and push @po_nums, $1;
 630
 631     # TODO: possible check of po_nums
 632     # now do a lot of checking
 633
 634     if ($val_1153 eq 'LI') {
 635         $id = $val_1154 or $logger->warn("EDI ORDRSP RFF/1154 reference to LI empty.  Attempting failover to LIN/1082");
 636     } else {
 637         $logger->warn("EDI ORDRSP RFF/1153 unexpected value ('$val_1153', not 'LI').  Attempting failover to LIN/1082");
 638     }
 639
 640     if ($id and $val_1082 and $val_1082 ne $id) {
 641         $logger->warn("EDI ORDRSP LIN/1082 Line Item ID mismatch ($id vs. $val_1082): cannot target update");
 642         return;
 643     }
 644     $id ||= $val_1082 || '';
 645     print STDERR "EDI retrieve/update lineitem $id\n";
 646
 647     my $li = OpenILS::Application::Acq::Lineitem::retrieve_lineitem_impl($e, $id, {
 648         flesh_li_details => 1,
 649         clear_marc       => 1,
 650     }, 1); # Could send more {options}.  The 1 is for no_auth.
 651
 652     if (! $li or ref($li) ne 'Fieldmapper::acq::lineitem') {
 653         $logger->error("EDI failed to retrieve lineitem by id '$id' for server " . ($server->{remote_host} || $server->{host} || Dumper($server)));
 654         return;
 655     }
 656     unless ((! $server) or (! $server->provider)) {     # but here we want $server to be acq.edi_account instead of RemoteAccount/
 657         if ($server->provider != $li->provider) {
 658             # links go both ways: acq.provider.edi_default and acq.edi_account.provider
 659             $logger->info("EDI acct provider (" . $server->provider. ") doesn't match lineitem provider("
 660                             . $li->provider . ").  Checking acq.provider.edi_default...");
 661             my $provider = $e->retrieve_acq_provider($li->provider);
 662             if ($provider->edi_default != $server->id) {
 663                 $logger->error(sprintf "EDI provider/acct %s/%s (%s) is blocked from updating lineitem $id belonging to provider/edi_default %s/%s",
 664                                 $server->provider, $server->id, $server->label, $li->provider, $provider->edi_default);
 665                 return;
 666             }
 667         }
 668     }
 669
 670     my $key = $line->xpath('LIN/1229') or $logger->warn("EDI LIN/1229 Action Code missing!");
 671     $key or return;
 672
 673     my $eg_reason = $e->retrieve_acq_cancel_reason(1000 + $key->value);  # DB populated w/ spec keys in 1000's
 674     $eg_reason or $logger->warn(sprintf "EDI LIN/1229 Action Code '%s' (%s) not recognized in acq.cancel_reason", $key->value, $key->label);
 675     $eg_reason or return;
 676
 677     $li->cancel_reason($eg_reason->id);
 678     unless ($eg_reason->keep_debits) {
 679         $logger->warn("EDI LIN/1229 Action Code '%s' (%s) has keep_debits=0", $key->value, $key->label);
 680     }
 681
 682     my $new_price = $line->xpath_value("PRI/5118");
 683     $li->estimated_unit_price($new_price) if $new_price;
 684
 685     return $li;
 686 }
 687
 688 # caching not needed for now (edi_fetcher is asynchronous)
 689 # sub get_reason {
 690 #     my ($class, $key, $e) = @_;
 691 #     $reasons->{$key} and return $reasons->{$key};
 692 #     $e ||= new_editor();
 693 #     $reasons->{$key} = $e->retrieve_acq_cancel_reason($key);
 694 #     return $reasons->{$key};
 695 # }
 696
 697 1;
 698
 699 __END__
 700
 701 Example JSON data.
 702
 703 Note the pseudo-hash 2-element arrays.
 704
 705 [
 706   'SG26',
 707   [
 708     [
 709       'LIN',
 710       {
 711         '1229' => '5',
 712         '1082' => 1,
 713         'C212' => {
 714           '7140' => '9780446360272',
 715           '7143' => 'EN'
 716         }
 717       }
 718     ],
 719     [
 720       'IMD',
 721       {
 722         '7081' => 'BST',
 723         '7077' => 'F',
 724         'C273' => {
 725           '7008' => [
 726             'NOT APPLIC WEBSTERS NEW WORLD THESA'
 727           ]
 728         }
 729       }
 730     ],
 731     [
 732       'QTY',
 733       {
 734         'C186' => {
 735           '6063' => '21',
 736           '6060' => 10
 737         }
 738       }
 739     ],
 740     [
 741       'QTY',
 742       {
 743         'C186' => {
 744           '6063' => '12',
 745           '6060' => 10
 746         }
 747       }
 748     ],
 749     [
 750       'QTY',
 751       {
 752         'C186' => {
 753           '6063' => '85',
 754           '6060' => 0
 755         }
 756       }
 757     ],
 758     [
 759       'FTX',
 760       {
 761         '4451' => 'LIN',
 762         'C107' => {
 763           '4441' => '01',
 764           '3055' => '28',
 765           '1131' => '8B'
 766         }
 767       }
 768     ],
 769     [
 770       'SG30',
 771       [
 772         [
 773           'PRI',
 774           {
 775             'C509' => {
 776               '5118' => '4.5',
 777               '5387' => 'SRP',
 778               '5125' => 'AAB'
 779             }
 780           }
 781         ]
 782       ]
 783     ],
 784     [
 785       'SG31',
 786       [
 787         [
 788           'RFF',
 789           {
 790             'C506' => {
 791               '1154' => '8/1',
 792               '1153' => 'LI'
 793             }
 794           }
 795         ]
 796       ]
 797     ]
 798   ]
 799 ],
 800