Bug 21395: Fix C4/Barcodes/ValueBuilder.pm
[koha.git] / Koha / Edifact / Order.pm
blobb5434872ae2c3812bf2d1971d5f2f9f43084c7ff
1 package Koha::Edifact::Order;
3 use strict;
4 use warnings;
5 use utf8;
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>.
24 use Carp;
25 use DateTime;
26 use Readonly;
27 use Business::ISBN;
28 use Koha::Database;
29 use Koha::DateUtils;
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;
43 sub new {
44 my ( $class, $parameter_hashref ) = @_;
46 my $self = {};
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};
53 # convenient alias
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';
61 return;
63 if ( !$self->{recipient} ) {
64 carp 'No vendor passed to order creation: basket = '
65 . $self->{basket}->basketno;
66 return;
68 if ( !$self->{sender} ) {
69 carp 'No sender ean passed to order creation: basket = '
70 . $self->{basket}->basketno;
71 return;
74 # do this once per object not once per orderline
75 my $database = Koha::Database->new();
76 $self->{schema} = $database->schema;
78 bless $self, $class;
79 return $self;
82 sub filename {
83 my $self = shift;
84 if ( !$self->{orderlines} ) {
85 return;
87 my $filename = 'ordr' . $self->{basket}->basketno;
88 $filename .= '.CEP';
89 return $filename;
92 sub encode {
93 my ($self) = @_;
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();
107 return $self->{transmission};
110 sub msg_date_string {
111 my $self = shift;
112 return $self->{message_date}->ymd();
115 sub initial_service_segments {
116 my $self = shift;
118 #UNA service string advice - specifies standard separators
119 my $segs = _const('service_string_advice');
121 #UNB interchange header
122 $segs .= $self->interchange_header();
124 #UNG functional group header NOT USED
125 return $segs;
128 sub interchange_header {
129 my $self = shift;
131 # syntax identifier
132 my $hdr =
133 'UNB+UNOC:3'; # controlling agency character set syntax version number
134 # Interchange Sender
135 $hdr .= _interchange_sr_identifier( $self->{sender}->ean,
136 $self->{sender}->id_code_qualifier ); # interchange sender
137 $hdr .= _interchange_sr_identifier( $self->{recipient}->san,
138 $self->{recipient}->id_code_qualifier ); # interchange Recipient
140 $hdr .= $separator;
142 # DateTime of preparation
143 $hdr .= $self->{message_date}->format_cldr('yyMMdd:HHmm');
144 $hdr .= $separator;
145 $hdr .= $self->interchange_control_reference();
146 $hdr .= $separator;
148 # Recipents reference password not usually used in edifact
149 $hdr .= q{+ORDERS}; # application reference
151 #Edifact does not usually include the following
152 # $hdr .= $separator; # Processing priority not usually used in edifact
153 # $hdr .= $separator; # Acknowledgewment request : not usually used in edifact
154 # $hdr .= q{+EANCOM} # Communications agreement id
155 # $hdr .= q{+1} # Test indicator
157 $hdr .= $seg_terminator;
158 return $hdr;
161 sub user_data_message_segments {
162 my $self = shift;
164 #UNH message_header :: seg count begins here
165 $self->message_header();
167 $self->order_msg_header();
169 my $line_number = 0;
170 foreach my $ol ( @{ $self->{orderlines} } ) {
171 ++$line_number;
172 $self->order_line( $line_number, $ol );
175 $self->message_trailer();
177 my $data_segment_string = join q{}, @{ $self->{segs} };
178 return $data_segment_string;
181 sub message_trailer {
182 my $self = shift;
184 # terminate the message
185 $self->add_seg("UNS+S$seg_terminator");
187 # CNT Control_Total
188 # Could be (code 1) total value of QTY segments
189 # or ( code = 2 ) number of lineitems
190 my $num_orderlines = @{ $self->{orderlines} };
191 $self->add_seg("CNT+2:$num_orderlines$seg_terminator");
193 # UNT Message Trailer
194 my $segments_in_message =
195 1 + @{ $self->{segs} }; # count incl UNH & UNT (!!this one)
196 my $reference = $self->message_reference('current');
197 $self->add_seg("UNT+$segments_in_message+$reference$seg_terminator");
198 return;
201 sub trailing_service_segments {
202 my $self = shift;
203 my $trailer = q{};
205 #UNE functional group trailer NOT USED
206 #UNZ interchange trailer
207 $trailer .= $self->interchange_trailer();
209 return $trailer;
212 sub interchange_control_reference {
213 my $self = shift;
214 if ( $self->{interchange_control_reference} ) {
215 return sprintf '%014d', $self->{interchange_control_reference};
217 else {
218 carp 'calling for ref of unencoded order';
219 return 'NONE ASSIGNED';
223 sub message_reference {
224 my ( $self, $function ) = @_;
225 if ( $function eq 'new' || !$self->{message_reference_no} ) {
227 # unique 14 char mesage ref
228 $self->{message_reference_no} = sprintf 'ME%012d', int rand($NINES_12);
230 return $self->{message_reference_no};
233 sub message_header {
234 my $self = shift;
236 $self->{segs} = []; # initialize the message
237 $self->{message_count}++; # In practice alwaya 1
239 my $hdr = q{UNH+} . $self->message_reference('new');
240 $hdr .= _const('message_identifier');
241 $self->add_seg($hdr);
242 return;
245 sub interchange_trailer {
246 my $self = shift;
248 my $t = "UNZ+$self->{message_count}+";
249 $t .= $self->interchange_control_reference;
250 $t .= $seg_terminator;
251 return $t;
254 sub order_msg_header {
255 my $self = shift;
256 my @header;
258 # UNH see message_header
259 # BGM
260 push @header,
261 beginning_of_message(
262 $self->{basket}->basketno,
263 $self->{recipient}->san,
264 $self->{is_response}
267 # DTM
268 push @header, message_date_segment( $self->{message_date} );
270 # NAD-RFF buyer supplier ids
271 push @header,
272 name_and_address(
273 'BUYER',
274 $self->{sender}->ean,
275 $self->{sender}->id_code_qualifier
277 push @header,
278 name_and_address(
279 'SUPPLIER',
280 $self->{recipient}->san,
281 $self->{recipient}->id_code_qualifier
284 # repeat for for other relevant parties
286 # CUX currency
287 # ISO 4217 code to show default currency prices are quoted in
288 # e.g. CUX+2:GBP:9'
289 # TBD currency handling
291 $self->add_seg(@header);
292 return;
295 sub beginning_of_message {
296 my $basketno = shift;
297 my $supplier_san = shift;
298 my $response = shift;
299 my $document_message_no = sprintf '%011d', $basketno;
301 # Peters & Bolinda use the BIC recommendation to use 22V a code not in Edifact
302 # If the order is in response to a quote
303 my %bic_sans = (
304 '5013546025065' => 'Peters',
305 '9377779308820' => 'Bolinda',
308 # my $message_function = 9; # original 7 = retransmission
309 # message_code values
310 # 220 prder
311 # 224 rush order
312 # 228 sample order :: order for approval / inspection copies
313 # 22C continuation order for volumes in a set etc.
314 # my $message_code = '220';
315 if ( exists $bic_sans{$supplier_san} && $response ) {
316 return "BGM+22V+$document_message_no+9$seg_terminator";
319 return "BGM+220+$document_message_no+9$seg_terminator";
322 sub name_and_address {
323 my ( $party, $id_code, $id_agency ) = @_;
324 my %qualifier_code = (
325 BUYER => 'BY',
326 DELIVERY => 'DP', # delivery location if != buyer
327 INVOICEE => 'IV', # if different from buyer
328 SUPPLIER => 'SU',
330 if ( !exists $qualifier_code{$party} ) {
331 carp "No qualifier code for $party";
332 return;
334 if ( $id_agency eq '14' ) {
335 $id_agency = '9'; # ean coded differently in this seg
338 return "NAD+$qualifier_code{$party}+${id_code}::$id_agency$seg_terminator";
341 sub order_line {
342 my ( $self, $linenumber, $orderline ) = @_;
344 my $basket = Koha::Acquisition::Orders->find( $orderline->ordernumber )->basket;
346 my $schema = $self->{schema};
347 if ( !$orderline->biblionumber )
348 { # cannot generate an orderline without a bib record
349 return;
351 my $biblionumber = $orderline->biblionumber->biblionumber;
352 my @biblioitems = $schema->resultset('Biblioitem')
353 ->search( { biblionumber => $biblionumber, } );
354 my $biblioitem = $biblioitems[0]; # makes the assumption there is 1 only
355 # or else all have same details
357 my $id_string = $orderline->line_item_id;
359 # LIN line-number in msg :: if we had a 13 digit ean we could add
360 $self->add_seg( lin_segment( $linenumber, $id_string ) );
362 # PIA isbn or other id
363 my @identifiers;
364 foreach my $id ( $biblioitem->ean, $biblioitem->issn, $biblioitem->isbn ) {
365 if ( $id && $id ne $id_string ) {
366 push @identifiers, $id;
369 $self->add_seg( additional_product_id( join( ' ', @identifiers ) ) );
371 # biblio description
372 $self->add_seg( item_description( $orderline->biblionumber, $biblioitem ) );
374 # QTY order quantity
375 my $qty = join q{}, 'QTY+21:', $orderline->quantity, $seg_terminator;
376 $self->add_seg($qty);
378 # DTM Optional date constraints on delivery
379 # we dont currently support this in koha
380 # GIR copy-related data
381 my @items;
382 if ( $basket->effective_create_items eq 'ordering' ) {
383 my @linked_itemnumbers = $orderline->aqorders_items;
385 foreach my $item (@linked_itemnumbers) {
386 my $i_obj = $schema->resultset('Item')->find( $item->itemnumber );
387 if ( defined $i_obj ) {
388 push @items, $i_obj;
392 else {
393 my $item_hash = {
394 itemtype => $biblioitem->itemtype,
395 shelfmark => $biblioitem->cn_class,
397 my $branch = $orderline->basketno->deliveryplace;
398 if ($branch) {
399 $item_hash->{branch} = $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}, };
407 if ( $orderline->order_vendornote ) {
408 $ol_fields->{servicing_instruction} = $orderline->order_vendornote;
410 my $item_fields = [];
411 for my $item (@items) {
412 push @{$item_fields},
414 branchcode => $item->homebranch->branchcode,
415 itype => $item->itype,
416 location => $item->location,
417 itemcallnumber => $item->itemcallnumber,
420 $self->add_seg(
421 gir_segments(
423 ol_fields => $ol_fields,
424 items => $item_fields
429 # TBD what if #items exceeds quantity
431 # FTX free text for current orderline TBD
432 # dont really have a special instructions field to encode here
433 # Encode notes here
434 # PRI-CUX-DTM unit price on which order is placed : optional
435 # Coutts read this as 0.00 if not present
436 if ( $orderline->listprice ) {
437 my $price = sprintf 'PRI+AAE:%.2f:CA', $orderline->listprice;
438 $price .= $seg_terminator;
439 $self->add_seg($price);
442 # RFF unique orderline reference no
443 my $rff = join q{}, 'RFF+LI:', $orderline->ordernumber, $seg_terminator;
444 $self->add_seg($rff);
446 # RFF : suppliers unique quotation reference number
447 if ( $orderline->suppliers_reference_number ) {
448 $rff = join q{}, 'RFF+', $orderline->suppliers_reference_qualifier,
449 ':', $orderline->suppliers_reference_number, $seg_terminator;
450 $self->add_seg($rff);
453 # LOC-QTY multiple delivery locations
454 #TBD to specify extra delivery locs
455 # NAD order line name and address
456 #TBD Optionally indicate a name & address or order originator
457 # TDT method of delivey ol-specific
458 # TBD requests a special delivery option
460 return;
463 sub item_description {
464 my ( $bib, $biblioitem ) = @_;
465 my $bib_desc = {
466 author => $bib->author,
467 title => $bib->title,
468 publisher => $biblioitem->publishercode,
469 year => $biblioitem->publicationyear,
472 my @itm = ();
474 # 009 Author
475 # 050 Title :: title
476 # 080 Vol/Part no
477 # 100 Edition statement
478 # 109 Publisher :: publisher
479 # 110 place of pub
480 # 170 Date of publication :: year
481 # 220 Binding :: binding
482 my %code = (
483 author => '009',
484 title => '050',
485 publisher => '109',
486 year => '170',
487 binding => '220',
489 for my $field (qw(author title publisher year binding )) {
490 if ( $bib_desc->{$field} ) {
491 my $data = encode_text( $bib_desc->{$field} );
492 push @itm, imd_segment( $code{$field}, $data );
496 return @itm;
499 sub imd_segment {
500 my ( $code, $data ) = @_;
502 my $seg_prefix = "IMD+L+$code+:::";
504 # chunk_line
505 my @chunks;
506 while ( my $x = substr $data, 0, $CHUNKSIZE, q{} ) {
507 if ( length $x == $CHUNKSIZE ) {
508 if ( $x =~ s/([?]{1,2})$// ) {
509 $data = "$1$data"; # dont breakup ?' ?? etc
512 push @chunks, $x;
514 my @segs;
515 my $odd = 1;
516 foreach my $c (@chunks) {
517 if ($odd) {
518 push @segs, "$seg_prefix$c";
520 else {
521 $segs[-1] .= ":$c$seg_terminator";
523 $odd = !$odd;
525 if ( @segs && $segs[-1] !~ m/[^?]$seg_terminator$/o ) {
526 $segs[-1] .= $seg_terminator;
528 return @segs;
531 sub gir_segments {
532 my ($params) = @_;
534 my $orderfields = $params->{ol_fields};
535 my @onorderitems = @{ $params->{items} };
537 my $budget_code = $orderfields->{budget_code};
538 my @segments;
539 my $sequence_no = 1;
540 foreach my $item (@onorderitems) {
541 my $elements_added = 0;
542 my @gir_elements;
543 if ($budget_code) {
544 push @gir_elements,
545 { identity_number => 'LFN', data => $budget_code };
547 if ( $item->{branchcode} ) {
548 push @gir_elements,
549 { identity_number => 'LLO', data => $item->{branchcode} };
551 if ( $item->{itype} ) {
552 push @gir_elements,
553 { identity_number => 'LST', data => $item->{itype} };
555 if ( $item->{location} ) {
556 push @gir_elements,
557 { identity_number => 'LSQ', data => $item->{location} };
559 if ( $item->{itemcallnumber} ) {
560 push @gir_elements,
561 { identity_number => 'LSM', data => $item->{itemcallnumber} };
564 # itemcallnumber -> shelfmark
565 if ( $orderfields->{servicing_instruction} ) {
566 push @gir_elements,
568 identity_number => 'LVT',
569 data => $orderfields->{servicing_instruction}
572 my $e_cnt = 0; # count number of elements so we dont exceed 5 per segment
573 my $copy_no = sprintf 'GIR+%03d', $sequence_no;
574 my $seg = $copy_no;
575 foreach my $e (@gir_elements) {
576 if ( $e_cnt == 5 ) {
577 push @segments, $seg;
578 $seg = $copy_no;
580 $seg .=
581 add_gir_identity_number( $e->{identity_number}, $e->{data} );
582 ++$e_cnt;
585 $sequence_no++;
586 push @segments, $seg;
588 return @segments;
591 sub add_gir_identity_number {
592 my ( $number_qualifier, $number ) = @_;
593 if ($number) {
594 return "+${number}:${number_qualifier}";
596 return q{};
599 sub add_seg {
600 my ( $self, @s ) = @_;
601 foreach my $segment (@s) {
602 if ( $segment !~ m/$seg_terminator$/o ) {
603 $segment .= $seg_terminator;
606 push @{ $self->{segs} }, @s;
607 return;
610 sub lin_segment {
611 my ( $line_number, $item_number_id ) = @_;
613 if ($item_number_id) {
614 $item_number_id = "++${item_number_id}:EN";
616 else {
617 $item_number_id = q||;
620 return "LIN+$line_number$item_number_id$seg_terminator";
623 sub additional_product_id {
624 my $isbn_field = shift;
625 my ( $product_id, $product_code );
626 if ( $isbn_field =~ m/(\d{13})/ ) {
627 $product_id = $1;
628 $product_code = 'EN';
630 elsif ( $isbn_field =~ m/(\d{9}[Xx\d])/ ) {
631 $product_id = $1;
632 $product_code = 'IB';
635 # TBD we could have a manufacturers no issn etc
636 if ( !$product_id ) {
637 return;
640 # function id set to 5 states this is the main product id
641 return "PIA+5+$product_id:$product_code$seg_terminator";
644 sub message_date_segment {
645 my $dt = shift;
647 # qualifier:message_date:format_code
649 my $message_date = $dt->ymd(q{}); # no sep in edifact format
651 return "DTM+137:$message_date:102$seg_terminator";
654 sub _const {
655 my $key = shift;
656 Readonly my %S => {
657 service_string_advice => q{UNA:+.? '},
658 message_identifier => q{+ORDERS:D:96A:UN:EAN008'},
660 return ( $S{$key} ) ? $S{$key} : q{};
663 sub _interchange_sr_identifier {
664 my ( $identification, $qualifier ) = @_;
666 if ( !$identification ) {
667 $identification = 'RANDOM';
668 $qualifier = '92';
669 carp 'undefined identifier';
672 # 14 EAN International
673 # 31B US SAN (preferred)
674 # also 91 assigned by supplier
675 # also 92 assigned by buyer
676 if ( $qualifier !~ m/^(?:14|31B|91|92)/xms ) {
677 $qualifier = '92';
680 return "+$identification:$qualifier";
683 sub encode_text {
684 my $string = shift;
685 if ($string) {
686 $string =~ s/[?]/??/g;
687 $string =~ s/'/?'/g;
688 $string =~ s/:/?:/g;
689 $string =~ s/[+]/?+/g;
691 return $string;
695 __END__
697 =head1 NAME
699 Koha::Edifact::Order
701 =head1 SYNOPSIS
703 Format an Edifact Order message from a Koha basket
705 =head1 DESCRIPTION
707 Generates an Edifact format Order message for a Koha basket.
708 Normally the only methods used directly by the caller would be
709 new to set up the message, encode to return the formatted message
710 and filename to obtain a name under which to store the message
712 =head1 BUGS
714 Should integrate into Koha::Edifact namespace
715 Can caller interface be made cleaner?
716 Make handling of GIR segments more customizable
718 =head1 METHODS
720 =head2 new
722 my $edi_order = Edifact::Order->new(
723 orderlines => \@orderlines,
724 vendor => $vendor_edi_account,
725 ean => $library_ean
728 instantiate the Edifact::Order object, all parameters are Schema::Resultset objects
729 Called in Koha::Edifact create_edi_order
731 =head2 filename
733 my $filename = $edi_order->filename()
735 returns a filename for the edi order. The filename embeds a reference to the
736 basket the message was created to encode
738 =head2 encode
740 my $edifact_message = $edi_order->encode();
742 Encodes the basket as a valid edifact message ready for transmission
744 =head2 initial_service_segments
746 Creates the service segments which begin the message
748 =head2 interchange_header
750 Return an interchange header encoding sender and recipient
751 ids message date and standards
753 =head2 user_data_message_segments
755 Include message data within the encoded message
757 =head2 message_trailer
759 Terminate message data including control data on number
760 of messages and segments included
762 =head2 trailing_service_segments
764 Include the service segments occurring at the end of the message
766 =head2 interchange_control_reference
768 Returns the unique interchange control reference as a 14 digit number
770 =head2 message_reference
772 On generates and subsequently returns the unique message
773 reference number as a 12 digit number preceded by ME, to generate a new number
774 pass the string 'new'.
775 In practice we encode 1 message per transmission so there is only one message
776 referenced. were we to encode multiple messages a new reference would be
777 neaded for each
779 =head2 message_header
781 Commences a new message
783 =head2 interchange_trailer
785 returns the UNZ segment which ends the tranmission encoding the
786 message count and control reference for the interchange
788 =head2 order_msg_header
790 Formats the message header segments
792 =head2 beginning_of_message
794 Returns the BGM segment which includes the Koha basket number
796 =head2 name_and_address
798 Parameters: Function ( BUYER, DELIVERY, INVOICE, SUPPLIER)
800 Agency
802 Returns a NAD segment containg the id and agency for for the Function
803 value. Handles the fact that NAD segments encode the value for 'EAN' differently
804 to elsewhere.
806 =head2 order_line
808 Creates the message segments wncoding an order line
810 =head2 item_description
812 Encodes the biblio item fields Author, title, publisher, date of publication
813 binding
815 =head2 imd_segment
817 Formats an IMD segment, handles the chunking of data into the 35 character
818 lengths required and the creation of repeat segments
820 =head2 gir_segments
822 Add item level information
824 =head2 add_gir_identity_number
826 Handle the formatting of a GIR element
827 return empty string if no data
829 =head2 add_seg
831 Adds a parssed array of segments to the objects segment list
832 ensures all segments are properly terminated by '
834 =head2 lin_segment
836 Adds a LIN segment consisting of the line number and the ean number
837 if the passed isbn is valid
839 =head2 additional_product_id
841 Add a PIA segment for an additional product id
843 =head2 message_date_segment
845 Passed a DateTime object returns a correctly formatted DTM segment
847 =head2 _const
849 Stores and returns constant strings for service_string_advice
850 and message_identifier
851 TBD replace with class variables
853 =head2 _interchange_sr_identifier
855 Format sender and receipient identifiers for use in the interchange header
857 =head2 encode_text
859 Encode textual data into the standard character set ( iso 8859-1 )
860 and quote any Edifact metacharacters
862 =head2 msg_date_string
864 Convenient routine which returns message date as a Y-m-d string
865 useful if the caller wants to log date of creation
867 =head1 AUTHOR
869 Colin Campbell <colin.campbell@ptfs-europe.com>
872 =head1 COPYRIGHT
874 Copyright 2014,2015,2016 PTFS-Europe Ltd
875 This program is free software, You may redistribute it under
876 under the terms of the GNU General Public License
879 =cut