Browse Source

Bug 7736: Support Ordering via Edifact EDI messages

Add support for processing incoming Edifact Quotes, Invoices
and order responses and generating and transmission of
Edifact Orders.
Basic workflow is that an incoming quote generates an aquisition
basket in Koha, with each line corresponding to an order record

The user can then generate an edifact order from this (or another)
basket, which is transferred to the vendor's site

The supplier generates an invoice on despatch and this will
result in corresponding invoices being generated in Koha
The orderlines on the invoice are receipted automatically.

We also support order response messages. This may include
simple order acknowledgements, supplier reports/amendments
on availability. Cancellation messages cause the koha order
to be cancelled, other messages are recorded against the order

Which messages are to be supported/processed is specifiable on a
vendor by vendor basis via the admin screens

You can also specify auto order i.e. to generate orders from quotes
without user intervention - This reflects existing
workflows where most work is done on the suppliers website
then generating a dummy quote

Received messages are stored in the edifact_messages table
and the original can be viewed via the online

Database changes are in installer/data/mysql/atomicchanges/edifact.sql
Note new perl dependencies:
    Net::SFTP:Foreign
    Text::Unidecode

Signed-off-by: Paul Johnson <p.johnson@staffs.ac.uk>

Signed-off-by: Sally Healey <sally.healey@cheshiresharedservices.gov.uk>

Signed-off-by: Kyle M Hall <kyle@bywatersolutions.com>

Signed-off-by: Brendan A Gallagher <brendan@bywatersolutions.com>
new_12478_elasticsearch
Colin Campbell 6 years ago
committed by Brendan A Gallagher
parent
commit
e2e9916348
  1. 6
      C4/Acquisition.pm
  2. 10
      C4/Installer/PerlDependencies.pm
  3. 1150
      Koha/EDI.pm
  4. 337
      Koha/Edifact.pm
  5. 864
      Koha/Edifact/Line.pm
  6. 249
      Koha/Edifact/Message.pm
  7. 831
      Koha/Edifact/Order.pm
  8. 204
      Koha/Edifact/Segment.pm
  9. 479
      Koha/Edifact/Transport.pm
  10. 19
      Koha/Schema/Result/Aqbasket.pm
  11. 36
      Koha/Schema/Result/Aqbookseller.pm
  12. 19
      Koha/Schema/Result/Aqbudget.pm
  13. 32
      Koha/Schema/Result/Aqinvoice.pm
  14. 37
      Koha/Schema/Result/Aqorder.pm
  15. 21
      Koha/Schema/Result/Branch.pm
  16. 117
      Koha/Schema/Result/EdifactEan.pm
  17. 202
      Koha/Schema/Result/EdifactMessage.pm
  18. 115
      Koha/Schema/Result/MsgInvoice.pm
  19. 249
      Koha/Schema/Result/VendorEdiAccount.pm
  20. 77
      acqui/basket.pl
  21. 17
      acqui/basketgroup.pl
  22. 64
      acqui/edi_ean.pl
  23. 62
      acqui/edifactmsgs.pl
  24. 72
      acqui/edimsg.pl
  25. 4
      acqui/invoices.pl
  26. 155
      admin/edi_accounts.pl
  27. 158
      admin/edi_ean_accounts.pl
  28. 78
      installer/data/mysql/atomicupdate/edifact.sql
  29. 76
      installer/data/mysql/kohastructure.sql
  30. 1
      installer/data/mysql/sysprefs.sql
  31. 1
      installer/data/mysql/userpermissions.sql
  32. 3
      koha-tmpl/intranet-tmpl/prog/en/includes/acquisitions-menu.inc
  33. 2
      koha-tmpl/intranet-tmpl/prog/en/includes/admin-menu.inc
  34. 38
      koha-tmpl/intranet-tmpl/prog/en/modules/acqui/basket.tt
  35. 2
      koha-tmpl/intranet-tmpl/prog/en/modules/acqui/basketgroup.tt
  36. 38
      koha-tmpl/intranet-tmpl/prog/en/modules/acqui/edi_ean.tt
  37. 90
      koha-tmpl/intranet-tmpl/prog/en/modules/acqui/edifactmsgs.tt
  38. 35
      koha-tmpl/intranet-tmpl/prog/en/modules/acqui/edimsg.tt
  39. 5
      koha-tmpl/intranet-tmpl/prog/en/modules/admin/admin-home.tt
  40. 299
      koha-tmpl/intranet-tmpl/prog/en/modules/admin/edi_accounts.tt
  41. 153
      koha-tmpl/intranet-tmpl/prog/en/modules/admin/edi_ean_accounts.tt
  42. 5
      koha-tmpl/intranet-tmpl/prog/en/modules/tools/tools-home.tt
  43. 163
      misc/cronjobs/edi_cron.pl
  44. 41
      misc/cronjobs/remove_temporary_edifiles.pl
  45. 75
      t/EdiInvoice.t
  46. 121
      t/Edifact.t
  47. 56
      t/Ediorder.t
  48. 59
      t/Ediordrsp.t
  49. 1
      t/edi_testfiles/BLSINV337023.CEI
  50. 1
      t/edi_testfiles/QUOTES_413514.CEQ
  51. 1
      t/edi_testfiles/ordrsp1.CEA
  52. 1
      t/edi_testfiles/ordrsp2.CEA
  53. 1
      t/edi_testfiles/ordrsp3.CEA
  54. 1
      t/edi_testfiles/ordrsp4.CEA
  55. 1
      t/edi_testfiles/prquotes_73050_20140430.CEQ

