From 6f6f8f6a00c8b444681c131e4da9dd4236ac7570 Mon Sep 17 00:00:00 2001 From: Bill Erickson Date: Fri, 28 Sep 2012 10:34:28 -0400 Subject: [PATCH] Custom/local EDI reader module for ORDRSP and INVOIC (etc) Provides a new perl module (OpenILS::Utils::EDIReader) for reading inbound EDI messages and producing data structures more easily understood by the ACQ code. Through this, extraction of EDI data is focused in one module instead of spread through various layers. EDIReader is a small, purpose built module focusing solely on extracting the needed EDI data and is not meant to be a general purpose EDI library. * Updates edi_fetcher and the ORDRSP and INVOIC handling code to use the new libs. * Removes Business::EDI Evergreen dependency, since it's no longer used (and is quite large). Signed-off-by: Bill Erickson Signed-off-by: Lebbeous Fogle-Weekley --- Open-ILS/src/extras/Makefile.install | 1 - Open-ILS/src/perlmods/Build.PL | 1 - .../lib/OpenILS/Application/Acq/EDI.pm | 850 ++++++------------ .../perlmods/lib/OpenILS/Utils/EDIReader.pm | 158 ++++ Open-ILS/src/perlmods/t/14-OpenILS-Utils.t | 13 +- Open-ILS/src/support-scripts/edi_fetcher.pl | 3 +- .../test-scripts/edi_reader.pl | 9 + 7 files changed, 432 insertions(+), 603 deletions(-) create mode 100644 Open-ILS/src/perlmods/lib/OpenILS/Utils/EDIReader.pm create mode 100755 Open-ILS/src/support-scripts/test-scripts/edi_reader.pl diff --git a/Open-ILS/src/extras/Makefile.install b/Open-ILS/src/extras/Makefile.install index b3a0953de0..60c8d66862 100644 --- a/Open-ILS/src/extras/Makefile.install +++ b/Open-ILS/src/extras/Makefile.install @@ -215,7 +215,6 @@ DEB_APACHE_DISMODS = \ # Chronically unpackaged CPAN modules CPAN_MODULES = \ - Business::EDI \ Business::OnlinePayment::PayPal \ Library::CallNumber::LC \ Net::Z3950::Simple2ZOOM \ diff --git a/Open-ILS/src/perlmods/Build.PL b/Open-ILS/src/perlmods/Build.PL index 00b0a26d09..e2bb24e5bb 100644 --- a/Open-ILS/src/perlmods/Build.PL +++ b/Open-ILS/src/perlmods/Build.PL @@ -16,7 +16,6 @@ my $build = Module::Build->new( 'APR::Const' => '0', 'APR::Table' => '0', 'Business::CreditCard' => '0', - 'Business::EDI' => '0', 'Business::ISBN' => '0', 'Business::OnlinePayment' => '0', 'Carp' => '0', diff --git a/Open-ILS/src/perlmods/lib/OpenILS/Application/Acq/EDI.pm b/Open-ILS/src/perlmods/lib/OpenILS/Application/Acq/EDI.pm index 6e9ce69d0d..1fd06399d4 100644 --- a/Open-ILS/src/perlmods/lib/OpenILS/Application/Acq/EDI.pm +++ b/Open-ILS/src/perlmods/lib/OpenILS/Application/Acq/EDI.pm @@ -16,8 +16,7 @@ use OpenILS::Utils::CStoreEditor q/new_editor/; use OpenILS::Utils::Fieldmapper; use OpenILS::Application::Acq::EDI::Translator; -use OpenILS::Utils::LooseEDI; -use Business::EDI; +use OpenILS::Utils::EDIReader; use Data::Dumper; our $verbose = 0; @@ -146,54 +145,75 @@ sub retrieve_core { $logger->error("(S)FTP get($description) failed"); next; } - my $incoming = __PACKAGE__->process_retrieval($content, $remote_file, $server, $account->id, $e); + my $incoming = __PACKAGE__->process_retrieval($content, $remote_file, $server, $account->id); # $server->delete(remote_file => $_); # delete remote copies of saved message - push @return, $incoming->id; + push @return, @$incoming; } } return \@return; } -# my $in = OpenILS::Application::Acq::EDI->process_retrieval($file_content, $remote_filename, $server, $account_id, $editor); +# my $msg_ids = OpenILS::Application::Acq::EDI->process_retrieval( +# $file_content, $remote_filename, $server, $account_id, $editor); sub process_retrieval { - my $incoming = Fieldmapper::acq::edi_message->new; - my ($class, $content, $remote, $server, $account_or_id, $e) = @_; + my ($class, $content, $filename, $server, $account_or_id) = @_; $content or return; - $e ||= new_editor; - my $account = __PACKAGE__->record_activity( $account_or_id, $e ); + my $e = new_editor; + my $account = __PACKAGE__->record_activity($account_or_id, $e); - my $z; # must predeclare - $z = ( $content =~ s/('UNH\+\d+\+ORDRSP:)0(:96A:UN')/$1D$2/g ) - 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 + # a single EDI blob can contain multiple messages + # create one edi_message per included message - $incoming->remote_file($remote); - $incoming->account($account->id); - $incoming->edi($content); - $incoming->message_type(($content =~ /'UNH\+\d+\+(\S{6}):/) ? $1 : 'ORDRSP'); # cheap sniffing, ORDRSP fallback - __PACKAGE__->attempt_translation($incoming); - $e->xact_begin; - $e->create_acq_edi_message($incoming); - $e->xact_commit; - # refresh: send process_jedi the updated row - $e->xact_begin; + my $messages = OpenILS::Utils::EDIReader->new->read($content); + my @return; + + for my $msg_hash (@$messages) { + + my $incoming = Fieldmapper::acq::edi_message->new; + + $incoming->remote_file($filename); + $incoming->account($account->id); + $incoming->edi($content); + $incoming->message_type($msg_hash->{message_type}); + $incoming->jedi(OpenSRF::Utils::JSON->perl2JSON($msg_hash)); # jedi-2.0 + $incoming->status('translated'); + $incoming->translate_time('NOW'); + + if ($msg_hash->{purchase_order}) { + $logger->info("EDI: processing message for PO " . $msg_hash->{purchase_order}); + $incoming->purchase_order($msg_hash->{purchase_order}); + } + + $e->xact_begin; + unless($e->create_acq_edi_message($incoming)) { + $logger->error("EDI: unable to create edi_message " . $e->die_event); + next; + } + # refresh to pickup create_date, etc. + $incoming = $e->retrieve_acq_edi_message($incoming->id); + $e->xact_commit; + + # since there's a fair chance of unhandled problems + # cropping up, particularly with new vendors, wrap w/ eval. + eval { $class->process_parsed_msg($account, $incoming, $msg_hash) }; - # LFW: I really don't understand in what sense you could call this - # message 'outgoing', except from the vendor's point of view? - my $outgoing = $e->retrieve_acq_edi_message($incoming->id); # refresh again! - $e->xact_rollback; - my $res = __PACKAGE__->process_jedi($outgoing, $server, $account, $e); - $e->xact_begin; - $outgoing = $e->retrieve_acq_edi_message($incoming->id); # refresh again! - $e->xact_rollback; - $outgoing->status($res ? 'processed' : 'proc_error'); - if ($res) { $e->xact_begin; - $e->update_acq_edi_message($outgoing); + $incoming = $e->retrieve_acq_edi_message($incoming->id); + if ($@) { + $incoming->status('proc_error'); + $incoming->error($@); + } else { + $incoming->status('processed'); + } + $e->update_acq_edi_message($incoming); $e->xact_commit; + + push(@return, $incoming->id); } - return $outgoing; + + return \@return; } # ->send_core @@ -265,6 +285,7 @@ sub attempt_translation { my $tran = translator(); my $ret = $to_edi ? $tran->json2edi($edi_message->jedi) : $tran->edi2json($edi_message->edi); # $logger->error("json: " . Dumper($json)); # debugging + if (not $ret or (! ref($ret)) or $ret->is_fault) { # RPC::XML::fault on failure $edi_message->status('trans_error'); $edi_message->error_time('NOW'); @@ -273,11 +294,13 @@ sub attempt_translation { ("$pre, Error " . $ret->code . ": " . __PACKAGE__->nice_string($ret->string)) : ("$pre: " . __PACKAGE__->nice_string($ret) ) ; $edi_message->error($message); - $logger->error( $message); + $logger->error($message); return; } + $edi_message->status('translated'); $edi_message->translate_time('NOW'); + if ($to_edi) { $edi_message->edi($ret->value); # translator returns an object } else { @@ -396,213 +419,147 @@ sub nice_string { # return substr($string,0,$head) . "... " . substr($string, -1*$tail); } -sub jedi2perl { - my ($class, $jedi) = @_; - $jedi or return; - my $msg = OpenSRF::Utils::JSON->JSON2perl( $jedi ); - open (FOO, ">>/tmp/JSON2perl_dump.txt"); - print FOO Dumper($msg), "\n\n"; - close FOO; - $logger->warn("Dumped JSON2perl to /tmp/JSON2perl_dump.txt"); - return $msg; -} +# parts of this process can fail without the entire +# thing failing. If a catastrophic error occurs, +# it will occur via die. +sub process_parsed_msg { + my ($class, $account, $incoming, $msg_hash) = @_; -our @datecodes = (35, 359, 17, 191, 69, 76, 75, 79, 85, 74, 84, 223); -our @noop_6063 = (21); - -# ->process_jedi($message, $server, $remote, $e) -# $message is an edi_message object -# -# This method has lots of logic to process ORDRSP messages (and theoretically -# OSTRPT messages) and to make changes based on those to EG acq objects. -# If it gets an INVOIC message, it hands that off to -# create_acq_invoice_from_edi() following a new model (this code all wants -# cleaned-up/refactored). -# -# This method currently returns an array of message objects, but no callers use -# that except in a boolean evaluation to test for success. So don't count on -# that array being there or containing anything specific in the future: it -# might get changed. -sub process_jedi { - my ($class, $message, $server, $remote, $e) = @_; - $message or return; - $server ||= {}; # context - $remote ||= {}; # context - $e ||= new_editor; - my $jedi; - unless (ref($message) and $jedi = $message->jedi) { # assignment, not comparison - $logger->warn("EDI process_jedi missing required argument (edi_message object with jedi)!"); - return; - } - my $perl = __PACKAGE__->jedi2perl($jedi); - my $error = ''; - if (ref($message) and not $perl) { - $error = ($message->error || '') . " JSON2perl (jedi2perl) FAILED to convert jedi"; - } - elsif (! $perl->{body}) { - $error = "EDI interchange body not found!"; - } - elsif (! $perl->{body}->[0]) { - $error = "EDI interchange body not a populated arrayref!"; - } - if ($error) { - $logger->warn($error); - $message->error($error); - $message->error_time('NOW'); - $e->xact_begin; - $e->update_acq_edi_message($message) or $logger->warn("EDI update_acq_edi_message failed! $!"); - $e->xact_commit; - return; + if ($incoming->message_type eq 'INVOIC') { + return $class->create_acq_invoice_from_edi( + $msg_hash, $account->provider, $incoming); } -# Crazy data structure. Most of the arrays will be 1 element... we think. -# JEDI looks like: -# {'body' => [{'ORDERS' => [['UNH',{'0062' => '4635','S009' => {'0057' => 'EAN008','0051' => 'UN','0052' => 'D','0065' => 'ORDERS', ... -# -# So you might access it like: -# $obj->{body}->[0]->{ORDERS}->[0]->[0] eq 'UNH' - - $logger->info("EDI interchange body has " . scalar(@{$perl->{body}}) . " message(s)"); - my @ok_msg_codes = qw/ORDRSP OSTRPT INVOIC/; - my @messages; - my $i = 0; - foreach my $part (@{$perl->{body}}) { - $i++; - unless (ref $part and scalar keys %$part) { - $logger->warn("EDI interchange message $i lacks structure. Skipping it."); + # ORDRSP + for my $li_hash (@{$msg_hash->{lineitems}}) { + my $e = new_editor(xact => 1); + + my $li_id = $li_hash->{id}; + my $li = $e->retrieve_acq_lineitem($li_id); + + if (!$li) { + $logger->error("EDI: reqest for invalid lineitem ID '$li_id'"); + $e->rollback; next; } - foreach my $key (keys %$part) { - if (! grep {$_ eq $key} @ok_msg_codes) { # We only do one type for now. TODO: other types here - $logger->warn("EDI interchange $i contains unhandled '$key' message. Ignoring it."); + + if ($li_hash->{expected_date}) { + my ($y, $m, $d) = $li_hash->{expected_date} =~ /^(\d{4})(\d{2})(\d{2})/g; + my $recv_time = $y; + $recv_time .= "-$m" if $m; + $recv_time .= "-$d" if $d; + $li->expected_recv_time($recv_time); + } + + $li->estimated_unit_price($li_hash->{unit_price}); + + if (not $incoming->purchase_order) { + # PO should come from the EDI message, but if not... + + # fetch the latest copy + $incoming = $e->retrieve_acq_edi_message($incoming->id); + $incoming->purchase_order($li->purchase_order); + + unless($e->update_acq_edi_message($incoming)) { + $logger->error("EDI: unable to update edi_message " . $e->die_event); next; } - if ($key eq 'INVOIC') { - # XXX TODO Maybe subclass O::U::LooseEDI::Message as - # something like OpenILS::Acq::{VendorInvoice,OrderReponse}, - # each one knowing how to read itself and update EG acq - # objects (not under OpenILS::Application perhaps). - my $invoice_message = - new OpenILS::Utils::LooseEDI::Message($part->{$key}); - push @messages, $invoice_message if - $class->create_acq_invoice_from_edi( - $e, $invoice_message, $remote->provider, $message - ); + } + + my $lids = $e->json_query({ + select => {acqlid => ['id']}, + from => 'acqlid', + where => { lineitem => $li->id } + }); + + my @lids = map { $_->{id} } @$lids; + my $lid_count = scalar(@lids); + my $lids_covered = 0; + my $lids_touched = 0; + + for my $qty (@{$li_hash->{quantities}}) { + + my $qty_count = $qty->{quantity} or next; + my $qty_code = $qty->{code}; + + if (!$qty_code) { + $logger->warn("EDI: Response for LI $li_id specifies quantity ". + "$qty_count with no 6063 code! Contact vendor to resolve."); next; } - my $msg = __PACKAGE__->message_object($part->{$key}) or next; - push @messages, $msg; + $logger->info("EDI: LI $li_id processing quantity count=$qty_count / code=$qty_code"); - my $bgm = $msg->xpath('BGM') or $logger->warn("EDI No BGM segment found?!"); - my $tag4343 = $msg->xpath('BGM/4343'); - my $tag1225 = $msg->xpath('BGM/1225'); - if (ref $tag4343) { - $logger->info(sprintf "EDI $key BGM/4343 Response Type: %s - %s", $tag4343->value, $tag4343->label) - } else { - $logger->warn("EDI $key BGM/4343 Response Type Code unrecognized"); # next; #? - } - if (ref $tag1225) { - $logger->info(sprintf "EDI $key BGM/1225 Message Function: %s - %s", $tag1225->value, $tag1225->label); - } else { - $logger->warn("EDI $key BGM/1225 Message Function Code unrecognized"); # next; #? + if ($qty_code eq '21') { # "ordered quantity" + $logger->info("EDI: LI $li_id -- vendor confirms $qty_count ordered"); + $logger->warn("EDI: LI $li_id -- order count $qty_count ". + "does not match LID count $lid_count") unless $qty_count == $lid_count; + next; } - # TODO: currency check, just to be paranoid - # *should* be unnecessary (vendor should reply in currency we send in ORDERS) - # That begs a policy question: how to handle mismatch? convert (bad accuracy), reject, or ignore? I say ignore. - - # ALL those codes below are basically some form of (lastest) delivery date/time - # see, e.g.: http://www.stylusstudio.com/edifact/D04B/2005.htm - # The order is the order of definitiveness (first match wins) - # Note: if/when we do serials via EDI, dates (and ranges/periods) will need massive special handling - my @dates; - my $ddate; - - foreach my $date ($msg->xpath('delivery_schedule')) { - my $val_2005 = $date->xpath_value('DTM/2005') or next; - (grep {$val_2005 eq $_} @datecodes) or next; # no match means some other kind of date we don't care about - push @dates, $date; - } - if (@dates) { - DATECODE: foreach my $dcode (@datecodes) { # now cycle back through hits in order of dcode definitiveness - foreach my $date (@dates) { - $date->xpath_value('DTM/2005') == $dcode or next; - $ddate = $date->xpath_value('DTM/2380') and last DATECODE; - # TODO: conversion based on format specified in DTM/2379 (best encapsulated in Business::EDI) - } - } + $lids_covered += $qty_count; + + if ($qty_code eq '12') { + $logger->info("EDI: LI $li_id -- vendor dispatched $qty_count"); + next; + + } elsif ($qty_code eq '57') { + $logger->info("EDI: LI $li_id -- $qty_count in transit"); + next; } - foreach my $detail ($msg->part('line_detail')) { - my $eg_line = __PACKAGE__->eg_li($detail, $remote, $server->{remote_host}, $e) or next; - my $li_date = $detail->xpath_value('DTM/2380') || $ddate; - my $price = $detail->xpath_value('line_price/PRI/5118') || ''; - $eg_line->expected_recv_time($li_date) if $li_date; - $eg_line->estimated_unit_price($price) if $price; - if (not $message->purchase_order) { # first good lineitem sets the message PO link - $message->purchase_order($eg_line->purchase_order); # EG $message object NOT Business::EDI $msg object - $e->xact_begin; - $e->update_acq_edi_message($message) or $logger->warn("EDI update_acq_edi_message (for PO number) failed! $!"); - $e->xact_commit; + # 84: urgent delivery + # 118: quantity manifested + # ... + + # ------------------------------------------------------------------------- + # All of the remaining quantity types require that we apply a cancel_reason + # DB populated w/ 6063 keys in 1200's + + my $eg_reason = $e->retrieve_acq_cancel_reason(1200 + $qty_code); + + if (!$eg_reason) { + $logger->warn("EDI: Unhandled quantity qty_code '$qty_code' ". + "for li $li_id. $qty_count items unprocessed"); + next; + } + + my $break = 0; + foreach (1 .. $qty_count) { + + my $lid_id = shift @lids; + if (!$lid_id) { + $logger->warn("EDI: Used up all $lid_count LIDs. ". + "Ignoring extra status '" . $eg_reason->label . "'"); + last; } - # $e->search_acq_edi_account([]); - my $touches = 0; - my $eg_lids = $e->search_acq_lineitem_detail({lineitem => $eg_line->id}); # should be the same as $eg_line->lineitem_details - my $lidcount = scalar(@$eg_lids); - $lidcount == $eg_line->item_count or $logger->warn( - sprintf "EDI: LI %s itemcount (%d) mismatch, %d LIDs found", $eg_line->id, $eg_line->item_count, $lidcount - ); - foreach my $qty ($detail->part('all_QTY')) { - my $ubound = $qty->xpath_value('6060') or next; # nothing to do if qty is 0 - my $val_6063 = $qty->xpath_value('6063'); - $ubound > 0 or next; # don't be crazy! - if (! $val_6063) { - $logger->warn("EDI: Response for LI " . $eg_line->id . " specifies quantity $ubound with no 6063 code! Contact vendor to resolve."); - next; - } - - my $eg_reason = $e->retrieve_acq_cancel_reason(1200 + $val_6063); # DB populated w/ 6063 keys in 1200's - if (! $eg_reason) { - $logger->warn("EDI: Unhandled quantity code '$val_6063' (LI " . $eg_line->id . ") $ubound items unprocessed"); - next; - } elsif (grep {$val_6063 == $_} @noop_6063) { # an FYI like "ordered quantity" - $ubound eq $lidcount - or $logger->warn("EDI: LI " . $eg_line->id . " -- Vendor says we ordered $ubound, but we have $lidcount LIDs!)"); - next; - } - # elsif ($val_6063 == 83) { # backorder - #} elsif ($val_6063 == 85) { # cancel - #} elsif ($val_6063 == 12 or $val_6063 == 57 or $val_6063 == 84 or $val_6063 == 118) { - # despatched, in transit, urgent delivery, or quantity manifested - #} - if ($touches >= $lidcount) { - $logger->warn("EDI: LI " . $eg_line->id . ", We already updated $touches of $lidcount LIDS, " . - "but message wants QTY $ubound more set to " . $eg_reason->label . ". Ignoring!"); - next; - } - $e->xact_begin; - foreach (1 .. $ubound) { - my $eg_lid = shift @$eg_lids or $logger->warn("EDI: Used up all $lidcount LIDs! Ignoring extra status " . $eg_reason->label); - $eg_lid or next; - $logger->debug(sprintf "Updating LID %s to %s", $eg_lid->id, $eg_reason->label); - $eg_lid->cancel_reason($eg_reason->id); - $e->update_acq_lineitem_detail($eg_lid); - $touches++; - } - $e->xact_commit; - if ($ubound == $eg_line->item_count) { - $eg_line->cancel_reason($eg_reason->id); # if ALL the items have the same cancel_reason, the PO gets it too - } + + my $lid = $e->retrieve_acq_lineitem_detail($lid_id); + $lid->cancel_reason($eg_reason->id); + $e->update_acq_lineitem_detail($lid); + $lids_touched++; + + # if ALL the items have the same cancel_reason, the LI gets it too + $li->cancel_reason($eg_reason->id) if $qty_count == $lid_count; + + $li->edit_time('now'); + unless ($e->update_acq_lineitem($li)) { + $logger->error("EDI: update_acq_lineitem failed " . $e->die_event); + $break = 1; + last; } - $eg_line->edit_time('NOW'); # TODO: have this field automatically updated via ON UPDATE trigger. - $e->xact_begin; - $e->update_acq_lineitem($eg_line) or $logger->warn("EDI: update_acq_lineitem FAILED"); - $e->xact_commit; - # print STDERR "Lineitem update: ", Dumper($eg_line); } + + # non-recoverable transaction error + # note in this case the commit below will be a silent no-op + last if $break; } + + # LI and LIDs updated, let's wrap this one up. + $e->commit; + + $logger->info("EDI LI $li_id -- $lids_covered LIDs mentioned; ". + "$lids_touched LIDs had cancel_reason's applied"); } - return \@messages; } @@ -611,11 +568,13 @@ sub process_jedi { # process_jedi(). # Return boolean success indicator. sub create_acq_invoice_from_edi { - my ($class, $e, $invoice, $provider, $message) = @_; - # $invoice is O::U::LooseEDI::Message, representing the EDI invoice message. + my ($class, $invoice, $provider, $message) = @_; + # $invoice is O::U::EDIReader hash # $provider is only a pkey # $message is Fieldmapper::acq::edi_message + my $e = new_editor(); + my $log_prefix = "create_acq_invoice_from_edi(..., id . ">): "; @@ -626,20 +585,16 @@ sub create_acq_invoice_from_edi { # distinguish provider and shipper? $eg_inv->recv_method("EDI"); - # Find the buyer's identifier in the invoice. - my $buyer_san; - foreach (@{$invoice->{SG2}}) { - my $nad = $_->{NAD}[0]; - if ($nad->{3035} eq 'BY' and $nad->{C082}{3055} eq '91') { - $buyer_san = $nad->{C082}{3039}; - } - } + my $buyer_san = $invoice->{buyer_san}; if (not $buyer_san) { $logger->error($log_prefix . "could not find buyer SAN in INVOIC"); return 0; } + # some vendors encode the SAN as "$SAN $vendcode" + $buyer_san =~ s/\s.*//g; + # Find the matching org unit based on SAN via 'aoa' table. my $addrs = $e->search_actor_org_address({valid => "t", san => $buyer_san}); @@ -655,130 +610,61 @@ sub create_acq_invoice_from_edi { # XXX Should we verify that this matches PO ordering agency later? $eg_inv->receiver($addrs->[0]->org_unit); - try { - $eg_inv->inv_ident($invoice->{BGM}[0]{1004}); - } catch Error with { + $eg_inv->inv_ident($invoice->{invoice_ident}); + + if (!$eg_inv->inv_ident) { $logger->error( $log_prefix . "no invoice ID # in INVOIC message; " . shift ); - }; - return 0 unless $eg_inv->inv_ident; + return 0; + } my @eg_inv_entries; - # The invoice message will have once instance of segment group 25 - # per lineitem. - foreach my $sg25 (@{ $invoice->{SG25} }) { - # quantity - my $c186 = $sg25->{QTY}[0]{C186}; - my $quantity = $c186->{6060}; - # $c186->{6411} will probably say 'PCE', but need we check it? - - # identifiers (typically ISBN for us, and we may not need these) - my @identifiers = (); - # from LIN... - try { - my $c212 = $sg25->{LIN}[0]{C212}; - push @identifiers, [$c212->{7143}, $c212->{7140}] if - $c212 and ref $c212 eq 'HASH'; - } catch Error with { - # move on - }; - - # from PIA... - try { - foreach my $pia (@{ $sg25->{PIA} }) { - foreach my $h (@{$pia->{C212}}) { - push @identifiers, [$h->{7143}, $h->{7140}]; - } - } - } catch Error with { - # move on - }; - - # @identifiers now contains lists of, say, - # ['IB', '0786222735'], # ISBN 10 - # ['EN','9780786222735'] # ISBN 13 - - # Segment Group 26-47 are all descendants of SG25. + $message->purchase_order($invoice->{purchase_order}); - # Segment Group 26 concerns *lineitem* price (i.e, total for all copies - # on this lineitem). + for my $lineitem (@{$invoice->{lineitems}}) { + my $li_id = $lineitem->{id}; - my $lineitem_price = $sg25->{SG26}[0]{MOA}[0]{C516}{5004}; + if (!$li_id) { + $logger->warn($log_prefix . "no lineitem ID"); + next; + } - # Segment Group 28 concerns *unit* (lineitem detail) price. We may - # not actually use this. TBD. - my $per_unit_price; - foreach my $sg28 (@{$sg25->{SG28}}) { - my $c509 = $sg28->{PRI}[0]{C509}; - my ($price_qualifier, $price_qualifier_type); - ($per_unit_price, $price_qualifier, $price_qualifier_type) = ( - $c509->{5118}, $c509->{5125}, $c509->{5387} - ); + my $li = $e->retrieve_acq_lineitem($li_id); - # price_qualifier=AAA seems to be the price to use. Otherwise, - # take what we can get. - last if $price_qualifier eq 'AAA'; + if (!$li) { + $logger->warn($log_prefix . + "no LI found with ID: $li_id : " . $e->event); + return 0; } - # Segment Group 29 will have references to LI and PO numbers - my $acq_identifiers = {}; - foreach my $sg29 (@{$sg25->{SG29}}) { - foreach my $rff (@{$sg29->{RFF}}) { - my $c506 = $rff->{C506}; - if ($c506->{1153} eq 'ON') { - $acq_identifiers->{po} = $c506->{1154}; - } elsif ($c506->{1153} eq 'LI') { - my ($po, $li) = split m./., $c506->{1154}; - if ($po and $li) { - if ($acq_identifiers->{po}) { - $logger->warn( - $log_prefix . - "RFFs within lineitem disagree on PO # ?" - ) unless $acq_identifiers->{po} eq $po; - } - $acq_identifiers->{li} = $li; - $acq_identifiers->{po} = $po; - } else { - $logger->warn( - $log_prefix . - "RFF 1154 doesn't match expectations (.+/.+) " . - "where 1153 is 'LI'" - ); - } - } - } + my ($quant) = grep {$_->{code} eq '47'} @{$lineitem->{quantities}}; + my $quantity = ($quant) ? $quant->{quantity} : 0; + + if (!$quantity) { + $logger->warn($log_prefix . + "no invoice quantity specified for LI $li_id"); + next; } - if ($acq_identifiers->{po}) { - # First PO number seen in INVOIC sets the purchase_order field for - # the entry in acq.edi_message (which model may need a rethink). + # NOTE: if needed, we also have $lineitem->{net_unit_price} + # and $lineitem->{gross_unit_price} + my $lineitem_price = $lineitem->{amount_billed}; - $message->purchase_order($acq_identifiers->{po}) unless - $message->purchase_order; - } else { - $logger->warn( - $log_prefix . - "SG29 missing or refers to no purchase order that we can tell" - ); - } - if (not $acq_identifiers->{li}) { - $logger->warn( - $log_prefix . - "SG29 missing or refers to no lineitem that we can tell" - ); - } + # if the top-level PO value is unset, get it from the first LI + $message->purchase_order($li->purchase_order) + unless $message->purchase_order; my $eg_inv_entry = Fieldmapper::acq::invoice_entry->new; $eg_inv_entry->inv_item_count($quantity); # XXX Validate by making sure the LI is on-order and belongs to # the right provider and ordering agency and all that. - $eg_inv_entry->lineitem($acq_identifiers->{li}); + $eg_inv_entry->lineitem($li_id); # XXX Do we actually need to link to PO directly here? - $eg_inv_entry->purchase_order($acq_identifiers->{po}); + $eg_inv_entry->purchase_order($li->purchase_order); # This is the total price for all units billed, not per-unit. $eg_inv_entry->cost_billed($lineitem_price); @@ -788,26 +674,41 @@ sub create_acq_invoice_from_edi { my @eg_inv_items; - # Find any taxes applied to the whole invoice. - try { - if ($invoice->{SG50}) { - foreach my $sg50 (@{ $invoice->{SG50} }) { - if ($sg50->{TAX} and $sg50->{MOA}) { - my $tax_amount = $sg50->{MOA}[0]{C516}{5004}; + my %charge_type_map = ( + 'TX' => ['TAX', 'Tax from electronic invoice'], + 'CA' => ['PRO', 'Cataloging services'], + 'DL' => ['SHP', 'Delivery'] + ); - my $eg_inv_item = Fieldmapper::acq::invoice_item->new; - $eg_inv_item->inv_item_type('TAX'); - $eg_inv_item->cost_billed($tax_amount); - # XXX i18n somehow? or maybe omit the note. - $eg_inv_item->note('Tax from electronic invoice'); + for my $charge (@{$invoice->{misc_charges}}) { + my $eg_inv_item = Fieldmapper::acq::invoice_item->new; - push @eg_inv_items, $eg_inv_item; - } - } + my $amount = $charge->{charge_amount}; + + if (!$amount) { + $logger->warn($log_prefix . "charge with no amount"); + next; + } + + my $map = $charge_type_map{$charge->{charge_type}}; + + if (!$map) { + $map = [ + 'PRO', + 'Unknown charge type ' . $charge->{charge_type} + ]; } - } catch Error with { - # move on - }; + + $eg_inv_item->inv_item_type($$map[0]); + $eg_inv_item->note($$map[1]); + $eg_inv_item->cost_billed($amount); + + push @eg_inv_items, $eg_inv_item; + } + + $logger->info($log_prefix . + sprintf("creating invoice with %d entries and %d items.", + scalar(@eg_inv_entries), scalar(@eg_inv_items))); $e->xact_begin; @@ -854,252 +755,5 @@ sub create_acq_invoice_from_edi { return 1; } -# returns message object if processing should continue -# returns false/undef value if processing should abort - -sub message_object { - my $class = shift; - my $body = shift or return; - my $key = shift if @_; - my $keystring = $key || 'UNSPECIFIED'; - - my $msg = Business::EDI::Message->new($body); - unless ($msg) { - $logger->error("EDI interchange message: $keystring body failed Business::EDI constructor. Skipping it."); - return; - } - $key = $msg->code if ! $key; # Now we set the key for reference if it wasn't specified - my $val_0065 = $msg->xpath_value('UNH/S009/0065') || ''; - unless ($val_0065 eq $key) { - $logger->error("EDI $key UNH/S009/0065 ('$val_0065') conflicts w/ message type $key. Aborting"); - return; - } - my $val_0051 = $msg->xpath_value('UNH/S009/0051') || ''; - unless ($val_0051 eq 'UN') { - $logger->warn("EDI $key UNH/S009/0051 designates '$val_0051', not 'UN' as controlling agency. Attempting to process anyway"); - } - my $val_0054 = $msg->xpath_value('UNH/S009/0054') || ''; - if ($val_0054) { - $logger->info("EDI $key UNH/S009/0054 uses Spec revision version '$val_0054'"); - # Possible Spec Version limitation - # my $yy = $tag_0054 ? substr($val_0054,0,2) : ''; - # unless ($yy eq '00' or $yy > 94 ...) { - # $logger->warn("EDI $key UNH/S009/0051 Spec revision version '$val_0054' not supported"); - # } - } else { - $logger->warn("EDI $key UNH/S009/0054 does not reference a known Spec revision version"); - } - return $msg; -} - -=head2 ->eg_li($lineitem_object, [$remote, $server_log_string, $editor]) - -my $line_item = OpenILS::Application::Acq::EDI->eg_li($edi_line, $remote, "test_server_01", $e); - - $remote is a acq.edi_account Fieldmapper object. - $server_log_string is an arbitrary string use to identify the remote host in potential log messages. - -Updates: - acq.lineitem.estimated_unit_price, - acq.lineitem.state (dependent on mapping codes), - acq.lineitem.expected_recv_time, - acq.lineitem.edit_time (consequently) - -=cut - -sub eg_li { - my ($class, $line, $server, $server_log_string, $e) = @_; - $line or return; - $e ||= new_editor(); - - my $id; - # my $rff = $line->part('line_reference/RFF') or $logger->warn("EDI ORDRSP line_detail/RFF missing!"); - my $val_1153 = $line->xpath_value('line_reference/RFF/1153') || ''; - my $val_1154 = $line->xpath_value('line_reference/RFF/1154') || ''; - my $val_1082 = $line->xpath_value('LIN/1082') || ''; - - my @po_nums; - - $val_1154 =~ s#^(.*)\/##; # Many sources send the ID as 'order_ID/LI_ID' - $1 and push @po_nums, $1; - $val_1082 =~ s#^(.*)\/##; # Many sources send the ID as 'order_ID/LI_ID' - $1 and push @po_nums, $1; - - # TODO: possible check of po_nums - # now do a lot of checking - - if ($val_1153 eq 'LI') { - $id = $val_1154 or $logger->warn("EDI ORDRSP RFF/1154 reference to LI empty. Attempting failover to LIN/1082"); - } else { - $logger->warn("EDI ORDRSP RFF/1153 unexpected value ('$val_1153', not 'LI'). Attempting failover to LIN/1082"); - } - - # FIXME - the line item ID in LIN/1082 ought to match RFF/1154, but - # not all materials vendors obey this. Commenting out check for now - # as being too strict. - #if ($id and $val_1082 and $val_1082 ne $id) { - # $logger->warn("EDI ORDRSP LIN/1082 Line Item ID mismatch ($id vs. $val_1082): cannot target update"); - # return; - #} - - $id ||= $val_1082 || ''; - if ($id eq '') { - $logger->warn('Cannot identify line item from EDI message'); - return; - } - - $logger->info("EDI retrieve/update lineitem $id"); - - my $li = OpenILS::Application::Acq::Lineitem::retrieve_lineitem_impl($e, $id, { - flesh_li_details => 1, - }, 1); # Could send more {options}. The 1 is for no_auth. - - if (! $li or ref($li) ne 'Fieldmapper::acq::lineitem') { - $logger->error("EDI failed to retrieve lineitem by id '$id' for server $server_log_string"); - return; - } - unless ((! $server) or (! $server->provider)) { # but here we want $server to be acq.edi_account instead of RemoteAccount - if ($server->provider != $li->provider) { - # links go both ways: acq.provider.edi_default and acq.edi_account.provider - $logger->info("EDI acct provider (" . $server->provider. ") doesn't match lineitem provider(" - . $li->provider . "). Checking acq.provider.edi_default..."); - my $provider = $e->retrieve_acq_provider($li->provider); - if ($provider->edi_default != $server->id) { - $logger->error(sprintf "EDI provider/acct %s/%s (%s) is blocked from updating lineitem $id belonging to provider/edi_default %s/%s", - $server->provider, $server->id, $server->label, $li->provider, $provider->edi_default); - return; - } - } - } - - my @lin_1229 = $line->xpath('LIN/1229') or $logger->warn("EDI LIN/1229 Action Code missing!"); - my $key = $lin_1229[0] or return; - - my $eg_reason = $e->retrieve_acq_cancel_reason(1000 + $key->value); # DB populated w/ spec keys in 1000's - $eg_reason or $logger->warn(sprintf "EDI LIN/1229 Action Code '%s' (%s) not recognized in acq.cancel_reason", $key->value, $key->label); - $eg_reason or return; - - $li->cancel_reason($eg_reason->id); - unless ($eg_reason->keep_debits) { - $logger->warn("EDI LIN/1229 Action Code '%s' (%s) has keep_debits=0", $key->value, $key->label); - } - - my @prices = $line->xpath_value("line_price/PRI/5118"); - $li->estimated_unit_price($prices[0]) if @prices; - - return $li; -} - -# caching not needed for now (edi_fetcher is asynchronous) -# sub get_reason { -# my ($class, $key, $e) = @_; -# $reasons->{$key} and return $reasons->{$key}; -# $e ||= new_editor(); -# $reasons->{$key} = $e->retrieve_acq_cancel_reason($key); -# return $reasons->{$key}; -# } - 1; -__END__ - -Example JSON data. - -Note the pseudo-hash 2-element arrays. - -[ - 'SG26', - [ - [ - 'LIN', - { - '1229' => '5', - '1082' => 1, - 'C212' => { - '7140' => '9780446360272', - '7143' => 'EN' - } - } - ], - [ - 'IMD', - { - '7081' => 'BST', - '7077' => 'F', - 'C273' => { - '7008' => [ - 'NOT APPLIC WEBSTERS NEW WORLD THESA' - ] - } - } - ], - [ - 'QTY', - { - 'C186' => { - '6063' => '21', - '6060' => 10 - } - } - ], - [ - 'QTY', - { - 'C186' => { - '6063' => '12', - '6060' => 10 - } - } - ], - [ - 'QTY', - { - 'C186' => { - '6063' => '85', - '6060' => 0 - } - } - ], - [ - 'FTX', - { - '4451' => 'LIN', - 'C107' => { - '4441' => '01', - '3055' => '28', - '1131' => '8B' - } - } - ], - [ - 'SG30', - [ - [ - 'PRI', - { - 'C509' => { - '5118' => '4.5', - '5387' => 'SRP', - '5125' => 'AAB' - } - } - ] - ] - ], - [ - 'SG31', - [ - [ - 'RFF', - { - 'C506' => { - '1154' => '8/1', - '1153' => 'LI' - } - } - ] - ] - ] - ] -], - diff --git a/Open-ILS/src/perlmods/lib/OpenILS/Utils/EDIReader.pm b/Open-ILS/src/perlmods/lib/OpenILS/Utils/EDIReader.pm new file mode 100644 index 0000000000..18d46ff88e --- /dev/null +++ b/Open-ILS/src/perlmods/lib/OpenILS/Utils/EDIReader.pm @@ -0,0 +1,158 @@ +# --------------------------------------------------------------- +# Copyright (C) 2012 Equinox Software, Inc +# Author: Bill Erickson +# +# This program is free software; you can redistribute it and/or +# modify it under the terms of the GNU General Public License +# as published by the Free Software Foundation; either version 2 +# of the License, or (at your option) any later version. + +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# --------------------------------------------------------------- +package OpenILS::Utils::EDIReader; +use strict; use warnings; + +my $NEW_MSG_RE = '^UNH'; # starts a new message +my $NEW_LIN_RE = '^LIN'; # starts a new line item + +my %edi_fields = ( + message_type => qr/^UNH\+\d+\+(\S{6})/, + buyer_san => qr/^NAD\+BY\+([^:]+)/, + vendor_san => qr/^NAD\+SU\+([^:]+)/, + purchase_order => qr/^RFF\+ON:(\S+)/, + invoice_ident => qr/^BGM\+380\+([^\+]+)/, + total_billed => qr/^MOA\+86:(\d+)/ +); + +my %edi_li_fields = ( + id => qr/^RFF\+LI:\S+\/(\S+)/, + index => qr/^LIN\+([^\+]+)/, + amount_billed => qr/^MOA\+203:(\d+)/, + net_unit_price => qr/^PRI\+AAA:(\d+)/, + gross_unit_price=> qr/^PRI\+AAB:(\d+)/, + expected_date => qr/^DTM\+44:([^:]+)/ +); + +my %edi_li_ident_fields = ( + ident => qr/^LIN\+\S+\++([^:]+):?(\S+)?/, + ident2 => qr/^PIA\+0*5\+([^:]+):?(\S+)?/, +); + +my %edi_li_quant_fields = ( + code => qr/^QTY\+(\d+):/, + quantity => qr/^QTY\+\d+:(\d+)/ +); + +my %edi_charge_fields = ( + charge_type => qr/^ALC\+C\++([^\+]+)/, + charge_amount => qr/^MOA\+(8|131):(\d+)/ +); + +sub new { + return bless({}, shift()); +} + +# see read() +sub read_file { + my $self = shift; + my $file = shift; + + open(EDI_FILE, $file) or die "Cannot open $file: $!\n"; + my $edi = join('', ); + close EDI_FILE; + + return $self->read($edi); +} + +# Reads an EDI string and parses the package one "line" at a time, extracting +# needed information via regular expressions. Returns an array of messages, +# each represented as a hash. See %edi_*fields above for lists of which fields +# may be present within a message. + +sub read { + my $self = shift; + my $edi = shift or return []; + my @msgs; + + $edi =~ s/\n//og; + + foreach (split(/'/, $edi)) { + my $msg = $msgs[-1]; + + # - starting a new message + + if (/$NEW_MSG_RE/) { + $msg = {lineitems => [], misc_charges => []}; + push(@msgs, $msg); + } + + # extract top-level message fields + + next unless $msg; + + for my $field (keys %edi_fields) { + ($msg->{$field}) = $_ =~ /$edi_fields{$field}/ + if /$edi_fields{$field}/; + } + + # - starting a new lineitem + + if (/$NEW_LIN_RE/) { + $msg->{_current_li} = {}; + push(@{$msg->{lineitems}}, $msg->{_current_li}); + } + + # - extract lineitem fields + + if (my $li = $msg->{_current_li}) { + + for my $field (keys %edi_li_fields) { + ($li->{$field}) = $_ =~ /$edi_li_fields{$field}/g + if /$edi_li_fields{$field}/; + } + + for my $field (keys %edi_li_ident_fields) { + if (/$edi_li_ident_fields{$field}/) { + my ($ident, $type) = $_ =~ /$edi_li_ident_fields{$field}/; + push(@{$li->{identifiers}}, {code => $type, value => $ident}); + } + } + + if (/$edi_li_quant_fields{quantity}/) { + my $quant = {}; + ($quant->{quantity}) = $_ =~ /$edi_li_quant_fields{quantity}/; + ($quant->{code}) = $_ =~ /$edi_li_quant_fields{code}/; + push(@{$li->{quantities}}, $quant); + } + + } + + # - starting a new misc. charge + + if (/$edi_charge_fields{charge_type}/) { + $msg->{_current_charge} = {}; + push (@{$msg->{misc_charges}}, $msg->{_current_charge}); + } + + # - extract charge fields + + if (my $charge = $msg->{_current_charge}) { + for my $field (keys %edi_charge_fields) { + ($charge->{$field}) = $_ =~ /$edi_charge_fields{$field}/ + if /$edi_charge_fields{$field}/; + } + } + } + + # remove the state-maintenance keys + for my $msg (@msgs) { + foreach (grep /^_/, keys %$msg) { + delete $msg->{$_}; + } + } + + return \@msgs; +} diff --git a/Open-ILS/src/perlmods/t/14-OpenILS-Utils.t b/Open-ILS/src/perlmods/t/14-OpenILS-Utils.t index 98789564c0..209a48b506 100644 --- a/Open-ILS/src/perlmods/t/14-OpenILS-Utils.t +++ b/Open-ILS/src/perlmods/t/14-OpenILS-Utils.t @@ -1,6 +1,6 @@ #!perl -T -use Test::More tests => 24; +use Test::More tests => 29; use_ok( 'OpenILS::Utils::Configure' ); use_ok( 'OpenILS::Utils::Cronscript' ); @@ -20,6 +20,7 @@ use_ok( 'OpenILS::Utils::RemoteAccount' ); use_ok( 'OpenILS::Utils::ScriptRunner' ); use_ok( 'OpenILS::Utils::SpiderMonkey' ); use_ok( 'OpenILS::Utils::ZClient' ); +use_ok( 'OpenILS::Utils::EDIReader' ); # LP 800269 - Test MFHD holdings for records that only contain a caption field my $co_marc = MARC::Record->new(); @@ -80,3 +81,13 @@ my $clean_xml = OpenILS::Utils::Normalize::clean_marc($raw_marcxml); is($clean_xml, $exp_xml, "clean_marc: header and space normalization"); is(OpenILS::Utils::Normalize::clean_marc('èöçÇÈÀ'), 'èöçÇÈÀ', 'clean_marc: diacritics'); + +my $edi_invoice = "UNA:+.? 'UNB+UNOC:3+1556150:31B+123EVER:31B+120926:1621+4'UNH+11+INVOIC:D:96A:UN'BGM+380+5TST084026+9'DTM+137:20120924:102'RFF+ON:24'NAD+BY+123EVER 0001::91'NAD+SU+1691503::31B'CUX+2:USD:4'LIN+1++9780446360272'QTY+47:5'MOA+146:4.5:USD:10'MOA+203:14.65'PRI+AAF:2.93:DI:NTP'RFF+LI:24/102'LIN+2++9780446357197'QTY+47:8'MOA+146:6.5:USD:10'MOA+203:33.84'PRI+AAF:4.23:DI:NTP'RFF+LI:24/100'UNS+S'MOA+86:66.18'ALC+C++++DL'MOA+8:2'ALC+C++++CA'MOA+131:12.3'ALC+C++++TX'MOA+8:3.39'UNT+28+11'UNH+12+INVOIC:D:96A:UN'BGM+380+5TST084027+9'DTM+137:20120924:102'RFF+ON:26'NAD+BY+123EVER 0001::91'NAD+SU+1691503::31B'CUX+2:USD:4'LIN+1++9780446360272'QTY+47:1'MOA+146:4.5:USD:10'MOA+203:4.05'PRI+AAF:4.05:DI:NTP'RFF+LI:26/106'LIN+2++9780446350105'QTY+47:3'MOA+146:6.99:USD:10'MOA+203:14.67'PRI+AAF:4.89:DI:NTP'RFF+LI:26/105'UNS+S'MOA+86:25.03'ALC+C++++DL'MOA+8:2'ALC+C++++CA'MOA+131:3'ALC+C++++TX'MOA+8:1.31'UNT+28+12'UNZ+4+4'"; + +my $edi_msgs = OpenILS::Utils::EDIReader->new->read($edi_invoice); + +is($edi_msgs->[0]->{message_type}, 'INVOIC', 'edi reader: message type'); +is($edi_msgs->[0]->{purchase_order}, '24', 'edi reader: PO number'); +is($edi_msgs->[1]->{invoice_ident}, '5TST084027', 'edi reader: invoice ident'); +is(scalar(@{$edi_msgs->[1]->{lineitems}}), '2', 'edi reader: lineitem count'); + diff --git a/Open-ILS/src/support-scripts/edi_fetcher.pl b/Open-ILS/src/support-scripts/edi_fetcher.pl index 9d5f1682bc..e4feb0f903 100755 --- a/Open-ILS/src/support-scripts/edi_fetcher.pl +++ b/Open-ILS/src/support-scripts/edi_fetcher.pl @@ -122,8 +122,7 @@ if (@ARGV) { $content, "localhost:" . File::Spec->rel2abs($_), OpenILS::Application::Acq::EDI->remote_account($acct), - $acct, - $e + $acct ); } exit; diff --git a/Open-ILS/src/support-scripts/test-scripts/edi_reader.pl b/Open-ILS/src/support-scripts/test-scripts/edi_reader.pl new file mode 100755 index 0000000000..242f90579c --- /dev/null +++ b/Open-ILS/src/support-scripts/test-scripts/edi_reader.pl @@ -0,0 +1,9 @@ +#!/usr/bin/perl +use strict; use warnings; +use OpenILS::Utils::EDIReader; +use Data::Dumper; + +my $reader = OpenILS::Utils::EDIReader->new; +my $msgs = $reader->read_file(shift()); +print Dumper($msgs); + -- 2.43.2