From: Lebbeous Fogle-Weekley Date: Mon, 30 Jul 2012 03:34:12 +0000 (-0400) Subject: Add OpenILS::Utils::LooseEDI module. X-Git-Url: https://old-git.evergreen-ils.org/?a=commitdiff_plain;h=7f8f10c1ecf24b26ddf2d25bc7ced7627fde97a4;p=evergreen%2Fequinox.git Add OpenILS::Utils::LooseEDI module. This doesn't try to do the validation and other helpful things that Business::EDI aims to do, but it does let us get at data in EDI invoices if we know what we're looking for. Signed-off-by: Lebbeous Fogle-Weekley --- diff --git a/Open-ILS/src/perlmods/lib/OpenILS/Utils/LooseEDI.pm b/Open-ILS/src/perlmods/lib/OpenILS/Utils/LooseEDI.pm new file mode 100644 index 0000000000..3ff5fa7c9a --- /dev/null +++ b/Open-ILS/src/perlmods/lib/OpenILS/Utils/LooseEDI.pm @@ -0,0 +1,245 @@ +# The OpenILS::Utils::LooseEDI classes are an intentiaonally simplistic way to +# represent EDI interchanges and the messages contained therein (which are in +# turn made up of segment groups, segments, and smaller data structures). +# +# There is virtually no validation against EDIFACT or Editeur rules. All we're +# doing here is the minimum data munging against incoming JEDI that will let us +# access segments by name without looping and searching for them, when they're +# where they should be. +# +# Segment groups are hereinafter just "groups." Groups can belong to other +# groups, and segments can belong to groups, but groups cannot belong to +# segments. +# +# Groups and segments at a given level always appear in +# arrays in case there are any repeats of the the same thing at the same level. +# Anything "less" than a segment is just copied as-is from the JEDI. +# +# The class you want to instantiate is OpenILS::Utils::LooseEDI::Interchange. +# The only argument you need to give new() is the JEDI data (in string form +# will do nicely). + +package OpenILS::Utils::LooseEDI::Segment; # so simple it does nothing. + +use strict; +use warnings; + +sub new { + my ($class, $data) = @_; + + my $self = bless $data, $class; # data is already hashref + + return $self; +} + +1; + +package OpenILS::Utils::LooseEDI::Group; + +use strict; +use warnings; + +use OpenSRF::Utils::Logger qw/:logger/; + +sub new { + my ($class, $data) = @_; + + my $self = bless { + data => $data + }, $class; + + $self->load; + + return $self; +} + +sub load { + my $self = shift; + + foreach (@{$self->{data}}) { + $logger->warn("bad element in data for " . __PACKAGE__) unless + @$_ == 2; + + my ($left, $right) = @$_; + $self->{$left} ||= []; + push @{$self->{$left}}, $self->load_children($right); + } + + delete $self->{data}; +} + +sub load_children { + my ($self, $thing) = @_; + + if (ref $thing eq 'ARRAY') { + return new OpenILS::Utils::LooseEDI::Group($thing); + } elsif (ref $thing eq 'HASH') { + return new OpenILS::Utils::LooseEDI::Segment($thing); + } else { + $logger->warn("unexpected data, neither array nor hashref"); + } +} + +1; + +package OpenILS::Utils::LooseEDI::Message; + +use strict; +use warnings; + +# In our unsophisticated implementation, a message is just like a segment group. +use base 'OpenILS::Utils::LooseEDI::Group'; + +sub message_name { + my ($self) = @_; + + return $self->{UNH}[0]{S009}{'0065'}; +} + +1; + +package OpenILS::Utils::LooseEDI::Interchange; + +use strict; +use warnings; + +use OpenSRF::EX qw/:try/; +use OpenSRF::Utils::JSON; +use OpenSRF::Utils::Logger qw/:logger/; + +sub new { + my ($class, $data) = @_; + + $data = OpenSRF::Utils::JSON->JSON2perl($data) unless ref $data; + + if (ref $data eq 'HASH') { + # Like a bad wine... + throw new OpenSRF::EX::Error("Interchange lacks body") unless + $data->{body}; + throw new OpenSRF::EX::Error("Interchange has empty body") unless + ref $data->{body} eq 'ARRAY' and @{ $data->{body} }; + + my $self = bless {}, $class; + + foreach my $part (@{ $data->{body} }) { + foreach my $msgname (grep /^[A-Z]/, keys %$part) { + $self->{$msgname} ||= []; + my $message = + new OpenILS::Utils::LooseEDI::Message($part->{$msgname}); + if ($msgname ne $message->message_name) { + $logger->warn( + "Found message thought to be named $msgname, " . + "but it says " . $message->message_name + ); + } + push @{$self->{$msgname}}, $message; + } + } + return $self; + } else { + $logger->error(__PACKAGE__ . " given bad data"); + } +} + +1; + +=pod +sub process_invoice { + my ($invoice) = @_; + + # The invoice message will have once instance of segment group 25 + # per lineitem. + foreach my $sg25 (@{ $invoice->{SG25} }) { + print "found a sg25 (for a lineitem)\n"; + + # quantity + my $c186 = $sg25->{QTY}[0]->{C186}; + printf("\tquantity: %d %s\n", $c186->{6060}, $c186->{6411} || ""); + + # 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}]; + } catch Error with { + # move on + }; + + # from PIA... + try { + my $c212 = $sg25->{PIA}[0]{C212}; + foreach my $h (@$c212) { + push @identifiers, [$h->{7143}, $h->{7140}]; + } + } catch Error with { + # move on + }; + + printf("\tidentifier: %s %13s\n", $_->[0], $_->[1]) for @identifiers; + + # Segment Group 26-47 are all descendants of SG25. + + # Segment Group 26 concerns *lineitem* price + try { + printf( + "\tlineitem amount: %.02f\n", + $sg25->{SG26}[0]{MOA}[0]{C516}{5004} + ); + } catch Error with { + # move on + }; + + # Segment Group 28 concerns *unit* (lineitem detail) price + foreach my $sg28 (@{$sg25->{SG28}}) { + my $c509 = $sg28->{PRI}[0]{C509}; + printf("\tsg28 (price/range details): %.02f, qual/type qual are %s/%s\n", $c509->{5118}, $c509->{5125}, $c509->{5387}); + } + + # Segment Group 29 concerns 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( + "RFFs within lineitem disagree on PO #" + ) unless $acq_identifiers->{po} eq $po; + + $acq_identifiers->{li} = $li; + } + } else { + $logger->warn( + "RFF 1154 doesn't match expectations where 1153 is LI" + ); + } + } + } + } + + printf( + "\treferences PO# %d and LI #%d\n", + $acq_identifiers->{po}, + $acq_identifiers->{li} + ); + } +} + +################ main ################## +local $/; +undef $/; + +my $interchange = new OpenILS::Utils::LooseEDI::Interchange(); + +foreach (@{ $interchange->{INVOIC} }) { + process_invoice($_); +} + +0; +=cut