6
C4/Acquisition.pm

@ -2476,6 +2476,10 @@ sub GetInvoices {
push @bind_strs, " borrowers.branchcode = ? ";
push @bind_args, $args{branchcode};
}
if($args{message_id}) {
push @bind_strs, " aqinvoices.message_id = ? ";
push @bind_args, $args{message_id};
}
$query .= " WHERE " . join(" AND ", @bind_strs) if @bind_strs;
$query .= " GROUP BY aqinvoices.invoiceid ";
@ -2600,7 +2604,7 @@ sub AddInvoice {
return unless(%invoice and $invoice{invoicenumber});
my @columns = qw(invoicenumber booksellerid shipmentdate billingdate
closedate shipmentcost shipmentcost_budgetid);
closedate shipmentcost shipmentcost_budgetid message_id);
my @set_strs;
my @set_args;

10
C4/Installer/PerlDependencies.pm

@ -782,6 +782,16 @@ our $PERL_DEPS = {
'required' => '0',
'min_ver' => '0.56',
},
'Net::SFTP::Foreign' => {
'usage' => 'Edifact',
'required' => '0',
'min_ver' => '1.73',
},
'Text::Unidecode' => {
'usage' => 'Edifact',
'required' => '0',
'min_ver' => '0.04',
},
};
1;

1150
Koha/EDI.pm

File diff suppressed because it is too large

337
Koha/Edifact.pm

