|
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 |
- |
|
|