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