Lines 23-41
use utf8;
Link Here
|
23 |
|
23 |
|
24 |
use Carp; |
24 |
use Carp; |
25 |
use DateTime; |
25 |
use DateTime; |
26 |
use Readonly; |
|
|
27 |
use Business::ISBN; |
26 |
use Business::ISBN; |
28 |
use Koha::Database; |
27 |
use Koha::Database; |
29 |
use C4::Budgets qw( GetBudget ); |
28 |
use C4::Budgets qw( GetBudget ); |
30 |
|
29 |
|
31 |
Readonly::Scalar my $seg_terminator => q{'}; |
30 |
use constant { |
32 |
Readonly::Scalar my $separator => q{+}; |
31 |
SEG_TERMINATOR => q{'}, |
33 |
Readonly::Scalar my $component_separator => q{:}; |
32 |
SEPARATOR => q{+}, |
34 |
Readonly::Scalar my $release_character => q{?}; |
33 |
COMPONENT_SEPARATOR => q{:}, |
|
|
34 |
RELEASE_CHARACTER => q{?}, |
35 |
|
35 |
|
36 |
Readonly::Scalar my $NINES_12 => 999_999_999_999; |
36 |
NINES_12 => 999_999_999_999, |
37 |
Readonly::Scalar my $NINES_14 => 99_999_999_999_999; |
37 |
NINES_14 => 99_999_999_999_999, |
38 |
Readonly::Scalar my $CHUNKSIZE => 35; |
38 |
CHUNKSIZE => 35, |
|
|
39 |
}; |
39 |
|
40 |
|
40 |
sub new { |
41 |
sub new { |
41 |
my ( $class, $parameter_hashref ) = @_; |
42 |
my ( $class, $parameter_hashref ) = @_; |
Lines 89-95
sub filename {
Link Here
|
89 |
sub encode { |
90 |
sub encode { |
90 |
my ($self) = @_; |
91 |
my ($self) = @_; |
91 |
|
92 |
|
92 |
$self->{interchange_control_reference} = int rand($NINES_14); |
93 |
$self->{interchange_control_reference} = int rand(NINES_14); |
93 |
$self->{message_count} = 0; |
94 |
$self->{message_count} = 0; |
94 |
|
95 |
|
95 |
# $self->{segs}; # Message segments |
96 |
# $self->{segs}; # Message segments |
Lines 134-157
sub interchange_header {
Link Here
|
134 |
$hdr .= _interchange_sr_identifier( $self->{recipient}->san, |
135 |
$hdr .= _interchange_sr_identifier( $self->{recipient}->san, |
135 |
$self->{recipient}->id_code_qualifier ); # interchange Recipient |
136 |
$self->{recipient}->id_code_qualifier ); # interchange Recipient |
136 |
|
137 |
|
137 |
$hdr .= $separator; |
138 |
$hdr .= SEPARATOR; |
138 |
|
139 |
|
139 |
# DateTime of preparation |
140 |
# DateTime of preparation |
140 |
$hdr .= $self->{message_date}->format_cldr('yyMMdd:HHmm'); |
141 |
$hdr .= $self->{message_date}->format_cldr('yyMMdd:HHmm'); |
141 |
$hdr .= $separator; |
142 |
$hdr .= SEPARATOR; |
142 |
$hdr .= $self->interchange_control_reference(); |
143 |
$hdr .= $self->interchange_control_reference(); |
143 |
$hdr .= $separator; |
144 |
$hdr .= SEPARATOR; |
144 |
|
145 |
|
145 |
# Recipents reference password not usually used in edifact |
146 |
# Recipents reference password not usually used in edifact |
146 |
$hdr .= q{+ORDERS}; # application reference |
147 |
$hdr .= q{+ORDERS}; # application reference |
147 |
|
148 |
|
148 |
#Edifact does not usually include the following |
149 |
#Edifact does not usually include the following |
149 |
# $hdr .= $separator; # Processing priority not usually used in edifact |
150 |
# $hdr .= SEPARATOR; # Processing priority not usually used in edifact |
150 |
# $hdr .= $separator; # Acknowledgewment request : not usually used in edifact |
151 |
# $hdr .= SEPARATOR; # Acknowledgewment request : not usually used in edifact |
151 |
# $hdr .= q{+EANCOM} # Communications agreement id |
152 |
# $hdr .= q{+EANCOM} # Communications agreement id |
152 |
# $hdr .= q{+1} # Test indicator |
153 |
# $hdr .= q{+1} # Test indicator |
153 |
# |
154 |
# |
154 |
$hdr .= $seg_terminator; |
155 |
$hdr .= SEG_TERMINATOR; |
155 |
return $hdr; |
156 |
return $hdr; |
156 |
} |
157 |
} |
157 |
|
158 |
|
Lines 179-197
sub message_trailer {
Link Here
|
179 |
my $self = shift; |
180 |
my $self = shift; |
180 |
|
181 |
|
181 |
# terminate the message |
182 |
# terminate the message |
182 |
$self->add_seg("UNS+S$seg_terminator"); |
183 |
$self->add_seg("UNS+S" . SEG_TERMINATOR); |
183 |
|
184 |
|
184 |
# CNT Control_Total |
185 |
# CNT Control_Total |
185 |
# Could be (code 1) total value of QTY segments |
186 |
# Could be (code 1) total value of QTY segments |
186 |
# or ( code = 2 ) number of lineitems |
187 |
# or ( code = 2 ) number of lineitems |
187 |
my $num_orderlines = @{ $self->{orderlines} }; |
188 |
my $num_orderlines = @{ $self->{orderlines} }; |
188 |
$self->add_seg("CNT+2:$num_orderlines$seg_terminator"); |
189 |
$self->add_seg("CNT+2:$num_orderlines" . SEG_TERMINATOR); |
189 |
|
190 |
|
190 |
# UNT Message Trailer |
191 |
# UNT Message Trailer |
191 |
my $segments_in_message = |
192 |
my $segments_in_message = |
192 |
1 + @{ $self->{segs} }; # count incl UNH & UNT (!!this one) |
193 |
1 + @{ $self->{segs} }; # count incl UNH & UNT (!!this one) |
193 |
my $reference = $self->message_reference('current'); |
194 |
my $reference = $self->message_reference('current'); |
194 |
$self->add_seg("UNT+$segments_in_message+$reference$seg_terminator"); |
195 |
$self->add_seg("UNT+$segments_in_message+$reference" . SEG_TERMINATOR); |
195 |
return; |
196 |
return; |
196 |
} |
197 |
} |
197 |
|
198 |
|
Lines 222-228
sub message_reference {
Link Here
|
222 |
if ( $function eq 'new' || !$self->{message_reference_no} ) { |
223 |
if ( $function eq 'new' || !$self->{message_reference_no} ) { |
223 |
|
224 |
|
224 |
# unique 14 char mesage ref |
225 |
# unique 14 char mesage ref |
225 |
$self->{message_reference_no} = sprintf 'ME%012d', int rand($NINES_12); |
226 |
$self->{message_reference_no} = sprintf 'ME%012d', int rand(NINES_12); |
226 |
} |
227 |
} |
227 |
return $self->{message_reference_no}; |
228 |
return $self->{message_reference_no}; |
228 |
} |
229 |
} |
Lines 244-250
sub interchange_trailer {
Link Here
|
244 |
|
245 |
|
245 |
my $t = "UNZ+$self->{message_count}+"; |
246 |
my $t = "UNZ+$self->{message_count}+"; |
246 |
$t .= $self->interchange_control_reference; |
247 |
$t .= $self->interchange_control_reference; |
247 |
$t .= $seg_terminator; |
248 |
$t .= SEG_TERMINATOR; |
248 |
return $t; |
249 |
return $t; |
249 |
} |
250 |
} |
250 |
|
251 |
|
Lines 310-319
sub beginning_of_message {
Link Here
|
310 |
# 22C continuation order for volumes in a set etc. |
311 |
# 22C continuation order for volumes in a set etc. |
311 |
# my $message_code = '220'; |
312 |
# my $message_code = '220'; |
312 |
if ( exists $bic_sans{$supplier_san} && $response ) { |
313 |
if ( exists $bic_sans{$supplier_san} && $response ) { |
313 |
return "BGM+22V+$document_message_no+9$seg_terminator"; |
314 |
return "BGM+22V+$document_message_no+9" . SEG_TERMINATOR; |
314 |
} |
315 |
} |
315 |
|
316 |
|
316 |
return "BGM+220+$document_message_no+9$seg_terminator"; |
317 |
return "BGM+220+$document_message_no+9" . SEG_TERMINATOR; |
317 |
} |
318 |
} |
318 |
|
319 |
|
319 |
sub name_and_address { |
320 |
sub name_and_address { |
Lines 332-338
sub name_and_address {
Link Here
|
332 |
$id_agency = '9'; # ean coded differently in this seg |
333 |
$id_agency = '9'; # ean coded differently in this seg |
333 |
} |
334 |
} |
334 |
|
335 |
|
335 |
return "NAD+$qualifier_code{$party}+${id_code}::$id_agency$seg_terminator"; |
336 |
return "NAD+$qualifier_code{$party}+${id_code}::$id_agency" . SEG_TERMINATOR; |
336 |
} |
337 |
} |
337 |
|
338 |
|
338 |
sub order_line { |
339 |
sub order_line { |
Lines 367-373
sub order_line {
Link Here
|
367 |
$self->add_seg( item_description( $orderline->biblionumber, $biblioitem ) ); |
368 |
$self->add_seg( item_description( $orderline->biblionumber, $biblioitem ) ); |
368 |
|
369 |
|
369 |
# QTY order quantity |
370 |
# QTY order quantity |
370 |
my $qty = join q{}, 'QTY+21:', $orderline->quantity, $seg_terminator; |
371 |
my $qty = join q{}, 'QTY+21:', $orderline->quantity, SEG_TERMINATOR; |
371 |
$self->add_seg($qty); |
372 |
$self->add_seg($qty); |
372 |
|
373 |
|
373 |
# DTM Optional date constraints on delivery |
374 |
# DTM Optional date constraints on delivery |
Lines 413-430
sub order_line {
Link Here
|
413 |
# Coutts read this as 0.00 if not present |
414 |
# Coutts read this as 0.00 if not present |
414 |
if ( $orderline->listprice ) { |
415 |
if ( $orderline->listprice ) { |
415 |
my $price = sprintf 'PRI+AAE:%.2f:CA', $orderline->listprice; |
416 |
my $price = sprintf 'PRI+AAE:%.2f:CA', $orderline->listprice; |
416 |
$price .= $seg_terminator; |
417 |
$price .= SEG_TERMINATOR; |
417 |
$self->add_seg($price); |
418 |
$self->add_seg($price); |
418 |
} |
419 |
} |
419 |
|
420 |
|
420 |
# RFF unique orderline reference no |
421 |
# RFF unique orderline reference no |
421 |
my $rff = join q{}, 'RFF+LI:', $orderline->ordernumber, $seg_terminator; |
422 |
my $rff = join q{}, 'RFF+LI:', $orderline->ordernumber, SEG_TERMINATOR; |
422 |
$self->add_seg($rff); |
423 |
$self->add_seg($rff); |
423 |
|
424 |
|
424 |
# RFF : suppliers unique quotation reference number |
425 |
# RFF : suppliers unique quotation reference number |
425 |
if ( $orderline->suppliers_reference_number ) { |
426 |
if ( $orderline->suppliers_reference_number ) { |
426 |
$rff = join q{}, 'RFF+', $orderline->suppliers_reference_qualifier, |
427 |
$rff = join q{}, 'RFF+', $orderline->suppliers_reference_qualifier, |
427 |
':', $orderline->suppliers_reference_number, $seg_terminator; |
428 |
':', $orderline->suppliers_reference_number, SEG_TERMINATOR; |
428 |
$self->add_seg($rff); |
429 |
$self->add_seg($rff); |
429 |
} |
430 |
} |
430 |
|
431 |
|
Lines 481-488
sub imd_segment {
Link Here
|
481 |
|
482 |
|
482 |
# chunk_line |
483 |
# chunk_line |
483 |
my @chunks; |
484 |
my @chunks; |
484 |
while ( my $x = substr $data, 0, $CHUNKSIZE, q{} ) { |
485 |
while ( my $x = substr $data, 0, CHUNKSIZE, q{} ) { |
485 |
if ( length $x == $CHUNKSIZE ) { |
486 |
if ( length $x == CHUNKSIZE ) { |
486 |
if ( $x =~ s/([?]{1,2})$// ) { |
487 |
if ( $x =~ s/([?]{1,2})$// ) { |
487 |
$data = "$1$data"; # dont breakup ?' ?? etc |
488 |
$data = "$1$data"; # dont breakup ?' ?? etc |
488 |
} |
489 |
} |
Lines 496-507
sub imd_segment {
Link Here
|
496 |
push @segs, "$seg_prefix$c"; |
497 |
push @segs, "$seg_prefix$c"; |
497 |
} |
498 |
} |
498 |
else { |
499 |
else { |
499 |
$segs[-1] .= ":$c$seg_terminator"; |
500 |
$segs[-1] .= ":$c" . SEG_TERMINATOR; |
500 |
} |
501 |
} |
501 |
$odd = !$odd; |
502 |
$odd = !$odd; |
502 |
} |
503 |
} |
503 |
if ( @segs && $segs[-1] !~ m/$seg_terminator$/o ) { |
504 |
if ( @segs && $segs[-1] !~ m/SEG_TERMINATOR$/o ) { |
504 |
$segs[-1] .= $seg_terminator; |
505 |
$segs[-1] .= SEG_TERMINATOR; |
505 |
} |
506 |
} |
506 |
return @segs; |
507 |
return @segs; |
507 |
} |
508 |
} |
Lines 552-559
sub add_gir_identity_number {
Link Here
|
552 |
sub add_seg { |
553 |
sub add_seg { |
553 |
my ( $self, @s ) = @_; |
554 |
my ( $self, @s ) = @_; |
554 |
foreach my $segment (@s) { |
555 |
foreach my $segment (@s) { |
555 |
if ( $segment !~ m/$seg_terminator$/o ) { |
556 |
if ( $segment !~ m/SEG_TERMINATOR$/o ) { |
556 |
$segment .= $seg_terminator; |
557 |
$segment .= SEG_TERMINATOR; |
557 |
} |
558 |
} |
558 |
} |
559 |
} |
559 |
push @{ $self->{segs} }, @s; |
560 |
push @{ $self->{segs} }, @s; |
Lines 570-576
sub lin_segment {
Link Here
|
570 |
$item_number_id = q||; |
571 |
$item_number_id = q||; |
571 |
} |
572 |
} |
572 |
|
573 |
|
573 |
return "LIN+$line_number$item_number_id$seg_terminator"; |
574 |
return "LIN+$line_number$item_number_id" . SEG_TERMINATOR; |
574 |
} |
575 |
} |
575 |
|
576 |
|
576 |
sub additional_product_id { |
577 |
sub additional_product_id { |
Lines 591-597
sub additional_product_id {
Link Here
|
591 |
} |
592 |
} |
592 |
|
593 |
|
593 |
# function id set to 5 states this is the main product id |
594 |
# function id set to 5 states this is the main product id |
594 |
return "PIA+5+$product_id:$product_code$seg_terminator"; |
595 |
return "PIA+5+$product_id:$product_code" . SEG_TERMINATOR; |
595 |
} |
596 |
} |
596 |
|
597 |
|
597 |
sub message_date_segment { |
598 |
sub message_date_segment { |
Lines 601-607
sub message_date_segment {
Link Here
|
601 |
|
602 |
|
602 |
my $message_date = $dt->ymd(q{}); # no sep in edifact format |
603 |
my $message_date = $dt->ymd(q{}); # no sep in edifact format |
603 |
|
604 |
|
604 |
return "DTM+137:$message_date:102$seg_terminator"; |
605 |
return "DTM+137:$message_date:102" . SEG_TERMINATOR; |
605 |
} |
606 |
} |
606 |
|
607 |
|
607 |
sub _const { |
608 |
sub _const { |
608 |
- |
|
|