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}->standard,
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 $standard = shift;
301 my $response = shift;
302 my $document_message_no = sprintf '%011d', $basketno;
304 # my $message_function = 9; # original 7 = retransmission
305 # message_code values
308 # 228 sample order :: order for approval / inspection copies
309 # 22C continuation order for volumes in a set etc.
310 # my $message_code = '220';
312 # If the order is in response to a quote and we're dealing with a BIC supplier
313 my $code = ( $response && ( $standard eq 'BIC' ) ) ? '22V' : '220';
314 return "BGM+$code+$document_message_no+9$seg_terminator";
317 sub name_and_address {
318 my ( $party, $id_code, $id_agency ) = @_;
319 my %qualifier_code = (
321 DELIVERY => 'DP', # delivery location if != buyer
322 INVOICEE => 'IV', # if different from buyer
325 if ( !exists $qualifier_code{$party} ) {
326 carp "No qualifier code for $party";
329 if ( $id_agency eq '14' ) {
330 $id_agency = '9'; # ean coded differently in this seg
333 return "NAD+$qualifier_code{$party}+${id_code}::$id_agency$seg_terminator";
337 my ( $self, $linenumber, $orderline ) = @_;
339 my $basket = Koha::Acquisition::Orders->find( $orderline->ordernumber )->basket;
341 my $schema = $self->{schema};
342 if ( !$orderline->biblionumber )
343 { # cannot generate an orderline without a bib record
346 my $biblionumber = $orderline->biblionumber->biblionumber;
347 my @biblioitems = $schema->resultset('Biblioitem')
348 ->search( { biblionumber => $biblionumber, } );
349 my $biblioitem = $biblioitems[0]; # makes the assumption there is 1 only
350 # or else all have same details
352 my $id_string = $orderline->line_item_id;
354 # LIN line-number in msg :: if we had a 13 digit ean we could add
355 $self->add_seg( lin_segment( $linenumber, $id_string ) );
357 # PIA isbn or other id
359 foreach my $id ( $biblioitem->ean, $biblioitem->issn, $biblioitem->isbn ) {
360 if ( $id && $id ne $id_string ) {
361 push @identifiers, $id;
364 $self->add_seg( additional_product_id( join( ' ', @identifiers ) ) );
367 $self->add_seg( item_description( $orderline->biblionumber, $biblioitem ) );
370 my $qty = join q{}, 'QTY+21:', $orderline->quantity, $seg_terminator;
371 $self->add_seg($qty);
373 # DTM Optional date constraints on delivery
374 # we dont currently support this in koha
375 # GIR copy-related data
377 if ( $basket->effective_create_items eq 'ordering' ) {
378 my @linked_itemnumbers = $orderline->aqorders_items;
380 foreach my $item (@linked_itemnumbers) {
381 my $i_obj = $schema->resultset('Item')->find( $item->itemnumber );
382 if ( defined $i_obj ) {
384 branchcode => $i_obj->get_column('homebranch'),
385 itype => $i_obj->effective_itemtype,
386 location => $i_obj->location,
387 itemcallnumber => $i_obj->itemcallnumber,
394 itype => $biblioitem->itemtype,
395 itemcallnumber => $biblioitem->cn_class,
397 my $branch = $orderline->basketno->deliveryplace;
399 $item_hash->{branchcode} = $branch;
401 for ( 1 .. $orderline->quantity ) {
402 push @items, $item_hash;
405 my $budget = GetBudget( $orderline->budget_id );
406 my $ol_fields = { budget_code => $budget->{budget_code}, };
408 my $item_fields = [];
409 for my $item (@items) {
410 push @{$item_fields},
412 branchcode => $item->{branchcode},
413 itype => $item->{itype},
414 location => $item->{location},
415 itemcallnumber => $item->{itemcallnumber},
421 ol_fields => $ol_fields,
422 items => $item_fields
427 # TBD what if #items exceeds quantity
429 # FTX free text for current orderline
430 # Pass vendor note in FTX free text segment
431 if ( $orderline->order_vendornote ) {
432 my $vendornote = $orderline->order_vendornote;
434 my $ftx = 'FTX+LIN+++';
436 $ftx .= $seg_terminator;
437 $self->add_seg($ftx);
440 # PRI-CUX-DTM unit price on which order is placed : optional
441 # Coutts read this as 0.00 if not present
442 if ( $orderline->listprice ) {
443 my $price = sprintf 'PRI+AAE:%.2f:CA', $orderline->listprice;
444 $price .= $seg_terminator;
445 $self->add_seg($price);
448 # RFF unique orderline reference no
449 my $rff = join q{}, 'RFF+LI:', $orderline->ordernumber, $seg_terminator;
450 $self->add_seg($rff);
452 # RFF : suppliers unique quotation reference number
453 if ( $orderline->suppliers_reference_number ) {
454 $rff = join q{}, 'RFF+', $orderline->suppliers_reference_qualifier,
455 ':', $orderline->suppliers_reference_number, $seg_terminator;
456 $self->add_seg($rff);
459 # LOC-QTY multiple delivery locations
460 #TBD to specify extra delivery locs
461 # NAD order line name and address
462 #TBD Optionally indicate a name & address or order originator
463 # TDT method of delivey ol-specific
464 # TBD requests a special delivery option
469 sub item_description {
470 my ( $bib, $biblioitem ) = @_;
472 author => $bib->author,
473 title => $bib->title,
474 publisher => $biblioitem->publishercode,
475 year => $biblioitem->publicationyear,
483 # 100 Edition statement
484 # 109 Publisher :: publisher
486 # 170 Date of publication :: year
487 # 220 Binding :: binding
495 for my $field (qw(author title publisher year binding )) {
496 if ( $bib_desc->{$field} ) {
497 my $data = encode_text( $bib_desc->{$field} );
498 push @itm, imd_segment( $code{$field}, $data );
506 my ( $code, $data ) = @_;
508 my $seg_prefix = "IMD+L+$code+:::";
512 while ( my $x = substr $data, 0, $CHUNKSIZE, q{} ) {
513 if ( length $x == $CHUNKSIZE ) {
514 if ( $x =~ s/([?]{1,2})$// ) {
515 $data = "$1$data"; # dont breakup ?' ?? etc
522 foreach my $c (@chunks) {
524 push @segs, "$seg_prefix$c";
527 $segs[-1] .= ":$c$seg_terminator";
531 if ( @segs && $segs[-1] !~ m/[^?]$seg_terminator$/o ) {
532 $segs[-1] .= $seg_terminator;
540 my $orderfields = $params->{ol_fields};
541 my @onorderitems = @{ $params->{items} };
543 my $budget_code = $orderfields->{budget_code};
546 foreach my $item (@onorderitems) {
547 my $elements_added = 0;
551 { identity_number => 'LFN', data => $budget_code };
553 if ( $item->{branchcode} ) {
555 { identity_number => 'LLO', data => $item->{branchcode} };
557 if ( $item->{itype} ) {
559 { identity_number => 'LST', data => $item->{itype} };
561 if ( $item->{location} ) {
563 { identity_number => 'LSQ', data => $item->{location} };
565 if ( $item->{itemcallnumber} ) {
567 { identity_number => 'LSM', data => $item->{itemcallnumber} };
570 # itemcallnumber -> shelfmark
571 if ( $orderfields->{servicing_instruction} ) {
574 identity_number => 'LVT',
575 data => $orderfields->{servicing_instruction}
578 my $e_cnt = 0; # count number of elements so we dont exceed 5 per segment
579 my $copy_no = sprintf 'GIR+%03d', $sequence_no;
581 foreach my $e (@gir_elements) {
583 push @segments, $seg;
587 add_gir_identity_number( $e->{identity_number}, $e->{data} );
592 push @segments, $seg;
597 sub add_gir_identity_number {
598 my ( $number_qualifier, $number ) = @_;
600 return "+${number}:${number_qualifier}";
606 my ( $self, @s ) = @_;
607 foreach my $segment (@s) {
608 if ( $segment !~ m/$seg_terminator$/o ) {
609 $segment .= $seg_terminator;
612 push @{ $self->{segs} }, @s;
617 my ( $line_number, $item_number_id ) = @_;
619 if ($item_number_id) {
620 $item_number_id = "++${item_number_id}:EN";
623 $item_number_id = q||;
626 return "LIN+$line_number$item_number_id$seg_terminator";
629 sub additional_product_id {
630 my $isbn_field = shift;
631 my ( $product_id, $product_code );
632 if ( $isbn_field =~ m/(\d{13})/ ) {
634 $product_code = 'EN';
636 elsif ( $isbn_field =~ m/(\d{9}[Xx\d])/ ) {
638 $product_code = 'IB';
641 # TBD we could have a manufacturers no issn etc
642 if ( !$product_id ) {
646 # function id set to 5 states this is the main product id
647 return "PIA+5+$product_id:$product_code$seg_terminator";
650 sub message_date_segment {
653 # qualifier:message_date:format_code
655 my $message_date = $dt->ymd(q{}); # no sep in edifact format
657 return "DTM+137:$message_date:102$seg_terminator";
663 service_string_advice => q{UNA:+.? '},
664 message_identifier => q{+ORDERS:D:96A:UN:EAN008'},
666 return ( $S{$key} ) ? $S{$key} : q{};
669 sub _interchange_sr_identifier {
670 my ( $identification, $qualifier ) = @_;
672 if ( !$identification ) {
673 $identification = 'RANDOM';
675 carp 'undefined identifier';
678 # 14 EAN International
679 # 31B US SAN (preferred)
680 # also 91 assigned by supplier
681 # also 92 assigned by buyer
682 if ( $qualifier !~ m/^(?:14|31B|91|92)/xms ) {
686 return "+$identification:$qualifier";
692 $string =~ s/[?]/??/g;
695 $string =~ s/[+]/?+/g;
709 Format an Edifact Order message from a Koha basket
713 Generates an Edifact format Order message for a Koha basket.
714 Normally the only methods used directly by the caller would be
715 new to set up the message, encode to return the formatted message
716 and filename to obtain a name under which to store the message
720 Should integrate into Koha::Edifact namespace
721 Can caller interface be made cleaner?
722 Make handling of GIR segments more customizable
728 my $edi_order = Edifact::Order->new(
729 orderlines => \@orderlines,
730 vendor => $vendor_edi_account,
734 instantiate the Edifact::Order object, all parameters are Schema::Resultset objects
735 Called in Koha::Edifact create_edi_order
739 my $filename = $edi_order->filename()
741 returns a filename for the edi order. The filename embeds a reference to the
742 basket the message was created to encode
746 my $edifact_message = $edi_order->encode();
748 Encodes the basket as a valid edifact message ready for transmission
750 =head2 initial_service_segments
752 Creates the service segments which begin the message
754 =head2 interchange_header
756 Return an interchange header encoding sender and recipient
757 ids message date and standards
759 =head2 user_data_message_segments
761 Include message data within the encoded message
763 =head2 message_trailer
765 Terminate message data including control data on number
766 of messages and segments included
768 =head2 trailing_service_segments
770 Include the service segments occurring at the end of the message
772 =head2 interchange_control_reference
774 Returns the unique interchange control reference as a 14 digit number
776 =head2 message_reference
778 On generates and subsequently returns the unique message
779 reference number as a 12 digit number preceded by ME, to generate a new number
780 pass the string 'new'.
781 In practice we encode 1 message per transmission so there is only one message
782 referenced. were we to encode multiple messages a new reference would be
785 =head2 message_header
787 Commences a new message
789 =head2 interchange_trailer
791 returns the UNZ segment which ends the tranmission encoding the
792 message count and control reference for the interchange
794 =head2 order_msg_header
796 Formats the message header segments
798 =head2 beginning_of_message
800 Returns the BGM segment which includes the Koha basket number
802 =head2 name_and_address
804 Parameters: Function ( BUYER, DELIVERY, INVOICE, SUPPLIER)
808 Returns a NAD segment containg the id and agency for for the Function
809 value. Handles the fact that NAD segments encode the value for 'EAN' differently
814 Creates the message segments wncoding an order line
816 =head2 item_description
818 Encodes the biblio item fields Author, title, publisher, date of publication
823 Formats an IMD segment, handles the chunking of data into the 35 character
824 lengths required and the creation of repeat segments
828 Add item level information
830 =head2 add_gir_identity_number
832 Handle the formatting of a GIR element
833 return empty string if no data
837 Adds a parssed array of segments to the objects segment list
838 ensures all segments are properly terminated by '
842 Adds a LIN segment consisting of the line number and the ean number
843 if the passed isbn is valid
845 =head2 additional_product_id
847 Add a PIA segment for an additional product id
849 =head2 message_date_segment
851 Passed a DateTime object returns a correctly formatted DTM segment
855 Stores and returns constant strings for service_string_advice
856 and message_identifier
857 TBD replace with class variables
859 =head2 _interchange_sr_identifier
861 Format sender and receipient identifiers for use in the interchange header
865 Encode textual data into the standard character set ( iso 8859-1 )
866 and quote any Edifact metacharacters
868 =head2 msg_date_string
870 Convenient routine which returns message date as a Y-m-d string
871 useful if the caller wants to log date of creation
875 Colin Campbell <colin.campbell@ptfs-europe.com>
880 Copyright 2014,2015,2016 PTFS-Europe Ltd
881 This program is free software, You may redistribute it under
882 under the terms of the GNU General Public License