"Fossies" - the Fresh Open Source Software Archive

Member "koha-19.11.15/Koha/Edifact/Line.pm" (23 Feb 2021, 25746 Bytes) of package /linux/misc/koha-19.11.15.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "Line.pm" see the Fossies "Dox" file reference documentation and the last Fossies "Diffs" side-by-side code changes report: 20.05.06_vs_20.11.00.

    1 package Koha::Edifact::Line;
    2 
    3 # Copyright 2014, 2015 PTFS-Europe Ltd
    4 #
    5 # This file is part of Koha.
    6 #
    7 # Koha is free software; you can redistribute it and/or modify it
    8 # under the terms of the GNU General Public License as published by
    9 # the Free Software Foundation; either version 3 of the License, or
   10 # (at your option) any later version.
   11 #
   12 # Koha is distributed in the hope that it will be useful, but
   13 # WITHOUT ANY WARRANTY; without even the implied warranty of
   14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
   15 # GNU General Public License for more details.
   16 #
   17 # You should have received a copy of the GNU General Public License
   18 # along with Koha; if not, see <http://www.gnu.org/licenses>.
   19 
   20 use strict;
   21 use warnings;
   22 use utf8;
   23 
   24 use MARC::Record;
   25 use MARC::Field;
   26 use Carp;
   27 
   28 sub new {
   29     my ( $class, $data_array_ref ) = @_;
   30     my $self = _parse_lines($data_array_ref);
   31 
   32     bless $self, $class;
   33     return $self;
   34 }
   35 
   36 # helper routine used by constructor
   37 # creates the hashref used as a data structure by the Line object
   38 
   39 sub _parse_lines {
   40     my $aref = shift;
   41 
   42     my $lin = shift @{$aref};
   43 
   44     my $id     = $lin->elem( 2, 0 );    # may be undef in ordrsp
   45     my $action = $lin->elem( 1, 0 );
   46     my $d      = {
   47         line_item_number       => $lin->elem(0),
   48         action_notification    => $action,
   49         item_number_id         => $id,
   50         additional_product_ids => [],
   51     };
   52     my @item_description;
   53 
   54     foreach my $s ( @{$aref} ) {
   55         if ( $s->tag eq 'PIA' ) {
   56             push @{ $d->{additional_product_ids} },
   57               {
   58                 function_code => $s->elem(0),
   59                 item_number   => $s->elem( 1, 0 ),
   60                 number_type   => $s->elem( 1, 1 ),
   61               };
   62         }
   63         elsif ( $s->tag eq 'IMD' ) {
   64             push @item_description, $s;
   65         }
   66         elsif ( $s->tag eq 'QTY' ) {
   67             if ( $s->elem( 0, 0 ) eq '47' ) {
   68                 $d->{quantity_invoiced} = $s->elem( 0, 1 );
   69             }
   70             $d->{quantity} = $s->elem( 0, 1 );
   71         }
   72         elsif ( $s->tag eq 'DTM' ) {
   73             if ( $s->elem( 0, 0 ) eq '44' ) {
   74                 $d->{availability_date} = $s->elem( 0, 1 );
   75             }
   76         }
   77         elsif ( $s->tag eq 'GIR' ) {
   78 
   79             # we may get a Gir for each copy if QTY > 1
   80             if ( !$d->{GIR} ) {
   81                 $d->{GIR} = [];
   82                 push @{ $d->{GIR} }, extract_gir($s);
   83             }
   84             else {
   85                 my $gir = extract_gir($s);
   86                 if ( $gir->{copy} ) {    # may have to merge
   87                     foreach my $g ( @{ $d->{GIR} } ) {
   88                         if ( $gir->{copy} eq $g->{copy} ) {
   89                             foreach my $field ( keys %{$gir} ) {
   90                                 if ( !exists $g->{$field} ) {
   91                                     $g->{$field} = $gir->{$field};
   92                                 }
   93                             }
   94                             undef $gir;
   95                             last;
   96                         }
   97                     }
   98                     if ( defined $gir ) {
   99                         push @{ $d->{GIR} }, $gir;
  100                     }
  101                 }
  102             }
  103         }
  104         elsif ( $s->tag eq 'FTX' ) {
  105 
  106             my $type  = $s->elem(0);
  107             my $ctype = 'coded_free_text';
  108             if ( $type eq 'LNO' ) {    # Ingrams Oasis Internal Notes field
  109                 $type  = 'internal_notes';
  110                 $ctype = 'coded_internal_note';
  111             }
  112             elsif ( $type eq 'LIN' ) {
  113                 $type  = 'orderline_free_text';
  114                 $ctype = 'coded_orderline_text';
  115             }
  116             elsif ( $type eq 'SUB' ) {
  117                 $type = 'coded_substitute_text';
  118             }
  119             else {
  120                 $type = 'free_text';
  121             }
  122 
  123             my $coded_text = $s->elem(2);
  124             if ( ref $coded_text eq 'ARRAY' && $coded_text->[0] ) {
  125                 $d->{$ctype}->{table} = $coded_text->[1];
  126                 $d->{$ctype}->{code}  = $coded_text->[0];
  127             }
  128 
  129             my $ftx = $s->elem(3);
  130             if ( ref $ftx eq 'ARRAY' ) {   # it comes in 70 character components
  131                 $ftx = join q{ }, @{$ftx};
  132             }
  133             if ( exists $d->{$type} ) {    # we can only catenate repeats
  134                 $d->{$type} .= q{ };
  135                 $d->{$type} .= $ftx;
  136             }
  137             else {
  138                 $d->{$type} = $ftx;
  139             }
  140         }
  141         elsif ( $s->tag eq 'MOA' ) {
  142 
  143             $d->{monetary_amount} = $s->elem( 0, 1 );
  144         }
  145         elsif ( $s->tag eq 'PRI' ) {
  146 
  147             $d->{price} = $s->elem( 0, 1 );
  148         }
  149         elsif ( $s->tag eq 'RFF' ) {
  150             my $qualifier = $s->elem( 0, 0 );
  151             if ( $qualifier eq 'QLI' ) {  # Suppliers unique quotation reference
  152                 $d->{reference} = $s->elem( 0, 1 );
  153             }
  154             elsif ( $qualifier eq 'LI' ) {    # Buyer's unique orderline number
  155                 $d->{ordernumber} = $s->elem( 0, 1 );
  156             }
  157             elsif ( $qualifier eq 'SLI' )
  158             {    # Suppliers unique order line reference number
  159                 $d->{orderline_reference_number} = $s->elem( 0, 1 );
  160             }
  161         }
  162     }
  163     $d->{item_description} = _format_item_description(@item_description);
  164     $d->{segs}             = $aref;
  165 
  166     return $d;
  167 }
  168 
  169 sub _format_item_description {
  170     my @imd    = @_;
  171     my $bibrec = {};
  172 
  173  # IMD : +Type code 'L' + characteristic code 3 char + Description in comp 3 & 4
  174     foreach my $imd (@imd) {
  175         my $type_code = $imd->elem(0);
  176         my $ccode     = $imd->elem(1);
  177         my $desc      = $imd->elem( 2, 3 );
  178         if ( $imd->elem( 2, 4 ) ) {
  179             $desc .= $imd->elem( 2, 4 );
  180         }
  181         if ( $type_code ne 'L' ) {
  182             carp
  183               "Only handles text item descriptions at present: code=$type_code";
  184             next;
  185         }
  186         if ( exists $bibrec->{$ccode} ) {
  187             $bibrec->{$ccode} .= q{ };
  188             $bibrec->{$ccode} .= $desc;
  189         }
  190         else {
  191             $bibrec->{$ccode} = $desc;
  192         }
  193     }
  194     return $bibrec;
  195 }
  196 
  197 sub marc_record {
  198     my $self = shift;
  199     my $b    = $self->{item_description};
  200 
  201     my $bib = MARC::Record->new();
  202 
  203     my @spec;
  204     my @fields;
  205     if ( exists $b->{'010'} ) {
  206         @spec = qw( 100 a 011 c 012 b 013 d 014 e );
  207         push @fields, new_field( $b, [ 100, 1, q{ } ], @spec );
  208     }
  209     if ( exists $b->{'020'} ) {
  210         @spec = qw( 020 a 021 c 022 b 023 d 024 e );
  211         push @fields, new_field( $b, [ 700, 1, q{ } ], @spec );
  212     }
  213 
  214     # corp conf
  215     if ( exists $b->{'030'} ) {
  216         push @fields, $self->corpcon(1);
  217     }
  218     if ( exists $b->{'040'} ) {
  219         push @fields, $self->corpcon(7);
  220     }
  221     if ( exists $b->{'050'} ) {
  222         @spec = qw( '050' a '060' b '065' c );
  223         push @fields, new_field( $b, [ 245, 1, 0 ], @spec );
  224     }
  225     if ( exists $b->{100} ) {
  226         @spec = qw( 100 a 101 b);
  227         push @fields, new_field( $b, [ 250, q{ }, q{ } ], @spec );
  228     }
  229     @spec = qw( 110 a 120 b 170 c );
  230     my $f = new_field( $b, [ 260, q{ }, q{ } ], @spec );
  231     if ($f) {
  232         push @fields, $f;
  233     }
  234     @spec = qw( 180 a 181 b 182 c 183 e);
  235     $f = new_field( $b, [ 300, q{ }, q{ } ], @spec );
  236     if ($f) {
  237         push @fields, $f;
  238     }
  239     if ( exists $b->{190} ) {
  240         @spec = qw( 190 a);
  241         push @fields, new_field( $b, [ 490, q{ }, q{ } ], @spec );
  242     }
  243 
  244     if ( exists $b->{200} ) {
  245         @spec = qw( 200 a);
  246         push @fields, new_field( $b, [ 490, q{ }, q{ } ], @spec );
  247     }
  248     if ( exists $b->{210} ) {
  249         @spec = qw( 210 a);
  250         push @fields, new_field( $b, [ 490, q{ }, q{ } ], @spec );
  251     }
  252     if ( exists $b->{300} ) {
  253         @spec = qw( 300 a);
  254         push @fields, new_field( $b, [ 500, q{ }, q{ } ], @spec );
  255     }
  256     if ( exists $b->{310} ) {
  257         @spec = qw( 310 a);
  258         push @fields, new_field( $b, [ 520, q{ }, q{ } ], @spec );
  259     }
  260     if ( exists $b->{320} ) {
  261         @spec = qw( 320 a);
  262         push @fields, new_field( $b, [ 521, q{ }, q{ } ], @spec );
  263     }
  264     if ( exists $b->{260} ) {
  265         @spec = qw( 260 a);
  266         push @fields, new_field( $b, [ 600, q{ }, q{ } ], @spec );
  267     }
  268     if ( exists $b->{270} ) {
  269         @spec = qw( 270 a);
  270         push @fields, new_field( $b, [ 650, q{ }, q{ } ], @spec );
  271     }
  272     if ( exists $b->{280} ) {
  273         @spec = qw( 280 a);
  274         push @fields, new_field( $b, [ 655, q{ }, q{ } ], @spec );
  275     }
  276 
  277     # class
  278     if ( exists $b->{230} ) {
  279         @spec = qw( 230 a);
  280         push @fields, new_field( $b, [ '082', q{ }, q{ } ], @spec );
  281     }
  282     if ( exists $b->{240} ) {
  283         @spec = qw( 240 a);
  284         push @fields, new_field( $b, [ '084', q{ }, q{ } ], @spec );
  285     }
  286     $bib->insert_fields_ordered(@fields);
  287 
  288     return $bib;
  289 }
  290 
  291 sub corpcon {
  292     my ( $self, $level ) = @_;
  293     my $test_these = {
  294         1 => [ '033', '032', '034' ],
  295         7 => [ '043', '042', '044' ],
  296     };
  297     my $conf = 0;
  298     foreach my $t ( @{ $test_these->{$level} } ) {
  299         if ( exists $self->{item_description}->{$t} ) {
  300             $conf = 1;
  301         }
  302     }
  303     my $tag;
  304     my @spec;
  305     my ( $i1, $i2 ) = ( q{ }, q{ } );
  306     if ($conf) {
  307         $tag = ( $level * 100 ) + 11;
  308         if ( $level == 1 ) {
  309             @spec = qw( 030 a 031 e 032 n 033 c 034 d);
  310         }
  311         else {
  312             @spec = qw( 040 a 041 e 042 n 043 c 044 d);
  313         }
  314     }
  315     else {
  316         $tag = ( $level * 100 ) + 10;
  317         if ( $level == 1 ) {
  318             @spec = qw( 030 a 031 b);
  319         }
  320         else {
  321             @spec = qw( 040 a 041 b);
  322         }
  323     }
  324     return new_field( $self->{item_description}, [ $tag, $i1, $i2 ], @spec );
  325 }
  326 
  327 sub new_field {
  328     my ( $b, $tag_ind, @sfd_elem ) = @_;
  329     my @sfd;
  330     while (@sfd_elem) {
  331         my $e = shift @sfd_elem;
  332         my $c = shift @sfd_elem;
  333         if ( exists $b->{$e} ) {
  334             push @sfd, $c, $b->{$e};
  335         }
  336     }
  337     if (@sfd) {
  338         my $field = MARC::Field->new( @{$tag_ind}, @sfd );
  339         return $field;
  340     }
  341     return;
  342 }
  343 
  344 # Accessor methods to line data
  345 
  346 sub item_number_id {
  347     my $self = shift;
  348     return $self->{item_number_id};
  349 }
  350 
  351 sub line_item_number {
  352     my $self = shift;
  353     return $self->{line_item_number};
  354 }
  355 
  356 sub additional_product_ids {
  357     my $self = shift;
  358     return $self->{additional_product_ids};
  359 }
  360 
  361 sub action_notification {
  362     my $self = shift;
  363     my $a    = $self->{action_notification};
  364     if ($a) {
  365         $a = _translate_action($a);    # return the associated text string
  366     }
  367     return $a;
  368 }
  369 
  370 sub item_description {
  371     my $self = shift;
  372     return $self->{item_description};
  373 }
  374 
  375 sub monetary_amount {
  376     my $self = shift;
  377     return $self->{monetary_amount};
  378 }
  379 
  380 sub quantity {
  381     my $self = shift;
  382     return $self->{quantity};
  383 }
  384 
  385 sub quantity_invoiced {
  386     my $self = shift;
  387     return $self->{quantity_invoiced};
  388 }
  389 
  390 sub price {
  391     my $self = shift;
  392     return $self->{price};
  393 }
  394 
  395 sub reference {
  396     my $self = shift;
  397     return $self->{reference};
  398 }
  399 
  400 sub orderline_reference_number {
  401     my $self = shift;
  402     return $self->{orderline_reference_number};
  403 }
  404 
  405 sub ordernumber {
  406     my $self = shift;
  407     return $self->{ordernumber};
  408 }
  409 
  410 sub free_text {
  411     my $self = shift;
  412     return $self->{free_text};
  413 }
  414 
  415 sub coded_free_text {
  416     my $self = shift;
  417     return $self->{coded_free_text}->{code};
  418 }
  419 
  420 sub internal_notes {
  421     my $self = shift;
  422     return $self->{internal_notes};
  423 }
  424 
  425 sub coded_internal_note {
  426     my $self = shift;
  427     return $self->{coded_internal_note}->{code};
  428 }
  429 
  430 sub orderline_free_text {
  431     my $self = shift;
  432     return $self->{orderline_free_text};
  433 }
  434 
  435 sub coded_orderline_text {
  436     my $self  = shift;
  437     my $code  = $self->{coded_orderline_text}->{code};
  438     my $table = $self->{coded_orderline_text}->{table};
  439     my $txt;
  440     if ( $table eq '8B' || $table eq '7B' ) {
  441         $txt = translate_8B($code);
  442     }
  443     elsif ( $table eq '12B' ) {
  444         $txt = translate_12B($code);
  445     }
  446     if ( !$txt || $txt eq 'no match' ) {
  447         $txt = $code;
  448     }
  449     return $txt;
  450 }
  451 
  452 sub substitute_free_text {
  453     my $self = shift;
  454     return $self->{substitute_free_text};
  455 }
  456 
  457 sub coded_substitute_text {
  458     my $self = shift;
  459     return $self->{coded_substitute_text}->{code};
  460 }
  461 
  462 # This will take a standard code as returned
  463 # by (orderline|substitue)-free_text (FTX seg LIN)
  464 # and expand it using EditEUR code list 8B
  465 sub translate_8B {
  466     my ($code) = @_;
  467 
  468     # list 7B is a subset of this
  469     my %code_list_8B = (
  470         AB => 'Publication abandoned',
  471         AD => 'Apply direct',
  472         AU => 'Publisher address unknown',
  473         CS => 'Status uncertain',
  474         FQ => 'Only available abroad',
  475         HK => 'Paperback OP: Hardback available',
  476         IB => 'In stock',
  477         IP => 'In print and in stock at publisher',
  478         MD => 'Manufactured on demand',
  479         NK => 'Item not known',
  480         NN => 'We do not supply this item',
  481         NP => 'Not yet published',
  482         NQ => 'Not stocked',
  483         NS => 'Not sold separately',
  484         OB => 'Temporarily out of stock',
  485         OF => 'This format out of print: other format available',
  486         OP => 'Out of print',
  487         OR => 'Out pf print; New Edition coming',
  488         PK => 'Hardback out of print: paperback available',
  489         PN => 'Publisher no longer in business',
  490         RE => 'Awaiting reissue',
  491         RF => 'refer to other publisher or distributor',
  492         RM => 'Remaindered',
  493         RP => 'Reprinting',
  494         RR => 'Rights restricted: cannot supply in this market',
  495         SD => 'Sold',
  496         SN => 'Our supplier cannot trace',
  497         SO => 'Pack or set not available: single items only',
  498         ST => 'Stocktaking: temporarily unavailable',
  499         TO => 'Only to order',
  500         TU => 'Temporarily unavailable',
  501         UB => 'Item unobtainable from our suppliers',
  502         UC => 'Unavailable@ reprint under consideration',
  503     );
  504 
  505     if ( exists $code_list_8B{$code} ) {
  506         return $code_list_8B{$code};
  507     }
  508     else {
  509         return 'no match';
  510     }
  511 }
  512 
  513 sub translate_12B {
  514     my ($code) = @_;
  515 
  516     my %code_list_12B = (
  517         100 => 'Order line accepted',
  518         101 => 'Price query: orderline will be held awaiting customer response',
  519         102 =>
  520           'Discount query: order line will be held awaiting customer response',
  521         103 => 'Minimum order value not reached: order line will be held',
  522         104 =>
  523 'Firm order required: order line will be held awaiting customer response',
  524         110 => 'Order line accepted, substitute product will be supplied',
  525         200 => 'Order line not accepted',
  526         201 => 'Price query: order line not accepted',
  527         202 => 'Discount query: order line not accepted',
  528         203 => 'Minimum order value not reached: order line not accepted',
  529         205 => 'Order line not accepted: quoted promotion is invalid',
  530         206 => 'Order line not accepted: quoted promotion has ended',
  531         207 =>
  532           'Order line not accepted: customer ineligible for quoted promotion',
  533         210 => 'Order line not accepted: substitute product is offered',
  534         220 => 'Oustanding order line cancelled: reason unspecified',
  535         221 => 'Oustanding order line cancelled: past order expiry date',
  536         222 => 'Oustanding order line cancelled by customer request',
  537         223 => 'Oustanding order line cancelled: unable to supply',
  538         300 => 'Order line passed to new supplier',
  539         301 => 'Order line passed to secondhand department',
  540         400 => 'Backordered - awaiting supply',
  541         401 => 'On order from our supplier',
  542         402 => 'On order from abroad',
  543         403 => 'Backordered, waiting to reach minimum order value',
  544         404 => 'Despatched from our supplier, awaiting delivery',
  545         405 => 'Our supplier sent wrong item(s), re-ordered',
  546         406 => 'Our supplier sent short, re-ordered',
  547         407 => 'Our supplier sent damaged item(s), re-ordered',
  548         408 => 'Our supplier sent imperfect item(s), re-ordered',
  549         409 => 'Our supplier cannot trace order, re-ordered',
  550         410 => 'Ordered item(s) being processed by bookseller',
  551         411 =>
  552 'Ordered item(s) being processed by bookseller, awaiting customer action',
  553         412 => 'Order line held awaiting customer instruction',
  554         500 => 'Order line on hold - contact customer service',
  555         800 => 'Order line already despatched',
  556         900 => 'Cannot trace order line',
  557         901 => 'Order line held: note title change',
  558         902 => 'Order line held: note availability date delay',
  559         903 => 'Order line held: note price change',
  560         999 => 'Temporary hold: order action not yet determined',
  561     );
  562 
  563     if ( exists $code_list_12B{$code} ) {
  564         return $code_list_12B{$code};
  565     }
  566     else {
  567         return 'no match';
  568     }
  569 }
  570 
  571 # item_desription_fields accessors
  572 
  573 sub title {
  574     my $self       = shift;
  575     my $titlefield = q{050};
  576     if ( exists $self->{item_description}->{$titlefield} ) {
  577         return $self->{item_description}->{$titlefield};
  578     }
  579     return;
  580 }
  581 
  582 sub author {
  583     my $self  = shift;
  584     my $field = q{010};
  585     if ( exists $self->{item_description}->{$field} ) {
  586         my $a              = $self->{item_description}->{$field};
  587         my $forename_field = q{011};
  588         if ( exists $self->{item_description}->{$forename_field} ) {
  589             $a .= ', ';
  590             $a .= $self->{item_description}->{$forename_field};
  591         }
  592         return $a;
  593     }
  594     return;
  595 }
  596 
  597 sub series {
  598     my $self  = shift;
  599     my $field = q{190};
  600     if ( exists $self->{item_description}->{$field} ) {
  601         return $self->{item_description}->{$field};
  602     }
  603     return;
  604 }
  605 
  606 sub publisher {
  607     my $self  = shift;
  608     my $field = q{120};
  609     if ( exists $self->{item_description}->{$field} ) {
  610         return $self->{item_description}->{$field};
  611     }
  612     return;
  613 }
  614 
  615 sub publication_date {
  616     my $self  = shift;
  617     my $field = q{170};
  618     if ( exists $self->{item_description}->{$field} ) {
  619         return $self->{item_description}->{$field};
  620     }
  621     return;
  622 }
  623 
  624 sub dewey_class {
  625     my $self  = shift;
  626     my $field = q{230};
  627     if ( exists $self->{item_description}->{$field} ) {
  628         return $self->{item_description}->{$field};
  629     }
  630     return;
  631 }
  632 
  633 sub lc_class {
  634     my $self  = shift;
  635     my $field = q{240};
  636     if ( exists $self->{item_description}->{$field} ) {
  637         return $self->{item_description}->{$field};
  638     }
  639     return;
  640 }
  641 
  642 sub girfield {
  643     my ( $self, $field, $occ ) = @_;
  644     if ( $self->number_of_girs ) {
  645 
  646         # defaults to occurrence 0 returns undef if occ requested > occs
  647         if ( defined $occ && $occ >= @{ $self->{GIR} } ) {
  648             return;
  649         }
  650         $occ ||= 0;
  651         return $self->{GIR}->[$occ]->{$field};
  652     }
  653     else {
  654         return;
  655     }
  656 }
  657 
  658 sub number_of_girs {
  659     my $self = shift;
  660     if ( $self->{GIR} ) {
  661 
  662         my $qty = @{ $self->{GIR} };
  663 
  664         return $qty;
  665     }
  666     else {
  667         return 0;
  668     }
  669 }
  670 
  671 sub extract_gir {
  672     my $s    = shift;
  673     my %qmap = (
  674         LAC => 'barcode',
  675         LAF => 'first_accession_number',
  676         LAL => 'last_accession_number',
  677         LCL => 'classification',
  678         LCO => 'item_unique_id',
  679         LCV => 'copy_value',
  680         LFH => 'feature_heading',
  681         LFN => 'fund_allocation',
  682         LFS => 'filing_suffix',
  683         LLN => 'loan_category',
  684         LLO => 'branch',
  685         LLS => 'label_sublocation',
  686         LQT => 'part_order_quantity',
  687         LRS => 'record_sublocation',
  688         LSM => 'shelfmark',
  689         LSQ => 'collection_code',
  690         LST => 'stock_category',
  691         LSZ => 'size_code',
  692         LVC => 'coded_servicing_instruction',
  693         LVT => 'servicing_instruction',
  694         LHC => 'library_holding_code',
  695         LRP => 'library_rotation_plan',
  696         LSC => 'statistical_category',
  697         RIC => 'reader_interest_category',
  698     );
  699 
  700     my $set_qualifier = $s->elem( 0, 0 );    # copy number
  701     my $gir_element = { copy => $set_qualifier, };
  702     my $element = 1;
  703     while ( my $e = $s->elem($element) ) {
  704         ++$element;
  705         if ( exists $qmap{ $e->[1] } ) {
  706             my $qualifier = $qmap{ $e->[1] };
  707             $gir_element->{$qualifier} = $e->[0];
  708         }
  709         else {
  710 
  711             carp "Unrecognized GIR code : $e->[1] for $e->[0]";
  712         }
  713     }
  714     return $gir_element;
  715 }
  716 
  717 # mainly for invoice processing amt_ will derive from MOA price_ from PRI and tax_ from TAX/MOA pairsn
  718 sub moa_amt {
  719     my ( $self, $qualifier ) = @_;
  720     foreach my $s ( @{ $self->{segs} } ) {
  721         if ( $s->tag eq 'MOA' && $s->elem( 0, 0 ) eq $qualifier ) {
  722             return $s->elem( 0, 1 );
  723         }
  724     }
  725     return;
  726 }
  727 sub moa_multiple_amt {
  728     my ( $self, $qualifier ) = @_;
  729     # return a repeatable MOA field
  730     my $amt   = 0;
  731     my $found = 0;
  732     foreach my $s ( @{ $self->{segs} } ) {
  733         if ( $s->tag eq 'MOA' && $s->elem( 0, 0 ) eq $qualifier ) {
  734             $amt += $s->elem( 0, 1 );
  735             $found = 1;
  736         }
  737     }
  738     if ($found) {
  739         return $amt;
  740     }
  741     return;
  742 }
  743 
  744 sub amt_discount {
  745     my $self = shift;
  746     return $self->moa_amt('52');
  747 }
  748 
  749 sub amt_prepayment {
  750     my $self = shift;
  751     return $self->moa_amt('113');
  752 }
  753 
  754 # total including allowances & tax
  755 sub amt_total {
  756     my $self = shift;
  757     return $self->moa_amt('128');
  758 }
  759 
  760 # Used to give price in currency other than that given in price
  761 sub amt_unitprice {
  762     my $self = shift;
  763     return $self->moa_amt('146');
  764 }
  765 
  766 # item amount after allowances excluding tax
  767 sub amt_lineitem {
  768     my $self = shift;
  769     return $self->moa_amt('203');
  770 }
  771 sub amt_taxoncharge {
  772     my $self = shift;
  773     return $self->moa_multiple_amt('124');
  774 }
  775 
  776 sub pri_price {
  777     my ( $self, $price_qualifier ) = @_;
  778             # In practice qualifier is AAE in the quote and AAA & AAB in invoices
  779             # but the following are defined
  780             # AAA calculation price net (unit price excl tax but incl any allowances or charges)
  781             # AAB calculation price gross (unit price excl all taxes, allowances and charges )
  782             # AAE information price (incl tax but excl allowances or charges )
  783             # AAF information price (including all taxes, allowances or charges)
  784     foreach my $s ( @{ $self->{segs} } ) {
  785         if ( $s->tag eq 'PRI' && $s->elem( 0, 0 ) eq $price_qualifier ) {
  786             # in practice not all 3 fields may be present
  787             # so use a temp variable to avoid runtime warnings
  788             my $p = {
  789                 price          => undef,
  790                 type           => undef,
  791                 type_qualifier => undef,
  792             };
  793             $p->{price}          = $s->elem( 0, 1 );
  794             $p->{type}           = $s->elem( 0, 2 );
  795             $p->{type_qualifier} = $s->elem( 0, 3 );
  796             return $p;
  797         }
  798     }
  799     return;
  800 }
  801 
  802 # unit price that will be chaged excl tax
  803 sub price_net {
  804     my $self = shift;
  805     my $p    = $self->pri_price('AAA');
  806     if ( defined $p ) {
  807         return $p->{price};
  808     }
  809     return;
  810 }
  811 
  812 # unit price excluding all allowances, charges and taxes
  813 sub price_gross {
  814     my $self = shift;
  815     my $p    = $self->pri_price('AAB');
  816     if ( defined $p ) {
  817         return $p->{price};
  818     }
  819     return;
  820 }
  821 
  822 # information price incl tax excluding allowances, charges
  823 sub price_info {
  824     my $self = shift;
  825     my $p    = $self->pri_price('AAE');
  826     if ( defined $p ) {
  827         return $p->{price};
  828     }
  829     return;
  830 }
  831 
  832 # information price incl tax,allowances, charges
  833 sub price_info_inclusive {
  834     my $self = shift;
  835     my $p    = $self->pri_price('AAF');
  836     if ( defined $p ) {
  837         return $p->{price};
  838     }
  839     return;
  840 }
  841 
  842 sub tax {
  843     my $self = shift;
  844     return $self->moa_amt('124');
  845 }
  846 
  847 sub tax_rate {
  848     my $self = shift;
  849     my $tr = {};
  850     foreach my $s ( @{ $self->{segs} } ) {
  851         if ( $s->tag eq 'TAX' && $s->elem( 0, 0 ) == 7 ) {
  852             $tr->{type} = $s->elem( 1, 0 ); # VAT, GST or IMP
  853             $tr->{rate} = $s->elem( 4, 3 ); # percentage
  854             # category values may be:
  855             # E = exempt from tax
  856             # G = export item, tax not charged
  857             # H = higher rate
  858             # L = lower rate
  859             # S = standard rate
  860             # Z = zero-rated
  861             $tr->{category} = $s->elem( 5, 0 );
  862             if (!defined $tr->{rate} && $tr->{category} eq 'Z') {
  863                 $tr->{rate} = 0;
  864             }
  865             return $tr;
  866         }
  867     }
  868     return;
  869 }
  870 
  871 sub availability_date {
  872     my $self = shift;
  873     if ( exists $self->{availability_date} ) {
  874         return $self->{availability_date};
  875     }
  876     return;
  877 }
  878 
  879 # return text string representing action code
  880 sub _translate_action {
  881     my $code   = shift;
  882     my %action = (
  883         2  => 'cancelled',
  884         3  => 'change_requested',
  885         4  => 'no_action',
  886         5  => 'accepted',
  887         10 => 'not_found',
  888         24 => 'recorded',           # Order accepted but a change notified
  889     );
  890     if ( $code && exists $action{$code} ) {
  891         return $action{$code};
  892     }
  893     return $code;
  894 
  895 }
  896 1;
  897 __END__
  898 
  899 =head1 NAME
  900 
  901 Koha::Edifact::Line
  902 
  903 =head1 SYNOPSIS
  904 
  905   Class to abstractly handle a Line in an Edifact Transmission
  906 
  907 =head1 DESCRIPTION
  908 
  909   Allows access to Edifact line elements by name
  910 
  911 =head1 BUGS
  912 
  913   None documented at present
  914 
  915 =head1 Methods
  916 
  917 =head2 new
  918 
  919    Called with an array ref of segments constituting the line
  920 
  921 =head1 AUTHOR
  922 
  923    Colin Campbell <colin.campbell@ptfs-europe.com>
  924 
  925 =head1 COPYRIGHT
  926 
  927    Copyright 2014,2015  PTFS-Europe Ltd
  928    This program is free software, You may redistribute it under
  929    under the terms of the GNU General Public License
  930 
  931 
  932 =cut