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