1 package Koha::Edifact::Line;
3 # Copyright 2014, 2015 PTFS-Europe Ltd
5 # This file is part of Koha.
7 # Koha is free software; you can redistribute it and/or modify it
8 # under the terms of the GNU General Public License as published by
9 # the Free Software Foundation; either version 3 of the License, or
10 # (at your option) any later version.
12 # Koha is distributed in the hope that it will be useful, but
13 # 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.
17 # You should have received a copy of the GNU General Public License
18 # along with Koha; if not, see <http://www.gnu.org/licenses>.
29 my ( $class, $data_array_ref ) = @_;
30 my $self = _parse_lines($data_array_ref);
36 # helper routine used by constructor
37 # creates the hashref used as a data structure by the Line object
42 my $lin = shift @{$aref};
44 my $id = $lin->elem( 2, 0 ); # may be undef in ordrsp
45 my $action = $lin->elem( 1, 0 );
47 line_item_number => $lin->elem(0),
48 action_notification => $action,
49 item_number_id => $id,
50 additional_product_ids => [],
54 foreach my $s ( @{$aref} ) {
55 if ( $s->tag eq 'PIA' ) {
56 push @{ $d->{additional_product_ids} },
58 function_code => $s->elem(0),
59 item_number => $s->elem( 1, 0 ),
60 number_type => $s->elem( 1, 1 ),
63 elsif ( $s->tag eq 'IMD' ) {
64 push @item_description, $s;
66 elsif ( $s->tag eq 'QTY' ) {
67 if ( $s->elem( 0, 0 ) eq '47' ) {
68 $d->{quantity_invoiced} = $s->elem( 0, 1 );
70 $d->{quantity} = $s->elem( 0, 1 );
72 elsif ( $s->tag eq 'DTM' ) {
73 if ( $s->elem( 0, 0 ) eq '44' ) {
74 $d->{availability_date} = $s->elem( 0, 1 );
77 elsif ( $s->tag eq 'GIR' ) {
79 # we may get a Gir for each copy if QTY > 1
82 push @{ $d->{GIR} }, extract_gir($s);
85 my $gir = extract_gir($s);
86 if ( $gir->{copy} ) { # may have to merge
87 foreach my $g ( @{ $d->{GIR} } ) {
88 if ( $gir->{copy} eq $g->{copy} ) {
89 foreach my $field ( keys %{$gir} ) {
90 if ( !exists $g->{$field} ) {
91 $g->{$field} = $gir->{$field};
99 push @{ $d->{GIR} }, $gir;
104 elsif ( $s->tag eq 'FTX' ) {
106 my $type = $s->elem(0);
107 my $ctype = 'coded_free_text';
108 if ( $type eq 'LNO' ) { # Ingrams Oasis Internal Notes field
109 $type = 'internal_notes';
110 $ctype = 'coded_internal_note';
112 elsif ( $type eq 'LIN' ) {
113 $type = 'orderline_free_text';
114 $ctype = 'coded_orderline_text';
116 elsif ( $type eq 'SUB' ) {
117 $type = 'coded_substitute_text';
123 my $coded_text = $s->elem(2);
124 if ( ref $coded_text eq 'ARRAY' && $coded_text->[0] ) {
125 $d->{$ctype}->{table} = $coded_text->[1];
126 $d->{$ctype}->{code} = $coded_text->[0];
129 my $ftx = $s->elem(3);
130 if ( ref $ftx eq 'ARRAY' ) { # it comes in 70 character components
131 $ftx = join q{ }, @{$ftx};
133 if ( exists $d->{$type} ) { # we can only catenate repeats
141 elsif ( $s->tag eq 'MOA' ) {
143 $d->{monetary_amount} = $s->elem( 0, 1 );
145 elsif ( $s->tag eq 'PRI' ) {
147 $d->{price} = $s->elem( 0, 1 );
149 elsif ( $s->tag eq 'RFF' ) {
150 my $qualifier = $s->elem( 0, 0 );
151 if ( $qualifier eq 'QLI' ) { # Suppliers unique quotation reference
152 $d->{reference} = $s->elem( 0, 1 );
154 elsif ( $qualifier eq 'LI' ) { # Buyer's unique orderline number
155 $d->{ordernumber} = $s->elem( 0, 1 );
157 elsif ( $qualifier eq 'SLI' )
158 { # Suppliers unique order line reference number
159 $d->{orderline_reference_number} = $s->elem( 0, 1 );
163 $d->{item_description} = _format_item_description(@item_description);
169 sub _format_item_description {
173 # IMD : +Type code 'L' + characteristic code 3 char + Description in comp 3 & 4
174 foreach my $imd (@imd) {
175 my $type_code = $imd->elem(0);
176 my $ccode = $imd->elem(1);
177 my $desc = $imd->elem( 2, 3 );
178 if ( $imd->elem( 2, 4 ) ) {
179 $desc .= $imd->elem( 2, 4 );
181 if ( $type_code ne 'L' ) {
183 "Only handles text item descriptions at present: code=$type_code";
186 if ( exists $bibrec->{$ccode} ) {
187 $bibrec->{$ccode} .= q{ };
188 $bibrec->{$ccode} .= $desc;
191 $bibrec->{$ccode} = $desc;
199 my $b = $self->{item_description};
201 my $bib = MARC::Record->new();
205 if ( exists $b->{'010'} ) {
206 @spec = qw( 100 a 011 c 012 b 013 d 014 e );
207 push @fields, new_field( $b, [ 100, 1, q{ } ], @spec );
209 if ( exists $b->{'020'} ) {
210 @spec = qw( 020 a 021 c 022 b 023 d 024 e );
211 push @fields, new_field( $b, [ 700, 1, q{ } ], @spec );
215 if ( exists $b->{'030'} ) {
216 push @fields, $self->corpcon(1);
218 if ( exists $b->{'040'} ) {
219 push @fields, $self->corpcon(7);
221 if ( exists $b->{'050'} ) {
222 @spec = qw( '050' a '060' b '065' c );
223 push @fields, new_field( $b, [ 245, 1, 0 ], @spec );
225 if ( exists $b->{100} ) {
226 @spec = qw( 100 a 101 b);
227 push @fields, new_field( $b, [ 250, q{ }, q{ } ], @spec );
229 @spec = qw( 110 a 120 b 170 c );
230 my $f = new_field( $b, [ 260, q{ }, q{ } ], @spec );
234 @spec = qw( 180 a 181 b 182 c 183 e);
235 $f = new_field( $b, [ 300, q{ }, q{ } ], @spec );
239 if ( exists $b->{190} ) {
241 push @fields, new_field( $b, [ 490, q{ }, q{ } ], @spec );
244 if ( exists $b->{200} ) {
246 push @fields, new_field( $b, [ 490, q{ }, q{ } ], @spec );
248 if ( exists $b->{210} ) {
250 push @fields, new_field( $b, [ 490, q{ }, q{ } ], @spec );
252 if ( exists $b->{300} ) {
254 push @fields, new_field( $b, [ 500, q{ }, q{ } ], @spec );
256 if ( exists $b->{310} ) {
258 push @fields, new_field( $b, [ 520, q{ }, q{ } ], @spec );
260 if ( exists $b->{320} ) {
262 push @fields, new_field( $b, [ 521, q{ }, q{ } ], @spec );
264 if ( exists $b->{260} ) {
266 push @fields, new_field( $b, [ 600, q{ }, q{ } ], @spec );
268 if ( exists $b->{270} ) {
270 push @fields, new_field( $b, [ 650, q{ }, q{ } ], @spec );
272 if ( exists $b->{280} ) {
274 push @fields, new_field( $b, [ 655, q{ }, q{ } ], @spec );
278 if ( exists $b->{230} ) {
280 push @fields, new_field( $b, [ '082', q{ }, q{ } ], @spec );
282 if ( exists $b->{240} ) {
284 push @fields, new_field( $b, [ '084', q{ }, q{ } ], @spec );
286 $bib->insert_fields_ordered(@fields);
292 my ( $self, $level ) = @_;
294 1 => [ '033', '032', '034' ],
295 7 => [ '043', '042', '044' ],
298 foreach my $t ( @{ $test_these->{$level} } ) {
299 if ( exists $self->{item_description}->{$t} ) {
305 my ( $i1, $i2 ) = ( q{ }, q{ } );
307 $tag = ( $level * 100 ) + 11;
309 @spec = qw( 030 a 031 e 032 n 033 c 034 d);
312 @spec = qw( 040 a 041 e 042 n 043 c 044 d);
316 $tag = ( $level * 100 ) + 10;
318 @spec = qw( 030 a 031 b);
321 @spec = qw( 040 a 041 b);
324 return new_field( $self->{item_description}, [ $tag, $i1, $i2 ], @spec );
328 my ( $b, $tag_ind, @sfd_elem ) = @_;
331 my $e = shift @sfd_elem;
332 my $c = shift @sfd_elem;
333 if ( exists $b->{$e} ) {
334 push @sfd, $c, $b->{$e};
338 my $field = MARC::Field->new( @{$tag_ind}, @sfd );
344 # Accessor methods to line data
348 return $self->{item_number_id};
351 sub line_item_number {
353 return $self->{line_item_number};
356 sub additional_product_ids {
358 return $self->{additional_product_ids};
361 sub action_notification {
363 my $a = $self->{action_notification};
365 $a = _translate_action($a); # return the associated text string
370 sub item_description {
372 return $self->{item_description};
375 sub monetary_amount {
377 return $self->{monetary_amount};
382 return $self->{quantity};
385 sub quantity_invoiced {
387 return $self->{quantity_invoiced};
392 return $self->{price};
397 return $self->{reference};
400 sub orderline_reference_number {
402 return $self->{orderline_reference_number};
407 return $self->{ordernumber};
412 return $self->{free_text};
415 sub coded_free_text {
417 return $self->{coded_free_text}->{code};
422 return $self->{internal_notes};
425 sub coded_internal_note {
427 return $self->{coded_internal_note}->{code};
430 sub orderline_free_text {
432 return $self->{orderline_free_text};
435 sub coded_orderline_text {
437 my $code = $self->{coded_orderline_text}->{code};
438 my $table = $self->{coded_orderline_text}->{table};
440 if ( $table eq '8B' || $table eq '7B' ) {
441 $txt = translate_8B($code);
443 elsif ( $table eq '12B' ) {
444 $txt = translate_12B($code);
446 if ( !$txt || $txt eq 'no match' ) {
452 sub substitute_free_text {
454 return $self->{substitute_free_text};
457 sub coded_substitute_text {
459 return $self->{coded_substitute_text}->{code};
462 # This will take a standard code as returned
463 # by (orderline|substitue)-free_text (FTX seg LIN)
464 # and expand it using EditEUR code list 8B
468 # list 7B is a subset of this
470 AB => 'Publication abandoned',
471 AD => 'Apply direct',
472 AU => 'Publisher address unknown',
473 CS => 'Status uncertain',
474 FQ => 'Only available abroad',
475 HK => 'Paperback OP: Hardback available',
477 IP => 'In print and in stock at publisher',
478 MD => 'Manufactured on demand',
479 NK => 'Item not known',
480 NN => 'We do not supply this item',
481 NP => 'Not yet published',
483 NS => 'Not sold separately',
484 OB => 'Temporarily out of stock',
485 OF => 'This format out of print: other format available',
486 OP => 'Out of print',
487 OR => 'Out pf print; New Edition coming',
488 PK => 'Hardback out of print: paperback available',
489 PN => 'Publisher no longer in business',
490 RE => 'Awaiting reissue',
491 RF => 'refer to other publisher or distributor',
494 RR => 'Rights restricted: cannot supply in this market',
496 SN => 'Our supplier cannot trace',
497 SO => 'Pack or set not available: single items only',
498 ST => 'Stocktaking: temporarily unavailable',
499 TO => 'Only to order',
500 TU => 'Temporarily unavailable',
501 UB => 'Item unobtainable from our suppliers',
502 UC => 'Unavailable@ reprint under consideration',
505 if ( exists $code_list_8B{$code} ) {
506 return $code_list_8B{$code};
516 my %code_list_12B = (
517 100 => 'Order line accepted',
518 101 => 'Price query: orderline will be held awaiting customer response',
520 'Discount query: order line will be held awaiting customer response',
521 103 => 'Minimum order value not reached: order line will be held',
523 'Firm order required: order line will be held awaiting customer response',
524 110 => 'Order line accepted, substitute product will be supplied',
525 200 => 'Order line not accepted',
526 201 => 'Price query: order line not accepted',
527 202 => 'Discount query: order line not accepted',
528 203 => 'Minimum order value not reached: order line not accepted',
529 205 => 'Order line not accepted: quoted promotion is invalid',
530 206 => 'Order line not accepted: quoted promotion has ended',
532 'Order line not accepted: customer ineligible for quoted promotion',
533 210 => 'Order line not accepted: substitute product is offered',
534 220 => 'Oustanding order line cancelled: reason unspecified',
535 221 => 'Oustanding order line cancelled: past order expiry date',
536 222 => 'Oustanding order line cancelled by customer request',
537 223 => 'Oustanding order line cancelled: unable to supply',
538 300 => 'Order line passed to new supplier',
539 301 => 'Order line passed to secondhand department',
540 400 => 'Backordered - awaiting supply',
541 401 => 'On order from our supplier',
542 402 => 'On order from abroad',
543 403 => 'Backordered, waiting to reach minimum order value',
544 404 => 'Despatched from our supplier, awaiting delivery',
545 405 => 'Our supplier sent wrong item(s), re-ordered',
546 406 => 'Our supplier sent short, re-ordered',
547 407 => 'Our supplier sent damaged item(s), re-ordered',
548 408 => 'Our supplier sent imperfect item(s), re-ordered',
549 409 => 'Our supplier cannot trace order, re-ordered',
550 410 => 'Ordered item(s) being processed by bookseller',
552 'Ordered item(s) being processed by bookseller, awaiting customer action',
553 412 => 'Order line held awaiting customer instruction',
554 500 => 'Order line on hold - contact customer service',
555 800 => 'Order line already despatched',
556 900 => 'Cannot trace order line',
557 901 => 'Order line held: note title change',
558 902 => 'Order line held: note availability date delay',
559 903 => 'Order line held: note price change',
560 999 => 'Temporary hold: order action not yet determined',
563 if ( exists $code_list_12B{$code} ) {
564 return $code_list_12B{$code};
571 # item_desription_fields accessors
575 my $titlefield = q{050};
576 if ( exists $self->{item_description}->{$titlefield} ) {
577 return $self->{item_description}->{$titlefield};
585 if ( exists $self->{item_description}->{$field} ) {
586 my $a = $self->{item_description}->{$field};
587 my $forename_field = q{011};
588 if ( exists $self->{item_description}->{$forename_field} ) {
590 $a .= $self->{item_description}->{$forename_field};
600 if ( exists $self->{item_description}->{$field} ) {
601 return $self->{item_description}->{$field};
609 if ( exists $self->{item_description}->{$field} ) {
610 return $self->{item_description}->{$field};
615 sub publication_date {
618 if ( exists $self->{item_description}->{$field} ) {
619 return $self->{item_description}->{$field};
627 if ( exists $self->{item_description}->{$field} ) {
628 return $self->{item_description}->{$field};
636 if ( exists $self->{item_description}->{$field} ) {
637 return $self->{item_description}->{$field};
643 my ( $self, $field, $occ ) = @_;
644 if ( $self->number_of_girs ) {
646 # defaults to occurrence 0 returns undef if occ requested > occs
647 if ( defined $occ && $occ >= @{ $self->{GIR} } ) {
651 return $self->{GIR}->[$occ]->{$field};
660 if ( $self->{GIR} ) {
662 my $qty = @{ $self->{GIR} };
675 LAF => 'first_accession_number',
676 LAL => 'last_accession_number',
677 LCL => 'classification',
678 LCO => 'item_unique_id',
680 LFH => 'feature_heading',
681 LFN => 'fund_allocation',
682 LFS => 'filing_suffix',
683 LLN => 'loan_category',
685 LLS => 'label_sublocation',
686 LQT => 'part_order_quantity',
687 LRS => 'record_sublocation',
689 LSQ => 'collection_code',
690 LST => 'stock_category',
692 LVC => 'coded_servicing_instruction',
693 LVT => 'servicing_instruction',
694 LHC => 'library_holding_code',
695 LRP => 'library_rotation_plan',
696 LSC => 'statistical_category',
697 RIC => 'reader_interest_category',
700 my $set_qualifier = $s->elem( 0, 0 ); # copy number
701 my $gir_element = { copy => $set_qualifier, };
703 while ( my $e = $s->elem($element) ) {
705 if ( exists $qmap{ $e->[1] } ) {
706 my $qualifier = $qmap{ $e->[1] };
707 $gir_element->{$qualifier} = $e->[0];
711 carp "Unrecognized GIR code : $e->[1] for $e->[0]";
717 # mainly for invoice processing amt_ will derive from MOA price_ from PRI and tax_ from TAX/MOA pairsn
719 my ( $self, $qualifier ) = @_;
720 foreach my $s ( @{ $self->{segs} } ) {
721 if ( $s->tag eq 'MOA' && $s->elem( 0, 0 ) eq $qualifier ) {
722 return $s->elem( 0, 1 );
727 sub moa_multiple_amt {
728 my ( $self, $qualifier ) = @_;
729 # return a repeatable MOA field
732 foreach my $s ( @{ $self->{segs} } ) {
733 if ( $s->tag eq 'MOA' && $s->elem( 0, 0 ) eq $qualifier ) {
734 $amt += $s->elem( 0, 1 );
746 return $self->moa_amt('52');
751 return $self->moa_amt('113');
754 # total including allowances & tax
757 return $self->moa_amt('128');
760 # Used to give price in currency other than that given in price
763 return $self->moa_amt('146');
766 # item amount after allowances excluding tax
769 return $self->moa_amt('203');
771 sub amt_taxoncharge {
773 return $self->moa_multiple_amt('124');
777 my ( $self, $price_qualifier ) = @_;
778 # In practice qualifier is AAE in the quote and AAA & AAB in invoices
779 # but the following are defined
780 # AAA calculation price net (unit price excl tax but incl any allowances or charges)
781 # AAB calculation price gross (unit price excl all taxes, allowances and charges )
782 # AAE information price (incl tax but excl allowances or charges )
783 # AAF information price (including all taxes, allowances or charges)
784 foreach my $s ( @{ $self->{segs} } ) {
785 if ( $s->tag eq 'PRI' && $s->elem( 0, 0 ) eq $price_qualifier ) {
786 # in practice not all 3 fields may be present
787 # so use a temp variable to avoid runtime warnings
791 type_qualifier => undef,
793 $p->{price} = $s->elem( 0, 1 );
794 $p->{type} = $s->elem( 0, 2 );
795 $p->{type_qualifier} = $s->elem( 0, 3 );
802 # unit price that will be chaged excl tax
805 my $p = $self->pri_price('AAA');
812 # unit price excluding all allowances, charges and taxes
815 my $p = $self->pri_price('AAB');
822 # information price incl tax excluding allowances, charges
825 my $p = $self->pri_price('AAE');
832 # information price incl tax,allowances, charges
833 sub price_info_inclusive {
835 my $p = $self->pri_price('AAF');
844 return $self->moa_amt('124');
850 foreach my $s ( @{ $self->{segs} } ) {
851 if ( $s->tag eq 'TAX' && $s->elem( 0, 0 ) == 7 ) {
852 $tr->{type} = $s->elem( 1, 0 ); # VAT, GST or IMP
853 $tr->{rate} = $s->elem( 4, 3 ); # percentage
854 # category values may be:
855 # E = exempt from tax
856 # G = export item, tax not charged
861 $tr->{category} = $s->elem( 5, 0 );
862 if (!defined $tr->{rate} && $tr->{category} eq 'Z') {
871 sub availability_date {
873 if ( exists $self->{availability_date} ) {
874 return $self->{availability_date};
879 # return text string representing action code
880 sub _translate_action {
884 3 => 'change_requested',
888 24 => 'recorded', # Order accepted but a change notified
890 if ( $code && exists $action{$code} ) {
891 return $action{$code};
905 Class to abstractly handle a Line in an Edifact Transmission
909 Allows access to Edifact line elements by name
913 None documented at present
919 Called with an array ref of segments constituting the line
923 Colin Campbell <colin.campbell@ptfs-europe.com>
927 Copyright 2014,2015 PTFS-Europe Ltd
928 This program is free software, You may redistribute it under
929 under the terms of the GNU General Public License