C4/Circulation.pm

   1 package C4::Circulation;
   2
   3 # Copyright 2000-2002 Katipo Communications
   4 #
   5 # This file is part of Koha.
   6 #
   7 # Koha is free software; you can redistribute it and/or modify it under the
   8 # terms of the GNU General Public License as published by the Free Software
   9 # Foundation; either version 2 of the License, or (at your option) any later
  10 # version.
  11 #
  12 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
  13 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  14 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU General Public License along with
  17 # Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
  18 # Suite 330, Boston, MA  02111-1307 USA
  19
  20 # $Id$
  21
  22 use strict;
  23 require Exporter;
  24 use C4::Context;
  25 use C4::Stats;
  26 use C4::Reserves2;
  27 use C4::Koha;
  28 use C4::Biblio;
  29 use C4::Accounts;
  30 use C4::Reserves2;
  31 use C4::Members;
  32 use C4::Date;
  33 use Date::Calc qw(
  34   Today
  35   Today_and_Now
  36   Add_Delta_YM
  37   Add_Delta_DHMS
  38   Date_to_Days
  39 );
  40 use POSIX qw(strftime);
  41 use C4::Branch; # GetBranches
  42 use C4::Log; # logaction
  43
  44 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  45
  46 # set the version for version checking
  47 $VERSION = do { my @v = '$Revision$' =~ /\d+/g; shift(@v).".".join( "_", map { sprintf "%03d", $_ } @v ); };
  48
  49 =head1 NAME
  50
  51 C4::Circulation::Circ2 - Koha circulation module
  52
  53 =head1 SYNOPSIS
  54
  55 use C4::Circulation;
  56
  57 =head1 DESCRIPTION
  58
  59 The functions in this module deal with circulation, issues, and
  60 returns, as well as general information about the library.
  61 Also deals with stocktaking.
  62
  63 =head1 FUNCTIONS
  64
  65 =cut
  66
  67 @ISA    = qw(Exporter);
  68
  69 # FIXME subs that should probably be elsewhere
  70 push @EXPORT, qw(
  71   &fixoverduesonreturn
  72 );
  73
  74 # subs to deal with issuing a book
  75 push @EXPORT, qw(
  76   &CanBookBeIssued
  77   &CanBookBeRenewed
  78   &AddIssue
  79   &AddRenewal
  80   &GetItemIssue
  81   &GetItemIssues
  82   &GetBorrowerIssues
  83   &GetIssuingCharges
  84   &GetBiblioIssues
  85   &AnonymiseIssueHistory
  86 );
  87 # subs to deal with returns
  88 push @EXPORT, qw(
  89   &AddReturn
  90 );
  91
  92 # subs to deal with transfers
  93 push @EXPORT, qw(
  94   &transferbook
  95   &GetTransfers
  96   &GetTransfersFromTo
  97   &updateWrongTransfer
  98   &DeleteTransfer
  99 );
 100
 101 # subs to remove
 102 push @EXPORT, qw(
 103   &decode
 104   &dotransfer
 105 );
 106
 107 =head2 decode
 108
 109 =head3 $str = &decode($chunk);
 110
 111 =over 4
 112
 113 =item Decodes a segment of a string emitted by a CueCat barcode scanner and
 114 returns it.
 115
 116 =back
 117
 118 =cut
 119
 120 # FIXME - At least, I'm pretty sure this is for decoding CueCat stuff.
 121
 122 # FIXME From Paul : i don't understand what this sub does & why it has to be called on every circ. Speak of this with chris maybe ?
 123 sub decode {
 124     my ($encoded) = @_;
 125     my $seq =
 126       'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789+-';
 127     my @s = map { index( $seq, $_ ); } split( //, $encoded );
 128     my $l = ( $#s + 1 ) % 4;
 129     if ($l) {
 130         if ( $l == 1 ) {
 131             warn "Error!";
 132             return;
 133         }
 134         $l = 4 - $l;
 135         $#s += $l;
 136     }
 137     my $r = '';
 138     while ( $#s >= 0 ) {
 139         my $n = ( ( $s[0] << 6 | $s[1] ) << 6 | $s[2] ) << 6 | $s[3];
 140         $r .=
 141             chr( ( $n >> 16 ) ^ 67 )
 142          .chr( ( $n >> 8 & 255 ) ^ 67 )
 143          .chr( ( $n & 255 ) ^ 67 );
 144         @s = @s[ 4 .. $#s ];
 145     }
 146     $r = substr( $r, 0, length($r) - $l );
 147     return $r;
 148 }
 149
 150 =head2 transferbook
 151
 152 ($dotransfer, $messages, $iteminformation) = &transferbook($newbranch, $barcode, $ignore_reserves);
 153
 154 Transfers an item to a new branch. If the item is currently on loan, it is automatically returned before the actual transfer.
 155
 156 C<$newbranch> is the code for the branch to which the item should be transferred.
 157
 158 C<$barcode> is the barcode of the item to be transferred.
 159
 160 If C<$ignore_reserves> is true, C<&transferbook> ignores reserves.
 161 Otherwise, if an item is reserved, the transfer fails.
 162
 163 Returns three values:
 164
 165 =head3 $dotransfer
 166
 167 is true if the transfer was successful.
 168
 169 =head3 $messages
 170
 171 is a reference-to-hash which may have any of the following keys:
 172
 173 =over 4
 174
 175 =item C<BadBarcode>
 176
 177 There is no item in the catalog with the given barcode. The value is C<$barcode>.
 178
 179 =item C<IsPermanent>
 180
 181 The item's home branch is permanent. This doesn't prevent the item from being transferred, though. The value is the code of the item's home branch.
 182
 183 =item C<DestinationEqualsHolding>
 184
 185 The item is already at the branch to which it is being transferred. The transfer is nonetheless considered to have failed. The value should be ignored.
 186
 187 =item C<WasReturned>
 188
 189 The item was on loan, and C<&transferbook> automatically returned it before transferring it. The value is the borrower number of the patron who had the item.
 190
 191 =item C<ResFound>
 192
 193 The item was reserved. The value is a reference-to-hash whose keys are fields from the reserves table of the Koha database, and C<biblioitemnumber>. It also has the key C<ResFound>, whose value is either C<Waiting> or C<Reserved>.
 194
 195 =item C<WasTransferred>
 196
 197 The item was eligible to be transferred. Barring problems communicating with the database, the transfer should indeed have succeeded. The value should be ignored.
 198
 199 =back
 200
 201 =cut
 202
 203 sub transferbook {
 204     my ( $tbr, $barcode, $ignoreRs ) = @_;
 205     my $messages;
 206     my %env;
 207     my $dotransfer      = 1;
 208     my $branches        = GetBranches();
 209     my $itemnumber = GetItemnumberFromBarcode( $barcode );
 210     my $issue      = GetItemIssue($itemnumber);
 211     my $biblio = GetBiblioFromItemNumber($itemnumber);
 212
 213     # bad barcode..
 214     if ( not $itemnumber ) {
 215         $messages->{'BadBarcode'} = $barcode;
 216         $dotransfer = 0;
 217     }
 218
 219     # get branches of book...
 220     my $hbr = $biblio->{'homebranch'};
 221     my $fbr = $biblio->{'holdingbranch'};
 222
 223     # if is permanent...
 224     if ( $hbr && $branches->{$hbr}->{'PE'} ) {
 225         $messages->{'IsPermanent'} = $hbr;
 226     }
 227
 228     # can't transfer book if is already there....
 229     if ( $fbr eq $tbr ) {
 230         $messages->{'DestinationEqualsHolding'} = 1;
 231         $dotransfer = 0;
 232     }
 233
 234     # check if it is still issued to someone, return it...
 235     if ($issue->{borrowernumber}) {
 236         AddReturn( $barcode, $fbr );
 237         $messages->{'WasReturned'} = $issue->{borrowernumber};
 238     }
 239
 240     # find reserves.....
 241     # That'll save a database query.
 242     my ( $resfound, $resrec ) =
 243       CheckReserves( $itemnumber );
 244     if ( $resfound and not $ignoreRs ) {
 245         $resrec->{'ResFound'} = $resfound;
 246
 247         #         $messages->{'ResFound'} = $resrec;
 248         $dotransfer = 1;
 249     }
 250
 251     #actually do the transfer....
 252     if ($dotransfer) {
 253         dotransfer( $itemnumber, $fbr, $tbr );
 254
 255         # don't need to update MARC anymore, we do it in batch now
 256         $messages->{'WasTransfered'} = 1;
 257     }
 258     return ( $dotransfer, $messages, $biblio );
 259 }
 260
 261 # Not exported
 262 # FIXME - This is only used in &transferbook. Why bother making it a
 263 # separate function?
 264 sub dotransfer {
 265     my ( $itm, $fbr, $tbr ) = @_;
 266
 267     my $dbh = C4::Context->dbh;
 268     $itm = $dbh->quote($itm);
 269     $fbr = $dbh->quote($fbr);
 270     $tbr = $dbh->quote($tbr);
 271
 272     #new entry in branchtransfers....
 273     $dbh->do(
 274 "INSERT INTO branchtransfers (itemnumber, frombranch, datesent, tobranch)
 275                     VALUES ($itm, $fbr, now(), $tbr)"
 276     );
 277
 278     #update holdingbranch in items .....
 279       $dbh->do(
 280           "UPDATE items set holdingbranch = $tbr WHERE items.itemnumber = $itm");
 281     &ModDateLastSeen($itm);
 282     &domarctransfer( $dbh, $itm );
 283     return;
 284 }
 285
 286 ##New sub to dotransfer in marc tables as well. Not exported -TG 10/04/2006
 287 sub domarctransfer {
 288     my ( $dbh, $itemnumber ) = @_;
 289     $itemnumber =~ s /\'//g;    ##itemnumber seems to come with quotes-TG
 290     my $sth =
 291       $dbh->prepare(
 292         "select biblionumber,holdingbranch from items where itemnumber=$itemnumber"
 293       );
 294     $sth->execute();
 295     while ( my ( $biblionumber, $holdingbranch ) = $sth->fetchrow ) {
 296         &ModItemInMarconefield( $biblionumber, $itemnumber,
 297             'items.holdingbranch', $holdingbranch );
 298     }
 299     return;
 300 }
 301
 302 =head2 CanBookBeIssued
 303
 304 Check if a book can be issued.
 305
 306 my ($issuingimpossible,$needsconfirmation) = CanBookBeIssued($env,$borrower,$barcode,$year,$month,$day);
 307
 308 =over 4
 309
 310 =item C<$env> Environment variable. Should be empty usually, but used by other subs. Next code cleaning could drop it.
 311
 312 =item C<$borrower> hash with borrower informations (from GetMemberDetails)
 313
 314 =item C<$barcode> is the bar code of the book being issued.
 315
 316 =item C<$year> C<$month> C<$day> contains the date of the return (in case it's forced by "stickyduedate".
 317
 318 =back
 319
 320 Returns :
 321
 322 =over 4
 323
 324 =item C<$issuingimpossible> a reference to a hash. It contains reasons why issuing is impossible.
 325 Possible values are :
 326
 327 =back
 328
 329 =head3 INVALID_DATE
 330
 331 sticky due date is invalid
 332
 333 =head3 GNA
 334
 335 borrower gone with no address
 336
 337 =head3 CARD_LOST
 338
 339 borrower declared it's card lost
 340
 341 =head3 DEBARRED
 342
 343 borrower debarred
 344
 345 =head3 UNKNOWN_BARCODE
 346
 347 barcode unknown
 348
 349 =head3 NOT_FOR_LOAN
 350
 351 item is not for loan
 352
 353 =head3 WTHDRAWN
 354
 355 item withdrawn.
 356
 357 =head3 RESTRICTED
 358
 359 item is restricted (set by ??)
 360
 361 C<$issuingimpossible> a reference to a hash. It contains reasons why issuing is impossible.
 362 Possible values are :
 363
 364 =head3 DEBT
 365
 366 borrower has debts.
 367
 368 =head3 RENEW_ISSUE
 369
 370 renewing, not issuing
 371
 372 =head3 ISSUED_TO_ANOTHER
 373
 374 issued to someone else.
 375
 376 =head3 RESERVED
 377
 378 reserved for someone else.
 379
 380 =head3 INVALID_DATE
 381
 382 sticky due date is invalid
 383
 384 =head3 TOO_MANY
 385
 386 if the borrower borrows to much things
 387
 388 =cut
 389
 390 # check if a book can be issued.
 391 # returns an array with errors if any
 392
 393 sub TooMany ($$) {
 394     my $borrower        = shift;
 395     my $biblionumber = shift;
 396     my $cat_borrower    = $borrower->{'categorycode'};
 397     my $branch_borrower = $borrower->{'branchcode'};
 398     my $dbh             = C4::Context->dbh;
 399
 400     my $sth =
 401       $dbh->prepare('select itemtype from biblioitems where biblionumber = ?');
 402     $sth->execute($biblionumber);
 403     my $type = $sth->fetchrow;
 404     $sth =
 405       $dbh->prepare(
 406 'select * from issuingrules where categorycode = ? and itemtype = ? and branchcode = ?'
 407       );
 408
 409 #     my $sth2 = $dbh->prepare("select COUNT(*) from issues i, biblioitems s where i.borrowernumber = ? and i.returndate is null and i.itemnumber = s.biblioitemnumber and s.itemtype like ?");
 410     my $sth2 =
 411       $dbh->prepare(
 412 "select COUNT(*) from issues i, biblioitems s1, items s2 where i.borrowernumber = ? and i.returndate is null and i.itemnumber = s2.itemnumber and s1.itemtype like ? and s1.biblioitemnumber = s2.biblioitemnumber"
 413       );
 414     my $sth3 =
 415       $dbh->prepare(
 416 'select COUNT(*) from issues where borrowernumber = ? and returndate is null'
 417       );
 418     my $alreadyissued;
 419
 420     # check the 3 parameters
 421     $sth->execute( $cat_borrower, $type, $branch_borrower );
 422     my $result = $sth->fetchrow_hashref;
 423
 424     #    warn "==>".$result->{maxissueqty};
 425
 426 # Currently, using defined($result) ie on an entire hash reports whether memory
 427 # for that aggregate has ever been allocated. As $result is used all over the place
 428 # it would rarely return as undefined.
 429     if ( defined( $result->{maxissueqty} ) ) {
 430         $sth2->execute( $borrower->{'borrowernumber'}, "%$type%" );
 431         my $alreadyissued = $sth2->fetchrow;
 432         if ( $result->{'maxissueqty'} <= $alreadyissued ) {
 433             return ( "a $alreadyissued / ".( $result->{maxissueqty} + 0 ) );
 434         }
 435         else {
 436             return;
 437         }
 438     }
 439
 440     # check for branch=*
 441     $sth->execute( $cat_borrower, $type, "" );
 442     $result = $sth->fetchrow_hashref;
 443     if ( defined( $result->{maxissueqty} ) ) {
 444         $sth2->execute( $borrower->{'borrowernumber'}, "%$type%" );
 445         my $alreadyissued = $sth2->fetchrow;
 446         if ( $result->{'maxissueqty'} <= $alreadyissued ) {
 447             return ( "b $alreadyissued / ".( $result->{maxissueqty} + 0 ) );
 448         }
 449         else {
 450             return;
 451         }
 452     }
 453
 454     # check for itemtype=*
 455     $sth->execute( $cat_borrower, "*", $branch_borrower );
 456     $result = $sth->fetchrow_hashref;
 457     if ( defined( $result->{maxissueqty} ) ) {
 458         $sth3->execute( $borrower->{'borrowernumber'} );
 459         my ($alreadyissued) = $sth3->fetchrow;
 460         if ( $result->{'maxissueqty'} <= $alreadyissued ) {
 461
 462 #        warn "HERE : $alreadyissued / ($result->{maxissueqty} for $borrower->{'borrowernumber'}";
 463             return ( "c $alreadyissued / " . ( $result->{maxissueqty} + 0 ) );
 464         }
 465         else {
 466             return;
 467         }
 468     }
 469
 470     # check for borrowertype=*
 471     $sth->execute( "*", $type, $branch_borrower );
 472     $result = $sth->fetchrow_hashref;
 473     if ( defined( $result->{maxissueqty} ) ) {
 474         $sth2->execute( $borrower->{'borrowernumber'}, "%$type%" );
 475         my $alreadyissued = $sth2->fetchrow;
 476         if ( $result->{'maxissueqty'} <= $alreadyissued ) {
 477             return ( "d $alreadyissued / " . ( $result->{maxissueqty} + 0 ) );
 478         }
 479         else {
 480             return;
 481         }
 482     }
 483
 484     $sth->execute( "*", "*", $branch_borrower );
 485     $result = $sth->fetchrow_hashref;
 486     if ( defined( $result->{maxissueqty} ) ) {
 487         $sth3->execute( $borrower->{'borrowernumber'} );
 488         my $alreadyissued = $sth3->fetchrow;
 489         if ( $result->{'maxissueqty'} <= $alreadyissued ) {
 490             return ( "e $alreadyissued / " . ( $result->{maxissueqty} + 0 ) );
 491         }
 492         else {
 493             return;
 494         }
 495     }
 496
 497     $sth->execute( "*", $type, "" );
 498     $result = $sth->fetchrow_hashref;
 499     if ( defined( $result->{maxissueqty} ) && $result->{maxissueqty} >= 0 ) {
 500         $sth2->execute( $borrower->{'borrowernumber'}, "%$type%" );
 501         my $alreadyissued = $sth2->fetchrow;
 502         if ( $result->{'maxissueqty'} <= $alreadyissued ) {
 503             return ( "f $alreadyissued / " . ( $result->{maxissueqty} + 0 ) );
 504         }
 505         else {
 506             return;
 507         }
 508     }
 509
 510     $sth->execute( $cat_borrower, "*", "" );
 511     $result = $sth->fetchrow_hashref;
 512     if ( defined( $result->{maxissueqty} ) ) {
 513         $sth2->execute( $borrower->{'borrowernumber'}, "%$type%" );
 514         my $alreadyissued = $sth2->fetchrow;
 515         if ( $result->{'maxissueqty'} <= $alreadyissued ) {
 516             return ( "g $alreadyissued / " . ( $result->{maxissueqty} + 0 ) );
 517         }
 518         else {
 519             return;
 520         }
 521     }
 522
 523     $sth->execute( "*", "*", "" );
 524     $result = $sth->fetchrow_hashref;
 525     if ( defined( $result->{maxissueqty} ) ) {
 526         $sth3->execute( $borrower->{'borrowernumber'} );
 527         my $alreadyissued = $sth3->fetchrow;
 528         if ( $result->{'maxissueqty'} <= $alreadyissued ) {
 529             return ( "h $alreadyissued / " . ( $result->{maxissueqty} + 0 ) );
 530         }
 531         else {
 532             return;
 533         }
 534     }
 535     return;
 536 }
 537
 538 =head2 itemissues
 539
 540   @issues = &itemissues($biblioitemnumber, $biblio);
 541
 542 Looks up information about who has borrowed the bookZ<>(s) with the
 543 given biblioitemnumber.
 544
 545 C<$biblio> is ignored.
 546
 547 C<&itemissues> returns an array of references-to-hash. The keys
 548 include the fields from the C<items> table in the Koha database.
 549 Additional keys include:
 550
 551 =over 4
 552
 553 =item C<date_due>
 554
 555 If the item is currently on loan, this gives the due date.
 556
 557 If the item is not on loan, then this is either "Available" or
 558 "Cancelled", if the item has been withdrawn.
 559
 560 =item C<card>
 561
 562 If the item is currently on loan, this gives the card number of the
 563 patron who currently has the item.
 564
 565 =item C<timestamp0>, C<timestamp1>, C<timestamp2>
 566
 567 These give the timestamp for the last three times the item was
 568 borrowed.
 569
 570 =item C<card0>, C<card1>, C<card2>
 571
 572 The card number of the last three patrons who borrowed this item.
 573
 574 =item C<borrower0>, C<borrower1>, C<borrower2>
 575
 576 The borrower number of the last three patrons who borrowed this item.
 577
 578 =back
 579
 580 =cut
 581
 582 #'
 583 sub itemissues {
 584     my ( $bibitem, $biblio ) = @_;
 585     my $dbh = C4::Context->dbh;
 586
 587     # FIXME - If this function die()s, the script will abort, and the
 588     # user won't get anything; depending on how far the script has
 589     # gotten, the user might get a blank page. It would be much better
 590     # to at least print an error message. The easiest way to do this
 591     # is to set $SIG{__DIE__}.
 592     my $sth =
 593       $dbh->prepare("Select * from items where items.biblioitemnumber = ?")
 594       || die $dbh->errstr;
 595     my $i = 0;
 596     my @results;
 597
 598     $sth->execute($bibitem) || die $sth->errstr;
 599
 600     while ( my $data = $sth->fetchrow_hashref ) {
 601
 602         # Find out who currently has this item.
 603         # FIXME - Wouldn't it be better to do this as a left join of
 604         # some sort? Currently, this code assumes that if
 605         # fetchrow_hashref() fails, then the book is on the shelf.
 606         # fetchrow_hashref() can fail for any number of reasons (e.g.,
 607         # database server crash), not just because no items match the
 608         # search criteria.
 609         my $sth2 = $dbh->prepare(
 610             "SELECT * FROM issues
 611                 LEFT JOIN borrowers ON issues.borrowernumber = borrowers.borrowernumber
 612                 WHERE itemnumber = ?
 613                     AND returndate IS NULL
 614             "
 615         );
 616
 617         $sth2->execute( $data->{'itemnumber'} );
 618         if ( my $data2 = $sth2->fetchrow_hashref ) {
 619             $data->{'date_due'} = $data2->{'date_due'};
 620             $data->{'card'}     = $data2->{'cardnumber'};
 621             $data->{'borrower'} = $data2->{'borrowernumber'};
 622         }
 623         else {
 624             if ( $data->{'wthdrawn'} eq '1' ) {
 625                 $data->{'date_due'} = 'Cancelled';
 626             }
 627             else {
 628                 $data->{'date_due'} = 'Available';
 629             }    # else
 630         }    # else
 631
 632         $sth2->finish;
 633
 634         # Find the last 3 people who borrowed this item.
 635         $sth2 = $dbh->prepare(
 636             "SELECT * FROM issues, borrowers
 637                 LEFT JOIN borrowers ON  issues.borrowernumber = borrowers.borrowernumber
 638                 WHERE itemnumber = ?
 639                 AND returndate IS NOT NULL
 640                 ORDER BY returndate DESC,timestamp DESC"
 641         );
 642
 643 #        $sth2 = $dbh->prepare("
 644 #            SELECT *
 645 #            FROM issues
 646 #                LEFT JOIN borrowers ON issues.borrowernumber = borrowers.borrowernumber
 647 #            WHERE   itemnumber = ?
 648 #                AND returndate is not NULL
 649 #            ORDER BY returndate DESC,timestamp DESC
 650 #        ");
 651
 652         $sth2->execute( $data->{'itemnumber'} );
 653         for ( my $i2 = 0 ; $i2 < 2 ; $i2++ )
 654         {    # FIXME : error if there is less than 3 pple borrowing this item
 655             if ( my $data2 = $sth2->fetchrow_hashref ) {
 656                 $data->{"timestamp$i2"} = $data2->{'timestamp'};
 657                 $data->{"card$i2"}      = $data2->{'cardnumber'};
 658                 $data->{"borrower$i2"}  = $data2->{'borrowernumber'};
 659             }    # if
 660         }    # for
 661
 662         $sth2->finish;
 663         $results[$i] = $data;
 664         $i++;
 665     }
 666
 667     $sth->finish;
 668     return (@results);
 669 }
 670
 671 =head2 CanBookBeIssued
 672
 673 $issuingimpossible, $needsconfirmation =
 674         CanBookBeIssued( $env, $borrower, $barcode, $year, $month, $day, $inprocess );
 675
 676 C<$issuingimpossible> and C<$needsconfirmation> are some hashref.
 677
 678 =cut
 679
 680 sub CanBookBeIssued {
 681     my ( $env, $borrower, $barcode, $year, $month, $day, $inprocess ) = @_;
 682     my %needsconfirmation;    # filled with problems that needs confirmations
 683     my %issuingimpossible;    # filled with problems that causes the issue to be IMPOSSIBLE
 684     my $item = GetItem(GetItemnumberFromBarcode( $barcode ));
 685     my $issue = GetItemIssue($item->{itemnumber});
 686     my $dbh             = C4::Context->dbh;
 687
 688     #
 689     # DUE DATE is OK ?
 690     #
 691     my ( $duedate, $invalidduedate ) = fixdate( $year, $month, $day );
 692     $issuingimpossible{INVALID_DATE} = 1 if ($invalidduedate);
 693
 694     #
 695     # BORROWER STATUS
 696     #
 697     if ( $borrower->{flags}->{GNA} ) {
 698         $issuingimpossible{GNA} = 1;
 699     }
 700     if ( $borrower->{flags}->{'LOST'} ) {
 701         $issuingimpossible{CARD_LOST} = 1;
 702     }
 703     if ( $borrower->{flags}->{'DBARRED'} ) {
 704         $issuingimpossible{DEBARRED} = 1;
 705     }
 706     if ( Date_to_Days(Today) >
 707         Date_to_Days( split "-", $borrower->{'dateexpiry'} ) )
 708     {
 709
 710         #
 711         #if (&Date_Cmp(&ParseDate($borrower->{expiry}),&ParseDate("today"))<0) {
 712         $issuingimpossible{EXPIRED} = 1;
 713     }
 714
 715     #
 716     # BORROWER STATUS
 717     #
 718
 719     # DEBTS
 720     my $amount =
 721       checkaccount( $borrower->{'borrowernumber'}, $dbh, $duedate );
 722     if ( C4::Context->preference("IssuingInProcess") ) {
 723         my $amountlimit = C4::Context->preference("noissuescharge");
 724         if ( $amount > $amountlimit && !$inprocess ) {
 725             $issuingimpossible{DEBT} = sprintf( "%.2f", $amount );
 726         }
 727         elsif ( $amount <= $amountlimit && !$inprocess ) {
 728             $needsconfirmation{DEBT} = sprintf( "%.2f", $amount );
 729         }
 730     }
 731     else {
 732         if ( $amount > 0 ) {
 733             $needsconfirmation{DEBT} = $amount;
 734         }
 735     }
 736
 737     #
 738     # JB34 CHECKS IF BORROWERS DONT HAVE ISSUE TOO MANY BOOKS
 739     #
 740     my $toomany = TooMany( $borrower, $item->{biblionumber} );
 741     $needsconfirmation{TOO_MANY} = $toomany if $toomany;
 742
 743     #
 744     # ITEM CHECKING
 745     #
 746     unless ( $item->{barcode} ) {
 747         $issuingimpossible{UNKNOWN_BARCODE} = 1;
 748     }
 749     if (   $item->{'notforloan'}
 750         && $item->{'notforloan'} > 0 )
 751     {
 752         $issuingimpossible{NOT_FOR_LOAN} = 1;
 753     }
 754     if ( $item->{'wthdrawn'} && $item->{'wthdrawn'} == 1 )
 755     {
 756         $issuingimpossible{WTHDRAWN} = 1;
 757     }
 758     if (   $item->{'restricted'}
 759         && $item->{'restricted'} == 1 )
 760     {
 761         $issuingimpossible{RESTRICTED} = 1;
 762     }
 763     if ( C4::Context->preference("IndependantBranches") ) {
 764         my $userenv = C4::Context->userenv;
 765         if ( ($userenv) && ( $userenv->{flags} != 1 ) ) {
 766             $issuingimpossible{NOTSAMEBRANCH} = 1
 767               if ( $item->{'holdingbranch'} ne $userenv->{branch} );
 768         }
 769     }
 770
 771     #
 772     # CHECK IF BOOK ALREADY ISSUED TO THIS BORROWER
 773     #
 774     if ( $issue->{borrowernumber} && $issue->{borrowernumber} eq $borrower->{'borrowernumber'} )
 775     {
 776
 777         # Already issued to current borrower. Ask whether the loan should
 778         # be renewed.
 779         my ($CanBookBeRenewed) = CanBookBeRenewed(
 780             $borrower->{'borrowernumber'},
 781             $item->{'itemnumber'}
 782         );
 783         if ( $CanBookBeRenewed == 0 ) {    # no more renewals allowed
 784             $issuingimpossible{NO_MORE_RENEWALS} = 1;
 785         }
 786         else {
 787
 788             #        $needsconfirmation{RENEW_ISSUE} = 1;
 789         }
 790     }
 791     elsif ($issue->{borrowernumber}) {
 792
 793         # issued to someone else
 794         my $currborinfo = GetMemberDetails( $issue->{borrowernumber} );
 795
 796 #        warn "=>.$currborinfo->{'firstname'} $currborinfo->{'surname'} ($currborinfo->{'cardnumber'})";
 797         $needsconfirmation{ISSUED_TO_ANOTHER} =
 798 "$currborinfo->{'reservedate'} : $currborinfo->{'firstname'} $currborinfo->{'surname'} ($currborinfo->{'cardnumber'})";
 799     }
 800
 801     # See if the item is on reserve.
 802     my ( $restype, $res ) = CheckReserves( $item->{'itemnumber'} );
 803     if ($restype) {
 804         my $resbor = $res->{'borrowernumber'};
 805         if ( $resbor ne $borrower->{'borrowernumber'} && $restype eq "Waiting" )
 806         {
 807
 808             # The item is on reserve and waiting, but has been
 809             # reserved by some other patron.
 810             my ( $resborrower, $flags ) =
 811               GetMemberDetails( $resbor, 0 );
 812             my $branches   = GetBranches();
 813             my $branchname =
 814               $branches->{ $res->{'branchcode'} }->{'branchname'};
 815             $needsconfirmation{RESERVE_WAITING} =
 816 "$resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'}, $branchname)";
 817
 818 # CancelReserve(0, $res->{'itemnumber'}, $res->{'borrowernumber'}); Doesn't belong in a checking subroutine.
 819         }
 820         elsif ( $restype eq "Reserved" ) {
 821
 822             # The item is on reserve for someone else.
 823             my ( $resborrower, $flags ) =
 824               GetMemberDetails( $resbor, 0 );
 825             my $branches   = GetBranches();
 826             my $branchname =
 827               $branches->{ $res->{'branchcode'} }->{'branchname'};
 828             $needsconfirmation{RESERVED} =
 829 "$res->{'reservedate'} : $resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'})";
 830         }
 831     }
 832     if ( C4::Context->preference("LibraryName") eq "Horowhenua Library Trust" )
 833     {
 834         if ( $borrower->{'categorycode'} eq 'W' ) {
 835             my %issuingimpossible;
 836             return ( \%issuingimpossible, \%needsconfirmation );
 837         }
 838         else {
 839             return ( \%issuingimpossible, \%needsconfirmation );
 840         }
 841     }
 842     else {
 843         return ( \%issuingimpossible, \%needsconfirmation );
 844     }
 845 }
 846
 847 =head2 AddIssue
 848
 849 Issue a book. Does no check, they are done in CanBookBeIssued. If we reach this sub, it means the user confirmed if needed.
 850
 851 &AddIssue($env,$borrower,$barcode,$date)
 852
 853 =over 4
 854
 855 =item C<$env> Environment variable. Should be empty usually, but used by other subs. Next code cleaning could drop it.
 856
 857 =item C<$borrower> hash with borrower informations (from GetMemberDetails)
 858
 859 =item C<$barcode> is the bar code of the book being issued.
 860
 861 =item C<$date> contains the max date of return. calculated if empty.
 862
 863 AddIssue does the following things :
 864 - step 0�: check that there is a borrowernumber & a barcode provided
 865 - check for RENEWAL (book issued & being issued to the same patron)
 866     - renewal YES = Calculate Charge & renew
 867     - renewal NO  =
 868         * BOOK ACTUALLY ISSUED ? do a return if book is actually issued (but to someone else)
 869         * RESERVE PLACED ?
 870             - fill reserve if reserve to this patron
 871             - cancel reserve or not, otherwise
 872         * TRANSFERT PENDING ?
 873             - complete the transfert
 874         * ISSUE THE BOOK
 875
 876 =back
 877
 878 =cut
 879
 880 sub AddIssue {
 881     my ( $env, $borrower, $barcode, $date, $cancelreserve ) = @_;
 882
 883     my $dbh = C4::Context->dbh;
 884 if ($borrower and $barcode){
 885 #   my ($borrower, $flags) = &GetMemberDetails($borrowernumber, 0);
 886     # find which item we issue
 887     my $item = GetItem('', $barcode);
 888
 889     # get actual issuing if there is one
 890     my $actualissue = GetItemIssue( $item->{itemnumber});
 891
 892     # get biblioinformation for this item
 893     my $biblio = GetBiblioFromItemNumber($item->{itemnumber});
 894
 895 #
 896 # check if we just renew the issue.
 897 #
 898     if ( $actualissue->{borrowernumber} eq $borrower->{'borrowernumber'} ) {
 899         # we renew, do we need to add some charge ?
 900         my ( $charge, $itemtype ) = GetIssuingCharges(
 901             $item->{'itemnumber'},
 902             $borrower->{'borrowernumber'}
 903         );
 904         if ( $charge > 0 ) {
 905             AddIssuingCharge(
 906                 $item->{'itemnumber'},
 907                 $borrower->{'borrowernumber'}, $charge
 908             );
 909             $item->{'charge'} = $charge;
 910         }
 911         &UpdateStats(
 912             $env,                           $env->{'branchcode'},
 913             'renew',                        $charge,
 914             '',                             $item->{'itemnumber'},
 915             $biblio->{'itemtype'}, $borrower->{'borrowernumber'}
 916         );
 917         AddRenewal(
 918             $borrower->{'borrowernumber'},
 919             $item->{'itemnumber'}
 920         );
 921     }
 922     else {# it's NOT a renewal
 923         if ( $actualissue->{borrowernumber}) {
 924             # This book is currently on loan, but not to the person
 925             # who wants to borrow it now. mark it returned before issuing to the new borrower
 926             AddReturn(
 927                 $item->{'barcode'},
 928                 C4::Context->userenv->{'branch'}
 929             );
 930         }
 931
 932         # See if the item is on reserve.
 933         my ( $restype, $res ) =
 934           CheckReserves( $item->{'itemnumber'} );
 935         if ($restype) {
 936             my $resbor = $res->{'borrowernumber'};
 937             if ( $resbor eq $borrower->{'borrowernumber'} ) {
 938
 939                 # The item is reserved by the current patron
 940                 FillReserve($res);
 941             }
 942             elsif ( $restype eq "Waiting" ) {
 943
 944                 # warn "Waiting";
 945                 # The item is on reserve and waiting, but has been
 946                 # reserved by some other patron.
 947                 my ( $resborrower, $flags ) = GetMemberDetails( $resbor, 0 );
 948                 my $branches   = GetBranches();
 949                 my $branchname =
 950                   $branches->{ $res->{'branchcode'} }->{'branchname'};
 951                 if ($cancelreserve) {
 952                     CancelReserve( 0, $res->{'itemnumber'},
 953                         $res->{'borrowernumber'} );
 954                 }
 955                 else {
 956
 957        # set waiting reserve to first in reserve queue as book isn't waiting now
 958                     UpdateReserve(
 959                         1,
 960                         $res->{'biblionumber'},
 961                         $res->{'borrowernumber'},
 962                         $res->{'branchcode'}
 963                     );
 964                 }
 965             }
 966             elsif ( $restype eq "Reserved" ) {
 967
 968                 # warn "Reserved";
 969                 # The item is reserved by someone else.
 970                 my ( $resborrower, $flags ) =
 971                   GetMemberDetails( $resbor, 0 );
 972                 my $branches   = GetBranches();
 973                 my $branchname =
 974                   $branches->{ $res->{'branchcode'} }->{'branchname'};
 975                 if ($cancelreserve) { # cancel reserves on this item
 976                     CancelReserve( 0, $res->{'itemnumber'},
 977                         $res->{'borrowernumber'} );
 978                 }
 979             }
 980         }
 981
 982         # Starting process for transfer job (checking transfert and validate it if we have one)
 983             my ($datesent) = GetTransfers($item->{'itemnumber'});
 984             if ($datesent) {
 985         #       updating line of branchtranfert to finish it, and changing the to branch value, implement a comment for lisibility of this case (maybe for stats ....)
 986             my $sth =
 987                     $dbh->prepare(
 988                     "UPDATE branchtransfers
 989                         SET datearrived = now(),
 990                         tobranch = ?,
 991                         comments = 'Forced branchtransfert'
 992                     WHERE itemnumber= ? AND datearrived IS NULL"
 993                     );
 994                     $sth->execute(C4::Context->userenv->{'branch'},$item->{'itemnumber'});
 995                     $sth->finish;
 996             }
 997
 998         # Record in the database the fact that the book was issued.
 999         my $sth =
1000           $dbh->prepare(
1001                 "INSERT INTO issues
1002                     (borrowernumber, itemnumber,issuedate, date_due, branchcode)
1003                 VALUES (?,?,?,?,?)"
1004           );
1005         my $loanlength = GetLoanLength(
1006             $borrower->{'categorycode'},
1007             $biblio->{'itemtype'},
1008             $borrower->{'branchcode'}
1009         );
1010         my $datedue  = time + ($loanlength) * 86400;
1011         my @datearr  = localtime($datedue);
1012         my $dateduef =
1013             ( 1900 + $datearr[5] ) . "-"
1014           . ( $datearr[4] + 1 ) . "-"
1015           . $datearr[3];
1016         if ($date) {
1017             $dateduef = $date;
1018         }
1019
1020        # if ReturnBeforeExpiry ON the datedue can't be after borrower expirydate
1021         if ( C4::Context->preference('ReturnBeforeExpiry')
1022             && $dateduef gt $borrower->{dateexpiry} )
1023         {
1024             $dateduef = $borrower->{dateexpiry};
1025         }
1026         $sth->execute(
1027             $borrower->{'borrowernumber'},
1028             $item->{'itemnumber'},
1029             strftime( "%Y-%m-%d", localtime ),$dateduef, $env->{'branchcode'}
1030         );
1031         $sth->finish;
1032         $item->{'issues'}++;
1033         $sth =
1034           $dbh->prepare(
1035             "UPDATE items SET issues=?, holdingbranch=?, itemlost=0, datelastborrowed  = now() WHERE itemnumber=?");
1036         $sth->execute(
1037             $item->{'issues'},
1038             C4::Context->userenv->{'branch'},
1039             $item->{'itemnumber'}
1040         );
1041         $sth->finish;
1042         &ModDateLastSeen( $item->{'itemnumber'} );
1043         # If it costs to borrow this book, charge it to the patron's account.
1044         my ( $charge, $itemtype ) = GetIssuingCharges(
1045             $item->{'itemnumber'},
1046             $borrower->{'borrowernumber'}
1047         );
1048         if ( $charge > 0 ) {
1049             AddIssuingCharge(
1050                 $item->{'itemnumber'},
1051                 $borrower->{'borrowernumber'}, $charge
1052             );
1053             $item->{'charge'} = $charge;
1054         }
1055
1056         # Record the fact that this book was issued.
1057         &UpdateStats(
1058             $env,                           $env->{'branchcode'},
1059             'issue',                        $charge,
1060             '',                             $item->{'itemnumber'},
1061             $item->{'itemtype'}, $borrower->{'borrowernumber'}
1062         );
1063     }
1064
1065     &logaction(C4::Context->userenv->{'number'},"CIRCULATION","ISSUE",$borrower->{'borrowernumber'},$biblio->{'biblionumber'})
1066         if C4::Context->preference("IssueLog");
1067   }
1068 }
1069
1070 =head2 GetLoanLength
1071
1072 Get loan length for an itemtype, a borrower type and a branch
1073
1074 my $loanlength = &GetLoanLength($borrowertype,$itemtype,branchcode)
1075
1076 =cut
1077
1078 sub GetLoanLength {
1079     my ( $borrowertype, $itemtype, $branchcode ) = @_;
1080     my $dbh = C4::Context->dbh;
1081     my $sth =
1082       $dbh->prepare(
1083 "select issuelength from issuingrules where categorycode=? and itemtype=? and branchcode=?"
1084       );
1085
1086 # try to find issuelength & return the 1st available.
1087 # check with borrowertype, itemtype and branchcode, then without one of those parameters
1088     $sth->execute( $borrowertype, $itemtype, $branchcode );
1089     my $loanlength = $sth->fetchrow_hashref;
1090     return $loanlength->{issuelength}
1091       if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
1092
1093     $sth->execute( $borrowertype, $itemtype, "" );
1094     $loanlength = $sth->fetchrow_hashref;
1095     return $loanlength->{issuelength}
1096       if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
1097
1098     $sth->execute( $borrowertype, "*", $branchcode );
1099     $loanlength = $sth->fetchrow_hashref;
1100     return $loanlength->{issuelength}
1101       if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
1102
1103     $sth->execute( "*", $itemtype, $branchcode );
1104     $loanlength = $sth->fetchrow_hashref;
1105     return $loanlength->{issuelength}
1106       if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
1107
1108     $sth->execute( $borrowertype, "*", "" );
1109     $loanlength = $sth->fetchrow_hashref;
1110     return $loanlength->{issuelength}
1111       if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
1112
1113     $sth->execute( "*", "*", $branchcode );
1114     $loanlength = $sth->fetchrow_hashref;
1115     return $loanlength->{issuelength}
1116       if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
1117
1118     $sth->execute( "*", $itemtype, "" );
1119     $loanlength = $sth->fetchrow_hashref;
1120     return $loanlength->{issuelength}
1121       if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
1122
1123     $sth->execute( "*", "*", "" );
1124     $loanlength = $sth->fetchrow_hashref;
1125     return $loanlength->{issuelength}
1126       if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
1127
1128     # if no rule is set => 21 days (hardcoded)
1129     return 21;
1130 }
1131
1132 =head2 AddReturn
1133
1134 ($doreturn, $messages, $iteminformation, $borrower) =
1135     &AddReturn($barcode, $branch);
1136
1137 Returns a book.
1138
1139 C<$barcode> is the bar code of the book being returned. C<$branch> is
1140 the code of the branch where the book is being returned.
1141
1142 C<&AddReturn> returns a list of four items:
1143
1144 C<$doreturn> is true iff the return succeeded.
1145
1146 C<$messages> is a reference-to-hash giving the reason for failure:
1147
1148 =over 4
1149
1150 =item C<BadBarcode>
1151
1152 No item with this barcode exists. The value is C<$barcode>.
1153
1154 =item C<NotIssued>
1155
1156 The book is not currently on loan. The value is C<$barcode>.
1157
1158 =item C<IsPermanent>
1159
1160 The book's home branch is a permanent collection. If you have borrowed
1161 this book, you are not allowed to return it. The value is the code for
1162 the book's home branch.
1163
1164 =item C<wthdrawn>
1165
1166 This book has been withdrawn/cancelled. The value should be ignored.
1167
1168 =item C<ResFound>
1169
1170 The item was reserved. The value is a reference-to-hash whose keys are
1171 fields from the reserves table of the Koha database, and
1172 C<biblioitemnumber>. It also has the key C<ResFound>, whose value is
1173 either C<Waiting>, C<Reserved>, or 0.
1174
1175 =back
1176
1177 C<$borrower> is a reference-to-hash, giving information about the
1178 patron who last borrowed the book.
1179
1180 =cut
1181
1182 # FIXME - This API is bogus. There's no need to return $borrower and
1183 # $iteminformation; the caller can ask about those separately, if it
1184 # cares (it'd be inefficient to make two database calls instead of
1185 # one, but &GetMemberDetails and &getiteminformation can be
1186 # memoized if this is an issue).
1187 #
1188 # The ($doreturn, $messages) tuple is redundant: if the return
1189 # succeeded, that's all the caller needs to know. So &AddReturn can
1190 # return 1 and 0 on success and failure, and set
1191 # $C4::Circulation::Circ2::errmsg to indicate the error. Or it can
1192 # return undef for success, and an error message on error (though this
1193 # is more C-ish than Perl-ish).
1194
1195 sub AddReturn {
1196     my ( $barcode, $branch ) = @_;
1197     my $dbh      = C4::Context->dbh;
1198     my $messages;
1199     my $doreturn = 1;
1200     my $borrower;
1201     my $validTransfert = 0;
1202     my $reserveDone = 0;
1203
1204     # get information on item
1205     my $iteminformation = GetItemIssue( GetItemnumberFromBarcode($barcode));
1206     unless ($iteminformation->{'itemnumber'} ) {
1207         $messages->{'BadBarcode'} = $barcode;
1208         $doreturn = 0;
1209     } else {
1210         # find the borrower
1211         if ( ( not $iteminformation->{borrowernumber} ) && $doreturn ) {
1212             $messages->{'NotIssued'} = $barcode;
1213             $doreturn = 0;
1214         }
1215
1216         # check if the book is in a permanent collection....
1217         my $hbr      = $iteminformation->{'homebranch'};
1218         my $branches = GetBranches();
1219         if ( $hbr && $branches->{$hbr}->{'PE'} ) {
1220             $messages->{'IsPermanent'} = $hbr;
1221         }
1222
1223         # check that the book has been cancelled
1224         if ( $iteminformation->{'wthdrawn'} ) {
1225             $messages->{'wthdrawn'} = 1;
1226             $doreturn = 0;
1227         }
1228
1229     #     new op dev : if the book returned in an other branch update the holding branch
1230
1231     # update issues, thereby returning book (should push this out into another subroutine
1232         $borrower = GetMemberDetails( $iteminformation->{borrowernumber}, 0 );
1233
1234     # case of a return of document (deal with issues and holdingbranch)
1235
1236         if ($doreturn) {
1237             my $sth =
1238             $dbh->prepare(
1239     "update issues set returndate = now() where (borrowernumber = ?) and (itemnumber = ?) and (returndate is null)"
1240             );
1241             $sth->execute( $borrower->{'borrowernumber'},
1242                 $iteminformation->{'itemnumber'} );
1243             $messages->{'WasReturned'} = 1;    # FIXME is the "= 1" right?
1244         }
1245
1246     # continue to deal with returns cases, but not only if we have an issue
1247
1248     # the holdingbranch is updated if the document is returned in an other location .
1249     if ( $iteminformation->{'holdingbranch'} ne C4::Context->userenv->{'branch'} )
1250             {
1251                     UpdateHoldingbranch(C4::Context->userenv->{'branch'},$iteminformation->{'itemnumber'});
1252     #           reload iteminformation holdingbranch with the userenv value
1253                     $iteminformation->{'holdingbranch'} = C4::Context->userenv->{'branch'};
1254             }
1255         ModDateLastSeen( $iteminformation->{'itemnumber'} );
1256         ($borrower) = GetMemberDetails( $iteminformation->{borrowernumber}, 0 );
1257
1258         # fix up the accounts.....
1259         if ( $iteminformation->{'itemlost'} ) {
1260             $messages->{'WasLost'} = 1;
1261         }
1262
1263     # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
1264     #     check if we have a transfer for this document
1265         my ($datesent,$frombranch,$tobranch) = GetTransfers( $iteminformation->{'itemnumber'} );
1266
1267     #     if we have a transfer to do, we update the line of transfers with the datearrived
1268         if ($datesent) {
1269             if ( $tobranch eq C4::Context->userenv->{'branch'} ) {
1270                     my $sth =
1271                     $dbh->prepare(
1272                             "update branchtransfers set datearrived = now() where itemnumber= ? AND datearrived IS NULL"
1273                     );
1274                     $sth->execute( $iteminformation->{'itemnumber'} );
1275                     $sth->finish;
1276     #         now we check if there is a reservation with the validate of transfer if we have one, we can         set it with the status 'W'
1277             SetWaitingStatus( $iteminformation->{'itemnumber'} );
1278             }
1279         else {
1280             $messages->{'WrongTransfer'} = $tobranch;
1281             $messages->{'WrongTransferItem'} = $iteminformation->{'itemnumber'};
1282         }
1283         $validTransfert = 1;
1284         }
1285
1286     # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
1287     # fix up the overdues in accounts...
1288         fixoverduesonreturn( $borrower->{'borrowernumber'},
1289             $iteminformation->{'itemnumber'} );
1290
1291     # find reserves.....
1292     #     if we don't have a reserve with the status W, we launch the Checkreserves routine
1293         my ( $resfound, $resrec ) =
1294         CheckReserves( $iteminformation->{'itemnumber'} );
1295         if ($resfound) {
1296             $resrec->{'ResFound'}   = $resfound;
1297             $messages->{'ResFound'} = $resrec;
1298             $reserveDone = 1;
1299         }
1300
1301         # update stats?
1302         # Record the fact that this book was returned.
1303         UpdateStats(
1304             $branch, 'return', '0', '',
1305             $iteminformation->{'itemnumber'},
1306             $iteminformation->{'itemtype'},
1307             $borrower->{'borrowernumber'}
1308         );
1309
1310         &logaction(C4::Context->userenv->{'number'},"CIRCULATION","RETURN",$iteminformation->{borrowernumber},$iteminformation->{'biblionumber'})
1311             if C4::Context->preference("ReturnLog");
1312
1313         #adding message if holdingbranch is non equal a userenv branch to return the document to homebranch
1314         #we check, if we don't have reserv or transfert for this document, if not, return it to homebranch .
1315
1316         if ( ($iteminformation->{'holdingbranch'} ne $iteminformation->{'homebranch'}) and not $messages->{'WrongTransfer'} and ($validTransfert ne 1) and ($reserveDone ne 1) ){
1317                     if (C4::Context->preference("AutomaticItemReturn") == 1) {
1318                     dotransfer($iteminformation->{'itemnumber'}, C4::Context->userenv->{'branch'}, $iteminformation->{'homebranch'});
1319                     $messages->{'WasTransfered'} = 1;
1320                     warn "was transfered";
1321                     }
1322         }
1323     }
1324     return ( $doreturn, $messages, $iteminformation, $borrower );
1325 }
1326
1327 =head2 fixoverdueonreturn
1328
1329     &fixoverdueonreturn($brn,$itm);
1330
1331 C<$brn> borrowernumber
1332
1333 C<$itm> itemnumber
1334
1335 =cut
1336
1337 sub fixoverduesonreturn {
1338     my ( $borrowernumber, $item ) = @_;
1339     my $dbh = C4::Context->dbh;
1340
1341     # check for overdue fine
1342     my $sth =
1343       $dbh->prepare(
1344 "SELECT * FROM accountlines WHERE (borrowernumber = ?) AND (itemnumber = ?) AND (accounttype='FU' OR accounttype='O')"
1345       );
1346     $sth->execute( $borrowernumber, $item );
1347
1348     # alter fine to show that the book has been returned
1349     if ( my $data = $sth->fetchrow_hashref ) {
1350         my $usth =
1351           $dbh->prepare(
1352 "UPDATE accountlines SET accounttype='F' WHERE (borrowernumber = ?) AND (itemnumber = ?) AND (accountno = ?)"
1353           );
1354         $usth->execute( $borrowernumber, $item, $data->{'accountno'} );
1355         $usth->finish();
1356     }
1357     $sth->finish();
1358     return;
1359 }
1360
1361 =head2 GetItemIssue
1362
1363 $issues = &GetBorrowerIssue($itemnumber);
1364
1365 Returns patrons currently having a book. nothing if item is not issued atm
1366
1367 C<$itemnumber> is the itemnumber
1368
1369 Returns an array of hashes
1370 =cut
1371
1372 sub GetItemIssue {
1373     my ( $itemnumber) = @_;
1374     return unless $itemnumber;
1375     my $dbh = C4::Context->dbh;
1376     my @GetItemIssues;
1377
1378     # get today date
1379     my $today = POSIX::strftime("%Y%m%d", localtime);
1380
1381     my $sth = $dbh->prepare(
1382         "SELECT * FROM issues
1383         LEFT JOIN items ON issues.itemnumber=items.itemnumber
1384     WHERE
1385     issues.itemnumber=?  AND returndate IS NULL ");
1386     $sth->execute($itemnumber);
1387     my $data = $sth->fetchrow_hashref;
1388     my $datedue = $data->{'date_due'};
1389     $datedue =~ s/-//g;
1390     if ( $datedue < $today ) {
1391         $data->{'overdue'} = 1;
1392     }
1393     $data->{'itemnumber'} = $itemnumber; # fill itemnumber, in case item is not on issue
1394     $sth->finish;
1395     return ($data);
1396 }
1397
1398 =head2 GetItemIssues
1399
1400 $issues = &GetBorrowerIssues($itemnumber, $history);
1401
1402 Returns patrons that have issued a book
1403
1404 C<$itemnumber> is the itemnumber
1405 C<$history> is 0 if you want actuel "issuer" (if it exist) and 1 if you want issues history
1406
1407 Returns an array of hashes
1408 =cut
1409
1410 sub GetItemIssues {
1411     my ( $itemnumber,$history ) = @_;
1412     my $dbh = C4::Context->dbh;
1413     my @GetItemIssues;
1414
1415     # get today date
1416     my $today = POSIX::strftime("%Y%m%d", localtime);
1417
1418     my $sth = $dbh->prepare(
1419         "SELECT * FROM issues
1420     WHERE
1421     itemnumber=?".($history?"":" AND returndate IS NULL ").
1422     "ORDER BY issues.date_due DESC"
1423     );
1424     $sth->execute($itemnumber);
1425     while ( my $data = $sth->fetchrow_hashref ) {
1426         my $datedue = $data->{'date_due'};
1427         $datedue =~ s/-//g;
1428         if ( $datedue < $today ) {
1429             $data->{'overdue'} = 1;
1430         }
1431         my $itemnumber = $data->{'itemnumber'};
1432
1433         push @GetItemIssues, $data;
1434     }
1435     $sth->finish;
1436     return ( \@GetItemIssues );
1437 }
1438
1439 =head2 GetBorrowerIssues
1440
1441 $issues = &GetBorrowerIssues($borrower);
1442
1443 Returns a list of books currently on loan to a patron.
1444
1445 C<$borrower->{borrowernumber}> is the borrower number of the patron
1446 whose issues we want to list.
1447
1448 C<&GetBorrowerIssues> returns a PHP-style array: C<$issues> is a
1449 reference-to-hash whose keys are integers in the range 1...I<n>, where
1450 I<n> is the number of items on issue (either today or before today).
1451 C<$issues-E<gt>{I<n>}> is a reference-to-hash whose keys are all of
1452 the fields of the biblio, biblioitems, items, and issues fields of the
1453 Koha database for that particular item.
1454
1455 =cut
1456
1457 sub GetBorrowerIssues {
1458     my ( $borrower ) = @_;
1459     my $dbh = C4::Context->dbh;
1460     my @GetBorrowerIssues;
1461     # get today date
1462     my $today = POSIX::strftime("%Y%m%d", localtime);
1463
1464     my $sth = $dbh->prepare(
1465         "SELECT * FROM issues
1466     LEFT JOIN items ON issues.itemnumber=items.itemnumber
1467     LEFT JOIN biblio ON     items.biblionumber=biblio.biblionumber
1468     LEFT JOIN biblioitems ON items.biblioitemnumber=biblioitems.biblioitemnumber
1469     WHERE
1470     borrowernumber=? AND returndate IS NULL
1471     ORDER BY issues.date_due"
1472     );
1473     $sth->execute($borrower->{'borrowernumber'});
1474     while ( my $data = $sth->fetchrow_hashref ) {
1475         my $datedue = $data->{'date_due'};
1476         $datedue =~ s/-//g;
1477         if ( $datedue < $today ) {
1478             $data->{'overdue'} = 1;
1479         }
1480         my $itemnumber = $data->{'itemnumber'};
1481
1482         push @GetBorrowerIssues, $data;
1483     }
1484     $sth->finish;
1485     return ( \@GetBorrowerIssues );
1486 }
1487
1488 =head2 GetBiblioIssues
1489
1490 $issues = GetBiblioIssues($biblionumber);
1491
1492 this function get all issues from a biblionumber.
1493
1494 Return:
1495 C<$issues> is a reference to array which each value is ref-to-hash. This ref-to-hash containts all column from
1496 tables issues and the firstname,surname & cardnumber from borrowers.
1497
1498 =cut
1499
1500 sub GetBiblioIssues {
1501     my $biblionumber = shift;
1502     return undef unless $biblionumber;
1503     my $dbh   = C4::Context->dbh;
1504     my $query = "
1505         SELECT issues.*,biblio.biblionumber,biblio.title, biblio.author,borrowers.cardnumber,borrowers.surname,borrowers.firstname
1506         FROM issues
1507             LEFT JOIN borrowers ON borrowers.borrowernumber = issues.borrowernumber
1508             LEFT JOIN items ON issues.itemnumber = items.itemnumber
1509             LEFT JOIN biblioitems ON items.itemnumber = biblioitems.biblioitemnumber
1510             LEFT JOIN biblio ON biblio.biblionumber = items.biblioitemnumber
1511         WHERE biblio.biblionumber = ?
1512         ORDER BY issues.timestamp
1513     ";
1514     my $sth = $dbh->prepare($query);
1515     $sth->execute($biblionumber);
1516
1517     my @issues;
1518     while ( my $data = $sth->fetchrow_hashref ) {
1519         push @issues, $data;
1520     }
1521     return \@issues;
1522 }
1523
1524 =head2 CanBookBeRenewed
1525
1526 $ok = &CanBookBeRenewed($borrowernumber, $itemnumber);
1527
1528 Find out whether a borrowed item may be renewed.
1529
1530 C<$env> is ignored.
1531
1532 C<$dbh> is a DBI handle to the Koha database.
1533
1534 C<$borrowernumber> is the borrower number of the patron who currently
1535 has the item on loan.
1536
1537 C<$itemnumber> is the number of the item to renew.
1538
1539 C<$CanBookBeRenewed> returns a true value iff the item may be renewed. The
1540 item must currently be on loan to the specified borrower; renewals
1541 must be allowed for the item's type; and the borrower must not have
1542 already renewed the loan.
1543
1544 =cut
1545
1546 sub CanBookBeRenewed {
1547
1548     # check renewal status
1549     my ( $borrowernumber, $itemnumber ) = @_;
1550     my $dbh       = C4::Context->dbh;
1551     my $renews    = 1;
1552     my $renewokay = 0;
1553
1554     # Look in the issues table for this item, lent to this borrower,
1555     # and not yet returned.
1556
1557     # FIXME - I think this function could be redone to use only one SQL call.
1558     my $sth1 = $dbh->prepare(
1559         "SELECT * FROM issues
1560             WHERE borrowernumber = ?
1561             AND itemnumber = ?
1562             AND returndate IS NULL"
1563     );
1564     $sth1->execute( $borrowernumber, $itemnumber );
1565     if ( my $data1 = $sth1->fetchrow_hashref ) {
1566
1567         # Found a matching item
1568
1569         # See if this item may be renewed. This query is convoluted
1570         # because it's a bit messy: given the item number, we need to find
1571         # the biblioitem, which gives us the itemtype, which tells us
1572         # whether it may be renewed.
1573         my $sth2 = $dbh->prepare(
1574             "SELECT renewalsallowed FROM items
1575                 LEFT JOIN biblioitems on items.biblioitemnumber = biblioitems.biblioitemnumber
1576                 LEFT JOIN itemtypes ON biblioitems.itemtype = itemtypes.itemtype
1577                 WHERE items.itemnumber = ?
1578                 "
1579         );
1580         $sth2->execute($itemnumber);
1581         if ( my $data2 = $sth2->fetchrow_hashref ) {
1582             $renews = $data2->{'renewalsallowed'};
1583         }
1584         if ( $renews && $renews > $data1->{'renewals'} ) {
1585             $renewokay = 1;
1586         }
1587         $sth2->finish;
1588         my ( $resfound, $resrec ) = C4::Reserves2::CheckReserves($itemnumber);
1589         if ($resfound) {
1590             $renewokay = 0;
1591         }
1592         ( $resfound, $resrec ) = C4::Reserves2::CheckReserves($itemnumber);
1593         if ($resfound) {
1594             $renewokay = 0;
1595         }
1596
1597     }
1598     $sth1->finish;
1599     return ($renewokay);
1600 }
1601
1602 =head2 AddRenewal
1603
1604 &AddRenewal($borrowernumber, $itemnumber, $datedue);
1605
1606 Renews a loan.
1607
1608 C<$env-E<gt>{branchcode}> is the code of the branch where the
1609 renewal is taking place.
1610
1611 C<$env-E<gt>{usercode}> is the value to log in C<statistics.usercode>
1612 in the Koha database.
1613
1614 C<$borrowernumber> is the borrower number of the patron who currently
1615 has the item.
1616
1617 C<$itemnumber> is the number of the item to renew.
1618
1619 C<$datedue> can be used to set the due date. If C<$datedue> is the
1620 empty string, C<&AddRenewal> will calculate the due date automatically
1621 from the book's item type. If you wish to set the due date manually,
1622 C<$datedue> should be in the form YYYY-MM-DD.
1623
1624 =cut
1625
1626 sub AddRenewal {
1627
1628     my ( $borrowernumber, $itemnumber, $datedue ) = @_;
1629     my $dbh = C4::Context->dbh;
1630
1631     # If the due date wasn't specified, calculate it by adding the
1632     # book's loan length to today's date.
1633     if ( $datedue eq "" ) {
1634
1635         my $biblio = GetBiblioFromItemNumber($itemnumber);
1636         my $borrower = GetMemberDetails( $borrowernumber, 0 );
1637         my $loanlength = GetLoanLength(
1638             $borrower->{'categorycode'},
1639             $biblio->{'itemtype'},
1640             $borrower->{'branchcode'}
1641         );
1642         my ( $due_year, $due_month, $due_day ) =
1643           Add_Delta_DHMS( Today_and_Now(), $loanlength, 0, 0, 0 );
1644         $datedue = "$due_year-$due_month-$due_day";
1645
1646     }
1647
1648     # Find the issues record for this book
1649     my $sth =
1650       $dbh->prepare("SELECT * FROM issues
1651                         WHERE borrowernumber=?
1652                         AND itemnumber=?
1653                         AND returndate IS NULL"
1654       );
1655     $sth->execute( $borrowernumber, $itemnumber );
1656     my $issuedata = $sth->fetchrow_hashref;
1657     $sth->finish;
1658
1659     # Update the issues record to have the new due date, and a new count
1660     # of how many times it has been renewed.
1661     my $renews = $issuedata->{'renewals'} + 1;
1662     $sth = $dbh->prepare("UPDATE issues SET date_due = ?, renewals = ?
1663                             WHERE borrowernumber=?
1664                             AND itemnumber=?
1665                             AND returndate IS NULL"
1666     );
1667     $sth->execute( $datedue, $renews, $borrowernumber, $itemnumber );
1668     $sth->finish;
1669
1670     # Log the renewal
1671     UpdateStats( C4::Context->userenv->{'branchcode'}, 'renew', '', '', $itemnumber );
1672
1673     # Charge a new rental fee, if applicable?
1674     my ( $charge, $type ) = GetIssuingCharges( $itemnumber, $borrowernumber );
1675     if ( $charge > 0 ) {
1676         my $accountno = getnextacctno( $borrowernumber );
1677         my $item = GetBiblioFromItemNumbe(r$itemnumber);
1678         $sth = $dbh->prepare(
1679                 "INSERT INTO accountlines
1680                     (borrowernumber,accountno,date,amount,
1681                         description,accounttype,amountoutstanding,
1682                     itemnumber)
1683                     VALUES (?,?,now(),?,?,?,?,?)"
1684         );
1685         $sth->execute( $borrowernumber, $accountno, $charge,
1686             "Renewal of Rental Item $item->{'title'} $item->{'barcode'}",
1687             'Rent', $charge, $itemnumber );
1688         $sth->finish;
1689     }
1690 }
1691
1692 =head2 GetIssuingCharges
1693
1694 ($charge, $item_type) = &GetIssuingCharges($itemnumber, $borrowernumber);
1695
1696 Calculate how much it would cost for a given patron to borrow a given
1697 item, including any applicable discounts.
1698
1699 C<$env> is ignored.
1700
1701 C<$itemnumber> is the item number of item the patron wishes to borrow.
1702
1703 C<$borrowernumber> is the patron's borrower number.
1704
1705 C<&GetIssuingCharges> returns two values: C<$charge> is the rental charge,
1706 and C<$item_type> is the code for the item's item type (e.g., C<VID>
1707 if it's a video).
1708
1709 =cut
1710
1711 sub GetIssuingCharges {
1712
1713     # calculate charges due
1714     my ( $itemnumber, $borrowernumber ) = @_;
1715     my $charge = 0;
1716     my $dbh    = C4::Context->dbh;
1717     my $item_type;
1718
1719     # Get the book's item type and rental charge (via its biblioitem).
1720     my $sth1 = $dbh->prepare(
1721         "SELECT itemtypes.itemtype,rentalcharge FROM items
1722             LEFT JOIN biblioitems ON biblioitems.biblioitemnumber = items.biblioitemnumber
1723             LEFT JOIN itemtypes ON biblioitems.itemtype = itemtypes.itemtype
1724             WHERE items.itemnumber =?
1725         "
1726     );
1727     $sth1->execute($itemnumber);
1728     if ( my $data1 = $sth1->fetchrow_hashref ) {
1729         $item_type = $data1->{'itemtype'};
1730         $charge    = $data1->{'rentalcharge'};
1731         my $q2 = "SELECT rentaldiscount FROM borrowers
1732             LEFT JOIN issuingrules ON borrowers.categorycode = issuingrules.categorycode
1733             WHERE borrowers.borrowernumber = ?
1734             AND issuingrules.itemtype = ?";
1735         my $sth2 = $dbh->prepare($q2);
1736         $sth2->execute( $borrowernumber, $item_type );
1737         if ( my $data2 = $sth2->fetchrow_hashref ) {
1738             my $discount = $data2->{'rentaldiscount'};
1739             if ( $discount eq 'NULL' ) {
1740                 $discount = 0;
1741             }
1742             $charge = ( $charge * ( 100 - $discount ) ) / 100;
1743         }
1744         $sth2->finish;
1745     }
1746
1747     $sth1->finish;
1748     return ( $charge, $item_type );
1749 }
1750
1751 =head2 AddIssuingCharge
1752
1753 &AddIssuingCharge( $itemno, $borrowernumber, $charge )
1754
1755 =cut
1756
1757 sub AddIssuingCharge {
1758     my ( $itemnumber, $borrowernumber, $charge ) = @_;
1759     my $dbh = C4::Context->dbh;
1760     my $nextaccntno = getnextacctno( $borrowernumber );
1761     my $query ="
1762         INSERT INTO accountlines
1763             (borrowernumber, itemnumber, accountno,
1764             date, amount, description, accounttype,
1765             amountoutstanding)
1766         VALUES (?, ?, ?,now(), ?, 'Rental', 'Rent',?)
1767     ";
1768     my $sth = $dbh->prepare($query);
1769     $sth->execute( $borrowernumber, $itemnumber, $nextaccntno, $charge, $charge );
1770     $sth->finish;
1771 }
1772
1773 =head2 GetTransfers
1774
1775 GetTransfers($itemnumber);
1776
1777 =cut
1778
1779 sub GetTransfers {
1780     my ($itemnumber) = @_;
1781
1782     my $dbh = C4::Context->dbh;
1783
1784     my $query = '
1785         SELECT datesent,
1786                frombranch,
1787                tobranch
1788         FROM branchtransfers
1789         WHERE itemnumber = ?
1790           AND datearrived IS NULL
1791         ';
1792     my $sth = $dbh->prepare($query);
1793     $sth->execute($itemnumber);
1794     my @row = $sth->fetchrow_array();
1795     $sth->finish;
1796     return @row;
1797 }
1798
1799
1800 =head2 GetTransfersFromTo
1801
1802 @results = GetTransfersFromTo($frombranch,$tobranch);
1803
1804 Returns the list of pending transfers between $from and $to branch
1805
1806 =cut
1807
1808 sub GetTransfersFromTo {
1809     my ( $frombranch, $tobranch ) = @_;
1810     return unless ( $frombranch && $tobranch );
1811     my $dbh   = C4::Context->dbh;
1812     my $query = "
1813         SELECT itemnumber,datesent,frombranch
1814         FROM   branchtransfers
1815         WHERE  frombranch=?
1816           AND  tobranch=?
1817           AND datearrived IS NULL
1818     ";
1819     my $sth = $dbh->prepare($query);
1820     $sth->execute( $frombranch, $tobranch );
1821     my @gettransfers;
1822
1823     while ( my $data = $sth->fetchrow_hashref ) {
1824         push @gettransfers, $data;
1825     }
1826     $sth->finish;
1827     return (@gettransfers);
1828 }
1829
1830 =head2 DeleteTransfer
1831
1832 &DeleteTransfer($itemnumber);
1833
1834 =cut
1835
1836 sub DeleteTransfer {
1837     my ($itemnumber) = @_;
1838     my $dbh          = C4::Context->dbh;
1839     my $sth          = $dbh->prepare(
1840         "DELETE FROM branchtransfers
1841          WHERE itemnumber=?
1842          AND datearrived IS NULL "
1843     );
1844     $sth->execute($itemnumber);
1845     $sth->finish;
1846 }
1847
1848 =head2 AnonymiseIssueHistory
1849
1850 $rows = AnonymiseIssueHistory($borrowernumber,$date)
1851
1852 This function write NULL instead of C<$borrowernumber> given on input arg into the table issues.
1853 if C<$borrowernumber> is not set, it will delete the issue history for all borrower older than C<$date>.
1854
1855 return the number of affected rows.
1856
1857 =cut
1858
1859 sub AnonymiseIssueHistory {
1860     my $date           = shift;
1861     my $borrowernumber = shift;
1862     my $dbh            = C4::Context->dbh;
1863     my $query          = "
1864         UPDATE issues
1865         SET    borrowernumber = NULL
1866         WHERE  returndate < '".$date."'
1867           AND borrowernumber IS NOT NULL
1868     ";
1869     $query .= " AND borrowernumber = '".$borrowernumber."'" if defined $borrowernumber;
1870     my $rows_affected = $dbh->do($query);
1871     return $rows_affected;
1872 }
1873
1874 =head2 updateWrongTransfer
1875
1876 $items = updateWrongTransfer($itemNumber,$borrowernumber,$waitingAtLibrary,$FromLibrary);
1877
1878 This function validate the line of brachtransfer but with the wrong destination (mistake from a librarian ...), and create a new line in branchtransfer from the actual library to the original library of reservation
1879
1880 =cut
1881
1882 sub updateWrongTransfer {
1883         my ( $itemNumber,$waitingAtLibrary,$FromLibrary ) = @_;
1884         my $dbh = C4::Context->dbh;
1885 # first step validate the actual line of transfert .
1886         my $sth =
1887                 $dbh->prepare(
1888                         "update branchtransfers set datearrived = now(),tobranch=?,comments='wrongtransfer' where itemnumber= ? AND datearrived IS NULL"
1889                 );
1890                 $sth->execute($FromLibrary,$itemNumber);
1891                 $sth->finish;
1892
1893 # second step create a new line of branchtransfer to the right location .
1894         dotransfer($itemNumber, $FromLibrary, $waitingAtLibrary);
1895
1896 #third step changing holdingbranch of item
1897         UpdateHoldingbranch($FromLibrary,$itemNumber);
1898 }
1899
1900 =head2 UpdateHoldingbranch
1901
1902 $items = UpdateHoldingbranch($branch,$itmenumber);
1903 Simple methode for updating hodlingbranch in items BDD line
1904 =cut
1905
1906 sub UpdateHoldingbranch {
1907         my ( $branch,$itmenumber ) = @_;
1908         my $dbh = C4::Context->dbh;
1909 # first step validate the actual line of transfert .
1910         my $sth =
1911                 $dbh->prepare(
1912                         "update items set holdingbranch = ? where itemnumber= ?"
1913                 );
1914                 $sth->execute($branch,$itmenumber);
1915                 $sth->finish;
1916
1917
1918 }
1919
1920 1;
1921
1922 __END__
1923
1924 =head1 AUTHOR
1925
1926 Koha Developement team <info@koha.org>
1927
1928 =cut
1929