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 Readonly
::Scalar
my $seg_terminator => q{'};
32 Readonly
::Scalar
my $separator => q{+};
33 Readonly
::Scalar
my $component_separator => q{:};
34 Readonly
::Scalar
my $release_character => q{?};
36 Readonly
::Scalar
my $NINES_12 => 999_999_999_999
;
37 Readonly
::Scalar
my $NINES_14 => 99_999_999_999_999
;
38 Readonly
::Scalar
my $CHUNKSIZE => 35;
41 my ( $class, $parameter_hashref ) = @_;
44 if ( ref $parameter_hashref ) {
45 $self->{orderlines
} = $parameter_hashref->{orderlines
};
46 $self->{recipient
} = $parameter_hashref->{vendor
};
47 $self->{sender
} = $parameter_hashref->{ean
};
48 $self->{is_response
} = $parameter_hashref->{is_response
};
51 $self->{basket
} = $self->{orderlines
}->[0]->basketno;
52 $self->{message_date
} = DateTime
->now( time_zone
=> 'local' );
55 # validate that its worth proceeding
56 if ( !$self->{orderlines
} ) {
57 carp
'No orderlines passed to create order';
60 if ( !$self->{recipient
} ) {
62 "No vendor passed to order creation: basket = $self->{basket}->basketno()";
65 if ( !$self->{sender
} ) {
67 "No sender ean passed to order creation: basket = $self->{basket}->basketno()";
71 # do this once per object not once per orderline
72 my $database = Koha
::Database
->new();
73 $self->{schema
} = $database->schema;
81 if ( !$self->{orderlines
} ) {
84 my $filename = 'ordr' . $self->{basket
}->basketno;
92 $self->{interchange_control_reference
} = int rand($NINES_14);
93 $self->{message_count
} = 0;
95 # $self->{segs}; # Message segments
97 $self->{transmission
} = q{};
99 $self->{transmission
} .= $self->initial_service_segments();
101 $self->{transmission
} .= $self->user_data_message_segments();
103 $self->{transmission
} .= $self->trailing_service_segments();
104 return $self->{transmission
};
107 sub msg_date_string
{
109 return $self->{message_date
}->ymd();
112 sub initial_service_segments
{
115 #UNA service string advice - specifies standard separators
116 my $segs = _const
('service_string_advice');
118 #UNB interchange header
119 $segs .= $self->interchange_header();
121 #UNG functional group header NOT USED
125 sub interchange_header
{
130 'UNB+UNOC:3'; # controlling agency character set syntax version number
132 $hdr .= _interchange_sr_identifier
( $self->{sender
}->ean,
133 $self->{sender
}->id_code_qualifier ); # interchange sender
134 $hdr .= _interchange_sr_identifier
( $self->{recipient
}->san,
135 $self->{recipient
}->id_code_qualifier ); # interchange Recipient
139 # DateTime of preparation
140 $hdr .= $self->{message_date
}->format_cldr('yyMMdd:HHmm');
142 $hdr .= $self->interchange_control_reference();
145 # Recipents reference password not usually used in edifact
146 $hdr .= q{+ORDERS}; # application reference
148 #Edifact does not usually include the following
149 # $hdr .= $separator; # Processing priority not usually used in edifact
150 # $hdr .= $separator; # Acknowledgewment request : not usually used in edifact
151 # $hdr .= q{+EANCOM} # Communications agreement id
152 # $hdr .= q{+1} # Test indicator
154 $hdr .= $seg_terminator;
158 sub user_data_message_segments
{
161 #UNH message_header :: seg count begins here
162 $self->message_header();
164 $self->order_msg_header();
167 foreach my $ol ( @
{ $self->{orderlines
} } ) {
169 $self->order_line( $line_number, $ol );
172 $self->message_trailer();
174 my $data_segment_string = join q{}, @
{ $self->{segs
} };
175 return $data_segment_string;
178 sub message_trailer
{
181 # terminate the message
182 $self->add_seg("UNS+S$seg_terminator");
185 # Could be (code 1) total value of QTY segments
186 # or ( code = 2 ) number of lineitems
187 my $num_orderlines = @
{ $self->{orderlines
} };
188 $self->add_seg("CNT+2:$num_orderlines$seg_terminator");
190 # UNT Message Trailer
191 my $segments_in_message =
192 1 + @
{ $self->{segs
} }; # count incl UNH & UNT (!!this one)
193 my $reference = $self->message_reference('current');
194 $self->add_seg("UNT+$segments_in_message+$reference$seg_terminator");
198 sub trailing_service_segments
{
202 #UNE functional group trailer NOT USED
203 #UNZ interchange trailer
204 $trailer .= $self->interchange_trailer();
209 sub interchange_control_reference
{
211 if ( $self->{interchange_control_reference
} ) {
212 return sprintf '%014d', $self->{interchange_control_reference
};
215 carp
'calling for ref of unencoded order';
216 return 'NONE ASSIGNED';
220 sub message_reference
{
221 my ( $self, $function ) = @_;
222 if ( $function eq 'new' || !$self->{message_reference_no
} ) {
224 # unique 14 char mesage ref
225 $self->{message_reference_no
} = sprintf 'ME%012d', int rand($NINES_12);
227 return $self->{message_reference_no
};
233 $self->{segs
} = []; # initialize the message
234 $self->{message_count
}++; # In practice alwaya 1
236 my $hdr = q{UNH+} . $self->message_reference('new');
237 $hdr .= _const
('message_identifier');
238 $self->add_seg($hdr);
242 sub interchange_trailer
{
245 my $t = "UNZ+$self->{message_count}+";
246 $t .= $self->interchange_control_reference;
247 $t .= $seg_terminator;
251 sub order_msg_header
{
255 # UNH see message_header
258 beginning_of_message
(
259 $self->{basket
}->basketno,
260 $self->{recipient
}->san,
265 push @header, message_date_segment
( $self->{message_date
} );
267 # NAD-RFF buyer supplier ids
271 $self->{sender
}->ean,
272 $self->{sender
}->id_code_qualifier
277 $self->{recipient
}->san,
278 $self->{recipient
}->id_code_qualifier
281 # repeat for for other relevant parties
284 # ISO 4217 code to show default currency prices are quoted in
286 # TBD currency handling
288 $self->add_seg(@header);
292 sub beginning_of_message
{
293 my $basketno = shift;
294 my $supplier_san = shift;
295 my $response = shift;
296 my $document_message_no = sprintf '%011d', $basketno;
298 # Peters & Bolinda use the BIC recommendation to use 22V a code not in Edifact
299 # If the order is in response to a quote
301 '5013546025065' => 'Peters',
302 '9377779308820' => 'Bolinda',
305 # my $message_function = 9; # original 7 = retransmission
306 # message_code values
309 # 228 sample order :: order for approval / inspection copies
310 # 22C continuation order for volumes in a set etc.
311 # my $message_code = '220';
312 if ( exists $bic_sans{$supplier_san} && $response ) {
313 return "BGM+22V+$document_message_no+9$seg_terminator";
316 return "BGM+220+$document_message_no+9$seg_terminator";
319 sub name_and_address
{
320 my ( $party, $id_code, $id_agency ) = @_;
321 my %qualifier_code = (
323 DELIVERY
=> 'DP', # delivery location if != buyer
324 INVOICEE
=> 'IV', # if different from buyer
327 if ( !exists $qualifier_code{$party} ) {
328 carp
"No qualifier code for $party";
331 if ( $id_agency eq '14' ) {
332 $id_agency = '9'; # ean coded differently in this seg
335 return "NAD+$qualifier_code{$party}+${id_code}::$id_agency$seg_terminator";
339 my ( $self, $linenumber, $orderline ) = @_;
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 ( C4
::Context
->preference('AcqCreateItem') 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 ) {
389 itemtype
=> $biblioitem->itemtype,
390 shelfmark
=> $biblioitem->cn_class,
392 my $branch = $orderline->basketno->deliveryplace;
394 $item_hash->{branch
} = $branch;
396 for ( 1 .. $orderline->quantity ) {
397 push @items, $item_hash;
400 my $budget = GetBudget
( $orderline->budget_id );
401 my $ol_fields = { budget_code
=> $budget->{budget_code
}, };
402 if ( $orderline->order_vendornote ) {
403 $ol_fields->{servicing_instruction
} = $orderline->order_vendornote;
405 $self->add_seg( gir_segments
( $ol_fields, @items ) );
407 # TBD what if #items exceeds quantity
409 # FTX free text for current orderline TBD
410 # dont really have a special instructions field to encode here
412 # PRI-CUX-DTM unit price on which order is placed : optional
413 # Coutts read this as 0.00 if not present
414 if ( $orderline->listprice ) {
415 my $price = sprintf 'PRI+AAE:%.2f:CA', $orderline->listprice;
416 $price .= $seg_terminator;
417 $self->add_seg($price);
420 # RFF unique orderline reference no
421 my $rff = join q{}, 'RFF+LI:', $orderline->ordernumber, $seg_terminator;
422 $self->add_seg($rff);
424 # RFF : suppliers unique quotation reference number
425 if ( $orderline->suppliers_reference_number ) {
426 $rff = join q{}, 'RFF+', $orderline->suppliers_reference_qualifier,
427 ':', $orderline->suppliers_reference_number, $seg_terminator;
428 $self->add_seg($rff);
431 # LOC-QTY multiple delivery locations
432 #TBD to specify extra delivery locs
433 # NAD order line name and address
434 #TBD Optionally indicate a name & address or order originator
435 # TDT method of delivey ol-specific
436 # TBD requests a special delivery option
441 sub item_description
{
442 my ( $bib, $biblioitem ) = @_;
444 author
=> $bib->author,
445 title
=> $bib->title,
446 publisher
=> $biblioitem->publishercode,
447 year
=> $biblioitem->publicationyear,
455 # 100 Edition statement
456 # 109 Publisher :: publisher
458 # 170 Date of publication :: year
459 # 220 Binding :: binding
467 for my $field (qw(author title publisher year binding )) {
468 if ( $bib_desc->{$field} ) {
469 my $data = encode_text
( $bib_desc->{$field} );
470 push @itm, imd_segment
( $code{$field}, $data );
478 my ( $code, $data ) = @_;
480 my $seg_prefix = "IMD+L+$code+:::";
484 while ( my $x = substr $data, 0, $CHUNKSIZE, q{} ) {
485 if ( length $x == $CHUNKSIZE ) {
486 if ( $x =~ s/([?]{1,2})$// ) {
487 $data = "$1$data"; # dont breakup ?' ?? etc
494 foreach my $c (@chunks) {
496 push @segs, "$seg_prefix$c";
499 $segs[-1] .= ":$c$seg_terminator";
503 if ( @segs && $segs[-1] !~ m/$seg_terminator$/o ) {
504 $segs[-1] .= $seg_terminator;
510 my ( $orderfields, @onorderitems ) = @_;
512 my $budget_code = $orderfields->{budget_code
};
515 foreach my $item (@onorderitems) {
516 my $seg = sprintf 'GIR+%03d', $sequence_no;
517 $seg .= add_gir_identity_number
( 'LFN', $budget_code );
518 if ( C4
::Context
->preference('AcqCreateItem') eq 'ordering' ) {
520 add_gir_identity_number
( 'LLO', $item->homebranch->branchcode );
521 $seg .= add_gir_identity_number
( 'LST', $item->itype );
522 $seg .= add_gir_identity_number
( 'LSQ', $item->location );
523 $seg .= add_gir_identity_number
( 'LSM', $item->itemcallnumber );
525 # itemcallnumber -> shelfmark
528 if ( $item->{branch
} ) {
529 $seg .= add_gir_identity_number
( 'LLO', $item->{branch
} );
531 $seg .= add_gir_identity_number
( 'LST', $item->{itemtype
} );
532 $seg .= add_gir_identity_number
( 'LSM', $item->{shelfmark
} );
534 if ( $orderfields->{servicing_instruction
} ) {
535 $seg .= add_gir_identity_number
( 'LVT',
536 $orderfields->{servicing_instruction
} );
539 push @segments, $seg;
544 sub add_gir_identity_number
{
545 my ( $number_qualifier, $number ) = @_;
547 return "+${number}:${number_qualifier}";
553 my ( $self, @s ) = @_;
554 foreach my $segment (@s) {
555 if ( $segment !~ m/$seg_terminator$/o ) {
556 $segment .= $seg_terminator;
559 push @
{ $self->{segs
} }, @s;
564 my ( $line_number, $item_number_id ) = @_;
566 if ($item_number_id) {
567 $item_number_id = "++${item_number_id}:EN";
570 $item_number_id = q
||;
573 return "LIN+$line_number$item_number_id$seg_terminator";
576 sub additional_product_id
{
577 my $isbn_field = shift;
578 my ( $product_id, $product_code );
579 if ( $isbn_field =~ m/(\d{13})/ ) {
581 $product_code = 'EN';
583 elsif ( $isbn_field =~ m/(\d{9})[Xx\d]/ ) {
585 $product_code = 'IB';
588 # TBD we could have a manufacturers no issn etc
589 if ( !$product_id ) {
593 # function id set to 5 states this is the main product id
594 return "PIA+5+$product_id:$product_code$seg_terminator";
597 sub message_date_segment
{
600 # qualifier:message_date:format_code
602 my $message_date = $dt->ymd(q{}); # no sep in edifact format
604 return "DTM+137:$message_date:102$seg_terminator";
610 service_string_advice
=> q{UNA:+.? '},
611 message_identifier
=> q{+ORDERS:D:96A:UN:EAN008'},
613 return ( $S{$key} ) ?
$S{$key} : q{};
616 sub _interchange_sr_identifier
{
617 my ( $identification, $qualifier ) = @_;
619 if ( !$identification ) {
620 $identification = 'RANDOM';
622 carp
'undefined identifier';
625 # 14 EAN International
626 # 31B US SAN (preferred)
627 # also 91 assigned by supplier
628 # also 92 assigned by buyer
629 if ( $qualifier !~ m/^(?:14|31B|91|92)/xms ) {
633 return "+$identification:$qualifier";
639 $string =~ s/[?]/??/g;
642 $string =~ s/[+]/?+/g;
656 Format an Edifact Order message from a Koha basket
660 Generates an Edifact format Order message for a Koha basket.
661 Normally the only methods used directly by the caller would be
662 new to set up the message, encode to return the formatted message
663 and filename to obtain a name under which to store the message
667 Should integrate into Koha::Edifact namespace
668 Can caller interface be made cleaner?
669 Make handling of GIR segments more customizable
675 my $edi_order = Edifact::Order->new(
676 orderlines => \@orderlines,
677 vendor => $vendor_edi_account,
681 instantiate the Edifact::Order object, all parameters are Schema::Resultset objects
682 Called in Koha::Edifact create_edi_order
686 my $filename = $edi_order->filename()
688 returns a filename for the edi order. The filename embeds a reference to the
689 basket the message was created to encode
693 my $edifact_message = $edi_order->encode();
695 Encodes the basket as a valid edifact message ready for transmission
697 =head2 initial_service_segments
699 Creates the service segments which begin the message
701 =head2 interchange_header
703 Return an interchange header encoding sender and recipient
704 ids message date and standards
706 =head2 user_data_message_segments
708 Include message data within the encoded message
710 =head2 message_trailer
712 Terminate message data including control data on number
713 of messages and segments included
715 =head2 trailing_service_segments
717 Include the service segments occurring at the end of the message
719 =head2 interchange_control_reference
721 Returns the unique interchange control reference as a 14 digit number
723 =head2 message_reference
725 On generates and subsequently returns the unique message
726 reference number as a 12 digit number preceded by ME, to generate a new number
727 pass the string 'new'.
728 In practice we encode 1 message per transmission so there is only one message
729 referenced. were we to encode multiple messages a new reference would be
732 =head2 message_header
734 Commences a new message
736 =head2 interchange_trailer
738 returns the UNZ segment which ends the tranmission encoding the
739 message count and control reference for the interchange
741 =head2 order_msg_header
743 Formats the message header segments
745 =head2 beginning_of_message
747 Returns the BGM segment which includes the Koha basket number
749 =head2 name_and_address
751 Parameters: Function ( BUYER, DELIVERY, INVOICE, SUPPLIER)
755 Returns a NAD segment containg the id and agency for for the Function
756 value. Handles the fact that NAD segments encode the value for 'EAN' differently
761 Creates the message segments wncoding an order line
763 =head2 item_description
765 Encodes the biblio item fields Author, title, publisher, date of publication
770 Formats an IMD segment, handles the chunking of data into the 35 character
771 lengths required and the creation of repeat segments
775 Add item level information
777 =head2 add_gir_identity_number
779 Handle the formatting of a GIR element
780 return empty string if no data
784 Adds a parssed array of segments to the objects segment list
785 ensures all segments are properly terminated by '
789 Adds a LIN segment consisting of the line number and the ean number
790 if the passed isbn is valid
792 =head2 additional_product_id
794 Add a PIA segment for an additional product id
796 =head2 message_date_segment
798 Passed a DateTime object returns a correctly formatted DTM segment
802 Stores and returns constant strings for service_string_advice
803 and message_identifier
804 TBD replace with class variables
806 =head2 _interchange_sr_identifier
808 Format sender and receipient identifiers for use in the interchange header
812 Encode textual data into the standard character set ( iso 8859-1 )
813 and quote any Edifact metacharacters
815 =head2 msg_date_string
817 Convenient routine which returns message date as a Y-m-d string
818 useful if the caller wants to log date of creation
822 Colin Campbell <colin.campbell@ptfs-europe.com>
827 Copyright 2014,2015,2016 PTFS-Europe Ltd
828 This program is free software, You may redistribute it under
829 under the terms of the GNU General Public License