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>.
30 use C4::Budgets qw( GetBudget );
32 use Koha::Acquisition::Orders;
34 Readonly::Scalar my $seg_terminator => q{'};
35 Readonly::Scalar my $separator => q{+};
36 Readonly::Scalar my $component_separator => q{:};
37 Readonly::Scalar my $release_character => q{?};
39 Readonly::Scalar my $NINES_12 => 999_999_999_999;
40 Readonly::Scalar my $NINES_14 => 99_999_999_999_999;
41 Readonly::Scalar my $CHUNKSIZE => 35;
44 my ( $class, $parameter_hashref ) = @_;
47 if ( ref $parameter_hashref ) {
48 $self->{orderlines} = $parameter_hashref->{orderlines};
49 $self->{recipient} = $parameter_hashref->{vendor};
50 $self->{sender} = $parameter_hashref->{ean};
51 $self->{is_response} = $parameter_hashref->{is_response};
54 $self->{basket} = $self->{orderlines}->[0]->basketno;
55 $self->{message_date} = dt_from_string();
58 # validate that its worth proceeding
59 if ( !$self->{orderlines} ) {
60 carp 'No orderlines passed to create order';
63 if ( !$self->{recipient} ) {
64 carp 'No vendor passed to order creation: basket = '
65 . $self->{basket}->basketno;
68 if ( !$self->{sender} ) {
69 carp 'No sender ean passed to order creation: basket = '
70 . $self->{basket}->basketno;
74 # do this once per object not once per orderline
75 my $database = Koha::Database->new();
76 $self->{schema} = $database->schema;
84 if ( !$self->{orderlines} ) {
87 my $filename = 'ordr' . $self->{basket}->basketno;
95 $self->{interchange_control_reference} = int rand($NINES_14);
96 $self->{message_count} = 0;
98 # $self->{segs}; # Message segments
100 $self->{transmission} = q{};
102 $self->{transmission} .= $self->initial_service_segments();
104 $self->{transmission} .= $self->user_data_message_segments();
106 $self->{transmission} .= $self->trailing_service_segments();
108 # Guard against CR LF etc being added in data from DB
109 $self->{transmission}=~s/[\r\n\t]//g;
111 return $self->{transmission};
114 sub msg_date_string {
116 return $self->{message_date}->ymd();
119 sub initial_service_segments {
122 #UNA service string advice - specifies standard separators
123 my $segs = _const('service_string_advice');
125 #UNB interchange header
126 $segs .= $self->interchange_header();
128 #UNG functional group header NOT USED
132 sub interchange_header {
137 'UNB+UNOC:3'; # controlling agency character set syntax version number
139 $hdr .= _interchange_sr_identifier( $self->{sender}->ean,
140 $self->{sender}->id_code_qualifier ); # interchange sender
141 $hdr .= _interchange_sr_identifier( $self->{recipient}->san,
142 $self->{recipient}->id_code_qualifier ); # interchange Recipient
146 # DateTime of preparation
147 $hdr .= $self->{message_date}->format_cldr('yyMMdd:HHmm');
149 $hdr .= $self->interchange_control_reference();
152 # Recipents reference password not usually used in edifact
153 $hdr .= q{+ORDERS}; # application reference
155 #Edifact does not usually include the following
156 # $hdr .= $separator; # Processing priority not usually used in edifact
157 # $hdr .= $separator; # Acknowledgewment request : not usually used in edifact
158 # $hdr .= q{+EANCOM} # Communications agreement id
159 # $hdr .= q{+1} # Test indicator
161 $hdr .= $seg_terminator;
165 sub user_data_message_segments {
168 #UNH message_header :: seg count begins here
169 $self->message_header();
171 $self->order_msg_header();
174 foreach my $ol ( @{ $self->{orderlines} } ) {
176 $self->order_line( $line_number, $ol );
179 $self->message_trailer();
181 my $data_segment_string = join q{}, @{ $self->{segs} };
182 return $data_segment_string;
185 sub message_trailer {
188 # terminate the message
189 $self->add_seg("UNS+S$seg_terminator");
192 # Could be (code 1) total value of QTY segments
193 # or ( code = 2 ) number of lineitems
194 my $num_orderlines = @{ $self->{orderlines} };
195 $self->add_seg("CNT+2:$num_orderlines$seg_terminator");
197 # UNT Message Trailer
198 my $segments_in_message =
199 1 + @{ $self->{segs} }; # count incl UNH & UNT (!!this one)
200 my $reference = $self->message_reference('current');
201 $self->add_seg("UNT+$segments_in_message+$reference$seg_terminator");
205 sub trailing_service_segments {
209 #UNE functional group trailer NOT USED
210 #UNZ interchange trailer
211 $trailer .= $self->interchange_trailer();
216 sub interchange_control_reference {
218 if ( $self->{interchange_control_reference} ) {
219 return sprintf '%014d', $self->{interchange_control_reference};
222 carp 'calling for ref of unencoded order';
223 return 'NONE ASSIGNED';
227 sub message_reference {
228 my ( $self, $function ) = @_;
229 if ( $function eq 'new' || !$self->{message_reference_no} ) {
231 # unique 14 char mesage ref
232 $self->{message_reference_no} = sprintf 'ME%012d', int rand($NINES_12);
234 return $self->{message_reference_no};
240 $self->{segs} = []; # initialize the message
241 $self->{message_count}++; # In practice alwaya 1
243 my $hdr = q{UNH+} . $self->message_reference('new');
244 $hdr .= _const('message_identifier');
245 $self->add_seg($hdr);
249 sub interchange_trailer {
252 my $t = "UNZ+$self->{message_count}+";
253 $t .= $self->interchange_control_reference;
254 $t .= $seg_terminator;
258 sub order_msg_header {
262 # UNH see message_header
265 beginning_of_message(
266 $self->{basket}->basketno,
267 $self->{recipient}->san,
272 push @header, message_date_segment( $self->{message_date} );
274 # NAD-RFF buyer supplier ids
278 $self->{sender}->ean,
279 $self->{sender}->id_code_qualifier
284 $self->{recipient}->san,
285 $self->{recipient}->id_code_qualifier
288 # repeat for for other relevant parties
291 # ISO 4217 code to show default currency prices are quoted in
293 # TBD currency handling
295 $self->add_seg(@header);
299 sub beginning_of_message {
300 my $basketno = shift;
301 my $supplier_san = shift;
302 my $response = shift;
303 my $document_message_no = sprintf '%011d', $basketno;
305 # Peters & Bolinda use the BIC recommendation to use 22V a code not in Edifact
306 # If the order is in response to a quote
308 '5013546025065' => 'Peters',
309 '9377779308820' => 'Bolinda',
312 # my $message_function = 9; # original 7 = retransmission
313 # message_code values
316 # 228 sample order :: order for approval / inspection copies
317 # 22C continuation order for volumes in a set etc.
318 # my $message_code = '220';
319 if ( exists $bic_sans{$supplier_san} && $response ) {
320 return "BGM+22V+$document_message_no+9$seg_terminator";
323 return "BGM+220+$document_message_no+9$seg_terminator";
326 sub name_and_address {
327 my ( $party, $id_code, $id_agency ) = @_;
328 my %qualifier_code = (
330 DELIVERY => 'DP', # delivery location if != buyer
331 INVOICEE => 'IV', # if different from buyer
334 if ( !exists $qualifier_code{$party} ) {
335 carp "No qualifier code for $party";
338 if ( $id_agency eq '14' ) {
339 $id_agency = '9'; # ean coded differently in this seg
342 return "NAD+$qualifier_code{$party}+${id_code}::$id_agency$seg_terminator";
346 my ( $self, $linenumber, $orderline ) = @_;
348 my $basket = Koha::Acquisition::Orders->find( $orderline->ordernumber )->basket;
350 my $schema = $self->{schema};
351 if ( !$orderline->biblionumber )
352 { # cannot generate an orderline without a bib record
355 my $biblionumber = $orderline->biblionumber->biblionumber;
356 my @biblioitems = $schema->resultset('Biblioitem')
357 ->search( { biblionumber => $biblionumber, } );
358 my $biblioitem = $biblioitems[0]; # makes the assumption there is 1 only
359 # or else all have same details
361 my $id_string = $orderline->line_item_id;
363 # LIN line-number in msg :: if we had a 13 digit ean we could add
364 $self->add_seg( lin_segment( $linenumber, $id_string ) );
366 # PIA isbn or other id
368 foreach my $id ( $biblioitem->ean, $biblioitem->issn, $biblioitem->isbn ) {
369 if ( $id && $id ne $id_string ) {
370 push @identifiers, $id;
373 $self->add_seg( additional_product_id( join( ' ', @identifiers ) ) );
376 $self->add_seg( item_description( $orderline->biblionumber, $biblioitem ) );
379 my $qty = join q{}, 'QTY+21:', $orderline->quantity, $seg_terminator;
380 $self->add_seg($qty);
382 # DTM Optional date constraints on delivery
383 # we dont currently support this in koha
384 # GIR copy-related data
386 if ( $basket->effective_create_items eq 'ordering' ) {
387 my @linked_itemnumbers = $orderline->aqorders_items;
389 foreach my $item (@linked_itemnumbers) {
390 my $i_obj = $schema->resultset('Item')->find( $item->itemnumber );
391 if ( defined $i_obj ) {
398 itemtype => $biblioitem->itemtype,
399 shelfmark => $biblioitem->cn_class,
401 my $branch = $orderline->basketno->deliveryplace;
403 $item_hash->{branch} = $branch;
405 for ( 1 .. $orderline->quantity ) {
406 push @items, $item_hash;
409 my $budget = GetBudget( $orderline->budget_id );
410 my $ol_fields = { budget_code => $budget->{budget_code}, };
412 my $item_fields = [];
413 for my $item (@items) {
414 push @{$item_fields},
416 branchcode => $item->homebranch->branchcode,
417 itype => $item->itype,
418 location => $item->location,
419 itemcallnumber => $item->itemcallnumber,
425 ol_fields => $ol_fields,
426 items => $item_fields
431 # TBD what if #items exceeds quantity
433 # FTX free text for current orderline
434 # Pass vendor note in FTX free text segment
435 if ( $orderline->order_vendornote ) {
436 my $vendornote = $orderline->order_vendornote;
438 my $ftx = 'FTX+LIN+++';
440 $ftx .= $seg_terminator;
441 $self->add_seg($ftx);
444 # PRI-CUX-DTM unit price on which order is placed : optional
445 # Coutts read this as 0.00 if not present
446 if ( $orderline->listprice ) {
447 my $price = sprintf 'PRI+AAE:%.2f:CA', $orderline->listprice;
448 $price .= $seg_terminator;
449 $self->add_seg($price);
452 # RFF unique orderline reference no
453 my $rff = join q{}, 'RFF+LI:', $orderline->ordernumber, $seg_terminator;
454 $self->add_seg($rff);
456 # RFF : suppliers unique quotation reference number
457 if ( $orderline->suppliers_reference_number ) {
458 $rff = join q{}, 'RFF+', $orderline->suppliers_reference_qualifier,
459 ':', $orderline->suppliers_reference_number, $seg_terminator;
460 $self->add_seg($rff);
463 # LOC-QTY multiple delivery locations
464 #TBD to specify extra delivery locs
465 # NAD order line name and address
466 #TBD Optionally indicate a name & address or order originator
467 # TDT method of delivey ol-specific
468 # TBD requests a special delivery option
473 sub item_description {
474 my ( $bib, $biblioitem ) = @_;
476 author => $bib->author,
477 title => $bib->title,
478 publisher => $biblioitem->publishercode,
479 year => $biblioitem->publicationyear,
487 # 100 Edition statement
488 # 109 Publisher :: publisher
490 # 170 Date of publication :: year
491 # 220 Binding :: binding
499 for my $field (qw(author title publisher year binding )) {
500 if ( $bib_desc->{$field} ) {
501 my $data = encode_text( $bib_desc->{$field} );
502 push @itm, imd_segment( $code{$field}, $data );
510 my ( $code, $data ) = @_;
512 my $seg_prefix = "IMD+L+$code+:::";
516 while ( my $x = substr $data, 0, $CHUNKSIZE, q{} ) {
517 if ( length $x == $CHUNKSIZE ) {
518 if ( $x =~ s/([?]{1,2})$// ) {
519 $data = "$1$data"; # dont breakup ?' ?? etc
526 foreach my $c (@chunks) {
528 push @segs, "$seg_prefix$c";
531 $segs[-1] .= ":$c$seg_terminator";
535 if ( @segs && $segs[-1] !~ m/[^?]$seg_terminator$/o ) {
536 $segs[-1] .= $seg_terminator;
544 my $orderfields = $params->{ol_fields};
545 my @onorderitems = @{ $params->{items} };
547 my $budget_code = $orderfields->{budget_code};
550 foreach my $item (@onorderitems) {
551 my $elements_added = 0;
555 { identity_number => 'LFN', data => $budget_code };
557 if ( $item->{branchcode} ) {
559 { identity_number => 'LLO', data => $item->{branchcode} };
561 if ( $item->{itype} ) {
563 { identity_number => 'LST', data => $item->{itype} };
565 if ( $item->{location} ) {
567 { identity_number => 'LSQ', data => $item->{location} };
569 if ( $item->{itemcallnumber} ) {
571 { identity_number => 'LSM', data => $item->{itemcallnumber} };
574 # itemcallnumber -> shelfmark
575 if ( $orderfields->{servicing_instruction} ) {
578 identity_number => 'LVT',
579 data => $orderfields->{servicing_instruction}
582 my $e_cnt = 0; # count number of elements so we dont exceed 5 per segment
583 my $copy_no = sprintf 'GIR+%03d', $sequence_no;
585 foreach my $e (@gir_elements) {
587 push @segments, $seg;
591 add_gir_identity_number( $e->{identity_number}, $e->{data} );
596 push @segments, $seg;
601 sub add_gir_identity_number {
602 my ( $number_qualifier, $number ) = @_;
604 return "+${number}:${number_qualifier}";
610 my ( $self, @s ) = @_;
611 foreach my $segment (@s) {
612 if ( $segment !~ m/$seg_terminator$/o ) {
613 $segment .= $seg_terminator;
616 push @{ $self->{segs} }, @s;
621 my ( $line_number, $item_number_id ) = @_;
623 if ($item_number_id) {
624 $item_number_id = "++${item_number_id}:EN";
627 $item_number_id = q||;
630 return "LIN+$line_number$item_number_id$seg_terminator";
633 sub additional_product_id {
634 my $isbn_field = shift;
635 my ( $product_id, $product_code );
636 if ( $isbn_field =~ m/(\d{13})/ ) {
638 $product_code = 'EN';
640 elsif ( $isbn_field =~ m/(\d{9}[Xx\d])/ ) {
642 $product_code = 'IB';
645 # TBD we could have a manufacturers no issn etc
646 if ( !$product_id ) {
650 # function id set to 5 states this is the main product id
651 return "PIA+5+$product_id:$product_code$seg_terminator";
654 sub message_date_segment {
657 # qualifier:message_date:format_code
659 my $message_date = $dt->ymd(q{}); # no sep in edifact format
661 return "DTM+137:$message_date:102$seg_terminator";
667 service_string_advice => q{UNA:+.? '},
668 message_identifier => q{+ORDERS:D:96A:UN:EAN008'},
670 return ( $S{$key} ) ? $S{$key} : q{};
673 sub _interchange_sr_identifier {
674 my ( $identification, $qualifier ) = @_;
676 if ( !$identification ) {
677 $identification = 'RANDOM';
679 carp 'undefined identifier';
682 # 14 EAN International
683 # 31B US SAN (preferred)
684 # also 91 assigned by supplier
685 # also 92 assigned by buyer
686 if ( $qualifier !~ m/^(?:14|31B|91|92)/xms ) {
690 return "+$identification:$qualifier";
696 $string =~ s/[?]/??/g;
699 $string =~ s/[+]/?+/g;
713 Format an Edifact Order message from a Koha basket
717 Generates an Edifact format Order message for a Koha basket.
718 Normally the only methods used directly by the caller would be
719 new to set up the message, encode to return the formatted message
720 and filename to obtain a name under which to store the message
724 Should integrate into Koha::Edifact namespace
725 Can caller interface be made cleaner?
726 Make handling of GIR segments more customizable
732 my $edi_order = Edifact::Order->new(
733 orderlines => \@orderlines,
734 vendor => $vendor_edi_account,
738 instantiate the Edifact::Order object, all parameters are Schema::Resultset objects
739 Called in Koha::Edifact create_edi_order
743 my $filename = $edi_order->filename()
745 returns a filename for the edi order. The filename embeds a reference to the
746 basket the message was created to encode
750 my $edifact_message = $edi_order->encode();
752 Encodes the basket as a valid edifact message ready for transmission
754 =head2 initial_service_segments
756 Creates the service segments which begin the message
758 =head2 interchange_header
760 Return an interchange header encoding sender and recipient
761 ids message date and standards
763 =head2 user_data_message_segments
765 Include message data within the encoded message
767 =head2 message_trailer
769 Terminate message data including control data on number
770 of messages and segments included
772 =head2 trailing_service_segments
774 Include the service segments occurring at the end of the message
776 =head2 interchange_control_reference
778 Returns the unique interchange control reference as a 14 digit number
780 =head2 message_reference
782 On generates and subsequently returns the unique message
783 reference number as a 12 digit number preceded by ME, to generate a new number
784 pass the string 'new'.
785 In practice we encode 1 message per transmission so there is only one message
786 referenced. were we to encode multiple messages a new reference would be
789 =head2 message_header
791 Commences a new message
793 =head2 interchange_trailer
795 returns the UNZ segment which ends the tranmission encoding the
796 message count and control reference for the interchange
798 =head2 order_msg_header
800 Formats the message header segments
802 =head2 beginning_of_message
804 Returns the BGM segment which includes the Koha basket number
806 =head2 name_and_address
808 Parameters: Function ( BUYER, DELIVERY, INVOICE, SUPPLIER)
812 Returns a NAD segment containg the id and agency for for the Function
813 value. Handles the fact that NAD segments encode the value for 'EAN' differently
818 Creates the message segments wncoding an order line
820 =head2 item_description
822 Encodes the biblio item fields Author, title, publisher, date of publication
827 Formats an IMD segment, handles the chunking of data into the 35 character
828 lengths required and the creation of repeat segments
832 Add item level information
834 =head2 add_gir_identity_number
836 Handle the formatting of a GIR element
837 return empty string if no data
841 Adds a parssed array of segments to the objects segment list
842 ensures all segments are properly terminated by '
846 Adds a LIN segment consisting of the line number and the ean number
847 if the passed isbn is valid
849 =head2 additional_product_id
851 Add a PIA segment for an additional product id
853 =head2 message_date_segment
855 Passed a DateTime object returns a correctly formatted DTM segment
859 Stores and returns constant strings for service_string_advice
860 and message_identifier
861 TBD replace with class variables
863 =head2 _interchange_sr_identifier
865 Format sender and receipient identifiers for use in the interchange header
869 Encode textual data into the standard character set ( iso 8859-1 )
870 and quote any Edifact metacharacters
872 =head2 msg_date_string
874 Convenient routine which returns message date as a Y-m-d string
875 useful if the caller wants to log date of creation
879 Colin Campbell <colin.campbell@ptfs-europe.com>
884 Copyright 2014,2015,2016 PTFS-Europe Ltd
885 This program is free software, You may redistribute it under
886 under the terms of the GNU General Public License