1 package Koha::Edifact::Order;
7 # Copyright 2014,2015 PTFS-Europe Ltd
9 # This file is part of Koha.
11 # Koha is free software; you can redistribute it and/or modify it
12 # under the terms of the GNU General Public License as published by
13 # the Free Software Foundation; either version 3 of the License, or
14 # (at your option) any later version.
16 # Koha is distributed in the hope that it will be useful, but
17 # WITHOUT ANY WARRANTY; without even the implied warranty of
18 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 # GNU General Public License for more details.
21 # You should have received a copy of the GNU General Public License
22 # along with Koha; if not, see <http://www.gnu.org/licenses>.
26 use Readonly qw( Readonly );
28 use Koha::DateUtils qw( dt_from_string );
29 use C4::Budgets qw( GetBudget );
31 use Koha::Acquisition::Orders;
33 Readonly::Scalar my $seg_terminator => q{'};
34 Readonly::Scalar my $separator => q{+};
35 Readonly::Scalar my $component_separator => q{:};
36 Readonly::Scalar my $release_character => q{?};
38 Readonly::Scalar my $NINES_12 => 999_999_999_999;
39 Readonly::Scalar my $NINES_14 => 99_999_999_999_999;
40 Readonly::Scalar my $CHUNKSIZE => 35;
43 my ( $class, $parameter_hashref ) = @_;
46 if ( ref $parameter_hashref ) {
47 $self->{orderlines} = $parameter_hashref->{orderlines};
48 $self->{recipient} = $parameter_hashref->{vendor};
49 $self->{sender} = $parameter_hashref->{ean};
50 $self->{is_response} = $parameter_hashref->{is_response};
53 $self->{basket} = $self->{orderlines}->[0]->basketno;
54 $self->{message_date} = dt_from_string();
57 # validate that its worth proceeding
58 if ( !$self->{orderlines} ) {
59 carp 'No orderlines passed to create order';
62 if ( !$self->{recipient} ) {
63 carp 'No vendor passed to order creation: basket = '
64 . $self->{basket}->basketno;
67 if ( !$self->{sender} ) {
68 carp 'No sender ean passed to order creation: basket = '
69 . $self->{basket}->basketno;
73 # do this once per object not once per orderline
74 my $database = Koha::Database->new();
75 $self->{schema} = $database->schema;
83 if ( !$self->{orderlines} ) {
86 my $filename = 'ordr' . $self->{basket}->basketno;
94 $self->{interchange_control_reference} = int rand($NINES_14);
95 $self->{message_count} = 0;
97 # $self->{segs}; # Message segments
99 $self->{transmission} = q{};
101 $self->{transmission} .= $self->initial_service_segments();
103 $self->{transmission} .= $self->user_data_message_segments();
105 $self->{transmission} .= $self->trailing_service_segments();
107 # Guard against CR LF etc being added in data from DB
108 $self->{transmission}=~s/[\r\n\t]//g;
110 return $self->{transmission};
113 sub msg_date_string {
115 return $self->{message_date}->ymd();
118 sub initial_service_segments {
121 #UNA service string advice - specifies standard separators
122 my $segs = _const('service_string_advice');
124 #UNB interchange header
125 $segs .= $self->interchange_header();
127 #UNG functional group header NOT USED
131 sub interchange_header {
136 'UNB+UNOC:3'; # controlling agency character set syntax version number
138 $hdr .= _interchange_sr_identifier( $self->{sender}->ean,
139 $self->{sender}->id_code_qualifier ); # interchange sender
140 $hdr .= _interchange_sr_identifier( $self->{recipient}->san,
141 $self->{recipient}->id_code_qualifier ); # interchange Recipient
145 # DateTime of preparation
146 $hdr .= $self->{message_date}->format_cldr('yyMMdd:HHmm');
148 $hdr .= $self->interchange_control_reference();
151 # Recipents reference password not usually used in edifact
152 $hdr .= q{+ORDERS}; # application reference
154 #Edifact does not usually include the following
155 # $hdr .= $separator; # Processing priority not usually used in edifact
156 # $hdr .= $separator; # Acknowledgewment request : not usually used in edifact
157 # $hdr .= q{+EANCOM} # Communications agreement id
158 # $hdr .= q{+1} # Test indicator
160 $hdr .= $seg_terminator;
164 sub user_data_message_segments {
167 #UNH message_header :: seg count begins here
168 $self->message_header();
170 $self->order_msg_header();
173 foreach my $ol ( @{ $self->{orderlines} } ) {
175 $self->order_line( $line_number, $ol );
178 $self->message_trailer();
180 my $data_segment_string = join q{}, @{ $self->{segs} };
181 return $data_segment_string;
184 sub message_trailer {
187 # terminate the message
188 $self->add_seg("UNS+S$seg_terminator");
191 # Could be (code 1) total value of QTY segments
192 # or ( code = 2 ) number of lineitems
193 my $num_orderlines = @{ $self->{orderlines} };
194 $self->add_seg("CNT+2:$num_orderlines$seg_terminator");
196 # UNT Message Trailer
197 my $segments_in_message =
198 1 + @{ $self->{segs} }; # count incl UNH & UNT (!!this one)
199 my $reference = $self->message_reference('current');
200 $self->add_seg("UNT+$segments_in_message+$reference$seg_terminator");
204 sub trailing_service_segments {
208 #UNE functional group trailer NOT USED
209 #UNZ interchange trailer
210 $trailer .= $self->interchange_trailer();
215 sub interchange_control_reference {
217 if ( $self->{interchange_control_reference} ) {
218 return sprintf '%014d', $self->{interchange_control_reference};
221 carp 'calling for ref of unencoded order';
222 return 'NONE ASSIGNED';
226 sub message_reference {
227 my ( $self, $function ) = @_;
228 if ( $function eq 'new' || !$self->{message_reference_no} ) {
230 # unique 14 char mesage ref
231 $self->{message_reference_no} = sprintf 'ME%012d', int rand($NINES_12);
233 return $self->{message_reference_no};
239 $self->{segs} = []; # initialize the message
240 $self->{message_count}++; # In practice alwaya 1
242 my $hdr = q{UNH+} . $self->message_reference('new');
243 $hdr .= _const('message_identifier');
244 $self->add_seg($hdr);
248 sub interchange_trailer {
251 my $t = "UNZ+$self->{message_count}+";
252 $t .= $self->interchange_control_reference;
253 $t .= $seg_terminator;
257 sub order_msg_header {
261 # UNH see message_header
264 beginning_of_message(
265 $self->{basket}->basketno,
266 $self->{recipient}->san,
271 push @header, message_date_segment( $self->{message_date} );
273 # NAD-RFF buyer supplier ids
277 $self->{sender}->ean,
278 $self->{sender}->id_code_qualifier
283 $self->{recipient}->san,
284 $self->{recipient}->id_code_qualifier
287 # repeat for for other relevant parties
290 # ISO 4217 code to show default currency prices are quoted in
292 # TBD currency handling
294 $self->add_seg(@header);
298 sub beginning_of_message {
299 my $basketno = shift;
300 my $supplier_san = shift;
301 my $response = shift;
302 my $document_message_no = sprintf '%011d', $basketno;
304 # Peters & Bolinda use the BIC recommendation to use 22V a code not in Edifact
305 # If the order is in response to a quote
307 '5013546025065' => 'Peters',
308 '9377779308820' => 'Bolinda',
311 # my $message_function = 9; # original 7 = retransmission
312 # message_code values
315 # 228 sample order :: order for approval / inspection copies
316 # 22C continuation order for volumes in a set etc.
317 # my $message_code = '220';
318 if ( exists $bic_sans{$supplier_san} && $response ) {
319 return "BGM+22V+$document_message_no+9$seg_terminator";
322 return "BGM+220+$document_message_no+9$seg_terminator";
325 sub name_and_address {
326 my ( $party, $id_code, $id_agency ) = @_;
327 my %qualifier_code = (
329 DELIVERY => 'DP', # delivery location if != buyer
330 INVOICEE => 'IV', # if different from buyer
333 if ( !exists $qualifier_code{$party} ) {
334 carp "No qualifier code for $party";
337 if ( $id_agency eq '14' ) {
338 $id_agency = '9'; # ean coded differently in this seg
341 return "NAD+$qualifier_code{$party}+${id_code}::$id_agency$seg_terminator";
345 my ( $self, $linenumber, $orderline ) = @_;
347 my $basket = Koha::Acquisition::Orders->find( $orderline->ordernumber )->basket;
349 my $schema = $self->{schema};
350 if ( !$orderline->biblionumber )
351 { # cannot generate an orderline without a bib record
354 my $biblionumber = $orderline->biblionumber->biblionumber;
355 my @biblioitems = $schema->resultset('Biblioitem')
356 ->search( { biblionumber => $biblionumber, } );
357 my $biblioitem = $biblioitems[0]; # makes the assumption there is 1 only
358 # or else all have same details
360 my $id_string = $orderline->line_item_id;
362 # LIN line-number in msg :: if we had a 13 digit ean we could add
363 $self->add_seg( lin_segment( $linenumber, $id_string ) );
365 # PIA isbn or other id
367 foreach my $id ( $biblioitem->ean, $biblioitem->issn, $biblioitem->isbn ) {
368 if ( $id && $id ne $id_string ) {
369 push @identifiers, $id;
372 $self->add_seg( additional_product_id( join( ' ', @identifiers ) ) );
375 $self->add_seg( item_description( $orderline->biblionumber, $biblioitem ) );
378 my $qty = join q{}, 'QTY+21:', $orderline->quantity, $seg_terminator;
379 $self->add_seg($qty);
381 # DTM Optional date constraints on delivery
382 # we dont currently support this in koha
383 # GIR copy-related data
385 if ( $basket->effective_create_items eq 'ordering' ) {
386 my @linked_itemnumbers = $orderline->aqorders_items;
388 foreach my $item (@linked_itemnumbers) {
389 my $i_obj = $schema->resultset('Item')->find( $item->itemnumber );
390 if ( defined $i_obj ) {
397 itemtype => $biblioitem->itemtype,
398 shelfmark => $biblioitem->cn_class,
400 my $branch = $orderline->basketno->deliveryplace;
402 $item_hash->{branch} = $branch;
404 for ( 1 .. $orderline->quantity ) {
405 push @items, $item_hash;
408 my $budget = GetBudget( $orderline->budget_id );
409 my $ol_fields = { budget_code => $budget->{budget_code}, };
411 my $item_fields = [];
412 for my $item (@items) {
413 push @{$item_fields},
415 branchcode => $item->homebranch->branchcode,
416 itype => $item->itype,
417 location => $item->location,
418 itemcallnumber => $item->itemcallnumber,
424 ol_fields => $ol_fields,
425 items => $item_fields
430 # TBD what if #items exceeds quantity
432 # FTX free text for current orderline
433 # Pass vendor note in FTX free text segment
434 if ( $orderline->order_vendornote ) {
435 my $vendornote = $orderline->order_vendornote;
437 my $ftx = 'FTX+LIN+++';
439 $ftx .= $seg_terminator;
440 $self->add_seg($ftx);
443 # PRI-CUX-DTM unit price on which order is placed : optional
444 # Coutts read this as 0.00 if not present
445 if ( $orderline->listprice ) {
446 my $price = sprintf 'PRI+AAE:%.2f:CA', $orderline->listprice;
447 $price .= $seg_terminator;
448 $self->add_seg($price);
451 # RFF unique orderline reference no
452 my $rff = join q{}, 'RFF+LI:', $orderline->ordernumber, $seg_terminator;
453 $self->add_seg($rff);
455 # RFF : suppliers unique quotation reference number
456 if ( $orderline->suppliers_reference_number ) {
457 $rff = join q{}, 'RFF+', $orderline->suppliers_reference_qualifier,
458 ':', $orderline->suppliers_reference_number, $seg_terminator;
459 $self->add_seg($rff);
462 # LOC-QTY multiple delivery locations
463 #TBD to specify extra delivery locs
464 # NAD order line name and address
465 #TBD Optionally indicate a name & address or order originator
466 # TDT method of delivey ol-specific
467 # TBD requests a special delivery option
472 sub item_description {
473 my ( $bib, $biblioitem ) = @_;
475 author => $bib->author,
476 title => $bib->title,
477 publisher => $biblioitem->publishercode,
478 year => $biblioitem->publicationyear,
486 # 100 Edition statement
487 # 109 Publisher :: publisher
489 # 170 Date of publication :: year
490 # 220 Binding :: binding
498 for my $field (qw(author title publisher year binding )) {
499 if ( $bib_desc->{$field} ) {
500 my $data = encode_text( $bib_desc->{$field} );
501 push @itm, imd_segment( $code{$field}, $data );
509 my ( $code, $data ) = @_;
511 my $seg_prefix = "IMD+L+$code+:::";
515 while ( my $x = substr $data, 0, $CHUNKSIZE, q{} ) {
516 if ( length $x == $CHUNKSIZE ) {
517 if ( $x =~ s/([?]{1,2})$// ) {
518 $data = "$1$data"; # dont breakup ?' ?? etc
525 foreach my $c (@chunks) {
527 push @segs, "$seg_prefix$c";
530 $segs[-1] .= ":$c$seg_terminator";
534 if ( @segs && $segs[-1] !~ m/[^?]$seg_terminator$/o ) {
535 $segs[-1] .= $seg_terminator;
543 my $orderfields = $params->{ol_fields};
544 my @onorderitems = @{ $params->{items} };
546 my $budget_code = $orderfields->{budget_code};
549 foreach my $item (@onorderitems) {
550 my $elements_added = 0;
554 { identity_number => 'LFN', data => $budget_code };
556 if ( $item->{branchcode} ) {
558 { identity_number => 'LLO', data => $item->{branchcode} };
560 if ( $item->{itype} ) {
562 { identity_number => 'LST', data => $item->{itype} };
564 if ( $item->{location} ) {
566 { identity_number => 'LSQ', data => $item->{location} };
568 if ( $item->{itemcallnumber} ) {
570 { identity_number => 'LSM', data => $item->{itemcallnumber} };
573 # itemcallnumber -> shelfmark
574 if ( $orderfields->{servicing_instruction} ) {
577 identity_number => 'LVT',
578 data => $orderfields->{servicing_instruction}
581 my $e_cnt = 0; # count number of elements so we dont exceed 5 per segment
582 my $copy_no = sprintf 'GIR+%03d', $sequence_no;
584 foreach my $e (@gir_elements) {
586 push @segments, $seg;
590 add_gir_identity_number( $e->{identity_number}, $e->{data} );
595 push @segments, $seg;
600 sub add_gir_identity_number {
601 my ( $number_qualifier, $number ) = @_;
603 return "+${number}:${number_qualifier}";
609 my ( $self, @s ) = @_;
610 foreach my $segment (@s) {
611 if ( $segment !~ m/$seg_terminator$/o ) {
612 $segment .= $seg_terminator;
615 push @{ $self->{segs} }, @s;
620 my ( $line_number, $item_number_id ) = @_;
622 if ($item_number_id) {
623 $item_number_id = "++${item_number_id}:EN";
626 $item_number_id = q||;
629 return "LIN+$line_number$item_number_id$seg_terminator";
632 sub additional_product_id {
633 my $isbn_field = shift;
634 my ( $product_id, $product_code );
635 if ( $isbn_field =~ m/(\d{13})/ ) {
637 $product_code = 'EN';
639 elsif ( $isbn_field =~ m/(\d{9}[Xx\d])/ ) {
641 $product_code = 'IB';
644 # TBD we could have a manufacturers no issn etc
645 if ( !$product_id ) {
649 # function id set to 5 states this is the main product id
650 return "PIA+5+$product_id:$product_code$seg_terminator";
653 sub message_date_segment {
656 # qualifier:message_date:format_code
658 my $message_date = $dt->ymd(q{}); # no sep in edifact format
660 return "DTM+137:$message_date:102$seg_terminator";
666 service_string_advice => q{UNA:+.? '},
667 message_identifier => q{+ORDERS:D:96A:UN:EAN008'},
669 return ( $S{$key} ) ? $S{$key} : q{};
672 sub _interchange_sr_identifier {
673 my ( $identification, $qualifier ) = @_;
675 if ( !$identification ) {
676 $identification = 'RANDOM';
678 carp 'undefined identifier';
681 # 14 EAN International
682 # 31B US SAN (preferred)
683 # also 91 assigned by supplier
684 # also 92 assigned by buyer
685 if ( $qualifier !~ m/^(?:14|31B|91|92)/xms ) {
689 return "+$identification:$qualifier";
695 $string =~ s/[?]/??/g;
698 $string =~ s/[+]/?+/g;
712 Format an Edifact Order message from a Koha basket
716 Generates an Edifact format Order message for a Koha basket.
717 Normally the only methods used directly by the caller would be
718 new to set up the message, encode to return the formatted message
719 and filename to obtain a name under which to store the message
723 Should integrate into Koha::Edifact namespace
724 Can caller interface be made cleaner?
725 Make handling of GIR segments more customizable
731 my $edi_order = Edifact::Order->new(
732 orderlines => \@orderlines,
733 vendor => $vendor_edi_account,
737 instantiate the Edifact::Order object, all parameters are Schema::Resultset objects
738 Called in Koha::Edifact create_edi_order
742 my $filename = $edi_order->filename()
744 returns a filename for the edi order. The filename embeds a reference to the
745 basket the message was created to encode
749 my $edifact_message = $edi_order->encode();
751 Encodes the basket as a valid edifact message ready for transmission
753 =head2 initial_service_segments
755 Creates the service segments which begin the message
757 =head2 interchange_header
759 Return an interchange header encoding sender and recipient
760 ids message date and standards
762 =head2 user_data_message_segments
764 Include message data within the encoded message
766 =head2 message_trailer
768 Terminate message data including control data on number
769 of messages and segments included
771 =head2 trailing_service_segments
773 Include the service segments occurring at the end of the message
775 =head2 interchange_control_reference
777 Returns the unique interchange control reference as a 14 digit number
779 =head2 message_reference
781 On generates and subsequently returns the unique message
782 reference number as a 12 digit number preceded by ME, to generate a new number
783 pass the string 'new'.
784 In practice we encode 1 message per transmission so there is only one message
785 referenced. were we to encode multiple messages a new reference would be
788 =head2 message_header
790 Commences a new message
792 =head2 interchange_trailer
794 returns the UNZ segment which ends the tranmission encoding the
795 message count and control reference for the interchange
797 =head2 order_msg_header
799 Formats the message header segments
801 =head2 beginning_of_message
803 Returns the BGM segment which includes the Koha basket number
805 =head2 name_and_address
807 Parameters: Function ( BUYER, DELIVERY, INVOICE, SUPPLIER)
811 Returns a NAD segment containg the id and agency for for the Function
812 value. Handles the fact that NAD segments encode the value for 'EAN' differently
817 Creates the message segments wncoding an order line
819 =head2 item_description
821 Encodes the biblio item fields Author, title, publisher, date of publication
826 Formats an IMD segment, handles the chunking of data into the 35 character
827 lengths required and the creation of repeat segments
831 Add item level information
833 =head2 add_gir_identity_number
835 Handle the formatting of a GIR element
836 return empty string if no data
840 Adds a parssed array of segments to the objects segment list
841 ensures all segments are properly terminated by '
845 Adds a LIN segment consisting of the line number and the ean number
846 if the passed isbn is valid
848 =head2 additional_product_id
850 Add a PIA segment for an additional product id
852 =head2 message_date_segment
854 Passed a DateTime object returns a correctly formatted DTM segment
858 Stores and returns constant strings for service_string_advice
859 and message_identifier
860 TBD replace with class variables
862 =head2 _interchange_sr_identifier
864 Format sender and receipient identifiers for use in the interchange header
868 Encode textual data into the standard character set ( iso 8859-1 )
869 and quote any Edifact metacharacters
871 =head2 msg_date_string
873 Convenient routine which returns message date as a Y-m-d string
874 useful if the caller wants to log date of creation
878 Colin Campbell <colin.campbell@ptfs-europe.com>
883 Copyright 2014,2015,2016 PTFS-Europe Ltd
884 This program is free software, You may redistribute it under
885 under the terms of the GNU General Public License