Martin Renvoize
509aebd60e
This patch adds a new system preference, EdifactLSQ, to allow configuration of the ambiguous LSQ, sequence code, field included in the EDIFACT specifications. Originally the field was hard coded to map to 'location', but as per the specification it could have been mapped to 'ccode'. From the specification: A code or other designation which identifies stock which is to be shelved in a specified sequence or collection. Signed-off-by: Katrin Fischer <katrin.fischer.83@web.de> Signed-off-by: Nick Clemens <nick@bywatersolutions.com> Signed-off-by: Fridolin Somers <fridolin.somers@biblibre.com>
887 lines
24 KiB
Perl
887 lines
24 KiB
Perl
package Koha::Edifact::Order;
|
|
|
|
use strict;
|
|
use warnings;
|
|
use utf8;
|
|
|
|
# Copyright 2014,2015 PTFS-Europe Ltd
|
|
#
|
|
# This file is part of Koha.
|
|
#
|
|
# Koha is free software; you can redistribute it and/or modify it
|
|
# under the terms of the GNU General Public License as published by
|
|
# the Free Software Foundation; either version 3 of the License, or
|
|
# (at your option) any later version.
|
|
#
|
|
# Koha is distributed in the hope that it will be useful, but
|
|
# WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
# GNU General Public License for more details.
|
|
#
|
|
# You should have received a copy of the GNU General Public License
|
|
# along with Koha; if not, see <http://www.gnu.org/licenses>.
|
|
|
|
use Carp qw( carp );
|
|
use DateTime;
|
|
use Readonly qw( Readonly );
|
|
use Koha::Database;
|
|
use Koha::DateUtils qw( dt_from_string );
|
|
use C4::Budgets qw( GetBudget );
|
|
|
|
use Koha::Acquisition::Orders;
|
|
|
|
Readonly::Scalar my $seg_terminator => q{'};
|
|
Readonly::Scalar my $separator => q{+};
|
|
Readonly::Scalar my $component_separator => q{:};
|
|
Readonly::Scalar my $release_character => q{?};
|
|
|
|
Readonly::Scalar my $NINES_12 => 999_999_999_999;
|
|
Readonly::Scalar my $NINES_14 => 99_999_999_999_999;
|
|
Readonly::Scalar my $CHUNKSIZE => 35;
|
|
|
|
sub new {
|
|
my ( $class, $parameter_hashref ) = @_;
|
|
|
|
my $self = {};
|
|
if ( ref $parameter_hashref ) {
|
|
$self->{orderlines} = $parameter_hashref->{orderlines};
|
|
$self->{recipient} = $parameter_hashref->{vendor};
|
|
$self->{sender} = $parameter_hashref->{ean};
|
|
$self->{is_response} = $parameter_hashref->{is_response};
|
|
|
|
# convenient alias
|
|
$self->{basket} = $self->{orderlines}->[0]->basketno;
|
|
$self->{message_date} = dt_from_string();
|
|
}
|
|
|
|
# validate that its worth proceeding
|
|
if ( !$self->{orderlines} ) {
|
|
carp 'No orderlines passed to create order';
|
|
return;
|
|
}
|
|
if ( !$self->{recipient} ) {
|
|
carp 'No vendor passed to order creation: basket = '
|
|
. $self->{basket}->basketno;
|
|
return;
|
|
}
|
|
if ( !$self->{sender} ) {
|
|
carp 'No sender ean passed to order creation: basket = '
|
|
. $self->{basket}->basketno;
|
|
return;
|
|
}
|
|
|
|
# do this once per object not once per orderline
|
|
my $database = Koha::Database->new();
|
|
$self->{schema} = $database->schema;
|
|
|
|
bless $self, $class;
|
|
return $self;
|
|
}
|
|
|
|
sub filename {
|
|
my $self = shift;
|
|
if ( !$self->{orderlines} ) {
|
|
return;
|
|
}
|
|
my $filename = 'ordr' . $self->{basket}->basketno;
|
|
$filename .= '.CEP';
|
|
return $filename;
|
|
}
|
|
|
|
sub encode {
|
|
my ($self) = @_;
|
|
|
|
$self->{interchange_control_reference} = int rand($NINES_14);
|
|
$self->{message_count} = 0;
|
|
|
|
# $self->{segs}; # Message segments
|
|
|
|
$self->{transmission} = q{};
|
|
|
|
$self->{transmission} .= $self->initial_service_segments();
|
|
|
|
$self->{transmission} .= $self->user_data_message_segments();
|
|
|
|
$self->{transmission} .= $self->trailing_service_segments();
|
|
|
|
# Guard against CR LF etc being added in data from DB
|
|
$self->{transmission}=~s/[\r\n\t]//g;
|
|
|
|
return $self->{transmission};
|
|
}
|
|
|
|
sub msg_date_string {
|
|
my $self = shift;
|
|
return $self->{message_date}->ymd();
|
|
}
|
|
|
|
sub initial_service_segments {
|
|
my $self = shift;
|
|
|
|
#UNA service string advice - specifies standard separators
|
|
my $segs = _const('service_string_advice');
|
|
|
|
#UNB interchange header
|
|
$segs .= $self->interchange_header();
|
|
|
|
#UNG functional group header NOT USED
|
|
return $segs;
|
|
}
|
|
|
|
sub interchange_header {
|
|
my $self = shift;
|
|
|
|
# syntax identifier
|
|
my $hdr =
|
|
'UNB+UNOC:3'; # controlling agency character set syntax version number
|
|
# Interchange Sender
|
|
$hdr .= _interchange_sr_identifier( $self->{sender}->ean,
|
|
$self->{sender}->id_code_qualifier ); # interchange sender
|
|
$hdr .= _interchange_sr_identifier( $self->{recipient}->san,
|
|
$self->{recipient}->id_code_qualifier ); # interchange Recipient
|
|
|
|
$hdr .= $separator;
|
|
|
|
# DateTime of preparation
|
|
$hdr .= $self->{message_date}->format_cldr('yyMMdd:HHmm');
|
|
$hdr .= $separator;
|
|
$hdr .= $self->interchange_control_reference();
|
|
$hdr .= $separator;
|
|
|
|
# Recipents reference password not usually used in edifact
|
|
$hdr .= q{+ORDERS}; # application reference
|
|
|
|
#Edifact does not usually include the following
|
|
# $hdr .= $separator; # Processing priority not usually used in edifact
|
|
# $hdr .= $separator; # Acknowledgewment request : not usually used in edifact
|
|
# $hdr .= q{+EANCOM} # Communications agreement id
|
|
# $hdr .= q{+1} # Test indicator
|
|
#
|
|
$hdr .= $seg_terminator;
|
|
return $hdr;
|
|
}
|
|
|
|
sub user_data_message_segments {
|
|
my $self = shift;
|
|
|
|
#UNH message_header :: seg count begins here
|
|
$self->message_header();
|
|
|
|
$self->order_msg_header();
|
|
|
|
my $line_number = 0;
|
|
foreach my $ol ( @{ $self->{orderlines} } ) {
|
|
++$line_number;
|
|
$self->order_line( $line_number, $ol );
|
|
}
|
|
|
|
$self->message_trailer();
|
|
|
|
my $data_segment_string = join q{}, @{ $self->{segs} };
|
|
return $data_segment_string;
|
|
}
|
|
|
|
sub message_trailer {
|
|
my $self = shift;
|
|
|
|
# terminate the message
|
|
$self->add_seg("UNS+S$seg_terminator");
|
|
|
|
# CNT Control_Total
|
|
# Could be (code 1) total value of QTY segments
|
|
# or ( code = 2 ) number of lineitems
|
|
my $num_orderlines = @{ $self->{orderlines} };
|
|
$self->add_seg("CNT+2:$num_orderlines$seg_terminator");
|
|
|
|
# UNT Message Trailer
|
|
my $segments_in_message =
|
|
1 + @{ $self->{segs} }; # count incl UNH & UNT (!!this one)
|
|
my $reference = $self->message_reference('current');
|
|
$self->add_seg("UNT+$segments_in_message+$reference$seg_terminator");
|
|
return;
|
|
}
|
|
|
|
sub trailing_service_segments {
|
|
my $self = shift;
|
|
my $trailer = q{};
|
|
|
|
#UNE functional group trailer NOT USED
|
|
#UNZ interchange trailer
|
|
$trailer .= $self->interchange_trailer();
|
|
|
|
return $trailer;
|
|
}
|
|
|
|
sub interchange_control_reference {
|
|
my $self = shift;
|
|
if ( $self->{interchange_control_reference} ) {
|
|
return sprintf '%014d', $self->{interchange_control_reference};
|
|
}
|
|
else {
|
|
carp 'calling for ref of unencoded order';
|
|
return 'NONE ASSIGNED';
|
|
}
|
|
}
|
|
|
|
sub message_reference {
|
|
my ( $self, $function ) = @_;
|
|
if ( $function eq 'new' || !$self->{message_reference_no} ) {
|
|
|
|
# unique 14 char mesage ref
|
|
$self->{message_reference_no} = sprintf 'ME%012d', int rand($NINES_12);
|
|
}
|
|
return $self->{message_reference_no};
|
|
}
|
|
|
|
sub message_header {
|
|
my $self = shift;
|
|
|
|
$self->{segs} = []; # initialize the message
|
|
$self->{message_count}++; # In practice alwaya 1
|
|
|
|
my $hdr = q{UNH+} . $self->message_reference('new');
|
|
$hdr .= _const('message_identifier');
|
|
$self->add_seg($hdr);
|
|
return;
|
|
}
|
|
|
|
sub interchange_trailer {
|
|
my $self = shift;
|
|
|
|
my $t = "UNZ+$self->{message_count}+";
|
|
$t .= $self->interchange_control_reference;
|
|
$t .= $seg_terminator;
|
|
return $t;
|
|
}
|
|
|
|
sub order_msg_header {
|
|
my $self = shift;
|
|
my @header;
|
|
|
|
# UNH see message_header
|
|
# BGM
|
|
push @header,
|
|
beginning_of_message(
|
|
$self->{basket}->basketno,
|
|
$self->{recipient}->standard,
|
|
$self->{is_response}
|
|
);
|
|
|
|
# DTM
|
|
push @header, message_date_segment( $self->{message_date} );
|
|
|
|
# NAD-RFF buyer supplier ids
|
|
push @header,
|
|
name_and_address(
|
|
'BUYER',
|
|
$self->{sender}->ean,
|
|
$self->{sender}->id_code_qualifier
|
|
);
|
|
push @header,
|
|
name_and_address(
|
|
'SUPPLIER',
|
|
$self->{recipient}->san,
|
|
$self->{recipient}->id_code_qualifier
|
|
);
|
|
|
|
# repeat for for other relevant parties
|
|
|
|
# CUX currency
|
|
# ISO 4217 code to show default currency prices are quoted in
|
|
# e.g. CUX+2:GBP:9'
|
|
# TBD currency handling
|
|
|
|
$self->add_seg(@header);
|
|
return;
|
|
}
|
|
|
|
sub beginning_of_message {
|
|
my $basketno = shift;
|
|
my $standard = shift;
|
|
my $response = shift;
|
|
my $document_message_no = sprintf '%011d', $basketno;
|
|
|
|
# my $message_function = 9; # original 7 = retransmission
|
|
# message_code values
|
|
# 220 order
|
|
# 224 rush order
|
|
# 228 sample order :: order for approval / inspection copies
|
|
# 22C continuation order for volumes in a set etc.
|
|
# my $message_code = '220';
|
|
|
|
# If the order is in response to a quote and we're dealing with a BIC supplier
|
|
my $code = ( $response && ( $standard eq 'BIC' ) ) ? '22V' : '220';
|
|
return "BGM+$code+$document_message_no+9$seg_terminator";
|
|
}
|
|
|
|
sub name_and_address {
|
|
my ( $party, $id_code, $id_agency ) = @_;
|
|
my %qualifier_code = (
|
|
BUYER => 'BY',
|
|
DELIVERY => 'DP', # delivery location if != buyer
|
|
INVOICEE => 'IV', # if different from buyer
|
|
SUPPLIER => 'SU',
|
|
);
|
|
if ( !exists $qualifier_code{$party} ) {
|
|
carp "No qualifier code for $party";
|
|
return;
|
|
}
|
|
if ( $id_agency eq '14' ) {
|
|
$id_agency = '9'; # ean coded differently in this seg
|
|
}
|
|
|
|
return "NAD+$qualifier_code{$party}+${id_code}::$id_agency$seg_terminator";
|
|
}
|
|
|
|
sub order_line {
|
|
my ( $self, $linenumber, $orderline ) = @_;
|
|
|
|
my $basket = Koha::Acquisition::Orders->find( $orderline->ordernumber )->basket;
|
|
|
|
my $schema = $self->{schema};
|
|
if ( !$orderline->biblionumber )
|
|
{ # cannot generate an orderline without a bib record
|
|
return;
|
|
}
|
|
my $biblionumber = $orderline->biblionumber->biblionumber;
|
|
my @biblioitems = $schema->resultset('Biblioitem')
|
|
->search( { biblionumber => $biblionumber, } );
|
|
my $biblioitem = $biblioitems[0]; # makes the assumption there is 1 only
|
|
# or else all have same details
|
|
|
|
my $id_string = $orderline->line_item_id;
|
|
|
|
# LIN line-number in msg :: if we had a 13 digit ean we could add
|
|
$self->add_seg( lin_segment( $linenumber, $id_string ) );
|
|
|
|
# PIA isbn or other id
|
|
my @identifiers;
|
|
foreach my $id ( $biblioitem->ean, $biblioitem->issn, $biblioitem->isbn ) {
|
|
if ( $id && $id ne $id_string ) {
|
|
push @identifiers, $id;
|
|
}
|
|
}
|
|
$self->add_seg( additional_product_id( join( ' ', @identifiers ) ) );
|
|
|
|
# biblio description
|
|
$self->add_seg( item_description( $orderline->biblionumber, $biblioitem ) );
|
|
|
|
# QTY order quantity
|
|
my $qty = join q{}, 'QTY+21:', $orderline->quantity, $seg_terminator;
|
|
$self->add_seg($qty);
|
|
|
|
# DTM Optional date constraints on delivery
|
|
# we dont currently support this in koha
|
|
# GIR copy-related data
|
|
my $lsq_field = C4::Context->preference('EdifactLSQ');
|
|
my @items;
|
|
if ( $basket->effective_create_items eq 'ordering' ) {
|
|
|
|
my @linked_itemnumbers = $orderline->aqorders_items;
|
|
foreach my $item (@linked_itemnumbers) {
|
|
my $i_obj = $schema->resultset('Item')->find( $item->itemnumber );
|
|
if ( defined $i_obj ) {
|
|
push @items, {
|
|
branchcode => $i_obj->get_column('homebranch'),
|
|
itype => $i_obj->effective_itemtype,
|
|
$lsq_field => $i_obj->$lsq_field,
|
|
itemcallnumber => $i_obj->itemcallnumber,
|
|
};
|
|
}
|
|
}
|
|
}
|
|
else {
|
|
my $item_hash = {
|
|
itype => $biblioitem->itemtype,
|
|
itemcallnumber => $biblioitem->cn_class,
|
|
};
|
|
my $branch = $orderline->basketno->deliveryplace;
|
|
if ($branch) {
|
|
$item_hash->{branchcode} = $branch;
|
|
}
|
|
for ( 1 .. $orderline->quantity ) {
|
|
push @items, $item_hash;
|
|
}
|
|
}
|
|
my $budget = GetBudget( $orderline->budget_id );
|
|
my $ol_fields = { budget_code => $budget->{budget_code}, };
|
|
|
|
my $item_fields = [];
|
|
for my $item (@items) {
|
|
push @{$item_fields},
|
|
{
|
|
branchcode => $item->{branchcode},
|
|
itype => $item->{itype},
|
|
$lsq_field => $item->{$lsq_field},
|
|
itemcallnumber => $item->{itemcallnumber},
|
|
};
|
|
}
|
|
$self->add_seg(
|
|
gir_segments(
|
|
{
|
|
ol_fields => $ol_fields,
|
|
items => $item_fields
|
|
}
|
|
)
|
|
);
|
|
|
|
# TBD what if #items exceeds quantity
|
|
|
|
# FTX free text for current orderline
|
|
# Pass vendor note in FTX free text segment
|
|
if ( $orderline->order_vendornote ) {
|
|
my $vendornote = $orderline->order_vendornote;
|
|
chomp $vendornote;
|
|
my $ftx = 'FTX+LIN+++';
|
|
$ftx .= $vendornote;
|
|
$ftx .= $seg_terminator;
|
|
$self->add_seg($ftx);
|
|
}
|
|
# Encode notes here
|
|
# PRI-CUX-DTM unit price on which order is placed : optional
|
|
# Coutts read this as 0.00 if not present
|
|
if ( $orderline->listprice ) {
|
|
my $price = sprintf 'PRI+AAE:%.2f:CA', $orderline->listprice;
|
|
$price .= $seg_terminator;
|
|
$self->add_seg($price);
|
|
}
|
|
|
|
# RFF unique orderline reference no
|
|
my $rff = join q{}, 'RFF+LI:', $orderline->ordernumber, $seg_terminator;
|
|
$self->add_seg($rff);
|
|
|
|
# RFF : suppliers unique quotation reference number
|
|
if ( $orderline->suppliers_reference_number ) {
|
|
$rff = join q{}, 'RFF+', $orderline->suppliers_reference_qualifier,
|
|
':', $orderline->suppliers_reference_number, $seg_terminator;
|
|
$self->add_seg($rff);
|
|
}
|
|
|
|
# LOC-QTY multiple delivery locations
|
|
#TBD to specify extra delivery locs
|
|
# NAD order line name and address
|
|
#TBD Optionally indicate a name & address or order originator
|
|
# TDT method of delivey ol-specific
|
|
# TBD requests a special delivery option
|
|
|
|
return;
|
|
}
|
|
|
|
sub item_description {
|
|
my ( $bib, $biblioitem ) = @_;
|
|
my $bib_desc = {
|
|
author => $bib->author,
|
|
title => $bib->title,
|
|
publisher => $biblioitem->publishercode,
|
|
year => $biblioitem->publicationyear,
|
|
};
|
|
|
|
my @itm = ();
|
|
|
|
# 009 Author
|
|
# 050 Title :: title
|
|
# 080 Vol/Part no
|
|
# 100 Edition statement
|
|
# 109 Publisher :: publisher
|
|
# 110 place of pub
|
|
# 170 Date of publication :: year
|
|
# 220 Binding :: binding
|
|
my %code = (
|
|
author => '009',
|
|
title => '050',
|
|
publisher => '109',
|
|
year => '170',
|
|
binding => '220',
|
|
);
|
|
for my $field (qw(author title publisher year binding )) {
|
|
if ( $bib_desc->{$field} ) {
|
|
my $data = encode_text( $bib_desc->{$field} );
|
|
push @itm, imd_segment( $code{$field}, $data );
|
|
}
|
|
}
|
|
|
|
return @itm;
|
|
}
|
|
|
|
sub imd_segment {
|
|
my ( $code, $data ) = @_;
|
|
|
|
my $seg_prefix = "IMD+L+$code+:::";
|
|
|
|
# chunk_line
|
|
my @chunks;
|
|
while ( my $x = substr $data, 0, $CHUNKSIZE, q{} ) {
|
|
if ( length $x == $CHUNKSIZE ) {
|
|
if ( $x =~ s/([?]{1,2})$// ) {
|
|
$data = "$1$data"; # dont breakup ?' ?? etc
|
|
}
|
|
}
|
|
push @chunks, $x;
|
|
}
|
|
my @segs;
|
|
my $odd = 1;
|
|
foreach my $c (@chunks) {
|
|
if ($odd) {
|
|
push @segs, "$seg_prefix$c";
|
|
}
|
|
else {
|
|
$segs[-1] .= ":$c$seg_terminator";
|
|
}
|
|
$odd = !$odd;
|
|
}
|
|
if ( @segs && $segs[-1] !~ m/[^?]$seg_terminator$/o ) {
|
|
$segs[-1] .= $seg_terminator;
|
|
}
|
|
return @segs;
|
|
}
|
|
|
|
sub gir_segments {
|
|
my ($params) = @_;
|
|
|
|
my $orderfields = $params->{ol_fields};
|
|
my @onorderitems = @{ $params->{items} };
|
|
|
|
my $budget_code = $orderfields->{budget_code};
|
|
my @segments;
|
|
my $sequence_no = 1;
|
|
my $lsq_field = C4::Context->preference('EdifactLSQ');
|
|
foreach my $item (@onorderitems) {
|
|
my $elements_added = 0;
|
|
my @gir_elements;
|
|
if ($budget_code) {
|
|
push @gir_elements,
|
|
{ identity_number => 'LFN', data => $budget_code };
|
|
}
|
|
if ( $item->{branchcode} ) {
|
|
push @gir_elements,
|
|
{ identity_number => 'LLO', data => $item->{branchcode} };
|
|
}
|
|
if ( $item->{itype} ) {
|
|
push @gir_elements,
|
|
{ identity_number => 'LST', data => $item->{itype} };
|
|
}
|
|
if ( $item->{$lsq_field} ) {
|
|
push @gir_elements,
|
|
{ identity_number => 'LSQ', data => $item->{$lsq_field} };
|
|
}
|
|
if ( $item->{itemcallnumber} ) {
|
|
push @gir_elements,
|
|
{ identity_number => 'LSM', data => $item->{itemcallnumber} };
|
|
}
|
|
|
|
# itemcallnumber -> shelfmark
|
|
if ( $orderfields->{servicing_instruction} ) {
|
|
push @gir_elements,
|
|
{
|
|
identity_number => 'LVT',
|
|
data => $orderfields->{servicing_instruction}
|
|
};
|
|
}
|
|
my $e_cnt = 0; # count number of elements so we dont exceed 5 per segment
|
|
my $copy_no = sprintf 'GIR+%03d', $sequence_no;
|
|
my $seg = $copy_no;
|
|
foreach my $e (@gir_elements) {
|
|
if ( $e_cnt == 5 ) {
|
|
push @segments, $seg;
|
|
$seg = $copy_no;
|
|
}
|
|
$seg .=
|
|
add_gir_identity_number( $e->{identity_number}, $e->{data} );
|
|
++$e_cnt;
|
|
}
|
|
|
|
$sequence_no++;
|
|
push @segments, $seg;
|
|
}
|
|
return @segments;
|
|
}
|
|
|
|
sub add_gir_identity_number {
|
|
my ( $number_qualifier, $number ) = @_;
|
|
if ($number) {
|
|
return "+${number}:${number_qualifier}";
|
|
}
|
|
return q{};
|
|
}
|
|
|
|
sub add_seg {
|
|
my ( $self, @s ) = @_;
|
|
foreach my $segment (@s) {
|
|
if ( $segment !~ m/$seg_terminator$/o ) {
|
|
$segment .= $seg_terminator;
|
|
}
|
|
}
|
|
push @{ $self->{segs} }, @s;
|
|
return;
|
|
}
|
|
|
|
sub lin_segment {
|
|
my ( $line_number, $item_number_id ) = @_;
|
|
|
|
if ($item_number_id) {
|
|
$item_number_id = "++${item_number_id}:EN";
|
|
}
|
|
else {
|
|
$item_number_id = q||;
|
|
}
|
|
|
|
return "LIN+$line_number$item_number_id$seg_terminator";
|
|
}
|
|
|
|
sub additional_product_id {
|
|
my $isbn_field = shift;
|
|
my ( $product_id, $product_code );
|
|
if ( $isbn_field =~ m/(\d{13})/ ) {
|
|
$product_id = $1;
|
|
$product_code = 'EN';
|
|
}
|
|
elsif ( $isbn_field =~ m/(\d{9}[Xx\d])/ ) {
|
|
$product_id = $1;
|
|
$product_code = 'IB';
|
|
}
|
|
|
|
# TBD we could have a manufacturers no issn etc
|
|
if ( !$product_id ) {
|
|
return;
|
|
}
|
|
|
|
# function id set to 5 states this is the main product id
|
|
return "PIA+5+$product_id:$product_code$seg_terminator";
|
|
}
|
|
|
|
sub message_date_segment {
|
|
my $dt = shift;
|
|
|
|
# qualifier:message_date:format_code
|
|
|
|
my $message_date = $dt->ymd(q{}); # no sep in edifact format
|
|
|
|
return "DTM+137:$message_date:102$seg_terminator";
|
|
}
|
|
|
|
sub _const {
|
|
my $key = shift;
|
|
Readonly my %S => {
|
|
service_string_advice => q{UNA:+.? '},
|
|
message_identifier => q{+ORDERS:D:96A:UN:EAN008'},
|
|
};
|
|
return ( $S{$key} ) ? $S{$key} : q{};
|
|
}
|
|
|
|
sub _interchange_sr_identifier {
|
|
my ( $identification, $qualifier ) = @_;
|
|
|
|
if ( !$identification ) {
|
|
$identification = 'RANDOM';
|
|
$qualifier = '92';
|
|
carp 'undefined identifier';
|
|
}
|
|
|
|
# 14 EAN International
|
|
# 31B US SAN (preferred)
|
|
# also 91 assigned by supplier
|
|
# also 92 assigned by buyer
|
|
if ( $qualifier !~ m/^(?:14|31B|91|92)/xms ) {
|
|
$qualifier = '92';
|
|
}
|
|
|
|
return "+$identification:$qualifier";
|
|
}
|
|
|
|
sub encode_text {
|
|
my $string = shift;
|
|
if ($string) {
|
|
$string =~ s/[?]/??/g;
|
|
$string =~ s/'/?'/g;
|
|
$string =~ s/:/?:/g;
|
|
$string =~ s/[+]/?+/g;
|
|
}
|
|
return $string;
|
|
}
|
|
|
|
1;
|
|
__END__
|
|
|
|
=head1 NAME
|
|
|
|
Koha::Edifact::Order
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
Format an Edifact Order message from a Koha basket
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
Generates an Edifact format Order message for a Koha basket.
|
|
Normally the only methods used directly by the caller would be
|
|
new to set up the message, encode to return the formatted message
|
|
and filename to obtain a name under which to store the message
|
|
|
|
=head1 BUGS
|
|
|
|
Should integrate into Koha::Edifact namespace
|
|
Can caller interface be made cleaner?
|
|
Make handling of GIR segments more customizable
|
|
|
|
=head1 METHODS
|
|
|
|
=head2 new
|
|
|
|
my $edi_order = Edifact::Order->new(
|
|
orderlines => \@orderlines,
|
|
vendor => $vendor_edi_account,
|
|
ean => $library_ean
|
|
);
|
|
|
|
instantiate the Edifact::Order object, all parameters are Schema::Resultset objects
|
|
Called in Koha::Edifact create_edi_order
|
|
|
|
=head2 filename
|
|
|
|
my $filename = $edi_order->filename()
|
|
|
|
returns a filename for the edi order. The filename embeds a reference to the
|
|
basket the message was created to encode
|
|
|
|
=head2 encode
|
|
|
|
my $edifact_message = $edi_order->encode();
|
|
|
|
Encodes the basket as a valid edifact message ready for transmission
|
|
|
|
=head2 initial_service_segments
|
|
|
|
Creates the service segments which begin the message
|
|
|
|
=head2 interchange_header
|
|
|
|
Return an interchange header encoding sender and recipient
|
|
ids message date and standards
|
|
|
|
=head2 user_data_message_segments
|
|
|
|
Include message data within the encoded message
|
|
|
|
=head2 message_trailer
|
|
|
|
Terminate message data including control data on number
|
|
of messages and segments included
|
|
|
|
=head2 trailing_service_segments
|
|
|
|
Include the service segments occurring at the end of the message
|
|
|
|
=head2 interchange_control_reference
|
|
|
|
Returns the unique interchange control reference as a 14 digit number
|
|
|
|
=head2 message_reference
|
|
|
|
On generates and subsequently returns the unique message
|
|
reference number as a 12 digit number preceded by ME, to generate a new number
|
|
pass the string 'new'.
|
|
In practice we encode 1 message per transmission so there is only one message
|
|
referenced. were we to encode multiple messages a new reference would be
|
|
neaded for each
|
|
|
|
=head2 message_header
|
|
|
|
Commences a new message
|
|
|
|
=head2 interchange_trailer
|
|
|
|
returns the UNZ segment which ends the tranmission encoding the
|
|
message count and control reference for the interchange
|
|
|
|
=head2 order_msg_header
|
|
|
|
Formats the message header segments
|
|
|
|
=head2 beginning_of_message
|
|
|
|
Returns the BGM segment which includes the Koha basket number
|
|
|
|
=head2 name_and_address
|
|
|
|
Parameters: Function ( BUYER, DELIVERY, INVOICE, SUPPLIER)
|
|
Id
|
|
Agency
|
|
|
|
Returns a NAD segment containg the id and agency for for the Function
|
|
value. Handles the fact that NAD segments encode the value for 'EAN' differently
|
|
to elsewhere.
|
|
|
|
=head2 order_line
|
|
|
|
Creates the message segments wncoding an order line
|
|
|
|
=head2 item_description
|
|
|
|
Encodes the biblio item fields Author, title, publisher, date of publication
|
|
binding
|
|
|
|
=head2 imd_segment
|
|
|
|
Formats an IMD segment, handles the chunking of data into the 35 character
|
|
lengths required and the creation of repeat segments
|
|
|
|
=head2 gir_segments
|
|
|
|
Add item level information
|
|
|
|
=head2 add_gir_identity_number
|
|
|
|
Handle the formatting of a GIR element
|
|
return empty string if no data
|
|
|
|
=head2 add_seg
|
|
|
|
Adds a parssed array of segments to the objects segment list
|
|
ensures all segments are properly terminated by '
|
|
|
|
=head2 lin_segment
|
|
|
|
Adds a LIN segment consisting of the line number and the ean number
|
|
if the passed isbn is valid
|
|
|
|
=head2 additional_product_id
|
|
|
|
Add a PIA segment for an additional product id
|
|
|
|
=head2 message_date_segment
|
|
|
|
Passed a DateTime object returns a correctly formatted DTM segment
|
|
|
|
=head2 _const
|
|
|
|
Stores and returns constant strings for service_string_advice
|
|
and message_identifier
|
|
TBD replace with class variables
|
|
|
|
=head2 _interchange_sr_identifier
|
|
|
|
Format sender and receipient identifiers for use in the interchange header
|
|
|
|
=head2 encode_text
|
|
|
|
Encode textual data into the standard character set ( iso 8859-1 )
|
|
and quote any Edifact metacharacters
|
|
|
|
=head2 msg_date_string
|
|
|
|
Convenient routine which returns message date as a Y-m-d string
|
|
useful if the caller wants to log date of creation
|
|
|
|
=head1 AUTHOR
|
|
|
|
Colin Campbell <colin.campbell@ptfs-europe.com>
|
|
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
Copyright 2014,2015,2016 PTFS-Europe Ltd
|
|
This program is free software, You may redistribute it under
|
|
under the terms of the GNU General Public License
|
|
|
|
|
|
=cut
|