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>.
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} = DateTime->now( time_zone => 'local' );
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();
106 return $self->{transmission};
109 sub msg_date_string {
111 return $self->{message_date}->ymd();
114 sub initial_service_segments {
117 #UNA service string advice - specifies standard separators
118 my $segs = _const('service_string_advice');
120 #UNB interchange header
121 $segs .= $self->interchange_header();
123 #UNG functional group header NOT USED
127 sub interchange_header {
132 'UNB+UNOC:3'; # controlling agency character set syntax version number
134 $hdr .= _interchange_sr_identifier( $self->{sender}->ean,
135 $self->{sender}->id_code_qualifier ); # interchange sender
136 $hdr .= _interchange_sr_identifier( $self->{recipient}->san,
137 $self->{recipient}->id_code_qualifier ); # interchange Recipient
141 # DateTime of preparation
142 $hdr .= $self->{message_date}->format_cldr('yyMMdd:HHmm');
144 $hdr .= $self->interchange_control_reference();
147 # Recipents reference password not usually used in edifact
148 $hdr .= q{+ORDERS}; # application reference
150 #Edifact does not usually include the following
151 # $hdr .= $separator; # Processing priority not usually used in edifact
152 # $hdr .= $separator; # Acknowledgewment request : not usually used in edifact
153 # $hdr .= q{+EANCOM} # Communications agreement id
154 # $hdr .= q{+1} # Test indicator
156 $hdr .= $seg_terminator;
160 sub user_data_message_segments {
163 #UNH message_header :: seg count begins here
164 $self->message_header();
166 $self->order_msg_header();
169 foreach my $ol ( @{ $self->{orderlines} } ) {
171 $self->order_line( $line_number, $ol );
174 $self->message_trailer();
176 my $data_segment_string = join q{}, @{ $self->{segs} };
177 return $data_segment_string;
180 sub message_trailer {
183 # terminate the message
184 $self->add_seg("UNS+S$seg_terminator");
187 # Could be (code 1) total value of QTY segments
188 # or ( code = 2 ) number of lineitems
189 my $num_orderlines = @{ $self->{orderlines} };
190 $self->add_seg("CNT+2:$num_orderlines$seg_terminator");
192 # UNT Message Trailer
193 my $segments_in_message =
194 1 + @{ $self->{segs} }; # count incl UNH & UNT (!!this one)
195 my $reference = $self->message_reference('current');
196 $self->add_seg("UNT+$segments_in_message+$reference$seg_terminator");
200 sub trailing_service_segments {
204 #UNE functional group trailer NOT USED
205 #UNZ interchange trailer
206 $trailer .= $self->interchange_trailer();
211 sub interchange_control_reference {
213 if ( $self->{interchange_control_reference} ) {
214 return sprintf '%014d', $self->{interchange_control_reference};
217 carp 'calling for ref of unencoded order';
218 return 'NONE ASSIGNED';
222 sub message_reference {
223 my ( $self, $function ) = @_;
224 if ( $function eq 'new' || !$self->{message_reference_no} ) {
226 # unique 14 char mesage ref
227 $self->{message_reference_no} = sprintf 'ME%012d', int rand($NINES_12);
229 return $self->{message_reference_no};
235 $self->{segs} = []; # initialize the message
236 $self->{message_count}++; # In practice alwaya 1
238 my $hdr = q{UNH+} . $self->message_reference('new');
239 $hdr .= _const('message_identifier');
240 $self->add_seg($hdr);
244 sub interchange_trailer {
247 my $t = "UNZ+$self->{message_count}+";
248 $t .= $self->interchange_control_reference;
249 $t .= $seg_terminator;
253 sub order_msg_header {
257 # UNH see message_header
260 beginning_of_message(
261 $self->{basket}->basketno,
262 $self->{recipient}->san,
267 push @header, message_date_segment( $self->{message_date} );
269 # NAD-RFF buyer supplier ids
273 $self->{sender}->ean,
274 $self->{sender}->id_code_qualifier
279 $self->{recipient}->san,
280 $self->{recipient}->id_code_qualifier
283 # repeat for for other relevant parties
286 # ISO 4217 code to show default currency prices are quoted in
288 # TBD currency handling
290 $self->add_seg(@header);
294 sub beginning_of_message {
295 my $basketno = shift;
296 my $supplier_san = shift;
297 my $response = shift;
298 my $document_message_no = sprintf '%011d', $basketno;
300 # Peters & Bolinda use the BIC recommendation to use 22V a code not in Edifact
301 # If the order is in response to a quote
303 '5013546025065' => 'Peters',
304 '9377779308820' => 'Bolinda',
307 # my $message_function = 9; # original 7 = retransmission
308 # message_code values
311 # 228 sample order :: order for approval / inspection copies
312 # 22C continuation order for volumes in a set etc.
313 # my $message_code = '220';
314 if ( exists $bic_sans{$supplier_san} && $response ) {
315 return "BGM+22V+$document_message_no+9$seg_terminator";
318 return "BGM+220+$document_message_no+9$seg_terminator";
321 sub name_and_address {
322 my ( $party, $id_code, $id_agency ) = @_;
323 my %qualifier_code = (
325 DELIVERY => 'DP', # delivery location if != buyer
326 INVOICEE => 'IV', # if different from buyer
329 if ( !exists $qualifier_code{$party} ) {
330 carp "No qualifier code for $party";
333 if ( $id_agency eq '14' ) {
334 $id_agency = '9'; # ean coded differently in this seg
337 return "NAD+$qualifier_code{$party}+${id_code}::$id_agency$seg_terminator";
341 my ( $self, $linenumber, $orderline ) = @_;
343 my $basket = Koha::Acquisition::Orders->find( $orderline->ordernumber )->basket;
345 my $schema = $self->{schema};
346 if ( !$orderline->biblionumber )
347 { # cannot generate an orderline without a bib record
350 my $biblionumber = $orderline->biblionumber->biblionumber;
351 my @biblioitems = $schema->resultset('Biblioitem')
352 ->search( { biblionumber => $biblionumber, } );
353 my $biblioitem = $biblioitems[0]; # makes the assumption there is 1 only
354 # or else all have same details
356 my $id_string = $orderline->line_item_id;
358 # LIN line-number in msg :: if we had a 13 digit ean we could add
359 $self->add_seg( lin_segment( $linenumber, $id_string ) );
361 # PIA isbn or other id
363 foreach my $id ( $biblioitem->ean, $biblioitem->issn, $biblioitem->isbn ) {
364 if ( $id && $id ne $id_string ) {
365 push @identifiers, $id;
368 $self->add_seg( additional_product_id( join( ' ', @identifiers ) ) );
371 $self->add_seg( item_description( $orderline->biblionumber, $biblioitem ) );
374 my $qty = join q{}, 'QTY+21:', $orderline->quantity, $seg_terminator;
375 $self->add_seg($qty);
377 # DTM Optional date constraints on delivery
378 # we dont currently support this in koha
379 # GIR copy-related data
381 if ( $basket->effective_create_items eq 'ordering' ) {
382 my @linked_itemnumbers = $orderline->aqorders_items;
384 foreach my $item (@linked_itemnumbers) {
385 my $i_obj = $schema->resultset('Item')->find( $item->itemnumber );
386 if ( defined $i_obj ) {
393 itemtype => $biblioitem->itemtype,
394 shelfmark => $biblioitem->cn_class,
396 my $branch = $orderline->basketno->deliveryplace;
398 $item_hash->{branch} = $branch;
400 for ( 1 .. $orderline->quantity ) {
401 push @items, $item_hash;
404 my $budget = GetBudget( $orderline->budget_id );
405 my $ol_fields = { budget_code => $budget->{budget_code}, };
406 if ( $orderline->order_vendornote ) {
407 $ol_fields->{servicing_instruction} = $orderline->order_vendornote;
409 my $item_fields = [];
410 for my $item (@items) {
411 push @{$item_fields},
413 branchcode => $item->homebranch->branchcode,
414 itype => $item->itype,
415 location => $item->location,
416 itemcallnumber => $item->itemcallnumber,
422 ol_fields => $ol_fields,
423 items => $item_fields
428 # TBD what if #items exceeds quantity
430 # FTX free text for current orderline TBD
431 # dont really have a special instructions field to encode here
433 # PRI-CUX-DTM unit price on which order is placed : optional
434 # Coutts read this as 0.00 if not present
435 if ( $orderline->listprice ) {
436 my $price = sprintf 'PRI+AAE:%.2f:CA', $orderline->listprice;
437 $price .= $seg_terminator;
438 $self->add_seg($price);
441 # RFF unique orderline reference no
442 my $rff = join q{}, 'RFF+LI:', $orderline->ordernumber, $seg_terminator;
443 $self->add_seg($rff);
445 # RFF : suppliers unique quotation reference number
446 if ( $orderline->suppliers_reference_number ) {
447 $rff = join q{}, 'RFF+', $orderline->suppliers_reference_qualifier,
448 ':', $orderline->suppliers_reference_number, $seg_terminator;
449 $self->add_seg($rff);
452 # LOC-QTY multiple delivery locations
453 #TBD to specify extra delivery locs
454 # NAD order line name and address
455 #TBD Optionally indicate a name & address or order originator
456 # TDT method of delivey ol-specific
457 # TBD requests a special delivery option
462 sub item_description {
463 my ( $bib, $biblioitem ) = @_;
465 author => $bib->author,
466 title => $bib->title,
467 publisher => $biblioitem->publishercode,
468 year => $biblioitem->publicationyear,
476 # 100 Edition statement
477 # 109 Publisher :: publisher
479 # 170 Date of publication :: year
480 # 220 Binding :: binding
488 for my $field (qw(author title publisher year binding )) {
489 if ( $bib_desc->{$field} ) {
490 my $data = encode_text( $bib_desc->{$field} );
491 push @itm, imd_segment( $code{$field}, $data );
499 my ( $code, $data ) = @_;
501 my $seg_prefix = "IMD+L+$code+:::";
505 while ( my $x = substr $data, 0, $CHUNKSIZE, q{} ) {
506 if ( length $x == $CHUNKSIZE ) {
507 if ( $x =~ s/([?]{1,2})$// ) {
508 $data = "$1$data"; # dont breakup ?' ?? etc
515 foreach my $c (@chunks) {
517 push @segs, "$seg_prefix$c";
520 $segs[-1] .= ":$c$seg_terminator";
524 if ( @segs && $segs[-1] !~ m/[^?]$seg_terminator$/o ) {
525 $segs[-1] .= $seg_terminator;
533 my $orderfields = $params->{ol_fields};
534 my @onorderitems = @{ $params->{items} };
536 my $budget_code = $orderfields->{budget_code};
539 foreach my $item (@onorderitems) {
540 my $elements_added = 0;
544 { identity_number => 'LFN', data => $budget_code };
546 if ( $item->{branchcode} ) {
548 { identity_number => 'LLO', data => $item->{branchcode} };
550 if ( $item->{itype} ) {
552 { identity_number => 'LST', data => $item->{itype} };
554 if ( $item->{location} ) {
556 { identity_number => 'LSQ', data => $item->{location} };
558 if ( $item->{itemcallnumber} ) {
560 { identity_number => 'LSM', data => $item->{itemcallnumber} };
563 # itemcallnumber -> shelfmark
564 if ( $orderfields->{servicing_instruction} ) {
567 identity_number => 'LVT',
568 data => $orderfields->{servicing_instruction}
571 my $e_cnt = 0; # count number of elements so we dont exceed 5 per segment
572 my $copy_no = sprintf 'GIR+%03d', $sequence_no;
574 foreach my $e (@gir_elements) {
576 push @segments, $seg;
580 add_gir_identity_number( $e->{identity_number}, $e->{data} );
585 push @segments, $seg;
590 sub add_gir_identity_number {
591 my ( $number_qualifier, $number ) = @_;
593 return "+${number}:${number_qualifier}";
599 my ( $self, @s ) = @_;
600 foreach my $segment (@s) {
601 if ( $segment !~ m/$seg_terminator$/o ) {
602 $segment .= $seg_terminator;
605 push @{ $self->{segs} }, @s;
610 my ( $line_number, $item_number_id ) = @_;
612 if ($item_number_id) {
613 $item_number_id = "++${item_number_id}:EN";
616 $item_number_id = q||;
619 return "LIN+$line_number$item_number_id$seg_terminator";
622 sub additional_product_id {
623 my $isbn_field = shift;
624 my ( $product_id, $product_code );
625 if ( $isbn_field =~ m/(\d{13})/ ) {
627 $product_code = 'EN';
629 elsif ( $isbn_field =~ m/(\d{9}[Xx\d])/ ) {
631 $product_code = 'IB';
634 # TBD we could have a manufacturers no issn etc
635 if ( !$product_id ) {
639 # function id set to 5 states this is the main product id
640 return "PIA+5+$product_id:$product_code$seg_terminator";
643 sub message_date_segment {
646 # qualifier:message_date:format_code
648 my $message_date = $dt->ymd(q{}); # no sep in edifact format
650 return "DTM+137:$message_date:102$seg_terminator";
656 service_string_advice => q{UNA:+.? '},
657 message_identifier => q{+ORDERS:D:96A:UN:EAN008'},
659 return ( $S{$key} ) ? $S{$key} : q{};
662 sub _interchange_sr_identifier {
663 my ( $identification, $qualifier ) = @_;
665 if ( !$identification ) {
666 $identification = 'RANDOM';
668 carp 'undefined identifier';
671 # 14 EAN International
672 # 31B US SAN (preferred)
673 # also 91 assigned by supplier
674 # also 92 assigned by buyer
675 if ( $qualifier !~ m/^(?:14|31B|91|92)/xms ) {
679 return "+$identification:$qualifier";
685 $string =~ s/[?]/??/g;
688 $string =~ s/[+]/?+/g;
702 Format an Edifact Order message from a Koha basket
706 Generates an Edifact format Order message for a Koha basket.
707 Normally the only methods used directly by the caller would be
708 new to set up the message, encode to return the formatted message
709 and filename to obtain a name under which to store the message
713 Should integrate into Koha::Edifact namespace
714 Can caller interface be made cleaner?
715 Make handling of GIR segments more customizable
721 my $edi_order = Edifact::Order->new(
722 orderlines => \@orderlines,
723 vendor => $vendor_edi_account,
727 instantiate the Edifact::Order object, all parameters are Schema::Resultset objects
728 Called in Koha::Edifact create_edi_order
732 my $filename = $edi_order->filename()
734 returns a filename for the edi order. The filename embeds a reference to the
735 basket the message was created to encode
739 my $edifact_message = $edi_order->encode();
741 Encodes the basket as a valid edifact message ready for transmission
743 =head2 initial_service_segments
745 Creates the service segments which begin the message
747 =head2 interchange_header
749 Return an interchange header encoding sender and recipient
750 ids message date and standards
752 =head2 user_data_message_segments
754 Include message data within the encoded message
756 =head2 message_trailer
758 Terminate message data including control data on number
759 of messages and segments included
761 =head2 trailing_service_segments
763 Include the service segments occurring at the end of the message
765 =head2 interchange_control_reference
767 Returns the unique interchange control reference as a 14 digit number
769 =head2 message_reference
771 On generates and subsequently returns the unique message
772 reference number as a 12 digit number preceded by ME, to generate a new number
773 pass the string 'new'.
774 In practice we encode 1 message per transmission so there is only one message
775 referenced. were we to encode multiple messages a new reference would be
778 =head2 message_header
780 Commences a new message
782 =head2 interchange_trailer
784 returns the UNZ segment which ends the tranmission encoding the
785 message count and control reference for the interchange
787 =head2 order_msg_header
789 Formats the message header segments
791 =head2 beginning_of_message
793 Returns the BGM segment which includes the Koha basket number
795 =head2 name_and_address
797 Parameters: Function ( BUYER, DELIVERY, INVOICE, SUPPLIER)
801 Returns a NAD segment containg the id and agency for for the Function
802 value. Handles the fact that NAD segments encode the value for 'EAN' differently
807 Creates the message segments wncoding an order line
809 =head2 item_description
811 Encodes the biblio item fields Author, title, publisher, date of publication
816 Formats an IMD segment, handles the chunking of data into the 35 character
817 lengths required and the creation of repeat segments
821 Add item level information
823 =head2 add_gir_identity_number
825 Handle the formatting of a GIR element
826 return empty string if no data
830 Adds a parssed array of segments to the objects segment list
831 ensures all segments are properly terminated by '
835 Adds a LIN segment consisting of the line number and the ean number
836 if the passed isbn is valid
838 =head2 additional_product_id
840 Add a PIA segment for an additional product id
842 =head2 message_date_segment
844 Passed a DateTime object returns a correctly formatted DTM segment
848 Stores and returns constant strings for service_string_advice
849 and message_identifier
850 TBD replace with class variables
852 =head2 _interchange_sr_identifier
854 Format sender and receipient identifiers for use in the interchange header
858 Encode textual data into the standard character set ( iso 8859-1 )
859 and quote any Edifact metacharacters
861 =head2 msg_date_string
863 Convenient routine which returns message date as a Y-m-d string
864 useful if the caller wants to log date of creation
868 Colin Campbell <colin.campbell@ptfs-europe.com>
873 Copyright 2014,2015,2016 PTFS-Europe Ltd
874 This program is free software, You may redistribute it under
875 under the terms of the GNU General Public License