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

   1 # ---------------------------------------------------------------
   2 # Copyright (C) 2016 King County Library System
   3 # Author: Bill Erickson <berickxx@gmail.com>
   4 #
   5 # Copied heavily from Application/Trigger/Reactor.pm
   6 #
   7 # This program is free software; you can redistribute it and/or
   8 # modify it under the terms of the GNU General Public License
   9 # as published by the Free Software Foundation; either version 2
  10 # of the License, or (at your option) any later version.
  11 #
  12 # This program is distributed in the hope that it will be useful,
  13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 # GNU General Public License for more details.
  16 # ---------------------------------------------------------------
  17 package OpenILS::Utils::EDIWriter;
  18 use strict; use warnings;
  19 use OpenILS::Utils::CStoreEditor qw/:funcs/;
  20 use OpenILS::Application::AppUtils;
  21 use DateTime;
  22 my $U = 'OpenILS::Application::AppUtils';
  23
  24 sub new {
  25     my ($class, $args) = @_;
  26     $args ||= {};
  27     return bless($args, $class);
  28 }
  29
  30 # Returns EDI string on success, undef on error.
  31 sub write {
  32     my ($self, $po_id, $msg_type) = @_;
  33     $msg_type ||= 'order';
  34
  35     my $po = $self->get_po($po_id);
  36     return undef unless $po;
  37
  38     $self->compile_po($po);
  39     return undef unless $self->{compiled};
  40
  41     my $edi = $self->build_order_edi if $msg_type eq 'order';
  42
  43     # remove the newlines unless we are pretty printing
  44     $edi =~ s/\n//g unless $self->{pretty};
  45
  46     return $edi;
  47 }
  48
  49 sub get_po {
  50     my ($self, $po_id) = @_;
  51     return new_editor()->retrieve_acq_purchase_order([
  52         $po_id, {
  53             flesh => 5,
  54             flesh_fields => {
  55                 acqpo   => [qw/lineitems ordering_agency provider/],
  56                 acqpro  => [qw/edi_default/],
  57                 acqedi  => [qw/attr_set/],
  58                 aeas    => [qw/attr_maps/],
  59                 jub     => [qw/lineitem_details lineitem_notes attributes/],
  60                 acqlid  => [qw/owning_lib location fund eg_copy_id/],
  61                 acp     => [qw/location call_number/],
  62                 aou     => [qw/mailing_address/]
  63             }
  64         }
  65     ]);
  66 }
  67
  68 sub add_release_characters {
  69     my ($self, $value) = @_;
  70     return '' if (not defined $value || ref($value));
  71
  72     # escape ? ' + : with the release character ?
  73     $value =~ s/([\?'\+:])/?$1/g;
  74
  75     return $value;
  76 }
  77 sub escape_edi_imd {
  78     my ($self, $value) = @_;
  79     return '' if (not defined $value || ref($value));
  80
  81     # Typical vendors dealing with EDIFACT (or is the problem with
  82     # our EDI translator itself?) would seem not to want
  83     # any characters outside the ASCII range, so trash them.
  84     $value =~ s/[^[:ascii:]]//g;
  85
  86     # What the heck, get rid of [ ] too (although I couldn't get them
  87     # to cause any problems for me, problems have been reported. See
  88     # LP #812593).
  89     $value =~ s/[\[\]]//g;
  90
  91     # Characters [\ <newline>] are all potentially problematic for
  92     # EDI messages, regardless of their position in the string.
  93     # Safest to simply remove them. Note that unlike escape_edi(),
  94     # we're not stripping out +, ', :, and + because we'll escape
  95     # them when buidling IMD segments
  96     $value =~ s/[\\]//g;
  97
  98     # Replace newlines with spaces.
  99     $value =~ s/\n/ /g;
 100
 101     return $value;
 102 }
 103 sub escape_edi {
 104     my ($self, $value) = @_;
 105
 106     my $str = $self->escape_edi_imd($value);
 107
 108     # further strip + ' : +
 109     $str =~ s/[\?\+':]//g;
 110
 111     return $str;
 112 }
 113
 114 # Returns an EDI-escaped version of the requested lineitem attribute
 115 # value.  If $attr_type is not set, the first attribute found matching
 116 # the requested $attr_name will be used.
 117 sub get_li_attr {
 118     my ($self, $li, $attr_name, $attr_type) = @_;
 119
 120     for my $attr (@{$li->attributes}) {
 121         next unless $attr->attr_name eq $attr_name;
 122         next if $attr_type && $attr->attr_type ne $attr_type;
 123         return $self->escape_edi($attr->attr_value);
 124     }
 125
 126     return '';
 127 }
 128
 129 # Like get_li_attr, but don't strip out ? + : ' as we'll
 130 # escape them later
 131 sub get_li_attr_imd {
 132     my ($self, $li, $attr_name, $attr_type) = @_;
 133
 134     for my $attr (@{$li->attributes}) {
 135         next unless $attr->attr_name eq $attr_name;
 136         next if $attr_type && $attr->attr_type ne $attr_type;
 137         return $self->escape_edi_imd($attr->attr_value);
 138     }
 139
 140     return '';
 141 }
 142
 143 # Generates a HASH version of the PO with all of the data necessary
 144 # to generate an EDI message from the PO.
 145 sub compile_po {
 146     my ($self, $po) = @_;
 147
 148     # Cannot generate EDI if the PO has no linked EDI account.
 149     return undef unless $po->provider->edi_default;
 150
 151     my %compiled = (
 152         po_id => $po->id,
 153         po_name => $self->escape_edi($po->name),
 154         provider_id => $po->provider->id,
 155         vendor_san => $po->provider->san || '',
 156         org_unit_san => $po->ordering_agency->mailing_address->san || '',
 157         currency_type => $po->provider->currency_type,
 158         edi_attrs => {},
 159         lineitems => []
 160     );
 161
 162     $self->{compiled} = \%compiled;
 163
 164     if ($po->provider->edi_default->attr_set) {
 165         $compiled{edi_attrs}{$_->attr} = 1
 166             for @{$po->provider->edi_default->attr_set->attr_maps}
 167     }
 168
 169     $compiled{buyer_code} = $po->provider->edi_default->vendacct;
 170
 171     $compiled{buyer_code} = # B&T
 172         $compiled{vendor_san}.' '.$po->provider->edi_default->vendcode
 173         if $compiled{edi_attrs}->{BUYER_ID_INCLUDE_VENDCODE};
 174
 175     $compiled{buyer_code} = $po->provider->edi_default->vendcode
 176         if $compiled{edi_attrs}->{BUYER_ID_ONLY_VENDCODE}; # MLS
 177
 178     push(@{$compiled{lineitems}},
 179         $self->compile_li($_)) for @{$po->lineitems};
 180
 181     return \%compiled;
 182 }
 183
 184 # Translate a lineitem order identifier attribute into an
 185 # EDI ID value and ID qualifier.
 186 sub set_li_order_ident {
 187     my ($self, $li, $li_hash) = @_;
 188
 189     my $idqual = 'EN'; # ISBN13
 190     my $idval = '';
 191
 192     if ($self->{compiled}->{edi_attr}->{LINEITEM_IDENT_VENDOR_NUMBER}) {
 193         # See if we have a vendor-specific lineitem identifier value
 194         $idval = $self->get_li_attr($li, 'vendor_num');
 195     }
 196
 197     if (!$idval) {
 198
 199         my $attr = $self->get_li_order_ident_attr($li->attributes);
 200
 201         if ($attr) {
 202             my $name = $attr->attr_name;
 203             $idval = $attr->attr_value;
 204
 205             if ($name eq 'isbn' && length($idval) != 13) {
 206                 $idqual = 'IB';
 207             } elsif ($name eq 'issn') {
 208                 $idqual = 'IS';
 209             }
 210         } else {
 211             $idqual = 'IN';
 212             $idval = $li->id;
 213         }
 214     }
 215
 216     $li_hash->{idqual} = $idqual;
 217     $li_hash->{idval} = $idval;
 218 }
 219
 220 # Find the acq.lineitem_attr object that represents the identifier
 221 # for a lineitem.
 222 sub get_li_order_ident_attr {
 223     my ($self, $attrs) = @_;
 224
 225     # preferred identifier
 226     my ($attr) =  grep { $U->is_true($_->order_ident) } @$attrs;
 227     return $attr if $attr;
 228
 229     # note we're not using get_li_attr, since we need the
 230     # attr object and not just the attr value
 231
 232     # isbn-13
 233     ($attr) = grep {
 234         $_->attr_name eq 'isbn' and
 235         $_->attr_type eq 'lineitem_marc_attr_definition' and
 236         length($_->attr_value) == 13
 237     } @$attrs;
 238     return $attr if $attr;
 239
 240     for my $name (qw/isbn issn upc/) {
 241         ($attr) = grep {
 242             $_->attr_name eq $name and
 243             $_->attr_type eq 'lineitem_marc_attr_definition'
 244         } @$attrs;
 245         return $attr if $attr;
 246     }
 247
 248     # any 'identifier' attr
 249     return (grep { $_->attr_name eq 'identifier' } @$attrs)[0];
 250 }
 251
 252 # Collect FTX notes and chop them into FTX-compatible values.
 253 sub get_li_ftx {
 254     my ($self, $li) = @_;
 255
 256     # all vendor-public, non-empty lineitem notes
 257     my @notes =
 258         map {$_->value}
 259         grep { $U->is_true($_->vendor_public) && $_->value }
 260         @{$li->lineitem_notes};
 261
 262     if ($self->{compiled}->{edi_attr}->{COPY_SPEC_CODES}) {
 263         for my $lid (@{$li->lineitem_details}) {
 264             push(@notes, $lid->note)
 265                 if ($lid->note || '') =~ /spec code [a-zA-Z0-9_]/;
 266         }
 267     }
 268
 269     my @trimmed_notes;
 270
 271     if (!@notes && $self->{compiled}->{edi_attr}->{INCLUDE_EMPTY_LI_NOTE}) {
 272         # lineitem has no notes.  Add a blank note if needed.
 273         push(@trimmed_notes, '');
 274
 275     } else {
 276         # EDI FTX fields have a max length of 512
 277         # While we're in here, EDI-escape the note values
 278         for my $note (@notes) {
 279             $note = $self->escape_edi($note);
 280             my @parts = ($note =~ m/.{1,512}/g);
 281             push(@trimmed_notes, @parts);
 282         }
 283     }
 284
 285     return \@trimmed_notes;
 286 }
 287
 288 sub compile_li {
 289     my ($self, $li) = @_;
 290
 291     my $li_hash = {
 292         id => $li->id,
 293         quantity => scalar(@{$li->lineitem_details}),
 294         estimated_unit_price => $li->estimated_unit_price || '0.00',
 295         notes => $self->get_li_ftx($li),
 296         copies => []
 297     };
 298
 299     $self->set_li_order_ident($li, $li_hash);
 300
 301     for my $name (qw/title author edition pubdate publisher pagination/) {
 302         $li_hash->{$name} = $self->get_li_attr_imd($li, $name);
 303     }
 304
 305     $self->compile_copies($li, $li_hash);
 306
 307     return $li_hash;
 308 }
 309
 310 sub compile_copies {
 311     my ($self, $li, $li_hash) = @_;
 312
 313     # does this EDI account want copy data?
 314     return unless $self->{compiled}->{edi_attrs}->{INCLUDE_COPIES};
 315
 316     for my $copy (@{$li->lineitem_details}) {
 317         $self->compile_copy($li, $li_hash, $copy);
 318     }
 319 }
 320
 321 sub compile_copy {
 322     my ($self, $li, $li_hash, $copy) = @_;
 323
 324     my $fund = $copy->fund ? $copy->fund->code : '';
 325     my $item_type = $copy->circ_modifier || '';
 326     my $call_number = $copy->cn_label || '';
 327     my $owning_lib = $copy->owning_lib ?
 328                         $self->{compiled}->{edi_attrs}->{USE_ID_FOR_OWNING_LIB} ?
 329                         $copy->owning_lib->id :
 330                         $copy->owning_lib->shortname :
 331                      '';
 332     my $location = $copy->location ? $copy->location->name : '';
 333     my $collection_code = $copy->collection_code || '';
 334     my $barcode = $copy->barcode || '';
 335
 336
 337     # When an ACQ copy links to a real copy (acp), treat the real
 338     # copy as authoritative for certain fields.
 339     my $acp = $copy->eg_copy_id;
 340     if ($acp) {
 341         $item_type = $acp->circ_modifier || '';
 342         $call_number = $acp->call_number->label;
 343         $location = $acp->location->name;
 344     }
 345
 346     my $found_match = 0;
 347
 348     # Collapse like copies into groups with a quantity value.
 349     # INCLUDE_COPY_ID implies one GIR row per copy, no collapsing.
 350     if (!$self->{compiled}->{edi_attrs}->{INCLUDE_COPY_ID}) {
 351
 352         for my $e_copy (@{$li_hash->{copies}}) {
 353             if (
 354                 ($fund eq $e_copy->{fund}) &&
 355                 ($item_type eq $e_copy->{item_type}) &&
 356                 ($call_number eq $e_copy->{call_number}) &&
 357                 ($owning_lib eq $e_copy->{owning_lib}) &&
 358                 ($location eq $e_copy->{location}) &&
 359                 ($barcode eq $e_copy->{barcode}) &&
 360                 ($collection_code eq $e_copy->{collection_code})
 361             ) {
 362                 $e_copy->{quantity}++;
 363                 $found_match = 1;
 364                 last;
 365             }
 366         }
 367     }
 368
 369     return if $found_match; # nothing left to do.
 370
 371     # No matching copy found.  Add it as a new copy to the lineitem
 372     # copies array.
 373
 374     push(@{$li_hash->{copies}}, {
 375         fund => $self->escape_edi($fund),
 376         item_type => $self->escape_edi($item_type),
 377         call_number => $self->escape_edi($call_number),
 378         owning_lib => $self->escape_edi($owning_lib),
 379         location => $self->escape_edi($location),
 380         barcode => $self->escape_edi($barcode),
 381         collection_code => $self->escape_edi($collection_code),
 382         copy_id => $copy->id, # for INCLUDE_COPY_ID
 383         quantity => 1
 384     });
 385 }
 386
 387 # IMD fields are limited to 70 chars per value over two DEs.
 388 # Any values longer # should be carried via repeating IMD fields.
 389 # IMD fields should only display the +::: when a value is present
 390 sub IMD {
 391     my ($self, $code, $value) = @_;
 392
 393     $value = ' ' if (
 394         $value eq '' &&
 395         $self->{compiled}->{edi_attrs}->{INCLUDE_EMPTY_IMD_VALUES}
 396     );
 397
 398     if ($value) {
 399         my $s = '';
 400         for my $part ($value =~ m/.{1,70}/g) {
 401             my $de;
 402             if (length($part) > 35) {
 403                 $de = $self->add_release_characters(substr($part, 0, 35)) .
 404                       ':' .
 405                       $self->add_release_characters(substr($part, 35));
 406             } else {
 407                 $de = $self->add_release_characters($part);
 408             }
 409             $s .= "IMD+F+$code+:::$de'\n";
 410         }
 411         return $s;
 412
 413     } else {
 414         return "IMD+F+$code'\n"
 415     }
 416 }
 417
 418 # EDI Segments: --
 419 # UNA
 420 # UNB
 421 # UNH
 422 # BGM
 423 # DTM
 424 # NAD+BY
 425 # NAD+SU...::31B
 426 # NAD+SU...::92
 427 # CUX
 428 # <lineitems and copies>
 429 # UNS
 430 # CNT
 431 # UNT
 432 # UNZ
 433 sub build_order_edi {
 434     my ($self) = @_;
 435     my %c = %{$self->{compiled}};
 436     my $date = DateTime->now->strftime("%Y%m%d");
 437     my $datetime = DateTime->now->strftime("%y%m%d:%H%M");
 438     my @lis = @{$c{lineitems}};
 439
 440     # EDI header
 441     my $edi = <<EDI;
 442 UNA:+.? '
 443 UNB+UNOB:3+$c{org_unit_san}:31B+$c{vendor_san}:31B+$datetime+1'
 444 UNH+1+ORDERS:D:96A:UN'
 445 BGM+220+$c{po_id}+9'
 446 DTM+137:$date:102'
 447 EDI
 448
 449     $edi .= "NAD+BY+$c{org_unit_san}::31B'\n" unless (
 450         $self->{compiled}->{edi_attrs}->{BUYER_ID_ONLY_VENDCODE} ||
 451         $self->{compiled}->{edi_attrs}->{BUYER_ID_INCLUDE_VENDCODE}
 452     );
 453
 454     $edi .= <<EDI;
 455 NAD+BY+$c{buyer_code}::91'
 456 NAD+SU+$c{vendor_san}::31B'
 457 NAD+SU+$c{provider_id}::92'
 458 CUX+2:$c{currency_type}:9'
 459 EDI
 460
 461     # EDI lineitem segments
 462     $edi .= $self->build_lineitem_segments($_) for @lis;
 463
 464     my $li_count = scalar(@lis);
 465
 466     # Count the number of segments in the EDI message by counting the
 467     # number of newlines.  Add to count for lines below, not including
 468     # the UNZ segment.
 469     my $segments = $edi =~ tr/\n//;
 470     $segments += 1; # UNS, CNT, UNT, but not UNA or UNB
 471
 472     # EDI Trailer
 473     $edi .= <<EDI;
 474 UNS+S'
 475 CNT+2:$li_count'
 476 UNT+$segments+1'
 477 UNZ+1+1'
 478 EDI
 479
 480     return $edi;
 481 }
 482
 483 # EDI Segments: --
 484 # LIN
 485 # PIA+5
 486 # IMD+F+BTI
 487 # IMD+F+BPD
 488 # IMD+F+BPU
 489 # IMD+F+BAU
 490 # IMD+F+BEN
 491 # IMD+F+BPH
 492 # QTY+21
 493 # FTX+LIN
 494 # PRI+AAB
 495 # RFF+LI
 496 sub build_lineitem_segments {
 497     my ($self, $li_hash) = @_;
 498     my %c = %{$self->{compiled}};
 499
 500     my $id = $li_hash->{id};
 501     my $idval = $li_hash->{idval};
 502     my $idqual = $li_hash->{idqual};
 503     my $quantity = $li_hash->{quantity};
 504     my $price = $li_hash->{estimated_unit_price};
 505
 506     # Line item identifier segments
 507     my $edi = "LIN+$id++$idval:$idqual'\n";
 508     $edi .= "PIA+5+$idval:$idqual'\n";
 509
 510     $edi .= $self->IMD('BTI', $li_hash->{title});
 511     $edi .= $self->IMD('BPU', $li_hash->{publisher});
 512     $edi .= $self->IMD('BPD', $li_hash->{pubdate});
 513
 514     $edi .= $self->IMD('BEN', $li_hash->{edition})
 515         if $c{edi_attrs}->{INCLUDE_BIB_EDITION};
 516
 517     $edi .= $self->IMD('BAU', $li_hash->{author})
 518         if $c{edi_attrs}->{INCLUDE_BIB_AUTHOR};
 519
 520     $edi .= $self->IMD('BPH', $li_hash->{pagination})
 521         if $c{edi_attrs}->{INCLUDE_BIB_PAGINATION};
 522
 523     $edi .= "QTY+21:$quantity'\n";
 524
 525     $edi .= $self->build_gir_segments($li_hash);
 526
 527     for my $note (@{$li_hash->{notes}}) {
 528         if ($note) {
 529             $edi .= "FTX+LIN+1+$note'\n"
 530         } else {
 531             $edi .= "FTX+LIN+1'\n"
 532         }
 533     }
 534
 535     $edi .= "PRI+AAB:$price'\n";
 536
 537     # Standard RFF
 538     my $rff = "$c{po_id}/$id";
 539
 540     if ($c{edi_attrs}->{LINEITEM_REF_ID_ONLY}) {
 541         # RFF with lineitem ID only (typically B&T)
 542         $rff = $id;
 543     } elsif ($c{edi_attrs}->{INCLUDE_PO_NAME}) {
 544         # RFF with PO name instead of PO ID
 545         $rff = "$c{po_name}/$id";
 546     }
 547
 548     $edi .= "RFF+LI:$rff'\n";
 549
 550     return $edi;
 551 }
 552
 553
 554 # Map of GIR segment codes, copy field names, inclusion attributes,
 555 # and include-if-empty attributes for encoding copy data.
 556 my @gir_fields = (
 557     {   code => 'LLO',
 558         field => 'owning_lib',
 559         attr => 'INCLUDE_OWNING_LIB'},
 560     {   code => 'LSQ',
 561         field => 'collection_code',
 562         attr => 'INCLUDE_COLLECTION_CODE',
 563         empty_attr => 'INCLUDE_EMPTY_COLLECTION_CODE'},
 564     {   code => 'LQT',
 565         field => 'quantity',
 566         attr => 'INCLUDE_QUANTITY'},
 567     {   code => 'LCO',
 568         field => 'copy_id',
 569         attr => 'INCLUDE_COPY_ID'},
 570     {   code => 'LST',
 571         field => 'item_type',
 572         attr => 'INCLUDE_ITEM_TYPE',
 573         empty_attr => 'INCLUDE_EMPTY_ITEM_TYPE'},
 574     {   code => 'LSM',
 575         field => 'call_number',
 576         attr => 'INCLUDE_CALL_NUMBER',
 577         empty_attr => 'INCLUDE_EMPTY_CALL_NUMBER'},
 578     {   code => 'LFN',
 579         field => 'fund',
 580         attr => 'INCLUDE_FUND'},
 581     {   code => 'LFH',
 582         field => 'location',
 583         attr => 'INCLUDE_LOCATION',
 584         empty_attr => 'INCLUDE_EMPTY_LOCATION'},
 585     {   code => 'LAC',
 586         field => 'barcode',
 587         attr => 'INCLUDE_ITEM_BARCODE'}
 588 );
 589
 590 # EDI Segments: --
 591 # GIR
 592 # Sub-Segments: --
 593 # LLO
 594 # LFN
 595 # LSM
 596 # LST
 597 # LSQ
 598 # LFH
 599 # LQT
 600 sub build_gir_segments {
 601     my ($self, $li_hash) = @_;
 602     my %c = %{$self->{compiled}};
 603     my $gir_index = 0;
 604     my $edi = '';
 605
 606     for my $copy (@{$li_hash->{copies}}) {
 607         $gir_index++;
 608         my $gir_idx_str = sprintf("%03d", $gir_index);
 609
 610         my $field_count = 0;
 611         for my $field (@gir_fields) {
 612             next unless $c{edi_attrs}->{$field->{attr}};
 613
 614             my $val = $copy->{$field->{field}};
 615             my $code = $field->{code};
 616
 617             # include the GIR component if we have a value or this
 618             # EDI account is configured to include the empty value
 619             next unless $val || $c{edi_attrs}->{$field->{empty_attr} || ''};
 620
 621             # EDI only allows 5 fields per GIR segment.  When we exceed
 622             # 5, finalize the in-process GIR segment and add a new one
 623             # as needed.
 624             if ($field_count == 5) {
 625                 $field_count = 0;
 626                 # Finalize this GIR segment with a ' and newline
 627                 $edi .= "'\n";
 628             }
 629
 630             $field_count++;
 631
 632             # Starting a new GIR line for the current copy.
 633             $edi .= "GIR+$gir_idx_str" if $field_count == 1;
 634
 635             # Add the field-specific value
 636             $edi .= "+$val:$code";
 637         }
 638
 639         # End the final GIR segment with a ' and newline
 640         $edi .= "'\n";
 641     }
 642
 643     return $edi;
 644 }
 645
 646 1;
 647