| Line 0
          
      
      
        Link Here | 
            
              |  |  | 1 | package Koha::Edifact::Order; | 
            
              | 2 |  | 
            
              | 3 | use strict; | 
            
              | 4 | use warnings; | 
            
              | 5 |  | 
            
              | 6 | # Copyright 2014 PTFS-Europe Ltd | 
            
              | 7 | # | 
            
              | 8 | # This file is part of Koha. | 
            
              | 9 | # | 
            
              | 10 | # Koha is free software; you can redistribute it and/or modify it | 
            
              | 11 | # under the terms of the GNU General Public License as published by | 
            
              | 12 | # the Free Software Foundation; either version 3 of the License, or | 
            
              | 13 | # (at your option) any later version. | 
            
              | 14 | # | 
            
              | 15 | # Koha is distributed in the hope that it will be useful, but | 
            
              | 16 | # WITHOUT ANY WARRANTY; without even the implied warranty of | 
            
              | 17 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | 
            
              | 18 | # GNU General Public License for more details. | 
            
              | 19 | # | 
            
              | 20 | # You should have received a copy of the GNU General Public License | 
            
              | 21 | # along with Koha; if not, see <http://www.gnu.org/licenses>. | 
            
              | 22 |  | 
            
              | 23 | use Carp; | 
            
              | 24 | use DateTime; | 
            
              | 25 | use Readonly; | 
            
              | 26 | use Business::ISBN; | 
            
              | 27 | use Encode qw(from_to); | 
            
              | 28 | use Koha::Database; | 
            
              | 29 | use C4::Budgets qw( GetBudget ); | 
            
              | 30 |  | 
            
              | 31 | Readonly::Scalar my $seg_terminator      => q{'}; | 
            
              | 32 | Readonly::Scalar my $separator           => q{+}; | 
            
              | 33 | Readonly::Scalar my $component_separator => q{:}; | 
            
              | 34 | Readonly::Scalar my $release_character   => q{?}; | 
            
              | 35 |  | 
            
              | 36 | Readonly::Scalar my $NINES_12  => 999_999_999_999; | 
            
              | 37 | Readonly::Scalar my $NINES_14  => 99_999_999_999_999; | 
            
              | 38 | Readonly::Scalar my $CHUNKSIZE => 35; | 
            
              | 39 |  | 
            
              | 40 | my $use_marc_based_description = | 
            
              | 41 |   0;    # A global configflag : not currently implemented | 
            
              | 42 |  | 
            
              | 43 | sub new { | 
            
              | 44 |     my ( $class, $parameter_hashref ) = @_; | 
            
              | 45 |  | 
            
              | 46 |     my $self = {}; | 
            
              | 47 |     if ( ref $parameter_hashref ) { | 
            
              | 48 |         $self->{orderlines} = $parameter_hashref->{orderlines}; | 
            
              | 49 |         $self->{recipient}  = $parameter_hashref->{vendor}; | 
            
              | 50 |         $self->{sender}     = $parameter_hashref->{ean}; | 
            
              | 51 |  | 
            
              | 52 |         # convenient alias | 
            
              | 53 |         $self->{basket} = $self->{orderlines}->[0]->basketno; | 
            
              | 54 |         $self->{message_date} = DateTime->now( time_zone => 'local' ); | 
            
              | 55 |     } | 
            
              | 56 |  | 
            
              | 57 |     # validate that its worth proceeding | 
            
              | 58 |     if ( !$self->{orderlines} ) { | 
            
              | 59 |         carp 'No orderlines passed to create order'; | 
            
              | 60 |         return; | 
            
              | 61 |     } | 
            
              | 62 |     if ( !$self->{recipient} ) { | 
            
              | 63 |         carp | 
            
              | 64 | "No vendor passed to order creation: basket = $self->{basket}->basketno()"; | 
            
              | 65 |         return; | 
            
              | 66 |     } | 
            
              | 67 |     if ( !$self->{sender} ) { | 
            
              | 68 |         carp | 
            
              | 69 | "No sender ean passed to order creation: basket = $self->{basket}->basketno()"; | 
            
              | 70 |         return; | 
            
              | 71 |     } | 
            
              | 72 |  | 
            
              | 73 |     # do this once per object not once per orderline | 
            
              | 74 |     my $database = Koha::Database->new(); | 
            
              | 75 |     $self->{schema} = $database->schema; | 
            
              | 76 |  | 
            
              | 77 |     bless $self, $class; | 
            
              | 78 |     return $self; | 
            
              | 79 | } | 
            
              | 80 |  | 
            
              | 81 | sub filename { | 
            
              | 82 |     my $self = shift; | 
            
              | 83 |     if ( !$self->{orderlines} ) { | 
            
              | 84 |         return; | 
            
              | 85 |     } | 
            
              | 86 |     my $filename = 'ordr' . $self->{basket}->basketno; | 
            
              | 87 |     $filename .= '.CEP'; | 
            
              | 88 |     return $filename; | 
            
              | 89 | } | 
            
              | 90 |  | 
            
              | 91 | sub encode { | 
            
              | 92 |     my ($self) = @_; | 
            
              | 93 |  | 
            
              | 94 |     $self->{interchange_control_reference} = int rand($NINES_14); | 
            
              | 95 |     $self->{message_count}                 = 0; | 
            
              | 96 |  | 
            
              | 97 |     #    $self->{segs}; # Message segments | 
            
              | 98 |  | 
            
              | 99 |     $self->{transmission} = q{}; | 
            
              | 100 |  | 
            
              | 101 |     $self->{transmission} .= $self->initial_service_segments(); | 
            
              | 102 |  | 
            
              | 103 |     $self->{transmission} .= $self->user_data_message_segments(); | 
            
              | 104 |  | 
            
              | 105 |     $self->{transmission} .= $self->trailing_service_segments(); | 
            
              | 106 |     return $self->{transmission}; | 
            
              | 107 | } | 
            
              | 108 |  | 
            
              | 109 | sub msg_date_string { | 
            
              | 110 |     my $self = shift; | 
            
              | 111 |     return $self->{message_date}->ymd(); | 
            
              | 112 | } | 
            
              | 113 |  | 
            
              | 114 | sub initial_service_segments { | 
            
              | 115 |     my $self = shift; | 
            
              | 116 |  | 
            
              | 117 |     #UNA service string advice - specifies standard separators | 
            
              | 118 |     my $segs = _const('service_string_advice'); | 
            
              | 119 |  | 
            
              | 120 |     #UNB interchange header | 
            
              | 121 |     $segs .= $self->interchange_header(); | 
            
              | 122 |  | 
            
              | 123 |     #UNG functional group header NOT USED | 
            
              | 124 |     return $segs; | 
            
              | 125 | } | 
            
              | 126 |  | 
            
              | 127 | sub interchange_header { | 
            
              | 128 |     my $self = shift; | 
            
              | 129 |  | 
            
              | 130 |     # syntax identifier | 
            
              | 131 |     my $hdr = | 
            
              | 132 |       'UNB+UNOC:3';    # controling agency character set syntax version number | 
            
              | 133 |                        # Interchange Sender | 
            
              | 134 |     $hdr .= _interchange_sr_identifier( $self->{sender}->ean, | 
            
              | 135 |         $self->{sender}->id_code_qualifier );    # interchange sender | 
            
              | 136 |     $hdr .= _interchange_sr_identifier( $self->{recipient}->san, | 
            
              | 137 |         $self->{recipient}->id_code_qualifier );    # interchange Recipient | 
            
              | 138 |  | 
            
              | 139 |     $hdr .= $separator; | 
            
              | 140 |  | 
            
              | 141 |     # DateTime of preparation | 
            
              | 142 |     $hdr .= $self->{message_date}->format_cldr('yyMMdd:HHmm'); | 
            
              | 143 |     $hdr .= $separator; | 
            
              | 144 |     $hdr .= $self->interchange_control_reference(); | 
            
              | 145 |     $hdr .= $separator; | 
            
              | 146 |  | 
            
              | 147 |     # Recipents reference password not usually used in edifact | 
            
              | 148 |     $hdr .= q{+ORDERS};                             # application reference | 
            
              | 149 |  | 
            
              | 150 | #Edifact does not usually include the following | 
            
              | 151 | #    $hdr .= $separator; # Processing priority  not usually used in edifact | 
            
              | 152 | #    $hdr .= $separator; # Acknowledgewment request : not usually used in edifact | 
            
              | 153 | #    $hdr .= q{+EANCOM} # Communications agreement id | 
            
              | 154 | #    $hdr .= q{+1} # Test indicator | 
            
              | 155 | # | 
            
              | 156 |     $hdr .= $seg_terminator; | 
            
              | 157 |     return $hdr; | 
            
              | 158 | } | 
            
              | 159 |  | 
            
              | 160 | sub user_data_message_segments { | 
            
              | 161 |     my $self = shift; | 
            
              | 162 |  | 
            
              | 163 |     #UNH message_header  :: seg count begins here | 
            
              | 164 |     $self->message_header(); | 
            
              | 165 |  | 
            
              | 166 |     $self->order_msg_header(); | 
            
              | 167 |  | 
            
              | 168 |     my $line_number = 0; | 
            
              | 169 |     foreach my $ol ( @{ $self->{orderlines} } ) { | 
            
              | 170 |         ++$line_number; | 
            
              | 171 |         $self->order_line( $line_number, $ol ); | 
            
              | 172 |     } | 
            
              | 173 |  | 
            
              | 174 |     $self->message_trailer(); | 
            
              | 175 |  | 
            
              | 176 |     my $data_segment_string = join q{}, @{ $self->{segs} }; | 
            
              | 177 |     return $data_segment_string; | 
            
              | 178 | } | 
            
              | 179 |  | 
            
              | 180 | sub message_trailer { | 
            
              | 181 |     my $self = shift; | 
            
              | 182 |  | 
            
              | 183 |     # terminate the message | 
            
              | 184 |     $self->add_seg("UNS+S$seg_terminator"); | 
            
              | 185 |  | 
            
              | 186 |     # CNT Control_Total | 
            
              | 187 |     # Could be (code  1) total value of QTY segments | 
            
              | 188 |     # or ( code = 2 ) number of lineitems | 
            
              | 189 |     my $num_orderlines = @{ $self->{orderlines} }; | 
            
              | 190 |     $self->add_seg("CNT+2:$num_orderlines$seg_terminator"); | 
            
              | 191 |  | 
            
              | 192 |     # UNT Message Trailer | 
            
              | 193 |     my $segments_in_message = | 
            
              | 194 |       1 + @{ $self->{segs} };    # count incl UNH & UNT (!!this one) | 
            
              | 195 |     my $reference = $self->message_reference('current'); | 
            
              | 196 |     $self->add_seg("UNT+$segments_in_message+$reference$seg_terminator"); | 
            
              | 197 |     return; | 
            
              | 198 | } | 
            
              | 199 |  | 
            
              | 200 | sub trailing_service_segments { | 
            
              | 201 |     my $self    = shift; | 
            
              | 202 |     my $trailer = q{}; | 
            
              | 203 |  | 
            
              | 204 |     #UNE functional group trailer NOT USED | 
            
              | 205 |     #UNZ interchange trailer | 
            
              | 206 |     $trailer .= $self->interchange_trailer(); | 
            
              | 207 |  | 
            
              | 208 |     return $trailer; | 
            
              | 209 | } | 
            
              | 210 |  | 
            
              | 211 | sub interchange_control_reference { | 
            
              | 212 |     my $self = shift; | 
            
              | 213 |     if ( $self->{interchange_control_reference} ) { | 
            
              | 214 |         return sprintf '%014d', $self->{interchange_control_reference}; | 
            
              | 215 |     } | 
            
              | 216 |     else { | 
            
              | 217 |         carp 'calling for ref of unencoded order'; | 
            
              | 218 |         return 'NONE ASSIGNED'; | 
            
              | 219 |     } | 
            
              | 220 | } | 
            
              | 221 |  | 
            
              | 222 | sub message_reference { | 
            
              | 223 |     my ( $self, $function ) = @_; | 
            
              | 224 |     if ( $function eq 'new' || !$self->{message_reference_no} ) { | 
            
              | 225 |  | 
            
              | 226 |         # unique 14 char mesage ref | 
            
              | 227 |         $self->{message_reference_no} = sprintf 'ME%012d', int rand($NINES_12); | 
            
              | 228 |     } | 
            
              | 229 |     return $self->{message_reference_no}; | 
            
              | 230 | } | 
            
              | 231 |  | 
            
              | 232 | sub message_header { | 
            
              | 233 |     my $self = shift; | 
            
              | 234 |  | 
            
              | 235 |     $self->{segs} = [];          # initialize the message | 
            
              | 236 |     $self->{message_count}++;    # In practice alwaya 1 | 
            
              | 237 |  | 
            
              | 238 |     my $hdr = q{UNH+} . $self->message_reference('new'); | 
            
              | 239 |     $hdr .= _const('message_identifier'); | 
            
              | 240 |     $self->add_seg($hdr); | 
            
              | 241 |     return; | 
            
              | 242 | } | 
            
              | 243 |  | 
            
              | 244 | sub interchange_trailer { | 
            
              | 245 |     my $self = shift; | 
            
              | 246 |  | 
            
              | 247 |     my $t = "UNZ+$self->{message_count}+"; | 
            
              | 248 |     $t .= $self->interchange_control_reference; | 
            
              | 249 |     $t .= $seg_terminator; | 
            
              | 250 |     return $t; | 
            
              | 251 | } | 
            
              | 252 |  | 
            
              | 253 | sub order_msg_header { | 
            
              | 254 |     my $self = shift; | 
            
              | 255 |     my @header; | 
            
              | 256 |  | 
            
              | 257 |     # UNH  see message_header | 
            
              | 258 |     # BGM | 
            
              | 259 |     push @header, beginning_of_message( $self->{basket}->basketno ); | 
            
              | 260 |  | 
            
              | 261 |     # DTM | 
            
              | 262 |     push @header, message_date_segment( $self->{message_date} ); | 
            
              | 263 |  | 
            
              | 264 |     # NAD-RFF buyer supplier ids | 
            
              | 265 |     push @header, | 
            
              | 266 |       name_and_address( | 
            
              | 267 |         'BUYER', | 
            
              | 268 |         $self->{sender}->ean, | 
            
              | 269 |         $self->{sender}->id_code_qualifier | 
            
              | 270 |       ); | 
            
              | 271 |     push @header, | 
            
              | 272 |       name_and_address( | 
            
              | 273 |         'SUPPLIER', | 
            
              | 274 |         $self->{recipient}->san, | 
            
              | 275 |         $self->{recipient}->id_code_qualifier | 
            
              | 276 |       ); | 
            
              | 277 |  | 
            
              | 278 |     # repeat for for other relevant parties | 
            
              | 279 |  | 
            
              | 280 |     # CUX currency | 
            
              | 281 |     # ISO 4217 code to show default currency prices are quoted in | 
            
              | 282 |     # e.g. CUX+2:GBP:9' | 
            
              | 283 |     # TBD currency handling | 
            
              | 284 |  | 
            
              | 285 |     $self->add_seg(@header); | 
            
              | 286 |     return; | 
            
              | 287 | } | 
            
              | 288 |  | 
            
              | 289 | sub beginning_of_message { | 
            
              | 290 |     my $basketno = shift; | 
            
              | 291 |     my $document_message_no = sprintf '%011d', $basketno; | 
            
              | 292 |  | 
            
              | 293 |     #    my $message_function = 9;    # original 7 = retransmission | 
            
              | 294 |     # message_code values | 
            
              | 295 |     #      220 prder | 
            
              | 296 |     #      224 rush order | 
            
              | 297 |     #      228 sample order :: order for approval / inspection copies | 
            
              | 298 |     #      22C continuation  order for volumes in a set etc. | 
            
              | 299 |     #    my $message_code = '220'; | 
            
              | 300 |  | 
            
              | 301 |     return "BGM+220+$document_message_no+9$seg_terminator"; | 
            
              | 302 | } | 
            
              | 303 |  | 
            
              | 304 | sub name_and_address { | 
            
              | 305 |     my ( $party, $id_code, $id_agency ) = @_; | 
            
              | 306 |     my %qualifier_code = ( | 
            
              | 307 |         BUYER    => 'BY', | 
            
              | 308 |         DELIVERY => 'DP',    # delivery location if != buyer | 
            
              | 309 |         INVOICEE => 'IV',    # if different from buyer | 
            
              | 310 |         SUPPLIER => 'SU', | 
            
              | 311 |     ); | 
            
              | 312 |     if ( !exists $qualifier_code{$party} ) { | 
            
              | 313 |         carp "No qualifier code for $party"; | 
            
              | 314 |         return; | 
            
              | 315 |     } | 
            
              | 316 |     if ( $id_agency eq '14' ) { | 
            
              | 317 |         $id_agency = '9';    # ean coded differently in this seg | 
            
              | 318 |     } | 
            
              | 319 |  | 
            
              | 320 |     return "NAD+$qualifier_code{$party}+${id_code}::$id_agency$seg_terminator"; | 
            
              | 321 | } | 
            
              | 322 |  | 
            
              | 323 | sub order_line { | 
            
              | 324 |     my ( $self, $linenumber, $orderline ) = @_; | 
            
              | 325 |  | 
            
              | 326 |     my $schema       = $self->{schema}; | 
            
              | 327 |     my $biblionumber = $orderline->biblionumber->biblionumber; | 
            
              | 328 |     my @biblioitems  = $schema->resultset('Biblioitem') | 
            
              | 329 |       ->search( { biblionumber => $biblionumber, } ); | 
            
              | 330 |     my $biblioitem = $biblioitems[0];    # makes the assumption there is 1 only | 
            
              | 331 |                                          # or else all have same details | 
            
              | 332 |  | 
            
              | 333 |     # LIN line-number in msg :: if we had a 13 digit ean we could add | 
            
              | 334 |     $self->add_seg( lin_segment( $linenumber, $biblioitem->isbn ) ); | 
            
              | 335 |  | 
            
              | 336 |     # PIA isbn or other id | 
            
              | 337 |     $self->add_seg( additional_product_id( $biblioitem->isbn ) ); | 
            
              | 338 |  | 
            
              | 339 |     # IMD biblio description | 
            
              | 340 |     if ($use_marc_based_description) { | 
            
              | 341 |  | 
            
              | 342 |         # get marc from biblioitem->marc | 
            
              | 343 |  | 
            
              | 344 |         # $ol .= marc_item_description($orderline->{bib_description}); | 
            
              | 345 |     } | 
            
              | 346 |     else {    # use brief description | 
            
              | 347 |         $self->add_seg( | 
            
              | 348 |             item_description( $orderline->biblionumber, $biblioitem ) ); | 
            
              | 349 |     } | 
            
              | 350 |  | 
            
              | 351 |     # QTY order quantity | 
            
              | 352 |     my $qty = join q{}, 'QTY+21:', $orderline->quantity, $seg_terminator; | 
            
              | 353 |     $self->add_seg($qty); | 
            
              | 354 |  | 
            
              | 355 |     # DTM Optional date constraints on delivery | 
            
              | 356 |     #     we dont currently support this in koha | 
            
              | 357 |     # GIR copy-related data | 
            
              | 358 |     my @items; | 
            
              | 359 |     if ( C4::Context->preference('AcqCreateItem') eq 'ordering' ) { | 
            
              | 360 |         my @linked_itemnumbers = $orderline->aqorders_items; | 
            
              | 361 |  | 
            
              | 362 |         foreach my $item (@linked_itemnumbers) { | 
            
              | 363 |             my $i_obj = $schema->resultset('Item')->find( $item->itemnumber ); | 
            
              | 364 |             if ( defined $i_obj ) { | 
            
              | 365 |                 push @items, $i_obj; | 
            
              | 366 |             } | 
            
              | 367 |         } | 
            
              | 368 |     } | 
            
              | 369 |     else { | 
            
              | 370 |         my $item_hash = { | 
            
              | 371 |             itemtype  => $biblioitem->itemtype, | 
            
              | 372 |             shelfmark => $biblioitem->cn_class, | 
            
              | 373 |         }; | 
            
              | 374 |         my $branch = $orderline->basketno->deliveryplace; | 
            
              | 375 |         if ($branch) { | 
            
              | 376 |             $item_hash->{branch} = $branch; | 
            
              | 377 |         } | 
            
              | 378 |         for ( 1 .. $orderline->quantity ) { | 
            
              | 379 |             push @items, $item_hash; | 
            
              | 380 |         } | 
            
              | 381 |     } | 
            
              | 382 |     my $budget = GetBudget( $orderline->budget_id ); | 
            
              | 383 |     my $ol_fields = { budget_code => $budget->{budget_code}, }; | 
            
              | 384 |     if ( $orderline->order_vendornote ) { | 
            
              | 385 |         $ol_fields->{servicing_instruction} = $orderline->order_vendornote; | 
            
              | 386 |     } | 
            
              | 387 |     $self->add_seg( gir_segments( $ol_fields, @items ) ); | 
            
              | 388 |  | 
            
              | 389 |     # TBD what if #items exceeds quantity | 
            
              | 390 |  | 
            
              | 391 |     # FTX free text for current orderline TBD | 
            
              | 392 |     #    dont really have a special instructions field to encode here | 
            
              | 393 |     # Encode notes here | 
            
              | 394 |     # PRI-CUX-DTM unit price on which order is placed : optional | 
            
              | 395 |     # Coutts read this as 0.00 if not present | 
            
              | 396 |     if ( $orderline->listprice ) { | 
            
              | 397 |         my $price = sprintf 'PRI+AAE:%.2f:CA', $orderline->listprice; | 
            
              | 398 |         $price .= $seg_terminator; | 
            
              | 399 |         $self->add_seg($price); | 
            
              | 400 |     } | 
            
              | 401 |  | 
            
              | 402 |     # RFF unique orderline reference no | 
            
              | 403 |     my $rff = join q{}, 'RFF+LI:', $orderline->ordernumber, $seg_terminator; | 
            
              | 404 |     $self->add_seg($rff); | 
            
              | 405 |  | 
            
              | 406 |     # LOC-QTY multiple delivery locations | 
            
              | 407 |     #TBD to specify extra delivery locs | 
            
              | 408 |     # NAD order line name and address | 
            
              | 409 |     #TBD Optionally indicate a name & address or order originator | 
            
              | 410 |     # TDT method of delivey ol-specific | 
            
              | 411 |     # TBD requests a special delivery option | 
            
              | 412 |  | 
            
              | 413 |     return; | 
            
              | 414 | } | 
            
              | 415 |  | 
            
              | 416 | # ??? Use the IMD MARC | 
            
              | 417 | sub marc_based_description { | 
            
              | 418 |  | 
            
              | 419 |     # this includes a much larger number of fields | 
            
              | 420 |     return; | 
            
              | 421 | } | 
            
              | 422 |  | 
            
              | 423 | sub item_description { | 
            
              | 424 |     my ( $bib, $biblioitem ) = @_; | 
            
              | 425 |     my $bib_desc = { | 
            
              | 426 |         author    => $bib->author, | 
            
              | 427 |         title     => $bib->title, | 
            
              | 428 |         publisher => $biblioitem->publishercode, | 
            
              | 429 |         year      => $biblioitem->publicationyear, | 
            
              | 430 |     }; | 
            
              | 431 |  | 
            
              | 432 |     my @itm = (); | 
            
              | 433 |  | 
            
              | 434 |     # 009 Author | 
            
              | 435 |     # 050 Title   :: title | 
            
              | 436 |     # 080 Vol/Part no | 
            
              | 437 |     # 100 Edition statement | 
            
              | 438 |     # 109 Publisher  :: publisher | 
            
              | 439 |     # 110 place of pub | 
            
              | 440 |     # 170 Date of publication :: year | 
            
              | 441 |     # 220 Binding  :: binding | 
            
              | 442 |     my %code = ( | 
            
              | 443 |         author    => '009', | 
            
              | 444 |         title     => '050', | 
            
              | 445 |         publisher => '109', | 
            
              | 446 |         year      => '170', | 
            
              | 447 |         binding   => '220', | 
            
              | 448 |     ); | 
            
              | 449 |     for my $field (qw(author title publisher year binding )) { | 
            
              | 450 |         if ( $bib_desc->{$field} ) { | 
            
              | 451 |             my $data = encode_text( $bib_desc->{$field} ); | 
            
              | 452 |             push @itm, imd_segment( $code{$field}, $data ); | 
            
              | 453 |         } | 
            
              | 454 |     } | 
            
              | 455 |  | 
            
              | 456 |     return @itm; | 
            
              | 457 | } | 
            
              | 458 |  | 
            
              | 459 | sub imd_segment { | 
            
              | 460 |     my ( $code, $data ) = @_; | 
            
              | 461 |  | 
            
              | 462 |     my $seg_prefix = "IMD+L+$code+:::"; | 
            
              | 463 |  | 
            
              | 464 |     # chunk_line | 
            
              | 465 |     my @chunks; | 
            
              | 466 |     while ( my $x = substr $data, 0, $CHUNKSIZE, q{} ) { | 
            
              | 467 |         if ( length $x == $CHUNKSIZE ) { | 
            
              | 468 |             if ( $x =~ s/([?]{1,2})$// ) { | 
            
              | 469 |                 $data = "$1$data";    # dont breakup ?' ?? etc | 
            
              | 470 |             } | 
            
              | 471 |         } | 
            
              | 472 |         push @chunks, $x; | 
            
              | 473 |     } | 
            
              | 474 |     my @segs; | 
            
              | 475 |     my $odd = 1; | 
            
              | 476 |     foreach my $c (@chunks) { | 
            
              | 477 |         if ($odd) { | 
            
              | 478 |             push @segs, "$seg_prefix$c"; | 
            
              | 479 |         } | 
            
              | 480 |         else { | 
            
              | 481 |             $segs[-1] .= ":$c$seg_terminator"; | 
            
              | 482 |         } | 
            
              | 483 |         $odd = !$odd; | 
            
              | 484 |     } | 
            
              | 485 |     if ( @segs && $segs[-1] !~ m/$seg_terminator$/o ) { | 
            
              | 486 |         $segs[-1] .= $seg_terminator; | 
            
              | 487 |     } | 
            
              | 488 |     return @segs; | 
            
              | 489 | } | 
            
              | 490 |  | 
            
              | 491 | sub gir_segments { | 
            
              | 492 |     my ( $orderfields, @onorderitems ) = @_; | 
            
              | 493 |  | 
            
              | 494 |     my $budget_code = $orderfields->{budget_code}; | 
            
              | 495 |     my @segments; | 
            
              | 496 |     my $sequence_no = 1; | 
            
              | 497 |     foreach my $item (@onorderitems) { | 
            
              | 498 |         my $seg = sprintf 'GIR+%03d', $sequence_no; | 
            
              | 499 |         $seg .= add_gir_identity_number( 'LFN', $budget_code ); | 
            
              | 500 |         if ( C4::Context->preference('AcqCreateItem') eq 'ordering' ) { | 
            
              | 501 |             $seg .= | 
            
              | 502 |               add_gir_identity_number( 'LLO', $item->homebranch->branchcode ); | 
            
              | 503 |             $seg .= add_gir_identity_number( 'LST', $item->itype ); | 
            
              | 504 |             $seg .= add_gir_identity_number( 'LSQ', $item->location ); | 
            
              | 505 |             $seg .= add_gir_identity_number( 'LSM', $item->itemcallnumber ); | 
            
              | 506 |  | 
            
              | 507 |             # itemcallnumber -> shelfmark | 
            
              | 508 |         } | 
            
              | 509 |         else { | 
            
              | 510 |             if ( $item->{branch} ) { | 
            
              | 511 |                 $seg .= add_gir_identity_number( 'LLO', $item->{branch} ); | 
            
              | 512 |             } | 
            
              | 513 |             $seg .= add_gir_identity_number( 'LST', $item->{itemtype} ); | 
            
              | 514 |             $seg .= add_gir_identity_number( 'LSM', $item->{shelfmark} ); | 
            
              | 515 |         } | 
            
              | 516 |         if ( $orderfields->{servicing_instruction} ) { | 
            
              | 517 |             $seg .= add_gir_identity_number( 'LVT', | 
            
              | 518 |                 $orderfields->{servicing_instruction} ); | 
            
              | 519 |         } | 
            
              | 520 |         $sequence_no++; | 
            
              | 521 |         push @segments, $seg; | 
            
              | 522 |     } | 
            
              | 523 |     return @segments; | 
            
              | 524 | } | 
            
              | 525 |  | 
            
              | 526 | sub add_gir_identity_number { | 
            
              | 527 |     my ( $number_qualifier, $number ) = @_; | 
            
              | 528 |     if ($number) { | 
            
              | 529 |         return "+${number}:${number_qualifier}"; | 
            
              | 530 |     } | 
            
              | 531 |     return q{}; | 
            
              | 532 | } | 
            
              | 533 |  | 
            
              | 534 | sub add_seg { | 
            
              | 535 |     my ( $self, @s ) = @_; | 
            
              | 536 |     foreach my $segment (@s) { | 
            
              | 537 |         if ( $segment !~ m/$seg_terminator$/o ) { | 
            
              | 538 |             $segment .= $seg_terminator; | 
            
              | 539 |         } | 
            
              | 540 |     } | 
            
              | 541 |     push @{ $self->{segs} }, @s; | 
            
              | 542 |     return; | 
            
              | 543 | } | 
            
              | 544 |  | 
            
              | 545 | sub lin_segment { | 
            
              | 546 |     my ( $line_number, $isbn ) = @_; | 
            
              | 547 |     my $isbn_string = q||; | 
            
              | 548 |     if ($isbn) { | 
            
              | 549 |         if ( $isbn =~ m/(978\d{10})/ ) { | 
            
              | 550 |             $isbn = $1; | 
            
              | 551 |         } | 
            
              | 552 |         elsif ( $isbn =~ m/(\d{9}[\dxX])/ ) { | 
            
              | 553 |             $isbn = $1; | 
            
              | 554 |         } | 
            
              | 555 |         else { | 
            
              | 556 |             undef $isbn; | 
            
              | 557 |         } | 
            
              | 558 |         if ($isbn) { | 
            
              | 559 |             my $b_isbn = Business::ISBN->new($isbn); | 
            
              | 560 |             if ( $b_isbn->is_valid ) { | 
            
              | 561 |                 $isbn        = $b_isbn->as_isbn13->isbn; | 
            
              | 562 |                 $isbn_string = "++$isbn:EN"; | 
            
              | 563 |             } | 
            
              | 564 |         } | 
            
              | 565 |     } | 
            
              | 566 |     return "LIN+$line_number$isbn_string$seg_terminator"; | 
            
              | 567 | } | 
            
              | 568 |  | 
            
              | 569 | sub additional_product_id { | 
            
              | 570 |     my $isbn_field = shift; | 
            
              | 571 |     my ( $product_id, $product_code ); | 
            
              | 572 |     if ( $isbn_field =~ m/(\d{13})/ ) { | 
            
              | 573 |         $product_id   = $1; | 
            
              | 574 |         $product_code = 'EN'; | 
            
              | 575 |     } | 
            
              | 576 |     elsif ( $isbn_field =~ m/(\d{9})[Xx\d]/ ) { | 
            
              | 577 |         $product_id   = $1; | 
            
              | 578 |         $product_code = 'IB'; | 
            
              | 579 |     } | 
            
              | 580 |  | 
            
              | 581 |     # TBD we could have a manufacturers no issn etc | 
            
              | 582 |     if ( !$product_id ) { | 
            
              | 583 |         return; | 
            
              | 584 |     } | 
            
              | 585 |  | 
            
              | 586 |     # function id set to 5 states this is the main product id | 
            
              | 587 |     return "PIA+5+$product_id:$product_code$seg_terminator"; | 
            
              | 588 | } | 
            
              | 589 |  | 
            
              | 590 | sub message_date_segment { | 
            
              | 591 |     my $dt = shift; | 
            
              | 592 |  | 
            
              | 593 |     # qualifier:message_date:format_code | 
            
              | 594 |  | 
            
              | 595 |     my $message_date = $dt->ymd(q{});    # no sep in edifact format | 
            
              | 596 |  | 
            
              | 597 |     return "DTM+137:$message_date:102$seg_terminator"; | 
            
              | 598 | } | 
            
              | 599 |  | 
            
              | 600 | sub _const { | 
            
              | 601 |     my $key = shift; | 
            
              | 602 |     Readonly my %S => { | 
            
              | 603 |         service_string_advice => q{UNA:+.? '}, | 
            
              | 604 |         message_identifier    => q{+ORDERS:D:96A:UN:EAN008'}, | 
            
              | 605 |     }; | 
            
              | 606 |     return ( $S{$key} ) ? $S{$key} : q{}; | 
            
              | 607 | } | 
            
              | 608 |  | 
            
              | 609 | sub _interchange_sr_identifier { | 
            
              | 610 |     my ( $identification, $qualifier ) = @_; | 
            
              | 611 |  | 
            
              | 612 |     if ( !$identification ) { | 
            
              | 613 |         $identification = 'RANDOM'; | 
            
              | 614 |         $qualifier      = '92'; | 
            
              | 615 |         carp 'undefined identifier'; | 
            
              | 616 |     } | 
            
              | 617 |  | 
            
              | 618 |     # 14   EAN International | 
            
              | 619 |     # 31B   US SAN (preferred) | 
            
              | 620 |     # also 91 assigned by supplier | 
            
              | 621 |     # also 92 assigned by buyer | 
            
              | 622 |     if ( $qualifier !~ m/^(?:14|31B|91|92)/xms ) { | 
            
              | 623 |         $qualifier = '92'; | 
            
              | 624 |     } | 
            
              | 625 |  | 
            
              | 626 |     return "+$identification:$qualifier"; | 
            
              | 627 | } | 
            
              | 628 |  | 
            
              | 629 | sub encode_text { | 
            
              | 630 |     my $string = shift; | 
            
              | 631 |     if ($string) { | 
            
              | 632 |         from_to( $string, 'utf8', 'iso-8859-1' ); | 
            
              | 633 |         $string =~ s/[?]/??/g; | 
            
              | 634 |         $string =~ s/'/?'/g; | 
            
              | 635 |         $string =~ s/:/?:/g; | 
            
              | 636 |         $string =~ s/[+]/?+/g; | 
            
              | 637 |     } | 
            
              | 638 |     return $string; | 
            
              | 639 | } | 
            
              | 640 |  | 
            
              | 641 | 1; | 
            
              | 642 | __END__ | 
            
              | 643 |  | 
            
              | 644 | =head1 NAME | 
            
              | 645 |  | 
            
              | 646 | Koha::Edifact::Order | 
            
              | 647 |  | 
            
              | 648 | =head1 SYNOPSIS | 
            
              | 649 |  | 
            
              | 650 | Format an Edifact Order message from a Koha basket | 
            
              | 651 |  | 
            
              | 652 | =head1 DESCRIPTION | 
            
              | 653 |  | 
            
              | 654 | Generates an Edifact format Order message for a Koha basket. | 
            
              | 655 | Normally the only methods used directly by the caller would be | 
            
              | 656 | new to set up the message, encode to return the formatted message | 
            
              | 657 | and filename to obtain a name under which to store the message | 
            
              | 658 |  | 
            
              | 659 | =head1 BUGS | 
            
              | 660 |  | 
            
              | 661 | Should integrate into Koha::Edifact namespace | 
            
              | 662 | Can caller interface be made cleaner? | 
            
              | 663 | Make handling of GIR segments more customizable | 
            
              | 664 |  | 
            
              | 665 | =head1 METHODS | 
            
              | 666 |  | 
            
              | 667 | =head2 new | 
            
              | 668 |  | 
            
              | 669 |   my $edi_order = Edifact::Order->new( | 
            
              | 670 |   orderlines => \@orderlines, | 
            
              | 671 |   vendor     => $vendor_edi_account, | 
            
              | 672 |   ean        => $library_ean | 
            
              | 673 |   ); | 
            
              | 674 |  | 
            
              | 675 |   instantiate the Edifact::Order object, all parameters are Schema::Resultset objects | 
            
              | 676 |   Called in Koha::Edifact create_edi_order | 
            
              | 677 |  | 
            
              | 678 | =head2 filename | 
            
              | 679 |  | 
            
              | 680 |    my $filename = $edi_order->filename() | 
            
              | 681 |  | 
            
              | 682 |    returns a filename for the edi order. The filename embeds a reference to the | 
            
              | 683 |    basket the message was created to encode | 
            
              | 684 |  | 
            
              | 685 | =head2 encode | 
            
              | 686 |  | 
            
              | 687 |    my $edifact_message = $edi_order->encode(); | 
            
              | 688 |  | 
            
              | 689 |    Encodes the basket as a valid edifact message ready for transmission | 
            
              | 690 |  | 
            
              | 691 | =head2 initial_service_segments | 
            
              | 692 |  | 
            
              | 693 |     Creates the service segments which begin the message | 
            
              | 694 |  | 
            
              | 695 | =head2 interchange_header | 
            
              | 696 |  | 
            
              | 697 |     Return an interchange header encoding sender and recipient | 
            
              | 698 |     ids message date and standards | 
            
              | 699 |  | 
            
              | 700 | =head2 user_data_message_segments | 
            
              | 701 |  | 
            
              | 702 |     Include message data within the encoded message | 
            
              | 703 |  | 
            
              | 704 | =head2 message_trailer | 
            
              | 705 |  | 
            
              | 706 |     Terminate message data including control data on number | 
            
              | 707 |     of messages and segments included | 
            
              | 708 |  | 
            
              | 709 | =head2 trailing_service_segments | 
            
              | 710 |  | 
            
              | 711 |    Include the service segments occuring at the end of the message | 
            
              | 712 | =head2 interchange_control_reference | 
            
              | 713 |  | 
            
              | 714 |    Returns the unique interchange control reference as a 14 digit number | 
            
              | 715 |  | 
            
              | 716 | =head2 message_reference | 
            
              | 717 |  | 
            
              | 718 |     On generates and subsequently returns the unique message | 
            
              | 719 |     reference number as a 12 digit number preceded by ME, to generate a new number | 
            
              | 720 |     pass the string 'new'. | 
            
              | 721 |     In practice we encode 1 message per transmission so there is only one message | 
            
              | 722 |     referenced. were we to encode multiple messages a new reference would be | 
            
              | 723 |     neaded for each | 
            
              | 724 |  | 
            
              | 725 | =head2 message_header | 
            
              | 726 |  | 
            
              | 727 |     Commences a new message | 
            
              | 728 |  | 
            
              | 729 | =head2 interchange_trailer | 
            
              | 730 |  | 
            
              | 731 |     returns the UNZ segment which ends the tranmission encoding the | 
            
              | 732 |     message count and control reference for the interchange | 
            
              | 733 |  | 
            
              | 734 | =head2 order_msg_header | 
            
              | 735 |  | 
            
              | 736 |     Formats the message header segments | 
            
              | 737 |  | 
            
              | 738 | =head2 beginning_of_message | 
            
              | 739 |  | 
            
              | 740 |     Returns the BGM segment which includes the Koha basket number | 
            
              | 741 |  | 
            
              | 742 | =head2 name_and_address | 
            
              | 743 |  | 
            
              | 744 |     Parameters: Function ( BUYER, DELIVERY, INVOICE, SUPPLIER) | 
            
              | 745 |                 Id | 
            
              | 746 |                 Agency | 
            
              | 747 |  | 
            
              | 748 |     Returns a NAD segment containg the id and agency for for the Function | 
            
              | 749 |     value. Handles the fact that NAD segments encode the value for 'EAN' differently | 
            
              | 750 |     to elsewhere. | 
            
              | 751 |  | 
            
              | 752 | =head2 order_line | 
            
              | 753 |  | 
            
              | 754 |     Creates the message segments wncoding an order line | 
            
              | 755 |  | 
            
              | 756 | =head2 marc_based_description | 
            
              | 757 |  | 
            
              | 758 |     Not yet implemented - To encode the the bibliographic info | 
            
              | 759 |     as MARC based IMD fields has the potential of encoding a wider range of info | 
            
              | 760 |  | 
            
              | 761 | =head2 item_description | 
            
              | 762 |  | 
            
              | 763 |     Encodes the biblio item fields Author, title, publisher, date of publication | 
            
              | 764 |     binding | 
            
              | 765 |  | 
            
              | 766 | =head2 imd_segment | 
            
              | 767 |  | 
            
              | 768 |     Formats an IMD segment, handles the chunking of data into the 35 character | 
            
              | 769 |     lengths required and the creation of repeat segments | 
            
              | 770 |  | 
            
              | 771 | =head2 gir_segments | 
            
              | 772 |  | 
            
              | 773 |     Add item level information | 
            
              | 774 |  | 
            
              | 775 | =head2 add_gir_identity_number | 
            
              | 776 |  | 
            
              | 777 |     Handle the formatting of a GIR element | 
            
              | 778 |     return empty string if no data | 
            
              | 779 |  | 
            
              | 780 | =head2 add_seg | 
            
              | 781 |  | 
            
              | 782 |     Adds a parssed array of segments to the objects segment list | 
            
              | 783 |     ensures all segments are properly terminated by ' | 
            
              | 784 |  | 
            
              | 785 | =head2 lin_segment | 
            
              | 786 |  | 
            
              | 787 |     Adds a LIN segment consisting of the line number and the ean number | 
            
              | 788 |     if the passed isbn is valid | 
            
              | 789 |  | 
            
              | 790 | =head2 additional_product_id | 
            
              | 791 |  | 
            
              | 792 |     Add a PIA segment for an additional product id | 
            
              | 793 |  | 
            
              | 794 | =head2 message_date_segment | 
            
              | 795 |  | 
            
              | 796 |     Passed a DateTime object returns a correctly formatted DTM segment | 
            
              | 797 |  | 
            
              | 798 | =head2 _const | 
            
              | 799 |  | 
            
              | 800 |     Stores and returns constant strings for service_string_advice | 
            
              | 801 |     and message_identifier | 
            
              | 802 |     TBD replace with class variables | 
            
              | 803 |  | 
            
              | 804 | =head2 _interchange_sr_identifier | 
            
              | 805 |  | 
            
              | 806 |     Format sender and receipient identifiers for use in the interchange header | 
            
              | 807 |  | 
            
              | 808 | =head2 encode_text | 
            
              | 809 |  | 
            
              | 810 |     Encode textual data into the standard character set ( iso 8859-1 ) | 
            
              | 811 |     and quote any Edifact metacharacters | 
            
              | 812 |  | 
            
              | 813 | =head2 msg_date_string | 
            
              | 814 |  | 
            
              | 815 |     Convenient routine which returns message date as a Y-m-d string | 
            
              | 816 |     useful if the caller wants to log date of creation | 
            
              | 817 |  | 
            
              | 818 | =head1 AUTHOR | 
            
              | 819 |  | 
            
              | 820 |    Colin Campbell <colin.campbell@ptfs-europe.com> | 
            
              | 821 |  | 
            
              | 822 |  | 
            
              | 823 | =head1 COPYRIGHT | 
            
              | 824 |  | 
            
              | 825 |    Copyright 2014, PTFS-Europe Ltd | 
            
              | 826 |    This program is free software, You may redistribute it under | 
            
              | 827 |    under the terms of the GNU General Public License | 
            
              | 828 |  | 
            
              | 829 |  | 
            
              | 830 | =cut |