LP#1373690: add USE_ID_FOR_OWNING_LIB EDI attribute
[Evergreen.git] / 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