@ -0,0 +1,337 @@
package Koha::Edifact;
# 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 strict;
use warnings;
use File::Slurp;
use Carp;
use Encode qw( from_to );
use Koha::Edifact::Segment;
use Koha::Edifact::Message;
my $separator = {
component => q{\:},
data => q{\+},
decimal => q{.},
release => q{\?},
reserved => q{ },
segment => q{\'},
};
sub new {
my ( $class, $param_hashref ) = @_;
my $transmission;
my $self = ();
if ( $param_hashref->{filename} ) {
if ( $param_hashref->{transmission} ) {
carp
"Cannot instantiate $class : both filename and transmission passed";
return;
}
$transmission = read_file( $param_hashref->{filename} );
}
else {
$transmission = $param_hashref->{transmission};
}
$self->{transmission} = _init($transmission);
bless $self, $class;
return $self;
}
sub interchange_header {
my ( $self, $field ) = @_;
my %element = (
sender => 1,
recipient => 2,
datetime => 3,
interchange_control_reference => 4,
application_reference => 6,
);
if ( !exists $element{$field} ) {
carp "No interchange header field $field available";
return;
}
my $data = $self->{transmission}->[0]->elem( $element{$field} );
return $data;
}
sub interchange_trailer {
my ( $self, $field ) = @_;
my $trailer = $self->{transmission}->[-1];
if ( $field eq 'interchange_control_count' ) {
return $trailer->elem(0);
}
elsif ( $field eq 'interchange_control_reference' ) {
return $trailer->elem(1);
}
carp "Trailer field $field not recognized";
return;
}
sub new_data_iterator {
my $self = shift;
my $offset = 0;
while ( $self->{transmission}->[$offset]->tag() ne 'UNH' ) {
++$offset;
if ( $offset == @{ $self->{transmission} } ) {
carp 'Cannot find message start';
return;
}
}
$self->{data_iterator} = $offset;
return 1;
}
sub next_segment {
my $self = shift;
if ( defined $self->{data_iterator} ) {
my $seg = $self->{transmission}->[ $self->{data_iterator} ];
if ( $seg->tag eq 'UNH' ) {
$self->{msg_type} = $seg->elem( 1, 0 );
}
elsif ( $seg->tag eq 'LIN' ) {
$self->{msg_type} = 'detail';
}
if ( $seg->tag ne 'UNZ' ) {
$self->{data_iterator}++;
}
else {
$self->{data_iterator} = undef;
}
return $seg;
}
return;
}
# for debugging return whole transmission
sub get_transmission {
my $self = shift;
return $self->{transmission};
}
sub message_type {
my $self = shift;
return $self->{msg_type};
}
sub _init {
my $msg = shift;
if ( !$msg ) {
return;
}
if ( $msg =~ s/^UNA(.{6})// ) {
if ( service_string_advice($1) ) {
return segmentize($msg);
}
return;
}
else {
my $s = substr $msg, 10;
croak "File does not start with a Service string advice :$s";
}
}
# return an array of Message objects
sub message_array {
my $self = shift;
# return an array of array_refs 1 ref to a message
my $msg_arr = [];
my $msg = [];
my $in_msg = 0;
foreach my $seg ( @{ $self->{transmission} } ) {
if ( $seg->tag eq 'UNH' ) {
$in_msg = 1;
push @{$msg}, $seg;
}
elsif ( $seg->tag eq 'UNT' ) {
$in_msg = 0;
if ( @{$msg} ) {
push @{$msg_arr}, Koha::Edifact::Message->new($msg);
$msg = [];
}
}
elsif ($in_msg) {
push @{$msg}, $seg;
}
}
return $msg_arr;
}
#
# internal parsing routines used in _init
#
sub service_string_advice {
my $ssa = shift;
# At present this just validates that the ssa
# is standard Edifact
# TBD reset the seps if non standard
if ( $ssa ne q{:+.? '} ) {
carp " Non standard Service String Advice [$ssa]";
return;
}
# else use default separators
return 1;
}
sub segmentize {
my $raw = shift;
# In practice edifact uses latin-1 but check
# Transport now converts to utf-8 on ingest
# Do not convert here
#my $char_set = 'iso-8859-1';
#if ( $raw =~ m/^UNB[+]UNO(.)/ ) {
# $char_set = msgcharset($1);
#}
#from_to( $raw, $char_set, 'utf8' );
my $re = qr{
(?> # dont backtrack into this group
[?]. # either the escape character
# followed by any other character
| # or
[^'?] # a character that is neither escape
# nor split
)+
}x;
my @segmented;
while ( $raw =~ /($re)/g ) {
push @segmented, Koha::Edifact::Segment->new( { seg_string => $1 } );
}
return \@segmented;
}
sub msgcharset {
my $code = shift;
if ( $code =~ m/^[^ABCDEF]$/ ) {
$code = 'default';
}
my %encoding_map = (
A => 'ascii',
B => 'ascii',
C => 'iso-8859-1',
D => 'iso-8859-1',
E => 'iso-8859-1',
F => 'iso-8859-1',
default => 'iso-8859-1',
);
return $encoding_map{$code};
}
1;
__END__
=head1 NAME
Edifact - Edifact message handler
=head1 DESCRIPTION
Koha module for parsing Edifact messages
=head1 SUBROUTINES
=head2 new
my $e = Koha::Edifact->new( { filename => 'myfilename' } );
or
my $e = Koha::Edifact->new( { transmission => $msg_variable } );
instantiate the Edifact parser, requires either to be passed an in-memory
edifact message as transmission or a filename which it will read on creation
=head2 interchange_header
will return the data in the header field designated by the parameter
specified. Valid parameters are: 'sender', 'recipient', 'datetime',
'interchange_control_reference', and 'application_reference'
=head2 interchange_trailer
called either with the string 'interchange_control_count' or
'interchange_control_reference' will return the corresponding field from
the interchange trailer
=head2 new_data_iterator
Sets the object's data_iterator to point to the UNH segment
=head2 next_segment
Returns the next segment pointed to by the data_iterator. Increments the
data_iterator member or destroys it if segment UNZ has been reached
=head2 get_transmission
This method is useful in debugg:ing. Call on an Edifact object
it returns the object's transmission member
=head2 message_type
return the object's message type
=head2 message_array
return an array of Message objects contained in the Edifact transmission
=head1 Internal Methods
=head2 _init
Called by the constructor to do the parsing of the transmission
=head2 service_string_advice
Examines the Service String Advice returns 1 if the default separartors are in use
undef otherwise
=head2 segmentize
takes a raw Edifact message and returns a reference to an array of
its segments
=head2 msgcharset
Return the character set the message was encoded in. The default is iso-8859-1
We preserve this info but will have converted to utf-8 on ingest
=head1 AUTHOR
Colin Campbell <colin.campbell@ptfs-europe.com>
=head1 COPYRIGHT
Copyright 2014,2015, PTFS-Europe Ltd
This program is free software, You may redistribute it under
under the terms of the GNU General Public License
=cut

864
Koha/Edifact/Line.pm

@ -0,0 +1,864 @@
package Koha::Edifact::Line;
# 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 strict;
use warnings;
use utf8;
use MARC::Record;
use MARC::Field;
use Carp;
sub new {
my ( $class, $data_array_ref ) = @_;
my $self = _parse_lines($data_array_ref);
bless $self, $class;
return $self;
}
# helper routine used by constructor
# creates the hashref used as a data structure by the Line object
sub _parse_lines {
my $aref = shift;
my $lin = shift @{$aref};
my $id = $lin->elem( 2, 0 ); # may be undef in ordrsp
my $action = $lin->elem( 1, 0 );
my $d = {
line_item_number => $lin->elem(0),
action_notification => $action,
item_number_id => $id,
additional_product_ids => [],
};
my @item_description;
foreach my $s ( @{$aref} ) {
if ( $s->tag eq 'PIA' ) {
push @{ $d->{additional_product_ids} },
{
function_code => $s->elem(0),
item_number => $s->elem( 1, 0 ),
number_type => $s->elem( 1, 1 ),
};
}
elsif ( $s->tag eq 'IMD' ) {
push @item_description, $s;
}
elsif ( $s->tag eq 'QTY' ) {
$d->{quantity} = $s->elem( 0, 1 );
}
elsif ( $s->tag eq 'DTM' ) {
if ( $s->elem( 0, 0 ) eq '44' ) {
$d->{availability_date} = $s->elem( 0, 1 );
}
}
elsif ( $s->tag eq 'GIR' ) {
# we may get a Gir for each copy if QTY > 1
if ( !$d->{GIR} ) {
$d->{GIR} = [];
push @{ $d->{GIR} }, extract_gir($s);
}
else {
my $gir = extract_gir($s);
if ( $gir->{copy} ) { # may have to merge
foreach my $g ( @{ $d->{GIR} } ) {
if ( $gir->{copy} eq $g->{copy} ) {
foreach my $field ( keys %{$gir} ) {
if ( !exists $g->{$field} ) {
$g->{$field} = $gir->{$field};
}
}
undef $gir;
last;
}
}
if ( defined $gir ) {
push @{ $d->{GIR} }, $gir;
}
}
}
}
elsif ( $s->tag eq 'FTX' ) {
my $type = $s->elem(0);
my $ctype = 'coded_free_text';
if ( $type eq 'LNO' ) { # Ingrams Oasis Internal Notes field
$type = 'internal_notes';
$ctype = 'coded_internal_note';
}
elsif ( $type eq 'LIN' ) {
$type = 'orderline_free_text';
$ctype = 'coded_orderline_text';
}
elsif ( $type eq 'SUB' ) {
$type = 'coded_substitute_text';
}
else {
$type = 'free_text';
}
my $coded_text = $s->elem(2);
if ( ref $coded_text eq 'ARRAY' && $coded_text->[0] ) {
$d->{$ctype}->{table} = $coded_text->[1];
$d->{$ctype}->{code} = $coded_text->[0];
}
my $ftx = $s->elem(3);
if ( ref $ftx eq 'ARRAY' ) { # it comes in 70 character components
$ftx = join q{ }, @{$ftx};
}
if ( exists $d->{$type} ) { # we can only catenate repeats
$d->{$type} .= q{ };
$d->{$type} .= $ftx;
}
else {
$d->{$type} = $ftx;
}
}
elsif ( $s->tag eq 'MOA' ) {
$d->{monetary_amount} = $s->elem( 0, 1 );
}
elsif ( $s->tag eq 'PRI' ) {
$d->{price} = $s->elem( 0, 1 );
}
elsif ( $s->tag eq 'RFF' ) {
my $qualifier = $s->elem( 0, 0 );
if ( $qualifier eq 'QLI' ) { # Suppliers unique quotation reference
$d->{reference} = $s->elem( 0, 1 );
}
elsif ( $qualifier eq 'LI' ) { # Buyer's unique orderline number
$d->{ordernumber} = $s->elem( 0, 1 );
}
elsif ( $qualifier eq 'SLI' )
{ # Suppliers unique order line reference number
$d->{orderline_reference_number} = $s->elem( 0, 1 );
}
}
}
$d->{item_description} = _format_item_description(@item_description);
$d->{segs} = $aref;
return $d;
}
sub _format_item_description {
my @imd = @_;
my $bibrec = {};
# IMD : +Type code 'L' + characteristic code 3 char + Description in comp 3 & 4
foreach my $imd (@imd) {
my $type_code = $imd->elem(0);
my $ccode = $imd->elem(1);
my $desc = $imd->elem( 2, 3 );
if ( $imd->elem( 2, 4 ) ) {
$desc .= $imd->elem( 2, 4 );
}
if ( $type_code ne 'L' ) {
carp
"Only handles text item descriptions at present: code=$type_code";
next;
}
if ( exists $bibrec->{$ccode} ) {
$bibrec->{$ccode} .= q{ };
$bibrec->{$ccode} .= $desc;
}
else {
$bibrec->{$ccode} = $desc;
}
}
return $bibrec;
}
sub marc_record {
my $self = shift;
my $b = $self->{item_description};
my $bib = MARC::Record->new();
my @spec;
my @fields;
if ( exists $b->{'010'} ) {
@spec = qw( 100 a 011 c 012 b 013 d 014 e );
push @fields, new_field( $b, [ 100, 1, q{ } ], @spec );
}
if ( exists $b->{'020'} ) {
@spec = qw( 020 a 021 c 022 b 023 d 024 e );
push @fields, new_field( $b, [ 700, 1, q{ } ], @spec );
}
# corp conf
if ( exists $b->{'030'} ) {
push @fields, $self->corpcon(1);
}
if ( exists $b->{'040'} ) {
push @fields, $self->corpcon(7);
}
if ( exists $b->{'050'} ) {
@spec = qw( '050' a '060' b '065' c );
push @fields, new_field( $b, [ 245, 1, 0 ], @spec );
}
if ( exists $b->{100} ) {
@spec = qw( 100 a 101 b);
push @fields, new_field( $b, [ 250, q{ }, q{ } ], @spec );
}
@spec = qw( 110 a 120 b 170 c );
my $f = new_field( $b, [ 260, q{ }, q{ } ], @spec );
if ($f) {
push @fields, $f;
}
@spec = qw( 180 a 181 b 182 c 183 e);
$f = new_field( $b, [ 300, q{ }, q{ } ], @spec );
if ($f) {
push @fields, $f;
}
if ( exists $b->{190} ) {
@spec = qw( 190 a);
push @fields, new_field( $b, [ 490, q{ }, q{ } ], @spec );
}
if ( exists $b->{200} ) {
@spec = qw( 200 a);
push @fields, new_field( $b, [ 490, q{ }, q{ } ], @spec );
}
if ( exists $b->{210} ) {
@spec = qw( 210 a);
push @fields, new_field( $b, [ 490, q{ }, q{ } ], @spec );
}
if ( exists $b->{300} ) {
@spec = qw( 300 a);
push @fields, new_field( $b, [ 500, q{ }, q{ } ], @spec );
}
if ( exists $b->{310} ) {
@spec = qw( 310 a);
push @fields, new_field( $b, [ 520, q{ }, q{ } ], @spec );
}
if ( exists $b->{320} ) {
@spec = qw( 320 a);
push @fields, new_field( $b, [ 521, q{ }, q{ } ], @spec );
}
if ( exists $b->{260} ) {
@spec = qw( 260 a);
push @fields, new_field( $b, [ 600, q{ }, q{ } ], @spec );
}
if ( exists $b->{270} ) {
@spec = qw( 270 a);
push @fields, new_field( $b, [ 650, q{ }, q{ } ], @spec );
}
if ( exists $b->{280} ) {
@spec = qw( 280 a);
push @fields, new_field( $b, [ 655, q{ }, q{ } ], @spec );
}
# class
if ( exists $b->{230} ) {
@spec = qw( 230 a);
push @fields, new_field( $b, [ '082', q{ }, q{ } ], @spec );
}
if ( exists $b->{240} ) {
@spec = qw( 240 a);
push @fields, new_field( $b, [ '084', q{ }, q{ } ], @spec );
}
$bib->insert_fields_ordered(@fields);
return $bib;
}
sub corpcon {
my ( $self, $level ) = @_;
my $test_these = {
1 => [ '033', '032', '034' ],
7 => [ '043', '042', '044' ],
};
my $conf = 0;
foreach my $t ( @{ $test_these->{$level} } ) {
if ( exists $self->{item_description}->{$t} ) {
$conf = 1;
}
}
my $tag;
my @spec;
my ( $i1, $i2 ) = ( q{ }, q{ } );
if ($conf) {
$tag = ( $level * 100 ) + 11;
if ( $level == 1 ) {
@spec = qw( 030 a 031 e 032 n 033 c 034 d);
}
else {
@spec = qw( 040 a 041 e 042 n 043 c 044 d);
}
}
else {
$tag = ( $level * 100 ) + 10;
if ( $level == 1 ) {
@spec = qw( 030 a 031 b);
}
else {
@spec = qw( 040 a 041 b);
}
}
return new_field( $self->{item_description}, [ $tag, $i1, $i2 ], @spec );
}
sub new_field {
my ( $b, $tag_ind, @sfd_elem ) = @_;
my @sfd;
while (@sfd_elem) {
my $e = shift @sfd_elem;
my $c = shift @sfd_elem;
if ( exists $b->{$e} ) {
push @sfd, $c, $b->{$e};
}
}
if (@sfd) {
my $field = MARC::Field->new( @{$tag_ind}, @sfd );
return $field;
}
return;
}
# Accessor methods to line data
sub item_number_id {
my $self = shift;
return $self->{item_number_id};
}
sub line_item_number {
my $self = shift;
return $self->{line_item_number};
}
sub additional_product_ids {
my $self = shift;
return $self->{additional_product_ids};
}
sub action_notification {
my $self = shift;
my $a = $self->{action_notification};
if ($a) {
$a = _translate_action($a); # return the associated text string
}
return $a;
}
sub item_description {
my $self = shift;
return $self->{item_description};
}
sub monetary_amount {
my $self = shift;
return $self->{monetary_amount};
}
sub quantity {
my $self = shift;
return $self->{quantity};
}
sub price {
my $self = shift;
return $self->{price};
}
sub reference {
my $self = shift;
return $self->{reference};
}
sub orderline_reference_number {
my $self = shift;
return $self->{orderline_reference_number};
}
sub ordernumber {
my $self = shift;
return $self->{ordernumber};
}
sub free_text {
my $self = shift;
return $self->{free_text};
}
sub coded_free_text {
my $self = shift;
return $self->{coded_free_text}->{code};
}
sub internal_notes {
my $self = shift;
return $self->{internal_notes};
}
sub coded_internal_note {
my $self = shift;
return $self->{coded_internal_note}->{code};
}
sub orderline_free_text {
my $self = shift;
return $self->{orderline_free_text};
}
sub coded_orderline_text {
my $self = shift;
my $code = $self->{coded_orderline_text}->{code};
my $table = $self->{coded_orderline_text}->{table};
my $txt;
if ( $table eq '8B' || $table eq '7B' ) {
$txt = translate_8B($code);
}
elsif ( $table eq '12B' ) {
$txt = translate_12B($code);
}
if ( !$txt || $txt eq 'no match' ) {
$txt = $code;
}
return $txt;
}
sub substitute_free_text {
my $self = shift;
return $self->{substitute_free_text};
}
sub coded_substitute_text {
my $self = shift;
return $self->{coded_substitute_text}->{code};
}
# This will take a standard code as returned
# by (orderline|substitue)-free_text (FTX seg LIN)
# and expand it useing EditEUR code list 8B
sub translate_8B {
my ($code) = @_;
# list 7B is a subset of this
my %code_list_8B = (
AB => 'Publication abandoned',
AD => 'Apply direct',
AU => 'Publisher address unknown',
CS => 'Status uncertain',
FQ => 'Only available abroad',
HK => 'Paperback OP: Hardback available',
IB => 'In stock',
IP => 'In print and in stock at publisher',
MD => 'Manufactured on demand',
NK => 'Item not known',
NN => 'We do not supply this item',
NP => 'Not yet published',
NQ => 'Not stocked',
NS => 'Not sold separately',
OB => 'Temporarily out of stock',
OF => 'This format out of print: other format available',
OP => 'Out of print',
OR => 'Out pf print; New Edition coming',
PK => 'Hardback out of print: paperback available',
PN => 'Publisher no longer in business',
RE => 'Awaiting reissue',
RF => 'refer to other publisher or distributor',
RM => 'Remaindered',
RP => 'Reprinting',
RR => 'Rights restricted: cannot supply in this market',
SD => 'Sold',
SN => 'Our supplier cannot trace',
SO => 'Pack or set not available: single items only',
ST => 'Stocktaking: temporarily unavailable',
TO => 'Only to order',
TU => 'Temporarily unavailable',
UB => 'Item unobtainable from our suppliers',
UC => 'Unavailable@ reprint under consideration',
);
if ( exists $code_list_8B{$code} ) {
return $code_list_8B{$code};
}
else {
return 'no match';
}
}
sub translate_12B {
my ($code) = @_;
my %code_list_12B = (
100 => 'Order line accepted',
101 => 'Price query: orderline will be held awaiting customer response',
102 =>
'Discount query: order line will be held awaiting customer response',
103 => 'Minimum order value not reached: order line will be held',
104 =>
'Firm order required: order line will be held awaiting customer response',
110 => 'Order line accepted, substitute product will be supplied',
200 => 'Order line not accepted',
201 => 'Price query: order line not accepted',
202 => 'Discount query: order line not accepted',
203 => 'Minimum order value not reached: order line not accepted',
205 => 'Order line not accepted: quoted promotion is invalid',
206 => 'Order line not accepted: quoted promotion has ended',
207 =>
'Order line not accepted: customer ineligible for quoted promotion',
210 => 'Order line not accepted: substitute product is offered',
220 => 'Oustanding order line cancelled: reason unspecified',
221 => 'Oustanding order line cancelled: past order expiry date',
222 => 'Oustanding order line cancelled by customer request',
223 => 'Oustanding order line cancelled: unable to supply',
300 => 'Order line passed to new supplier',
301 => 'Order line passed to secondhand department',
400 => 'Backordered - awaiting supply',
401 => 'On order from our supplier',
402 => 'On order from abroad',
403 => 'Backordered, waiting to reach minimum order value',
404 => 'Despatched from our supplier, awaiting delivery',
405 => 'Our supplier sent wrong item(s), re-ordered',
406 => 'Our supplier sent short, re-ordered',
407 => 'Our supplier sent damaged item(s), re-ordered',
408 => 'Our supplier sent imperfect item(s), re-ordered',
409 => 'Our supplier cannot trace order, re-ordered',
410 => 'Ordered item(s) being processed by bookseller',
411 =>
'Ordered item(s) being processed by bookseller, awaiting customer action',
412 => 'Order line held awaiting customer instruction',
500 => 'Order line on hold - contact customer service',
800 => 'Order line already despatched',
900 => 'Cannot trace order line',
901 => 'Order line held: note title change',
902 => 'Order line held: note availability date delay',
903 => 'Order line held: note price change',
999 => 'Temporary hold: order action not yet determined',
);
if ( exists $code_list_12B{$code} ) {
return $code_list_12B{$code};
}
else {
return 'no match';
}
}
# item_desription_fields accessors
sub title {
my $self = shift;
my $titlefield = q{050};
if ( exists $self->{item_description}->{$titlefield} ) {
return $self->{item_description}->{$titlefield};
}
return;
}
sub author {
my $self = shift;
my $field = q{010};
if ( exists $self->{item_description}->{$field} ) {
my $a = $self->{item_description}->{$field};
my $forename_field = q{011};
if ( exists $self->{item_description}->{$forename_field} ) {
$a .= ', ';
$a .= $self->{item_description}->{$forename_field};
}
return $a;
}
return;
}
sub series {
my $self = shift;
my $field = q{190};
if ( exists $self->{item_description}->{$field} ) {
return $self->{item_description}->{$field};
}
return;
}
sub publisher {
my $self = shift;
my $field = q{120};
if ( exists $self->{item_description}->{$field} ) {
return $self->{item_description}->{$field};
}
return;
}
sub publication_date {
my $self = shift;
my $field = q{170};
if ( exists $self->{item_description}->{$field} ) {
return $self->{item_description}->{$field};
}
return;
}
sub dewey_class {
my $self = shift;
my $field = q{230};
if ( exists $self->{item_description}->{$field} ) {
return $self->{item_description}->{$field};
}
return;
}
sub lc_class {
my $self = shift;
my $field = q{240};
if ( exists $self->{item_description}->{$field} ) {
return $self->{item_description}->{$field};
}
return;
}
sub girfield {
my ( $self, $field, $occ ) = @_;
if ( $self->number_of_girs ) {
# defaults to occurence 0 returns undef if occ requested > occs
if ( defined $occ && $occ >= @{ $self->{GIR} } ) {
return;
}
$occ ||= 0;
return $self->{GIR}->[$occ]->{$field};
}
else {
return;
}
}
sub number_of_girs {
my $self = shift;
if ( $self->{GIR} ) {
my $qty = @{ $self->{GIR} };
return $qty;
}
else {
return 0;
}
}
sub extract_gir {
my $s = shift;
my %qmap = (
LAC => 'barcode',
LAF => 'first_accession_number',
LAL => 'last_accession_number',
LCL => 'classification',
LCO => 'item_unique_id',
LCV => 'copy_value',
LFH => 'feature_heading',
LFN => 'fund_allocation',
LFS => 'filing_suffix',
LLN => 'loan_category',
LLO => 'branch',
LLS => 'label_sublocation',
LQT => 'part_order_quantity',
LRS => 'record_sublocation',
LSM => 'shelfmark',
LSQ => 'collection_code',
LST => 'stock_category',
LSZ => 'size_code',
LVC => 'coded_servicing_instruction',
LVT => 'servicing_instruction',
);
my $set_qualifier = $s->elem( 0, 0 ); # copy number
my $gir_element = { copy => $set_qualifier, };
my $element = 1;
while ( my $e = $s->elem($element) ) {
++$element;
if ( exists $qmap{ $e->[1] } ) {
my $qualifier = $qmap{ $e->[1] };
$gir_element->{$qualifier} = $e->[0];
}
else {
carp "Unrecognized GIR code : $e->[1] for $e->[0]";
}
}
return $gir_element;
}
# mainly for invoice processing amt_ will derive from MOA price_ from PRI and tax_ from TAX/MOA pairsn
sub moa_amt {
my ( $self, $qualifier ) = @_;
foreach my $s ( @{ $self->{segs} } ) {
if ( $s->tag eq 'MOA' && $s->elem( 0, 0 ) eq $qualifier ) {
return $s->elem( 0, 1 );
}
}
return;
}
sub amt_discount {
my $self = shift;
return $self->moa_amt('52');
}
sub amt_prepayment {
my $self = shift;
return $self->moa_amt('113');
}
# total including allowances & tax
sub amt_total {
my $self = shift;
return $self->moa_amt('128');
}
# Used to give price in currency other than that given in price
sub amt_unitprice {
my $self = shift;
return $self->moa_amt('146');
}
# item amount after allowances excluding tax
sub amt_lineitem {
my $self = shift;
return $self->moa_amt('203');
}
sub pri_price {
my ( $self, $price_qualifier ) = @_;
foreach my $s ( @{ $self->{segs} } ) {
if ( $s->tag eq 'PRI' && $s->elem( 0, 0 ) eq $price_qualifier ) {
return {
price => $s->elem( 0, 1 ),
type => $s->elem( 0, 2 ),
type_qualifier => $s->elem( 0, 3 ),
};
}
}
return;
}
# unit price that will be chaged excl tax
sub price_net {
my $self = shift;
my $p = $self->pri_price('AAA');
if ( defined $p ) {
return $p->{price};
}
return;
}
# unit price excluding all allowances, charges and taxes
sub price_gross {
my $self = shift;
my $p = $self->pri_price('AAB');
if ( defined $p ) {
return $p->{price};
}
return;
}
# information price incl tax excluding allowances, charges
sub price_info {
my $self = shift;
my $p = $self->pri_price('AAE');
if ( defined $p ) {
return $p->{price};
}
return;
}
# information price incl tax,allowances, charges
sub price_info_inclusive {
my $self = shift;
my $p = $self->pri_price('AAE');
if ( defined $p ) {
return $p->{price};
}
return;
}
sub tax {
my $self = shift;
return $self->moa_amt('124');
}
sub availability_date {
my $self = shift;
if ( exists $self->{availability_date} ) {
return $self->{availability_date};
}
return;
}
# return text string representing action code
sub _translate_action {
my $code = shift;
my %action = (
2 => 'cancelled',
3 => 'change_requested',
4 => 'no_action',
5 => 'accepted',
10 => 'not_found',
24 => 'recorded', # Order accepted but a change notified
);
if ( $code && exists $action{$code} ) {
return $action{$code};
}
return $code;
}
1;
__END__
=head1 NAME
Koha::Edifact::Line
=head1 SYNOPSIS
Class to abstractly handle a Line in an Edifact Transmission
=head1 DESCRIPTION
Allows access to Edifact line elements by name
=head1 BUGS
None documented at present
=head1 Methods
=head2 new
Called with an array ref of segments constituting the line
=head1 AUTHOR
Colin Campbell <colin.campbell@ptfs-europe.com>
=head1 COPYRIGHT
Copyright 2014,2015 PTFS-Europe Ltd
This program is free software, You may redistribute it under
under the terms of the GNU General Public License
=cut

249
Koha/Edifact/Message.pm

@ -0,0 +1,249 @@
package Koha::Edifact::Message;
# 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 strict;
use warnings;
use utf8;
use Koha::Edifact::Line;
sub new {
my ( $class, $data_array_ref ) = @_;
my $header = shift @{$data_array_ref};
my $bgm = shift @{$data_array_ref};
my $msg_function = $bgm->elem(2);
my $dtm = [];
while ( $data_array_ref->[0]->tag eq 'DTM' ) {
push @{$dtm}, shift @{$data_array_ref};
}
my $self = {
function => $msg_function,
header => $header,
bgm => $bgm,
message_reference_number => $header->elem(0),
dtm => $dtm,
datasegs => $data_array_ref,
};
bless $self, $class;
return $self;
}
sub message_refno {
my $self = shift;
return $self->{message_reference_number};
}
sub function {
my $self = shift;
my $msg_function = $self->{bgm}->elem(2);
if ( $msg_function == 9 ) {
return 'original';
}
elsif ( $msg_function == 7 ) {
return 'retransmission';
}
return;
}
sub message_reference_number {
my $self = shift;
return $self->{header}->elem(0);
}
sub message_type {
my $self = shift;
return $self->{header}->elem( 1, 0 );
}
sub message_code {
my $self = shift;
return $self->{bgm}->elem( 0, 0 );
}
sub docmsg_number {
my $self = shift;
return $self->{bgm}->elem(1);
}
sub message_date {
my $self = shift;
# usually the first if not only dtm
foreach my $d ( @{ $self->{dtm} } ) {
if ( $d->elem( 0, 0 ) eq '137' ) {
return $d->elem( 0, 1 );
}
}
return; # this should not happen
}
sub tax_point_date {
my $self = shift;
if ( $self->message_type eq 'INVOIC' ) {
foreach my $d ( @{ $self->{dtm} } ) {
if ( $d->elem( 0, 0 ) eq '131' ) {
return $d->elem( 0, 1 );
}
}
}
return;
}
sub expiry_date {
my $self = shift;
if ( $self->message_type eq 'QUOTES' ) {
foreach my $d ( @{ $self->{dtm} } ) {
if ( $d->elem( 0, 0 ) eq '36' ) {
return $d->elem( 0, 1 );
}
}
}
return;
}
sub shipment_charge {
my $self = shift;
# A large number of different charges can be expressed at invoice and
# item level but the only one koha takes cognizance of is shipment
# should we wrap all invoice level charges into it??
if ( $self->message_type eq 'INVOIC' ) {
my $delivery = 0;
my $amt = 0;
foreach my $s ( @{ $self->{datasegs} } ) {
if ( $s->tag eq 'LIN' ) {
last;
}
if ( $s->tag eq 'ALC' ) {
if ( $s->elem(0) eq 'C' ) { # Its a charge
if ( $s->elem( 4, 0 ) eq 'DL' ) { # delivery charge
$delivery = 1;
}
}
next;
}
if ( $s->tag eq 'MOA' ) {
$amt += $s->elem( 0, 1 );
}
}
return $amt;
}
return;
}
# return NAD fields
sub buyer_ean {
my $self = shift;
foreach my $s ( @{ $self->{datasegs} } ) {
if ( $s->tag eq 'LIN' ) {
last;
}
if ( $s->tag eq 'NAD' ) {
my $qualifier = $s->elem(0);
if ( $qualifier eq 'BY' ) {
return $s->elem( 1, 0 );
}
}
}
return;
}
sub supplier_ean {
my $self = shift;
foreach my $s ( @{ $self->{datasegs} } ) {
if ( $s->tag eq 'LIN' ) {
last;
}
if ( $s->tag eq 'NAD' ) {
my $qualifier = $s->elem(0);
if ( $qualifier eq 'SU' ) {
return $s->elem( 1, 0 );
}
}
}
return;
}
sub lineitems {
my $self = shift;
if ( $self->{quotation_lines} ) {
return $self->{quotation_lines};
}
else {
my $items = [];
my $item_arr = [];
foreach my $seg ( @{ $self->{datasegs} } ) {
my $tag = $seg->tag;
if ( $tag eq 'LIN' ) {
if ( @{$item_arr} ) {
push @{$items}, Koha::Edifact::Line->new($item_arr);
}
$item_arr = [$seg];
next;
}
elsif ( $tag =~ m/^(UNS|CNT|UNT)$/sxm ) {
if ( @{$item_arr} ) {
push @{$items}, Koha::Edifact::Line->new($item_arr);
}
last;
}
else {
if ( @{$item_arr} ) {
push @{$item_arr}, $seg;
}
}
}
$self->{quotation_lines} = $items;
return $items;
}
}
1;
__END__
=head1 NAME
Koha::Edifact::Message
=head1 DESCRIPTION
Class modelling an Edifact Message for parsing
=head1 METHODS
=head2 new
Passed an array of segments extracts message level info
and parses lineitems as Line objects
=head1 AUTHOR
Colin Campbell <colin.campbell@ptfs-europe.com>
=head1 COPYRIGHT
Copyright 2014,2015 PTFS-Europe Ltd
This program is free software, You may redistribute it under
under the terms of the GNU General Public License
=cut

831
Koha/Edifact/Order.pm

@ -0,0 +1,831 @@
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;
use DateTime;
use Readonly;
use Business::ISBN;
use Koha::Database;
use C4::Budgets qw( GetBudget );
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};