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