Koha/Edifact/Line.pm

   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