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
376 my $lsq_field = C4::Context->preference('EdifactLSQ');
378 if ( $basket->effective_create_items eq 'ordering' ) {
380 my @linked_itemnumbers = $orderline->aqorders_items;
381 foreach my $item (@linked_itemnumbers) {
382 my $i_obj = $schema->resultset('Item')->find( $item->itemnumber );
383 if ( defined $i_obj ) {
385 branchcode => $i_obj->get_column('homebranch'),
386 itype => $i_obj->effective_itemtype,
387 $lsq_field => $i_obj->$lsq_field,
388 itemcallnumber => $i_obj->itemcallnumber,
395 itype => $biblioitem->itemtype,
396 itemcallnumber => $biblioitem->cn_class,
398 my $branch = $orderline->basketno->deliveryplace;
400 $item_hash->{branchcode} = $branch;
402 for ( 1 .. $orderline->quantity ) {
403 push @items, $item_hash;
406 my $budget = GetBudget( $orderline->budget_id );
407 my $ol_fields = { budget_code => $budget->{budget_code}, };
409 my $item_fields = [];
410 for my $item (@items) {
411 push @{$item_fields},
413 branchcode => $item->{branchcode},
414 itype => $item->{itype},
415 $lsq_field => $item->{$lsq_field},
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
431 # Pass vendor note in FTX free text segment
432 if ( $orderline->order_vendornote ) {
433 my $vendornote = $orderline->order_vendornote;
435 my $ftx = 'FTX+LIN+++';
437 $ftx .= $seg_terminator;
438 $self->add_seg($ftx);
441 # PRI-CUX-DTM unit price on which order is placed : optional
442 # Coutts read this as 0.00 if not present
443 if ( $orderline->listprice ) {
444 my $price = sprintf 'PRI+AAE:%.2f:CA', $orderline->listprice;
445 $price .= $seg_terminator;
446 $self->add_seg($price);
449 # RFF unique orderline reference no
450 my $rff = join q{}, 'RFF+LI:', $orderline->ordernumber, $seg_terminator;
451 $self->add_seg($rff);
453 # RFF : suppliers unique quotation reference number
454 if ( $orderline->suppliers_reference_number ) {
455 $rff = join q{}, 'RFF+', $orderline->suppliers_reference_qualifier,
456 ':', $orderline->suppliers_reference_number, $seg_terminator;
457 $self->add_seg($rff);
460 # LOC-QTY multiple delivery locations
461 #TBD to specify extra delivery locs
462 # NAD order line name and address
463 #TBD Optionally indicate a name & address or order originator
464 # TDT method of delivey ol-specific
465 # TBD requests a special delivery option
470 sub item_description {
471 my ( $bib, $biblioitem ) = @_;
473 author => $bib->author,
474 title => $bib->title,
475 publisher => $biblioitem->publishercode,
476 year => $biblioitem->publicationyear,
484 # 100 Edition statement
485 # 109 Publisher :: publisher
487 # 170 Date of publication :: year
488 # 220 Binding :: binding
496 for my $field (qw(author title publisher year binding )) {
497 if ( $bib_desc->{$field} ) {
498 my $data = encode_text( $bib_desc->{$field} );
499 push @itm, imd_segment( $code{$field}, $data );
507 my ( $code, $data ) = @_;
509 my $seg_prefix = "IMD+L+$code+:::";
513 while ( my $x = substr $data, 0, $CHUNKSIZE, q{} ) {
514 if ( length $x == $CHUNKSIZE ) {
515 if ( $x =~ s/([?]{1,2})$// ) {
516 $data = "$1$data"; # dont breakup ?' ?? etc
523 foreach my $c (@chunks) {
525 push @segs, "$seg_prefix$c";
528 $segs[-1] .= ":$c$seg_terminator";
532 if ( @segs && $segs[-1] !~ m/[^?]$seg_terminator$/o ) {
533 $segs[-1] .= $seg_terminator;
541 my $orderfields = $params->{ol_fields};
542 my @onorderitems = @{ $params->{items} };
544 my $budget_code = $orderfields->{budget_code};
547 my $lsq_field = C4::Context->preference('EdifactLSQ');
548 foreach my $item (@onorderitems) {
549 my $elements_added = 0;
553 { identity_number => 'LFN', data => $budget_code };
555 if ( $item->{branchcode} ) {
557 { identity_number => 'LLO', data => $item->{branchcode} };
559 if ( $item->{itype} ) {
561 { identity_number => 'LST', data => $item->{itype} };
563 if ( $item->{$lsq_field} ) {
565 { identity_number => 'LSQ', data => $item->{$lsq_field} };
567 if ( $item->{itemcallnumber} ) {
569 { identity_number => 'LSM', data => $item->{itemcallnumber} };
572 # itemcallnumber -> shelfmark
573 if ( $orderfields->{servicing_instruction} ) {
576 identity_number => 'LVT',
577 data => $orderfields->{servicing_instruction}
580 my $e_cnt = 0; # count number of elements so we dont exceed 5 per segment
581 my $copy_no = sprintf 'GIR+%03d', $sequence_no;
583 foreach my $e (@gir_elements) {
585 push @segments, $seg;
589 add_gir_identity_number( $e->{identity_number}, $e->{data} );
594 push @segments, $seg;
599 sub add_gir_identity_number {
600 my ( $number_qualifier, $number ) = @_;
602 return "+${number}:${number_qualifier}";
608 my ( $self, @s ) = @_;
609 foreach my $segment (@s) {
610 if ( $segment !~ m/$seg_terminator$/o ) {
611 $segment .= $seg_terminator;
614 push @{ $self->{segs} }, @s;
619 my ( $line_number, $item_number_id ) = @_;
621 if ($item_number_id) {
622 $item_number_id = "++${item_number_id}:EN";
625 $item_number_id = q||;
628 return "LIN+$line_number$item_number_id$seg_terminator";
631 sub additional_product_id {
632 my $isbn_field = shift;
633 my ( $product_id, $product_code );
634 if ( $isbn_field =~ m/(\d{13})/ ) {
636 $product_code = 'EN';
638 elsif ( $isbn_field =~ m/(\d{9}[Xx\d])/ ) {
640 $product_code = 'IB';
643 # TBD we could have a manufacturers no issn etc
644 if ( !$product_id ) {
648 # function id set to 5 states this is the main product id
649 return "PIA+5+$product_id:$product_code$seg_terminator";
652 sub message_date_segment {
655 # qualifier:message_date:format_code
657 my $message_date = $dt->ymd(q{}); # no sep in edifact format
659 return "DTM+137:$message_date:102$seg_terminator";
665 service_string_advice => q{UNA:+.? '},
666 message_identifier => q{+ORDERS:D:96A:UN:EAN008'},
668 return ( $S{$key} ) ? $S{$key} : q{};
671 sub _interchange_sr_identifier {
672 my ( $identification, $qualifier ) = @_;
674 if ( !$identification ) {
675 $identification = 'RANDOM';
677 carp 'undefined identifier';
680 # 14 EAN International
681 # 31B US SAN (preferred)
682 # also 91 assigned by supplier
683 # also 92 assigned by buyer
684 if ( $qualifier !~ m/^(?:14|31B|91|92)/xms ) {
688 return "+$identification:$qualifier";
694 $string =~ s/[?]/??/g;
697 $string =~ s/[+]/?+/g;
711 Format an Edifact Order message from a Koha basket
715 Generates an Edifact format Order message for a Koha basket.
716 Normally the only methods used directly by the caller would be
717 new to set up the message, encode to return the formatted message
718 and filename to obtain a name under which to store the message
722 Should integrate into Koha::Edifact namespace
723 Can caller interface be made cleaner?
724 Make handling of GIR segments more customizable
730 my $edi_order = Edifact::Order->new(
731 orderlines => \@orderlines,
732 vendor => $vendor_edi_account,
736 instantiate the Edifact::Order object, all parameters are Schema::Resultset objects
737 Called in Koha::Edifact create_edi_order
741 my $filename = $edi_order->filename()
743 returns a filename for the edi order. The filename embeds a reference to the
744 basket the message was created to encode
748 my $edifact_message = $edi_order->encode();
750 Encodes the basket as a valid edifact message ready for transmission
752 =head2 initial_service_segments
754 Creates the service segments which begin the message
756 =head2 interchange_header
758 Return an interchange header encoding sender and recipient
759 ids message date and standards
761 =head2 user_data_message_segments
763 Include message data within the encoded message
765 =head2 message_trailer
767 Terminate message data including control data on number
768 of messages and segments included
770 =head2 trailing_service_segments
772 Include the service segments occurring at the end of the message
774 =head2 interchange_control_reference
776 Returns the unique interchange control reference as a 14 digit number
778 =head2 message_reference
780 On generates and subsequently returns the unique message
781 reference number as a 12 digit number preceded by ME, to generate a new number
782 pass the string 'new'.
783 In practice we encode 1 message per transmission so there is only one message
784 referenced. were we to encode multiple messages a new reference would be
787 =head2 message_header
789 Commences a new message
791 =head2 interchange_trailer
793 returns the UNZ segment which ends the tranmission encoding the
794 message count and control reference for the interchange
796 =head2 order_msg_header
798 Formats the message header segments
800 =head2 beginning_of_message
802 Returns the BGM segment which includes the Koha basket number
804 =head2 name_and_address
806 Parameters: Function ( BUYER, DELIVERY, INVOICE, SUPPLIER)
810 Returns a NAD segment containg the id and agency for for the Function
811 value. Handles the fact that NAD segments encode the value for 'EAN' differently
816 Creates the message segments wncoding an order line
818 =head2 item_description
820 Encodes the biblio item fields Author, title, publisher, date of publication
825 Formats an IMD segment, handles the chunking of data into the 35 character
826 lengths required and the creation of repeat segments
830 Add item level information
832 =head2 add_gir_identity_number
834 Handle the formatting of a GIR element
835 return empty string if no data
839 Adds a parssed array of segments to the objects segment list
840 ensures all segments are properly terminated by '
844 Adds a LIN segment consisting of the line number and the ean number
845 if the passed isbn is valid
847 =head2 additional_product_id
849 Add a PIA segment for an additional product id
851 =head2 message_date_segment
853 Passed a DateTime object returns a correctly formatted DTM segment
857 Stores and returns constant strings for service_string_advice
858 and message_identifier
859 TBD replace with class variables
861 =head2 _interchange_sr_identifier
863 Format sender and receipient identifiers for use in the interchange header
867 Encode textual data into the standard character set ( iso 8859-1 )
868 and quote any Edifact metacharacters
870 =head2 msg_date_string
872 Convenient routine which returns message date as a Y-m-d string
873 useful if the caller wants to log date of creation
877 Colin Campbell <colin.campbell@ptfs-europe.com>
882 Copyright 2014,2015,2016 PTFS-Europe Ltd
883 This program is free software, You may redistribute it under
884 under the terms of the GNU General Public License