Open-ILS/src/perlmods/lib/OpenILS/Utils/EDIReader.pm

   1 # ---------------------------------------------------------------
   2 # Copyright (C) 2012 Equinox Software, Inc
   3 # Author: Bill Erickson <berickr@esilibrary.com>
   4 #
   5 # This program is free software; you can redistribute it and/or
   6 # modify it under the terms of the GNU General Public License
   7 # as published by the Free Software Foundation; either version 2
   8 # of the License, or (at your option) any later version.
   9
  10 # This program is distributed in the hope that it will be useful,
  11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 # GNU General Public License for more details.
  14 # ---------------------------------------------------------------
  15 package OpenILS::Utils::EDIReader;
  16 use strict; use warnings;
  17
  18 my $NEW_MSG_RE = '^UNH'; # starts a new message
  19 my $NEW_LIN_RE = '^LIN'; # starts a new line item
  20 my $END_ALL_LIN = '^UNS'; # no more lineitems after this
  21
  22 my %edi_fields = (
  23     message_type    => qr/^UNH\+[A-z0-9]+\+(\S{6})/,
  24     buyer_san       => qr/^NAD\+BY\+([^:]+)::31B/,
  25     buyer_acct      => qr/^NAD\+BY\+([^:]+)::91/,
  26     buyer_ident     => qr/^NAD\+BY\+([^:]+)::9$/, # alternate SAN
  27     buyer_code      => qr/^RFF\+API:(\S+)/,
  28     vendor_san      => qr/^NAD\+SU\+([^:]+)::31B/,
  29     vendor_acct     => qr/^NAD\+SU\+([^:]+)::91/,
  30     vendor_ident    => qr/^NAD\+SU\+([^:]+)::9$/, # alternate SAN
  31     purchase_order  => qr/^RFF\+ON:(\S+)/,
  32     invoice_ident   => qr/^BGM\+380\+([^\+]+)/,
  33     total_billed    => qr/^MOA\+86:([^:]+)/,
  34     invoice_date    => qr/^DTM\+137:([^:]+)/, # This is really "messge date"
  35     # We don't retain a top-level container code -- they can repeat.
  36     _container_code => qr/^GIN\+BJ\+([^:]+)/,
  37     _container_code_alt => qr/^PCI\+33E\+([^:]+)/,
  38     lading_number   => qr/^RFF\+BM:([^:]+)/
  39 );
  40
  41 my %edi_li_fields = (
  42     id      => qr/^RFF\+LI:(?:[^\/]+\/)?(\d+)/,
  43     index   => qr/^LIN\+([^\+]+)/,
  44     amount_billed   => qr/^MOA\+203:([^:]+)/,
  45     net_unit_price  => qr/^PRI\+AAA:([^:]+)/,
  46     gross_unit_price=> qr/^PRI\+AAB:([^:]+)/,
  47     expected_date   => qr/^DTM\+44:([^:]+)/,
  48     avail_status    => qr/^FTX\+LIN\++([^:]+):8B:28/,
  49     # "1B" codes are deprecated, but still in use.
  50     # Pretend it's "12B" and it should just work
  51     order_status    => qr/^FTX\+LIN\++([^:]+):12?B:28/,
  52     # DESADV messages have multiple PO ID's, one RFF+ON per LIN.
  53     purchase_order  => qr/^RFF\+ON:(\S+)/
  54 );
  55
  56 my %edi_li_ident_fields = (
  57     ident  => qr/^LIN\+\S+\++([^:]+):?(\S+)?/,
  58     ident2 => qr/^PIA\+0*5\+([^:]+):?(\S+)?/,
  59 );
  60
  61 my %edi_li_quant_fields = (
  62     code     => qr/^QTY\+(\d+):/,
  63     quantity => qr/^QTY\+\d+:(\d+)/
  64 );
  65
  66 my %edi_charge_fields = (
  67     type   => qr/^ALC\+C\++([^\+]+)/,
  68     amount => qr/^MOA\+(?:8|131|304):([^:]+)/
  69 );
  70
  71 # This may need to be liberalized later, but it works for the only example I
  72 # have so far.
  73 my %edi_tax_fields = (
  74     type   => qr/^TAX\+7\+([^\+]+)/,
  75     amount => qr/^MOA\+124:([^:]+)/
  76 );
  77
  78 sub new {
  79     return bless({}, shift());
  80 }
  81
  82 # see read()
  83 sub read_file {
  84     my $self = shift;
  85     my $file = shift;
  86
  87     open(EDI_FILE, $file) or die "Cannot open $file: $!\n";
  88     my $edi = join('', <EDI_FILE>);
  89     close EDI_FILE;
  90
  91     return $self->read($edi);
  92 }
  93
  94 # Reads an EDI string and parses the package one "line" at a time, extracting
  95 # needed information via regular expressions.  Returns an array of messages,
  96 # each represented as a hash.  See %edi_*fields above for lists of which fields
  97 # may be present within a message.
  98
  99 sub read {
 100     my $self = shift;
 101     my $edi = shift or return [];
 102     my @msgs;
 103
 104     $edi =~ s/\n//og;
 105
 106     foreach (split(/'/, $edi)) {
 107         my $msg = $msgs[-1];
 108
 109         # - starting a new message
 110
 111         if (/$NEW_MSG_RE/) {
 112             $msg = {lineitems => [], misc_charges => [], taxes => []};
 113             push(@msgs, $msg);
 114         }
 115
 116         # extract top-level message fields
 117
 118         next unless $msg;
 119
 120         for my $field (keys %edi_fields) {
 121             ($msg->{$field}) = $_ =~ /$edi_fields{$field}/
 122                 if /$edi_fields{$field}/;
 123         }
 124
 125         # - starting a new lineitem
 126
 127         if (/$NEW_LIN_RE/) {
 128             $msg->{_current_li} = {};
 129
 130             # In DESADV messages there may be multiple container codes
 131             # per message.  They precede the lineitems contained within
 132             # each container.  Instead of restructuring the messages to
 133             # be containers of lineitems, just tag each lineitem with
 134             # its container if one is specified.
 135             my $ccode = $msg->{_container_code} || $msg->{_container_code_alt};
 136             $msg->{_current_li}->{container_code} = $ccode if $ccode;
 137
 138             push(@{$msg->{lineitems}}, $msg->{_current_li});
 139         }
 140
 141         # - extract lineitem fields
 142
 143         if (my $li = $msg->{_current_li}) {
 144
 145             for my $field (keys %edi_li_fields) {
 146                 ($li->{$field}) = $_ =~ /$edi_li_fields{$field}/g
 147                     if /$edi_li_fields{$field}/;
 148             }
 149
 150             for my $field (keys %edi_li_ident_fields) {
 151                 if (/$edi_li_ident_fields{$field}/) {
 152                     my ($ident, $type) = $_ =~ /$edi_li_ident_fields{$field}/;
 153                     push(@{$li->{identifiers}}, {code => $type, value => $ident});
 154                 }
 155             }
 156
 157             if (/$edi_li_quant_fields{quantity}/) {
 158                 my $quant = {};
 159                 ($quant->{quantity}) = $_ =~ /$edi_li_quant_fields{quantity}/;
 160                 ($quant->{code}) = $_ =~ /$edi_li_quant_fields{code}/;
 161                 push(@{$li->{quantities}}, $quant);
 162             }
 163
 164         }
 165
 166         # - starting a new misc. charge
 167
 168         if (/$edi_charge_fields{type}/) {
 169             $msg->{_current_charge} = {};
 170             push (@{$msg->{misc_charges}}, $msg->{_current_charge});
 171         }
 172
 173         # - extract charge fields
 174
 175         if (my $charge = $msg->{_current_charge}) {
 176             for my $field (keys %edi_charge_fields) {
 177                 ($charge->{$field}) = $_ =~ /$edi_charge_fields{$field}/
 178                     if /$edi_charge_fields{$field}/;
 179             }
 180         }
 181
 182         # - starting a new tax charge.  Taxes wind up on current lineitem if
 183         # any, otherwise in the top-level taxes array
 184
 185         if (/$edi_tax_fields{type}/) {
 186             $msg->{_current_tax} = {};
 187             if ($msg->{_current_li}) {
 188                 $msg->{_current_li}{tax} = $msg->{_current_tax}
 189             } else {
 190                 push (@{$msg->{taxes}}, $msg->{_current_tax});
 191             }
 192         }
 193
 194         # - extract tax field
 195
 196         if (my $tax = $msg->{_current_tax}) {
 197             for my $field (keys %edi_tax_fields) {
 198                 ($tax->{$field}) = $_ =~ /$edi_tax_fields{$field}/
 199                     if /$edi_tax_fields{$field}/;
 200             }
 201         }
 202
 203         # This helps avoid associating taxes and charges at the end of the
 204         # message with the final lineitem inapporiately.
 205         if (/$END_ALL_LIN/) {
 206             # remove the state-maintenance keys
 207             foreach (grep /^_/, keys %$msg) {
 208                 delete $msg->{$_};
 209             }
 210         }
 211     }
 212
 213     # remove the state-maintenance keys
 214     for my $msg (@msgs) {
 215         foreach (grep /^_/, keys %$msg) {
 216             delete $msg->{$_};
 217         }
 218     }
 219
 220     return \@msgs;
 221 }