C4/Circulation/Circ2.pm

   1 package C4::Circulation::Circ2;
   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::Accounts2;
  30 use Date::Calc qw(
  31   Today
  32   Today_and_Now
  33   Add_Delta_YM
  34   Add_Delta_DHMS
  35   Date_to_Days
  36 );
  37 use POSIX qw(strftime);
  38 use C4::Branch; # GetBranches
  39 use C4::Log; # logaction
  40
  41 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  42
  43 # set the version for version checking
  44 $VERSION = do { my @v = '$Revision$' =~ /\d+/g; shift(@v).".".join( "_", map { sprintf "%03d", $_ } @v ); };
  45
  46 =head1 NAME
  47
  48 C4::Circulation::Circ2 - Koha circulation module
  49
  50 =head1 SYNOPSIS
  51
  52 use C4::Circulation::Circ2;
  53
  54 =head1 DESCRIPTION
  55
  56 The functions in this module deal with circulation, issues, and
  57 returns, as well as general information about the library.
  58 Also deals with stocktaking.
  59
  60 =head1 FUNCTIONS
  61
  62 =cut
  63
  64 @ISA    = qw(Exporter);
  65 @EXPORT = qw(
  66   &getpatroninformation
  67   &currentissues
  68   &getissues
  69   &getiteminformation
  70   &renewstatus
  71   &renewbook
  72   &canbookbeissued
  73   &issuebook
  74   &returnbook
  75   &find_reserves
  76   &transferbook
  77   &decode
  78   &calc_charges
  79   &GetItemsForInventory
  80   &itemseen
  81   &fixdate
  82   &get_current_return_date_of
  83   &get_transfert_infos
  84   &checktransferts
  85   &GetReservesForBranch
  86   &GetReservesToBranch
  87   &GetTransfersFromBib
  88   &getBranchIp
  89   &dotransfer
  90   &GetOverduesForBranch
  91   &AddNotifyLine
  92   &RemoveNotifyLine
  93   &GetIssuesFromBiblio
  94   &AnonymiseIssueHistory
  95   &GetLostItems
  96   &itemissues
  97   &updateWrongTransfer
  98 );
  99
 100 =head2 itemseen
 101
 102 &itemseen($itemnum)
 103 Mark item as seen. Is called when an item is issued, returned or manually marked during inventory/stocktaking
 104 C<$itemnum> is the item number
 105
 106 =cut
 107
 108 sub itemseen {
 109     my ($itemnum) = @_;
 110     my $dbh       = C4::Context->dbh;
 111     my $sth       =
 112       $dbh->prepare(
 113           "update items set itemlost=0, datelastseen  = now() where items.itemnumber = ?"
 114       );
 115     $sth->execute($itemnum);
 116     return;
 117 }
 118
 119 =head2 itemborrowed
 120
 121 &itemseen($itemnum)
 122 Mark item as borrowed. Is called when an item is issued.
 123 C<$itemnum> is the item number
 124
 125 =cut
 126
 127 sub itemborrowed {
 128     my ($itemnum) = @_;
 129     my $dbh       = C4::Context->dbh;
 130     my $sth       =
 131       $dbh->prepare(
 132           "update items set itemlost=0, datelastborrowed  = now() where items.itemnumber = ?"
 133       );
 134     $sth->execute($itemnum);
 135     return;
 136 }
 137
 138 =head2 GetItemsForInventory
 139
 140 $itemlist = GetItemsForInventory($minlocation,$maxlocation,$datelastseen,$offset,$size)
 141
 142 Retrieve a list of title/authors/barcode/callnumber, for biblio inventory.
 143
 144 The sub returns a list of hashes, containing itemnumber, author, title, barcode & item callnumber.
 145 It is ordered by callnumber,title.
 146
 147 The minlocation & maxlocation parameters are used to specify a range of item callnumbers
 148 the datelastseen can be used to specify that you want to see items not seen since a past date only.
 149 offset & size can be used to retrieve only a part of the whole listing (defaut behaviour)
 150
 151 =cut
 152
 153 sub GetItemsForInventory {
 154     my ( $minlocation, $maxlocation, $datelastseen, $branch, $offset, $size ) = @_;
 155     my $dbh = C4::Context->dbh;
 156     my $sth;
 157     if ($datelastseen) {
 158         my $query =
 159                 "SELECT itemnumber,barcode,itemcallnumber,title,author,datelastseen
 160                  FROM items
 161                    LEFT JOIN biblio ON items.biblionumber=biblio.biblionumber
 162                  WHERE itemcallnumber>= ?
 163                    AND itemcallnumber <=?
 164                    AND (datelastseen< ? OR datelastseen IS NULL)";
 165         $query.= " AND items.homebranch=".$dbh->quote($branch) if $branch;
 166         $query .= " ORDER BY itemcallnumber,title";
 167         $sth = $dbh->prepare($query);
 168         $sth->execute( $minlocation, $maxlocation, $datelastseen );
 169     }
 170     else {
 171         my $query ="
 172                 SELECT itemnumber,barcode,itemcallnumber,title,author,datelastseen
 173                 FROM items
 174                   LEFT JOIN biblio ON items.biblionumber=biblio.biblionumber
 175                 WHERE itemcallnumber>= ?
 176                   AND itemcallnumber <=?";
 177         $query.= " AND items.homebranch=".$dbh->quote($branch) if $branch;
 178         $query .= " ORDER BY itemcallnumber,title";
 179         $sth = $dbh->prepare($query);
 180         $sth->execute( $minlocation, $maxlocation );
 181     }
 182     my @results;
 183     while ( my $row = $sth->fetchrow_hashref ) {
 184         $offset-- if ($offset);
 185         if ( ( !$offset ) && $size ) {
 186             push @results, $row;
 187             $size--;
 188         }
 189     }
 190     return \@results;
 191 }
 192
 193 =head2 getpatroninformation
 194
 195 ($borrower, $flags) = &getpatroninformation($env, $borrowernumber, $cardnumber);
 196
 197 Looks up a patron and returns information about him or her. If
 198 C<$borrowernumber> is true (nonzero), C<&getpatroninformation> looks
 199 up the borrower by number; otherwise, it looks up the borrower by card
 200 number.
 201
 202 C<$env> is effectively ignored, but should be a reference-to-hash.
 203
 204 C<$borrower> is a reference-to-hash whose keys are the fields of the
 205 borrowers table in the Koha database. In addition,
 206 C<$borrower-E<gt>{flags}> is a hash giving more detailed information
 207 about the patron. Its keys act as flags :
 208
 209     if $borrower->{flags}->{LOST} {
 210         # Patron's card was reported lost
 211     }
 212
 213 Each flag has a C<message> key, giving a human-readable explanation of
 214 the flag. If the state of a flag means that the patron should not be
 215 allowed to borrow any more books, then it will have a C<noissues> key
 216 with a true value.
 217
 218 The possible flags are:
 219
 220 =head3 CHARGES
 221
 222 =over 4
 223
 224 =item Shows the patron's credit or debt, if any.
 225
 226 =back
 227
 228 =head3 GNA
 229
 230 =over 4
 231
 232 =item (Gone, no address.) Set if the patron has left without giving a
 233 forwarding address.
 234
 235 =back
 236
 237 =head3 LOST
 238
 239 =over 4
 240
 241 =item Set if the patron's card has been reported as lost.
 242
 243 =back
 244
 245 =head3 DBARRED
 246
 247 =over 4
 248
 249 =item Set if the patron has been debarred.
 250
 251 =back
 252
 253 =head3 NOTES
 254
 255 =over 4
 256
 257 =item Any additional notes about the patron.
 258
 259 =back
 260
 261 =head3 ODUES
 262
 263 =over 4
 264
 265 =item Set if the patron has overdue items. This flag has several keys:
 266
 267 C<$flags-E<gt>{ODUES}{itemlist}> is a reference-to-array listing the
 268 overdue items. Its elements are references-to-hash, each describing an
 269 overdue item. The keys are selected fields from the issues, biblio,
 270 biblioitems, and items tables of the Koha database.
 271
 272 C<$flags-E<gt>{ODUES}{itemlist}> is a string giving a text listing of
 273 the overdue items, one per line.
 274
 275 =back
 276
 277 =head3 WAITING
 278
 279 =over 4
 280
 281 =item Set if any items that the patron has reserved are available.
 282
 283 C<$flags-E<gt>{WAITING}{itemlist}> is a reference-to-array listing the
 284 available items. Each element is a reference-to-hash whose keys are
 285 fields from the reserves table of the Koha database.
 286
 287 =back
 288
 289 =cut
 290
 291 sub getpatroninformation {
 292     my ( $env, $borrowernumber, $cardnumber ) = @_;
 293     my $dbh = C4::Context->dbh;
 294     my $query;
 295     my $sth;
 296     if ($borrowernumber) {
 297         $sth = $dbh->prepare("select * from borrowers where borrowernumber=?");
 298         $sth->execute($borrowernumber);
 299     }
 300     elsif ($cardnumber) {
 301         $sth = $dbh->prepare("select * from borrowers where cardnumber=?");
 302         $sth->execute($cardnumber);
 303     }
 304     else {
 305         return undef;
 306     }
 307     my $borrower = $sth->fetchrow_hashref;
 308     my $amount = checkaccount( $env, $borrowernumber, $dbh );
 309     $borrower->{'amountoutstanding'} = $amount;
 310     my $flags = patronflags( $env, $borrower, $dbh );
 311     my $accessflagshash;
 312
 313     $sth = $dbh->prepare("select bit,flag from userflags");
 314     $sth->execute;
 315     while ( my ( $bit, $flag ) = $sth->fetchrow ) {
 316         if ( $borrower->{'flags'} && $borrower->{'flags'} & 2**$bit ) {
 317             $accessflagshash->{$flag} = 1;
 318         }
 319     }
 320     $sth->finish;
 321     $borrower->{'flags'}     = $flags;
 322     $borrower->{'authflags'} = $accessflagshash;
 323
 324     # find out how long the membership lasts
 325     $sth =
 326       $dbh->prepare(
 327         "select enrolmentperiod from categories where categorycode = ?");
 328     $sth->execute( $borrower->{'categorycode'} );
 329     my $enrolment = $sth->fetchrow;
 330     $borrower->{'enrolmentperiod'} = $enrolment;
 331     return ($borrower);    #, $flags, $accessflagshash);
 332 }
 333
 334 =head2 decode
 335
 336 =head3 $str = &decode($chunk);
 337
 338 =over 4
 339
 340 =item Decodes a segment of a string emitted by a CueCat barcode scanner and
 341 returns it.
 342
 343 =back
 344
 345 =cut
 346
 347 # FIXME - At least, I'm pretty sure this is for decoding CueCat stuff.
 348 sub decode {
 349     my ($encoded) = @_;
 350     my $seq =
 351       'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789+-';
 352     my @s = map { index( $seq, $_ ); } split( //, $encoded );
 353     my $l = ( $#s + 1 ) % 4;
 354     if ($l) {
 355         if ( $l == 1 ) {
 356             warn "Error!";
 357             return;
 358         }
 359         $l = 4 - $l;
 360         $#s += $l;
 361     }
 362     my $r = '';
 363     while ( $#s >= 0 ) {
 364         my $n = ( ( $s[0] << 6 | $s[1] ) << 6 | $s[2] ) << 6 | $s[3];
 365         $r .=
 366             chr( ( $n >> 16 ) ^ 67 )
 367          .chr( ( $n >> 8 & 255 ) ^ 67 )
 368          .chr( ( $n & 255 ) ^ 67 );
 369         @s = @s[ 4 .. $#s ];
 370     }
 371     $r = substr( $r, 0, length($r) - $l );
 372     return $r;
 373 }
 374
 375 =head2 getiteminformation
 376
 377 $item = &getiteminformation($itemnumber, $barcode);
 378
 379 Looks up information about an item, given either its item number or
 380 its barcode. If C<$itemnumber> is a nonzero value, it is used;
 381 otherwise, C<$barcode> is used.
 382
 383 C<$item> is a reference-to-hash whose keys are fields from the biblio,
 384 items, and biblioitems tables of the Koha database. It may also
 385 contain the following keys:
 386
 387 =head3 date_due
 388
 389 =over 4
 390
 391 =item The due date on this item, if it has been borrowed and not returned
 392 yet. The date is in YYYY-MM-DD format.
 393
 394 =back
 395
 396 =head3 notforloan
 397
 398 =over 4
 399
 400 =item True if the item may not be borrowed.
 401
 402 =back
 403
 404 =cut
 405
 406 sub getiteminformation {
 407
 408  # returns a hash of item information given either the itemnumber or the barcode
 409     my ( $itemnumber, $barcode ) = @_;
 410     my $dbh = C4::Context->dbh;
 411     my $sth;
 412     if ($itemnumber) {
 413         $sth =
 414           $dbh->prepare(
 415         "select *
 416         from  biblio,items,biblioitems
 417         where items.itemnumber=? and biblio.biblionumber=items.biblionumber and biblioitems.biblioitemnumber = items.biblioitemnumber"
 418           );
 419         $sth->execute($itemnumber);
 420     }
 421     elsif ($barcode) {
 422         $sth =
 423           $dbh->prepare(
 424         "select * from biblio,items,biblioitems where items.barcode=? and biblio.biblionumber=items.biblionumber and biblioitems.biblioitemnumber = items.biblioitemnumber"
 425           );
 426         $sth->execute($barcode);
 427     }
 428     else {
 429         return undef;
 430     }
 431     my $iteminformation = $sth->fetchrow_hashref;
 432     $sth->finish;
 433     if ($iteminformation) {
 434         $sth =
 435           $dbh->prepare("select date_due from issues where itemnumber=? and isnull(returndate)");
 436         $sth->execute( $iteminformation->{'itemnumber'} );
 437         my ($date_due) = $sth->fetchrow;
 438         $iteminformation->{'date_due'} = $date_due;
 439         $sth->finish;
 440         ( $iteminformation->{'dewey'} == 0 )
 441           && ( $iteminformation->{'dewey'} = '' );
 442         $sth = $dbh->prepare("select * from itemtypes where itemtype=?");
 443         $sth->execute( $iteminformation->{'itemtype'} );
 444         my $itemtype = $sth->fetchrow_hashref;
 445
 446         # if specific item notforloan, don't use itemtype notforloan field.
 447         # otherwise, use itemtype notforloan value to see if item can be issued.
 448         $iteminformation->{'notforloan'} = $itemtype->{'notforloan'}
 449           unless $iteminformation->{'notforloan'};
 450         $sth->finish;
 451     }
 452     return ($iteminformation);
 453 }
 454
 455 =head2 transferbook
 456
 457 ($dotransfer, $messages, $iteminformation) = &transferbook($newbranch, $barcode, $ignore_reserves);
 458
 459 Transfers an item to a new branch. If the item is currently on loan, it is automatically returned before the actual transfer.
 460
 461 C<$newbranch> is the code for the branch to which the item should be transferred.
 462
 463 C<$barcode> is the barcode of the item to be transferred.
 464
 465 If C<$ignore_reserves> is true, C<&transferbook> ignores reserves.
 466 Otherwise, if an item is reserved, the transfer fails.
 467
 468 Returns three values:
 469
 470 =head3 $dotransfer
 471
 472 is true if the transfer was successful.
 473
 474 =head3 $messages
 475
 476 is a reference-to-hash which may have any of the following keys:
 477
 478 =over 4
 479
 480 =item C<BadBarcode>
 481
 482 There is no item in the catalog with the given barcode. The value is C<$barcode>.
 483
 484 =item C<IsPermanent>
 485
 486 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.
 487
 488 =item C<DestinationEqualsHolding>
 489
 490 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.
 491
 492 =item C<WasReturned>
 493
 494 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.
 495
 496 =item C<ResFound>
 497
 498 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>.
 499
 500 =item C<WasTransferred>
 501
 502 The item was eligible to be transferred. Barring problems communicating with the database, the transfer should indeed have succeeded. The value should be ignored.
 503
 504 =back
 505
 506 =cut
 507
 508 #'
 509 # FIXME - This function tries to do too much, and its API is clumsy.
 510 # If it didn't also return books, it could be used to change the home
 511 # branch of a book while the book is on loan.
 512 #
 513 # Is there any point in returning the item information? The caller can
 514 # look that up elsewhere if ve cares.
 515 #
 516 # This leaves the ($dotransfer, $messages) tuple. This seems clumsy.
 517 # If the transfer succeeds, that's all the caller should need to know.
 518 # Thus, this function could simply return 1 or 0 to indicate success
 519 # or failure, and set $C4::Circulation::Circ2::errmsg in case of
 520 # failure. Or this function could return undef if successful, and an
 521 # error message in case of failure (this would feel more like C than
 522 # Perl, though).
 523 sub transferbook {
 524     my ( $tbr, $barcode, $ignoreRs ) = @_;
 525     my $messages;
 526     my %env;
 527     my $dotransfer      = 1;
 528     my $branches        = GetBranches();
 529     my $iteminformation = getiteminformation( 0, $barcode );
 530
 531     # bad barcode..
 532     if ( not $iteminformation ) {
 533         $messages->{'BadBarcode'} = $barcode;
 534         $dotransfer = 0;
 535     }
 536
 537     # get branches of book...
 538     my $hbr = $iteminformation->{'homebranch'};
 539     my $fbr = $iteminformation->{'holdingbranch'};
 540
 541     # if is permanent...
 542     if ( $hbr && $branches->{$hbr}->{'PE'} ) {
 543         $messages->{'IsPermanent'} = $hbr;
 544     }
 545
 546     # can't transfer book if is already there....
 547     # FIXME - Why not? Shouldn't it trivially succeed?
 548     if ( $fbr eq $tbr ) {
 549         $messages->{'DestinationEqualsHolding'} = 1;
 550         $dotransfer = 0;
 551     }
 552
 553     # check if it is still issued to someone, return it...
 554     my ($currentborrower) = currentborrower( $iteminformation->{'itemnumber'} );
 555     if ($currentborrower) {
 556         returnbook( $barcode, $fbr );
 557         $messages->{'WasReturned'} = $currentborrower;
 558     }
 559
 560     # find reserves.....
 561     # FIXME - Don't call &CheckReserves unless $ignoreRs is true.
 562     # That'll save a database query.
 563     my ( $resfound, $resrec ) =
 564       CheckReserves( $iteminformation->{'itemnumber'} );
 565     if ( $resfound and not $ignoreRs ) {
 566         $resrec->{'ResFound'} = $resfound;
 567
 568         #         $messages->{'ResFound'} = $resrec;
 569         $dotransfer = 1;
 570     }
 571
 572     #actually do the transfer....
 573     if ($dotransfer) {
 574         dotransfer( $iteminformation->{'itemnumber'}, $fbr, $tbr );
 575
 576         # don't need to update MARC anymore, we do it in batch now
 577         $messages->{'WasTransfered'} = 1;
 578     }
 579     return ( $dotransfer, $messages, $iteminformation );
 580 }
 581
 582 # Not exported
 583 # FIXME - This is only used in &transferbook. Why bother making it a
 584 # separate function?
 585 sub dotransfer {
 586     my ( $itm, $fbr, $tbr ) = @_;
 587
 588     my $dbh = C4::Context->dbh;
 589     $itm = $dbh->quote($itm);
 590     $fbr = $dbh->quote($fbr);
 591     $tbr = $dbh->quote($tbr);
 592
 593     #new entry in branchtransfers....
 594     $dbh->do(
 595 "INSERT INTO branchtransfers (itemnumber, frombranch, datesent, tobranch)
 596                     VALUES ($itm, $fbr, now(), $tbr)"
 597     );
 598
 599     #update holdingbranch in items .....
 600       $dbh->do(
 601           "UPDATE items set holdingbranch = $tbr WHERE items.itemnumber = $itm");
 602     &itemseen($itm);
 603     &domarctransfer( $dbh, $itm );
 604     return;
 605 }
 606
 607 ##New sub to dotransfer in marc tables as well. Not exported -TG 10/04/2006
 608 sub domarctransfer {
 609     my ( $dbh, $itemnumber ) = @_;
 610     $itemnumber =~ s /\'//g;    ##itemnumber seems to come with quotes-TG
 611     my $sth =
 612       $dbh->prepare(
 613         "select biblionumber,holdingbranch from items where itemnumber=$itemnumber"
 614       );
 615     $sth->execute();
 616     while ( my ( $biblionumber, $holdingbranch ) = $sth->fetchrow ) {
 617         &MARCmoditemonefield( $biblionumber, $itemnumber,
 618             'items.holdingbranch', $holdingbranch, 0 );
 619     }
 620     return;
 621 }
 622
 623 =head2 canbookbeissued
 624
 625 Check if a book can be issued.
 626
 627 my ($issuingimpossible,$needsconfirmation) = canbookbeissued($env,$borrower,$barcode,$year,$month,$day);
 628
 629 =over 4
 630
 631 =item C<$env> Environment variable. Should be empty usually, but used by other subs. Next code cleaning could drop it.
 632
 633 =item C<$borrower> hash with borrower informations (from getpatroninformation)
 634
 635 =item C<$barcode> is the bar code of the book being issued.
 636
 637 =item C<$year> C<$month> C<$day> contains the date of the return (in case it's forced by "stickyduedate".
 638
 639 =back
 640
 641 Returns :
 642
 643 =over 4
 644
 645 =item C<$issuingimpossible> a reference to a hash. It contains reasons why issuing is impossible.
 646 Possible values are :
 647
 648 =back
 649
 650 =head3 INVALID_DATE
 651
 652 sticky due date is invalid
 653
 654 =head3 GNA
 655
 656 borrower gone with no address
 657
 658 =head3 CARD_LOST
 659
 660 borrower declared it's card lost
 661
 662 =head3 DEBARRED
 663
 664 borrower debarred
 665
 666 =head3 UNKNOWN_BARCODE
 667
 668 barcode unknown
 669
 670 =head3 NOT_FOR_LOAN
 671
 672 item is not for loan
 673
 674 =head3 WTHDRAWN
 675
 676 item withdrawn.
 677
 678 =head3 RESTRICTED
 679
 680 item is restricted (set by ??)
 681
 682 C<$issuingimpossible> a reference to a hash. It contains reasons why issuing is impossible.
 683 Possible values are :
 684
 685 =head3 DEBT
 686
 687 borrower has debts.
 688
 689 =head3 RENEW_ISSUE
 690
 691 renewing, not issuing
 692
 693 =head3 ISSUED_TO_ANOTHER
 694
 695 issued to someone else.
 696
 697 =head3 RESERVED
 698
 699 reserved for someone else.
 700
 701 =head3 INVALID_DATE
 702
 703 sticky due date is invalid
 704
 705 =head3 TOO_MANY
 706
 707 if the borrower borrows to much things
 708
 709 =cut
 710
 711 # check if a book can be issued.
 712 # returns an array with errors if any
 713
 714 sub TooMany ($$) {
 715     my $borrower        = shift;
 716     my $iteminformation = shift;
 717     my $cat_borrower    = $borrower->{'categorycode'};
 718     my $branch_borrower = $borrower->{'branchcode'};
 719     my $dbh             = C4::Context->dbh;
 720
 721     my $sth =
 722       $dbh->prepare('select itemtype from biblioitems where biblionumber = ?');
 723     $sth->execute( $iteminformation->{'biblionumber'} );
 724     my $type = $sth->fetchrow;
 725     $sth =
 726       $dbh->prepare(
 727 'select * from issuingrules where categorycode = ? and itemtype = ? and branchcode = ?'
 728       );
 729
 730 #     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 ?");
 731     my $sth2 =
 732       $dbh->prepare(
 733 "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"
 734       );
 735     my $sth3 =
 736       $dbh->prepare(
 737 'select COUNT(*) from issues where borrowernumber = ? and returndate is null'
 738       );
 739     my $alreadyissued;
 740
 741     # check the 3 parameters
 742     $sth->execute( $cat_borrower, $type, $branch_borrower );
 743     my $result = $sth->fetchrow_hashref;
 744
 745     #    warn "==>".$result->{maxissueqty};
 746
 747 # Currently, using defined($result) ie on an entire hash reports whether memory
 748 # for that aggregate has ever been allocated. As $result is used all over the place
 749 # it would rarely return as undefined.
 750     if ( defined( $result->{maxissueqty} ) ) {
 751         $sth2->execute( $borrower->{'borrowernumber'}, "%$type%" );
 752         my $alreadyissued = $sth2->fetchrow;
 753         if ( $result->{'maxissueqty'} <= $alreadyissued ) {
 754             return ( "a $alreadyissued / ".( $result->{maxissueqty} + 0 ) );
 755         }
 756         else {
 757             return;
 758         }
 759     }
 760
 761     # check for branch=*
 762     $sth->execute( $cat_borrower, $type, "" );
 763     $result = $sth->fetchrow_hashref;
 764     if ( defined( $result->{maxissueqty} ) ) {
 765         $sth2->execute( $borrower->{'borrowernumber'}, "%$type%" );
 766         my $alreadyissued = $sth2->fetchrow;
 767         if ( $result->{'maxissueqty'} <= $alreadyissued ) {
 768             return ( "b $alreadyissued / ".( $result->{maxissueqty} + 0 ) );
 769         }
 770         else {
 771             return;
 772         }
 773     }
 774
 775     # check for itemtype=*
 776     $sth->execute( $cat_borrower, "*", $branch_borrower );
 777     $result = $sth->fetchrow_hashref;
 778     if ( defined( $result->{maxissueqty} ) ) {
 779         $sth3->execute( $borrower->{'borrowernumber'} );
 780         my ($alreadyissued) = $sth3->fetchrow;
 781         if ( $result->{'maxissueqty'} <= $alreadyissued ) {
 782
 783 #        warn "HERE : $alreadyissued / ($result->{maxissueqty} for $borrower->{'borrowernumber'}";
 784             return ( "c $alreadyissued / " . ( $result->{maxissueqty} + 0 ) );
 785         }
 786         else {
 787             return;
 788         }
 789     }
 790
 791     # check for borrowertype=*
 792     $sth->execute( "*", $type, $branch_borrower );
 793     $result = $sth->fetchrow_hashref;
 794     if ( defined( $result->{maxissueqty} ) ) {
 795         $sth2->execute( $borrower->{'borrowernumber'}, "%$type%" );
 796         my $alreadyissued = $sth2->fetchrow;
 797         if ( $result->{'maxissueqty'} <= $alreadyissued ) {
 798             return ( "d $alreadyissued / " . ( $result->{maxissueqty} + 0 ) );
 799         }
 800         else {
 801             return;
 802         }
 803     }
 804
 805     $sth->execute( "*", "*", $branch_borrower );
 806     $result = $sth->fetchrow_hashref;
 807     if ( defined( $result->{maxissueqty} ) ) {
 808         $sth3->execute( $borrower->{'borrowernumber'} );
 809         my $alreadyissued = $sth3->fetchrow;
 810         if ( $result->{'maxissueqty'} <= $alreadyissued ) {
 811             return ( "e $alreadyissued / " . ( $result->{maxissueqty} + 0 ) );
 812         }
 813         else {
 814             return;
 815         }
 816     }
 817
 818     $sth->execute( "*", $type, "" );
 819     $result = $sth->fetchrow_hashref;
 820     if ( defined( $result->{maxissueqty} ) && $result->{maxissueqty} >= 0 ) {
 821         $sth2->execute( $borrower->{'borrowernumber'}, "%$type%" );
 822         my $alreadyissued = $sth2->fetchrow;
 823         if ( $result->{'maxissueqty'} <= $alreadyissued ) {
 824             return ( "f $alreadyissued / " . ( $result->{maxissueqty} + 0 ) );
 825         }
 826         else {
 827             return;
 828         }
 829     }
 830
 831     $sth->execute( $cat_borrower, "*", "" );
 832     $result = $sth->fetchrow_hashref;
 833     if ( defined( $result->{maxissueqty} ) ) {
 834         $sth2->execute( $borrower->{'borrowernumber'}, "%$type%" );
 835         my $alreadyissued = $sth2->fetchrow;
 836         if ( $result->{'maxissueqty'} <= $alreadyissued ) {
 837             return ( "g $alreadyissued / " . ( $result->{maxissueqty} + 0 ) );
 838         }
 839         else {
 840             return;
 841         }
 842     }
 843
 844     $sth->execute( "*", "*", "" );
 845     $result = $sth->fetchrow_hashref;
 846     if ( defined( $result->{maxissueqty} ) ) {
 847         $sth3->execute( $borrower->{'borrowernumber'} );
 848         my $alreadyissued = $sth3->fetchrow;
 849         if ( $result->{'maxissueqty'} <= $alreadyissued ) {
 850             return ( "h $alreadyissued / " . ( $result->{maxissueqty} + 0 ) );
 851         }
 852         else {
 853             return;
 854         }
 855     }
 856     return;
 857 }
 858
 859 =head2 itemissues
 860
 861   @issues = &itemissues($biblioitemnumber, $biblio);
 862
 863 Looks up information about who has borrowed the bookZ<>(s) with the
 864 given biblioitemnumber.
 865
 866 C<$biblio> is ignored.
 867
 868 C<&itemissues> returns an array of references-to-hash. The keys
 869 include the fields from the C<items> table in the Koha database.
 870 Additional keys include:
 871
 872 =over 4
 873
 874 =item C<date_due>
 875
 876 If the item is currently on loan, this gives the due date.
 877
 878 If the item is not on loan, then this is either "Available" or
 879 "Cancelled", if the item has been withdrawn.
 880
 881 =item C<card>
 882
 883 If the item is currently on loan, this gives the card number of the
 884 patron who currently has the item.
 885
 886 =item C<timestamp0>, C<timestamp1>, C<timestamp2>
 887
 888 These give the timestamp for the last three times the item was
 889 borrowed.
 890
 891 =item C<card0>, C<card1>, C<card2>
 892
 893 The card number of the last three patrons who borrowed this item.
 894
 895 =item C<borrower0>, C<borrower1>, C<borrower2>
 896
 897 The borrower number of the last three patrons who borrowed this item.
 898
 899 =back
 900
 901 =cut
 902
 903 #'
 904 sub itemissues {
 905     my ( $bibitem, $biblio ) = @_;
 906     my $dbh = C4::Context->dbh;
 907
 908     # FIXME - If this function die()s, the script will abort, and the
 909     # user won't get anything; depending on how far the script has
 910     # gotten, the user might get a blank page. It would be much better
 911     # to at least print an error message. The easiest way to do this
 912     # is to set $SIG{__DIE__}.
 913     my $sth =
 914       $dbh->prepare("Select * from items where items.biblioitemnumber = ?")
 915       || die $dbh->errstr;
 916     my $i = 0;
 917     my @results;
 918
 919     $sth->execute($bibitem) || die $sth->errstr;
 920
 921     while ( my $data = $sth->fetchrow_hashref ) {
 922
 923         # Find out who currently has this item.
 924         # FIXME - Wouldn't it be better to do this as a left join of
 925         # some sort? Currently, this code assumes that if
 926         # fetchrow_hashref() fails, then the book is on the shelf.
 927         # fetchrow_hashref() can fail for any number of reasons (e.g.,
 928         # database server crash), not just because no items match the
 929         # search criteria.
 930         my $sth2 = $dbh->prepare(
 931             "select * from issues,borrowers
 932 where itemnumber = ?
 933 and returndate is NULL
 934 and issues.borrowernumber = borrowers.borrowernumber"
 935         );
 936
 937         $sth2->execute( $data->{'itemnumber'} );
 938         if ( my $data2 = $sth2->fetchrow_hashref ) {
 939             $data->{'date_due'} = $data2->{'date_due'};
 940             $data->{'card'}     = $data2->{'cardnumber'};
 941             $data->{'borrower'} = $data2->{'borrowernumber'};
 942         }
 943         else {
 944             if ( $data->{'wthdrawn'} eq '1' ) {
 945                 $data->{'date_due'} = 'Cancelled';
 946             }
 947             else {
 948                 $data->{'date_due'} = 'Available';
 949             }    # else
 950         }    # else
 951
 952         $sth2->finish;
 953
 954         # Find the last 3 people who borrowed this item.
 955         $sth2 = $dbh->prepare(
 956             "select * from issues, borrowers
 957                         where itemnumber = ?
 958                                     and issues.borrowernumber = borrowers.borrowernumber
 959                                     and returndate is not NULL
 960                                     order by returndate desc,timestamp desc"
 961         );
 962
 963 #        $sth2 = $dbh->prepare("
 964 #            SELECT *
 965 #            FROM issues
 966 #                LEFT JOIN borrowers ON issues.borrowernumber = borrowers.borrowernumber
 967 #            WHERE   itemnumber = ?
 968 #                AND returndate is not NULL
 969 #            ORDER BY returndate DESC,timestamp DESC
 970 #        ");
 971
 972         $sth2->execute( $data->{'itemnumber'} );
 973         for ( my $i2 = 0 ; $i2 < 2 ; $i2++ )
 974         {    # FIXME : error if there is less than 3 pple borrowing this item
 975             if ( my $data2 = $sth2->fetchrow_hashref ) {
 976                 $data->{"timestamp$i2"} = $data2->{'timestamp'};
 977                 $data->{"card$i2"}      = $data2->{'cardnumber'};
 978                 $data->{"borrower$i2"}  = $data2->{'borrowernumber'};
 979             }    # if
 980         }    # for
 981
 982         $sth2->finish;
 983         $results[$i] = $data;
 984         $i++;
 985     }
 986
 987     $sth->finish;
 988     return (@results);
 989 }
 990
 991 =head2 canbookbeissued
 992
 993 $issuingimpossible, $needsconfirmation =
 994         canbookbeissued( $env, $borrower, $barcode, $year, $month, $day, $inprocess );
 995
 996 C<$issuingimpossible> and C<$needsconfirmation> are some hashref.
 997
 998 =cut
 999
1000 sub canbookbeissued {
1001     my ( $env, $borrower, $barcode, $year, $month, $day, $inprocess ) = @_;
1002     my %needsconfirmation;    # filled with problems that needs confirmations
1003     my %issuingimpossible
1004       ;    # filled with problems that causes the issue to be IMPOSSIBLE
1005     my $iteminformation = getiteminformation( 0, $barcode );
1006     my $dbh             = C4::Context->dbh;
1007
1008     #
1009     # DUE DATE is OK ?
1010     #
1011     my ( $duedate, $invalidduedate ) = fixdate( $year, $month, $day );
1012     $issuingimpossible{INVALID_DATE} = 1 if ($invalidduedate);
1013
1014     #
1015     # BORROWER STATUS
1016     #
1017     if ( $borrower->{flags}->{GNA} ) {
1018         $issuingimpossible{GNA} = 1;
1019     }
1020     if ( $borrower->{flags}->{'LOST'} ) {
1021         $issuingimpossible{CARD_LOST} = 1;
1022     }
1023     if ( $borrower->{flags}->{'DBARRED'} ) {
1024         $issuingimpossible{DEBARRED} = 1;
1025     }
1026     if ( Date_to_Days(Today) >
1027         Date_to_Days( split "-", $borrower->{'dateexpiry'} ) )
1028     {
1029
1030         #
1031         #if (&Date_Cmp(&ParseDate($borrower->{expiry}),&ParseDate("today"))<0) {
1032         $issuingimpossible{EXPIRED} = 1;
1033     }
1034
1035     #
1036     # BORROWER STATUS
1037     #
1038
1039     # DEBTS
1040     my $amount =
1041       checkaccount( $env, $borrower->{'borrowernumber'}, $dbh, $duedate );
1042     if ( C4::Context->preference("IssuingInProcess") ) {
1043         my $amountlimit = C4::Context->preference("noissuescharge");
1044         if ( $amount > $amountlimit && !$inprocess ) {
1045             $issuingimpossible{DEBT} = sprintf( "%.2f", $amount );
1046         }
1047         elsif ( $amount <= $amountlimit && !$inprocess ) {
1048             $needsconfirmation{DEBT} = sprintf( "%.2f", $amount );
1049         }
1050     }
1051     else {
1052         if ( $amount > 0 ) {
1053             $needsconfirmation{DEBT} = $amount;
1054         }
1055     }
1056
1057     #
1058     # JB34 CHECKS IF BORROWERS DONT HAVE ISSUE TOO MANY BOOKS
1059     #
1060     my $toomany = TooMany( $borrower, $iteminformation );
1061     $needsconfirmation{TOO_MANY} = $toomany if $toomany;
1062
1063     #
1064     # ITEM CHECKING
1065     #
1066     unless ( $iteminformation->{barcode} ) {
1067         $issuingimpossible{UNKNOWN_BARCODE} = 1;
1068     }
1069     if (   $iteminformation->{'notforloan'}
1070         && $iteminformation->{'notforloan'} > 0 )
1071     {
1072         $issuingimpossible{NOT_FOR_LOAN} = 1;
1073     }
1074     if (   $iteminformation->{'itemtype'}
1075         && $iteminformation->{'itemtype'} eq 'REF' )
1076     {
1077         $issuingimpossible{NOT_FOR_LOAN} = 1;
1078     }
1079     if ( $iteminformation->{'wthdrawn'} && $iteminformation->{'wthdrawn'} == 1 )
1080     {
1081         $issuingimpossible{WTHDRAWN} = 1;
1082     }
1083     if (   $iteminformation->{'restricted'}
1084         && $iteminformation->{'restricted'} == 1 )
1085     {
1086         $issuingimpossible{RESTRICTED} = 1;
1087     }
1088     if ( C4::Context->preference("IndependantBranches") ) {
1089         my $userenv = C4::Context->userenv;
1090         if ( ($userenv) && ( $userenv->{flags} != 1 ) ) {
1091             $issuingimpossible{NOTSAMEBRANCH} = 1
1092               if ( $iteminformation->{'holdingbranch'} ne $userenv->{branch} );
1093         }
1094     }
1095
1096     #
1097     # CHECK IF BOOK ALREADY ISSUED TO THIS BORROWER
1098     #
1099     my ($currentborrower) = currentborrower( $iteminformation->{'itemnumber'} );
1100     if ( $currentborrower && $currentborrower eq $borrower->{'borrowernumber'} )
1101     {
1102
1103         # Already issued to current borrower. Ask whether the loan should
1104         # be renewed.
1105         my ($renewstatus) = renewstatus(
1106             $env,
1107             $borrower->{'borrowernumber'},
1108             $iteminformation->{'itemnumber'}
1109         );
1110         if ( $renewstatus == 0 ) {    # no more renewals allowed
1111             $issuingimpossible{NO_MORE_RENEWALS} = 1;
1112         }
1113         else {
1114
1115             #        $needsconfirmation{RENEW_ISSUE} = 1;
1116         }
1117     }
1118     elsif ($currentborrower) {
1119
1120         # issued to someone else
1121         my $currborinfo = getpatroninformation( 0, $currentborrower );
1122
1123 #        warn "=>.$currborinfo->{'firstname'} $currborinfo->{'surname'} ($currborinfo->{'cardnumber'})";
1124         $needsconfirmation{ISSUED_TO_ANOTHER} =
1125 "$currborinfo->{'reservedate'} : $currborinfo->{'firstname'} $currborinfo->{'surname'} ($currborinfo->{'cardnumber'})";
1126     }
1127
1128     # See if the item is on reserve.
1129     my ( $restype, $res ) = CheckReserves( $iteminformation->{'itemnumber'} );
1130     if ($restype) {
1131         my $resbor = $res->{'borrowernumber'};
1132         if ( $resbor ne $borrower->{'borrowernumber'} && $restype eq "Waiting" )
1133         {
1134
1135             # The item is on reserve and waiting, but has been
1136             # reserved by some other patron.
1137             my ( $resborrower, $flags ) =
1138               getpatroninformation( $env, $resbor, 0 );
1139             my $branches   = GetBranches();
1140             my $branchname =
1141               $branches->{ $res->{'branchcode'} }->{'branchname'};
1142             $needsconfirmation{RESERVE_WAITING} =
1143 "$resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'}, $branchname)";
1144
1145 # CancelReserve(0, $res->{'itemnumber'}, $res->{'borrowernumber'}); Doesn't belong in a checking subroutine.
1146         }
1147         elsif ( $restype eq "Reserved" ) {
1148
1149             # The item is on reserve for someone else.
1150             my ( $resborrower, $flags ) =
1151               getpatroninformation( $env, $resbor, 0 );
1152             my $branches   = GetBranches();
1153             my $branchname =
1154               $branches->{ $res->{'branchcode'} }->{'branchname'};
1155             $needsconfirmation{RESERVED} =
1156 "$res->{'reservedate'} : $resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'})";
1157         }
1158     }
1159     if ( C4::Context->preference("LibraryName") eq "Horowhenua Library Trust" )
1160     {
1161         if ( $borrower->{'categorycode'} eq 'W' ) {
1162             my %issuingimpossible;
1163             return ( \%issuingimpossible, \%needsconfirmation );
1164         }
1165         else {
1166             return ( \%issuingimpossible, \%needsconfirmation );
1167         }
1168     }
1169     else {
1170         return ( \%issuingimpossible, \%needsconfirmation );
1171     }
1172 }
1173
1174 =head2 issuebook
1175
1176 Issue a book. Does no check, they are done in canbookbeissued. If we reach this sub, it means the user confirmed if needed.
1177
1178 &issuebook($env,$borrower,$barcode,$date)
1179
1180 =over 4
1181
1182 =item C<$env> Environment variable. Should be empty usually, but used by other subs. Next code cleaning could drop it.
1183
1184 =item C<$borrower> hash with borrower informations (from getpatroninformation)
1185
1186 =item C<$barcode> is the bar code of the book being issued.
1187
1188 =item C<$date> contains the max date of return. calculated if empty.
1189
1190 =back
1191
1192 =cut
1193
1194 sub issuebook {
1195     my ( $env, $borrower, $barcode, $date, $cancelreserve ) = @_;
1196     my $dbh = C4::Context->dbh;
1197
1198 #   my ($borrower, $flags) = &getpatroninformation($env, $borrowernumber, 0);
1199     my $iteminformation = getiteminformation( 0, $barcode );
1200
1201 #
1202 # check if we just renew the issue.
1203 #
1204     my ($currentborrower) = currentborrower( $iteminformation->{'itemnumber'} );
1205     if ( $currentborrower eq $borrower->{'borrowernumber'} ) {
1206         my ( $charge, $itemtype ) = calc_charges(
1207             $env,
1208             $iteminformation->{'itemnumber'},
1209             $borrower->{'borrowernumber'}
1210         );
1211         if ( $charge > 0 ) {
1212             createcharge(
1213                 $env, $dbh,
1214                 $iteminformation->{'itemnumber'},
1215                 $borrower->{'borrowernumber'}, $charge
1216             );
1217             $iteminformation->{'charge'} = $charge;
1218         }
1219         &UpdateStats(
1220             $env,                           $env->{'branchcode'},
1221             'renew',                        $charge,
1222             '',                             $iteminformation->{'itemnumber'},
1223             $iteminformation->{'itemtype'}, $borrower->{'borrowernumber'}
1224         );
1225         renewbook(
1226             $env,
1227             $borrower->{'borrowernumber'},
1228             $iteminformation->{'itemnumber'}
1229         );
1230     }
1231     else {
1232
1233         #
1234         # NOT a renewal
1235         #
1236         if ( $currentborrower ne '' ) {
1237
1238 # This book is currently on loan, but not to the person
1239 # who wants to borrow it now. mark it returned before issuing to the new borrower
1240             returnbook(
1241                 $iteminformation->{'barcode'},
1242                 C4::Context->userenv->{'branch'}
1243             );
1244         }
1245
1246         # See if the item is on reserve.
1247         my ( $restype, $res ) =
1248           CheckReserves( $iteminformation->{'itemnumber'} );
1249         if ($restype) {
1250             my $resbor = $res->{'borrowernumber'};
1251             if ( $resbor eq $borrower->{'borrowernumber'} ) {
1252
1253                 # The item is on reserve to the current patron
1254                 FillReserve($res);
1255             }
1256             elsif ( $restype eq "Waiting" ) {
1257
1258                 #                 warn "Waiting";
1259                 # The item is on reserve and waiting, but has been
1260                 # reserved by some other patron.
1261                 my ( $resborrower, $flags ) =
1262                   getpatroninformation( $env, $resbor, 0 );
1263                 my $branches   = GetBranches();
1264                 my $branchname =
1265                   $branches->{ $res->{'branchcode'} }->{'branchname'};
1266                 if ($cancelreserve) {
1267                     CancelReserve( 0, $res->{'itemnumber'},
1268                         $res->{'borrowernumber'} );
1269                 }
1270                 else {
1271
1272        # set waiting reserve to first in reserve queue as book isn't waiting now
1273                     UpdateReserve(
1274                         1,
1275                         $res->{'biblionumber'},
1276                         $res->{'borrowernumber'},
1277                         $res->{'branchcode'}
1278                     );
1279                 }
1280             }
1281             elsif ( $restype eq "Reserved" ) {
1282
1283                 #                 warn "Reserved";
1284                 # The item is on reserve for someone else.
1285                 my ( $resborrower, $flags ) =
1286                   getpatroninformation( $env, $resbor, 0 );
1287                 my $branches   = GetBranches();
1288                 my $branchname =
1289                   $branches->{ $res->{'branchcode'} }->{'branchname'};
1290                 if ($cancelreserve) {
1291
1292                     # cancel reserves on this item
1293                     CancelReserve( 0, $res->{'itemnumber'},
1294                         $res->{'borrowernumber'} );
1295
1296 # also cancel reserve on biblio related to this item
1297 #my $st_Fbiblio = $dbh->prepare("select biblionumber from items where itemnumber=?");
1298 #$st_Fbiblio->execute($res->{'itemnumber'});
1299 #my $biblionumber = $st_Fbiblio->fetchrow;
1300 #CancelReserve($biblionumber,0,$res->{'borrowernumber'});
1301 #warn "CancelReserve $res->{'itemnumber'}, $res->{'borrowernumber'}";
1302                 }
1303                 else {
1304
1305 #                     my $tobrcd = ReserveWaiting($res->{'itemnumber'}, $res->{'borrowernumber'});
1306 #                     transferbook($tobrcd,$barcode, 1);
1307 #                     warn "transferbook";
1308                 }
1309             }
1310         }
1311 # END OF THE RESTYPE WORK
1312
1313 # Starting process for transfer job (checking transfert and validate it if we have one)
1314
1315         my ($datesent) = get_transfert_infos($iteminformation->{'itemnumber'});
1316
1317         if ($datesent) {
1318 #       updating line of branchtranfert to finish it, and changing the to branch value, implement a comment for lisibility of this case (maybe for stats ....)
1319         my $sth =
1320                 $dbh->prepare(
1321                         "update branchtransfers set datearrived = now(),
1322                         tobranch = ?,
1323                         comments = 'Forced branchtransfert'
1324                          where
1325                          itemnumber= ? AND datearrived IS NULL"
1326                 );
1327                 $sth->execute(C4::Context->userenv->{'branch'},$iteminformation->{'itemnumber'});
1328                 $sth->finish;
1329         }
1330
1331 # Ending process for transfert check
1332
1333         # Record in the database the fact that the book was issued.
1334         my $sth =
1335           $dbh->prepare(
1336 "insert into issues (borrowernumber, itemnumber,issuedate, date_due, branchcode) values (?,?,?,?,?)"
1337           );
1338         my $loanlength = getLoanLength(
1339             $borrower->{'categorycode'},
1340             $iteminformation->{'itemtype'},
1341             $borrower->{'branchcode'}
1342         );
1343         my $datedue  = time + ($loanlength) * 86400;
1344         my @datearr  = localtime($datedue);
1345         my $dateduef =
1346             ( 1900 + $datearr[5] ) . "-"
1347           . ( $datearr[4] + 1 ) . "-"
1348           . $datearr[3];
1349         if ($date) {
1350             $dateduef = $date;
1351         }
1352
1353        # if ReturnBeforeExpiry ON the datedue can't be after borrower expirydate
1354         if ( C4::Context->preference('ReturnBeforeExpiry')
1355             && $dateduef gt $borrower->{dateexpiry} )
1356         {
1357             $dateduef = $borrower->{dateexpiry};
1358         }
1359         $sth->execute(
1360             $borrower->{'borrowernumber'},
1361             $iteminformation->{'itemnumber'},
1362             strftime( "%Y-%m-%d", localtime ),$dateduef, $env->{'branchcode'}
1363         );
1364         $sth->finish;
1365         $iteminformation->{'issues'}++;
1366         $sth =
1367           $dbh->prepare(
1368             "update items set issues=?, holdingbranch=? where itemnumber=?");
1369         $sth->execute(
1370             $iteminformation->{'issues'},
1371             C4::Context->userenv->{'branch'},
1372             $iteminformation->{'itemnumber'}
1373         );
1374         $sth->finish;
1375         &itemseen( $iteminformation->{'itemnumber'} );
1376         itemborrowed( $iteminformation->{'itemnumber'} );
1377
1378         # If it costs to borrow this book, charge it to the patron's account.
1379         my ( $charge, $itemtype ) = calc_charges(
1380             $env,
1381             $iteminformation->{'itemnumber'},
1382             $borrower->{'borrowernumber'}
1383         );
1384         if ( $charge > 0 ) {
1385             createcharge(
1386                 $env, $dbh,
1387                 $iteminformation->{'itemnumber'},
1388                 $borrower->{'borrowernumber'}, $charge
1389             );
1390             $iteminformation->{'charge'} = $charge;
1391         }
1392
1393         # Record the fact that this book was issued.
1394         &UpdateStats(
1395             $env,                           $env->{'branchcode'},
1396             'issue',                        $charge,
1397             '',                             $iteminformation->{'itemnumber'},
1398             $iteminformation->{'itemtype'}, $borrower->{'borrowernumber'}
1399         );
1400     }
1401
1402     &logaction(C4::Context->userenv->{'number'},"CIRCULATION","ISSUE",$borrower->{'borrowernumber'},$iteminformation->{'biblionumber'})
1403         if C4::Context->preference("IssueLog");
1404
1405 }
1406
1407 =head2 getLoanLength
1408
1409 Get loan length for an itemtype, a borrower type and a branch
1410
1411 my $loanlength = &getLoanLength($borrowertype,$itemtype,branchcode)
1412
1413 =cut
1414
1415 sub getLoanLength {
1416     my ( $borrowertype, $itemtype, $branchcode ) = @_;
1417     my $dbh = C4::Context->dbh;
1418     my $sth =
1419       $dbh->prepare(
1420 "select issuelength from issuingrules where categorycode=? and itemtype=? and branchcode=?"
1421       );
1422
1423 # try to find issuelength & return the 1st available.
1424 # check with borrowertype, itemtype and branchcode, then without one of those parameters
1425     $sth->execute( $borrowertype, $itemtype, $branchcode );
1426     my $loanlength = $sth->fetchrow_hashref;
1427     return $loanlength->{issuelength}
1428       if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
1429
1430     $sth->execute( $borrowertype, $itemtype, "" );
1431     $loanlength = $sth->fetchrow_hashref;
1432     return $loanlength->{issuelength}
1433       if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
1434
1435     $sth->execute( $borrowertype, "*", $branchcode );
1436     $loanlength = $sth->fetchrow_hashref;
1437     return $loanlength->{issuelength}
1438       if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
1439
1440     $sth->execute( "*", $itemtype, $branchcode );
1441     $loanlength = $sth->fetchrow_hashref;
1442     return $loanlength->{issuelength}
1443       if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
1444
1445     $sth->execute( $borrowertype, "*", "" );
1446     $loanlength = $sth->fetchrow_hashref;
1447     return $loanlength->{issuelength}
1448       if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
1449
1450     $sth->execute( "*", "*", $branchcode );
1451     $loanlength = $sth->fetchrow_hashref;
1452     return $loanlength->{issuelength}
1453       if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
1454
1455     $sth->execute( "*", $itemtype, "" );
1456     $loanlength = $sth->fetchrow_hashref;
1457     return $loanlength->{issuelength}
1458       if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
1459
1460     $sth->execute( "*", "*", "" );
1461     $loanlength = $sth->fetchrow_hashref;
1462     return $loanlength->{issuelength}
1463       if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
1464
1465     # if no rule is set => 21 days (hardcoded)
1466     return 21;
1467 }
1468
1469 =head2 returnbook
1470
1471 ($doreturn, $messages, $iteminformation, $borrower) =
1472     &returnbook($barcode, $branch);
1473
1474 Returns a book.
1475
1476 C<$barcode> is the bar code of the book being returned. C<$branch> is
1477 the code of the branch where the book is being returned.
1478
1479 C<&returnbook> returns a list of four items:
1480
1481 C<$doreturn> is true iff the return succeeded.
1482
1483 C<$messages> is a reference-to-hash giving the reason for failure:
1484
1485 =over 4
1486
1487 =item C<BadBarcode>
1488
1489 No item with this barcode exists. The value is C<$barcode>.
1490
1491 =item C<NotIssued>
1492
1493 The book is not currently on loan. The value is C<$barcode>.
1494
1495 =item C<IsPermanent>
1496
1497 The book's home branch is a permanent collection. If you have borrowed
1498 this book, you are not allowed to return it. The value is the code for
1499 the book's home branch.
1500
1501 =item C<wthdrawn>
1502
1503 This book has been withdrawn/cancelled. The value should be ignored.
1504
1505 =item C<ResFound>
1506
1507 The item was reserved. The value is a reference-to-hash whose keys are
1508 fields from the reserves table of the Koha database, and
1509 C<biblioitemnumber>. It also has the key C<ResFound>, whose value is
1510 either C<Waiting>, C<Reserved>, or 0.
1511
1512 =back
1513
1514 C<$borrower> is a reference-to-hash, giving information about the
1515 patron who last borrowed the book.
1516
1517 =cut
1518
1519 # FIXME - This API is bogus. There's no need to return $borrower and
1520 # $iteminformation; the caller can ask about those separately, if it
1521 # cares (it'd be inefficient to make two database calls instead of
1522 # one, but &getpatroninformation and &getiteminformation can be
1523 # memoized if this is an issue).
1524 #
1525 # The ($doreturn, $messages) tuple is redundant: if the return
1526 # succeeded, that's all the caller needs to know. So &returnbook can
1527 # return 1 and 0 on success and failure, and set
1528 # $C4::Circulation::Circ2::errmsg to indicate the error. Or it can
1529 # return undef for success, and an error message on error (though this
1530 # is more C-ish than Perl-ish).
1531
1532 sub returnbook {
1533     my ( $barcode, $branch ) = @_;
1534     my %env;
1535     my $messages;
1536     my $dbh      = C4::Context->dbh;
1537     my $doreturn = 1;
1538     my $validTransfert = 0;
1539     my $reserveDone = 0;
1540
1541     die '$branch not defined' unless defined $branch;  # just in case (bug 170)
1542                                                        # get information on item
1543     my ($iteminformation) = getiteminformation( 0, $barcode );
1544
1545     if ( not $iteminformation ) {
1546         $messages->{'BadBarcode'} = $barcode;
1547         $doreturn = 0;
1548     }
1549
1550     # find the borrower
1551     my ($currentborrower) = currentborrower( $iteminformation->{'itemnumber'} );
1552     if ( ( not $currentborrower ) && $doreturn ) {
1553         $messages->{'NotIssued'} = $barcode;
1554         $doreturn = 0;
1555     }
1556
1557     # check if the book is in a permanent collection....
1558     my $hbr      = $iteminformation->{'homebranch'};
1559     my $branches = GetBranches();
1560     if ( $hbr && $branches->{$hbr}->{'PE'} ) {
1561         $messages->{'IsPermanent'} = $hbr;
1562     }
1563
1564     # check that the book has been cancelled
1565     if ( $iteminformation->{'wthdrawn'} ) {
1566         $messages->{'wthdrawn'} = 1;itemnumber
1567         $doreturn = 0;
1568     }
1569
1570 #     new op dev : if the book returned in an other branch update the holding branch
1571
1572 # update issues, thereby returning book (should push this out into another subroutine
1573     my ($borrower) = getpatroninformation( \%env, $currentborrower, 0 );
1574
1575 # case of a return of document (deal with issues and holdingbranch)
1576
1577     if ($doreturn) {
1578         my $sth =
1579           $dbh->prepare(
1580 "update issues set returndate = now() where (borrowernumber = ?) and (itemnumber = ?) and (returndate is null)"
1581           );
1582         $sth->execute( $borrower->{'borrowernumber'},
1583             $iteminformation->{'itemnumber'} );
1584         $messages->{'WasReturned'} = 1;    # FIXME is the "= 1" right?
1585     }
1586
1587 # continue to deal with returns cases, but not only if we have an issue
1588
1589 # the holdingbranch is updated if the document is returned in an other location .
1590 if ( $iteminformation->{'holdingbranch'} ne C4::Context->userenv->{'branch'} )
1591         {
1592                 UpdateHoldingbranch(C4::Context->userenv->{'branch'},$iteminformation->{'itemnumber'});
1593 #               reload iteminformation holdingbranch with the userenv value
1594                 $iteminformation->{'holdingbranch'} = C4::Context->userenv->{'branch'};
1595         }
1596     itemseen( $iteminformation->{'itemnumber'} );
1597     ($borrower) = getpatroninformation( \%env, $currentborrower, 0 );
1598
1599     # fix up the accounts.....
1600     if ( $iteminformation->{'itemlost'} ) {
1601         fixaccountforlostandreturned( $iteminformation, $borrower );
1602         $messages->{'WasLost'} = 1;    # FIXME is the "= 1" right?
1603     }
1604
1605    # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
1606    #     check if we have a transfer for this document
1607     my ($datesent,$frombranch,$tobranch) = checktransferts( $iteminformation->{'itemnumber'} );
1608
1609  #     if we have a return, we update the line of transfers with the datearrived
1610     if ($datesent) {
1611         if ( $tobranch eq C4::Context->userenv->{'branch'} ) {
1612                 my $sth =
1613                 $dbh->prepare(
1614                         "update branchtransfers set datearrived = now() where itemnumber= ? AND datearrived IS NULL"
1615                 );
1616                 $sth->execute( $iteminformation->{'itemnumber'} );
1617                 $sth->finish;
1618 #         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'
1619         SetWaitingStatus( $iteminformation->{'itemnumber'} );
1620         }
1621      else {
1622         $messages->{'WrongTransfer'} = $tobranch;
1623         $messages->{'WrongTransferItem'} = $iteminformation->{'itemnumber'};
1624      }
1625      $validTransfert = 1;
1626     }
1627
1628 # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
1629 # fix up the overdues in accounts...
1630     fixoverduesonreturn( $borrower->{'borrowernumber'},
1631         $iteminformation->{'itemnumber'} );
1632
1633 # find reserves.....
1634 #     if we don't have a reserve with the status W, we launch the Checkreserves routine
1635     my ( $resfound, $resrec ) =
1636       CheckReserves( $iteminformation->{'itemnumber'} );
1637     if ($resfound) {
1638
1639 #    my $tobrcd = ReserveWaiting($resrec->{'itemnumber'}, $resrec->{'borrowernumber'});
1640         $resrec->{'ResFound'}   = $resfound;
1641         $messages->{'ResFound'} = $resrec;
1642         $reserveDone = 1;
1643     }
1644
1645     # update stats?
1646     # Record the fact that this book was returned.
1647     UpdateStats(
1648         \%env, $branch, 'return', '0', '',
1649         $iteminformation->{'itemnumber'},
1650         $iteminformation->{'itemtype'},
1651         $borrower->{'borrowernumber'}
1652     );
1653
1654     &logaction(C4::Context->userenv->{'number'},"CIRCULATION","RETURN",$currentborrower,$iteminformation->{'biblionumber'})
1655         if C4::Context->preference("ReturnLog");
1656
1657     #adding message if holdingbranch is non equal a userenv branch to return the document to homebranch
1658     #we check, if we don't have reserv or transfert for this document, if not, return it to homebranch .
1659
1660     if ( ($iteminformation->{'holdingbranch'} ne $iteminformation->{'homebranch'}) and not $messages->{'WrongTransfer'} and ($validTransfert ne 1) and ($reserveDone ne 1) ){
1661                 if (C4::Context->preference("AutomaticItemReturn") == 1) {
1662                 dotransfer($iteminformation->{'itemnumber'}, C4::Context->userenv->{'branch'}, $iteminformation->{'homebranch'});
1663                 $messages->{'WasTransfered'} = 1;
1664                 warn "was transfered";
1665                 }
1666     }
1667
1668     return ( $doreturn, $messages, $iteminformation, $borrower );
1669 }
1670
1671 =head2 fixaccountforlostandreturned
1672
1673     &fixaccountforlostandreturned($iteminfo,$borrower);
1674
1675 Calculates the charge for a book lost and returned (Not exported & used only once)
1676
1677 C<$iteminfo> is a hashref to iteminfo. Only {itemnumber} is used.
1678
1679 C<$borrower> is a hashref to borrower. Only {borrowernumber is used.
1680
1681 =cut
1682
1683 sub fixaccountforlostandreturned {
1684     my ( $iteminfo, $borrower ) = @_;
1685     my %env;
1686     my $dbh = C4::Context->dbh;
1687     my $itm = $iteminfo->{'itemnumber'};
1688
1689     # check for charge made for lost book
1690     my $sth =
1691       $dbh->prepare(
1692 "select * from accountlines where (itemnumber = ?) and (accounttype='L' or accounttype='Rep') order by date desc"
1693       );
1694     $sth->execute($itm);
1695     if ( my $data = $sth->fetchrow_hashref ) {
1696
1697         # writeoff this amount
1698         my $offset;
1699         my $amount = $data->{'amount'};
1700         my $acctno = $data->{'accountno'};
1701         my $amountleft;
1702         if ( $data->{'amountoutstanding'} == $amount ) {
1703             $offset     = $data->{'amount'};
1704             $amountleft = 0;
1705         }
1706         else {
1707             $offset     = $amount - $data->{'amountoutstanding'};
1708             $amountleft = $data->{'amountoutstanding'} - $amount;
1709         }
1710         my $usth = $dbh->prepare(
1711             "update accountlines set accounttype = 'LR',amountoutstanding='0'
1712             where (borrowernumber = ?)
1713             and (itemnumber = ?) and (accountno = ?) "
1714         );
1715         $usth->execute( $data->{'borrowernumber'}, $itm, $acctno );
1716         $usth->finish;
1717
1718         #check if any credit is left if so writeoff other accounts
1719         my $nextaccntno =
1720           getnextacctno( \%env, $data->{'borrowernumber'}, $dbh );
1721         if ( $amountleft < 0 ) {
1722             $amountleft *= -1;
1723         }
1724         if ( $amountleft > 0 ) {
1725             my $msth = $dbh->prepare(
1726                 "select * from accountlines where (borrowernumber = ?)
1727                             and (amountoutstanding >0) order by date"
1728             );
1729             $msth->execute( $data->{'borrowernumber'} );
1730
1731             # offset transactions
1732             my $newamtos;
1733             my $accdata;
1734             while ( ( $accdata = $msth->fetchrow_hashref )
1735                 and ( $amountleft > 0 ) )
1736             {
1737                 if ( $accdata->{'amountoutstanding'} < $amountleft ) {
1738                     $newamtos = 0;
1739                     $amountleft -= $accdata->{'amountoutstanding'};
1740                 }
1741                 else {
1742                     $newamtos   = $accdata->{'amountoutstanding'} - $amountleft;
1743                     $amountleft = 0;
1744                 }
1745                 my $thisacct = $accdata->{'accountno'};
1746                 my $usth     = $dbh->prepare(
1747                     "update accountlines set amountoutstanding= ?
1748                     where (borrowernumber = ?)
1749                     and (accountno=?)"
1750                 );
1751                 $usth->execute( $newamtos, $data->{'borrowernumber'},
1752                     '$thisacct' );
1753                 $usth->finish;
1754                 $usth = $dbh->prepare(
1755                     "insert into accountoffsets
1756                 (borrowernumber, accountno, offsetaccount,  offsetamount)
1757                 values
1758                 (?,?,?,?)"
1759                 );
1760                 $usth->execute(
1761                     $data->{'borrowernumber'},
1762                     $accdata->{'accountno'},
1763                     $nextaccntno, $newamtos
1764                 );
1765                 $usth->finish;
1766             }
1767             $msth->finish;
1768         }
1769         if ( $amountleft > 0 ) {
1770             $amountleft *= -1;
1771         }
1772         my $desc = "Book Returned " . $iteminfo->{'barcode'};
1773         $usth = $dbh->prepare(
1774             "insert into accountlines
1775             (borrowernumber,accountno,date,amount,description,accounttype,amountoutstanding)
1776             values (?,?,now(),?,?,'CR',?)"
1777         );
1778         $usth->execute(
1779             $data->{'borrowernumber'},
1780             $nextaccntno, 0 - $amount,
1781             $desc, $amountleft
1782         );
1783         $usth->finish;
1784         $usth = $dbh->prepare(
1785             "insert into accountoffsets
1786             (borrowernumber, accountno, offsetaccount,  offsetamount)
1787             values (?,?,?,?)"
1788         );
1789         $usth->execute( $borrower->{'borrowernumber'},
1790             $data->{'accountno'}, $nextaccntno, $offset );
1791         $usth->finish;
1792         $usth = $dbh->prepare("update items set paidfor='' where itemnumber=?");
1793         $usth->execute($itm);
1794         $usth->finish;
1795     }
1796     $sth->finish;
1797     return;
1798 }
1799
1800 =head2 fixoverdueonreturn
1801
1802     &fixoverdueonreturn($brn,$itm);
1803
1804 C<$brn> borrowernumber
1805
1806 C<$itm> itemnumber
1807
1808 =cut
1809
1810 sub fixoverduesonreturn {
1811     my ( $brn, $itm ) = @_;
1812     my $dbh = C4::Context->dbh;
1813
1814     # check for overdue fine
1815     my $sth =
1816       $dbh->prepare(
1817 "select * from accountlines where (borrowernumber = ?) and (itemnumber = ?) and (accounttype='FU' or accounttype='O')"
1818       );
1819     $sth->execute( $brn, $itm );
1820
1821     # alter fine to show that the book has been returned
1822     if ( my $data = $sth->fetchrow_hashref ) {
1823         my $usth =
1824           $dbh->prepare(
1825 "update accountlines set accounttype='F' where (borrowernumber = ?) and (itemnumber = ?) and (accountno = ?)"
1826           );
1827         $usth->execute( $brn, $itm, $data->{'accountno'} );
1828         $usth->finish();
1829     }
1830     $sth->finish();
1831     return;
1832 }
1833
1834 =head2 patronflags
1835
1836  Not exported
1837
1838  NOTE!: If you change this function, be sure to update the POD for
1839  &getpatroninformation.
1840
1841  $flags = &patronflags($env, $patron, $dbh);
1842
1843  $flags->{CHARGES}
1844         {message}    Message showing patron's credit or debt
1845        {noissues}    Set if patron owes >$5.00
1846          {GNA}            Set if patron gone w/o address
1847         {message}    "Borrower has no valid address"
1848         {noissues}    Set.
1849         {LOST}        Set if patron's card reported lost
1850         {message}    Message to this effect
1851         {noissues}    Set.
1852         {DBARRED}        Set is patron is debarred
1853         {message}    Message to this effect
1854         {noissues}    Set.
1855          {NOTES}        Set if patron has notes
1856         {message}    Notes about patron
1857          {ODUES}        Set if patron has overdue books
1858         {message}    "Yes"
1859         {itemlist}    ref-to-array: list of overdue books
1860         {itemlisttext}    Text list of overdue items
1861          {WAITING}        Set if there are items available that the
1862                 patron reserved
1863         {message}    Message to this effect
1864         {itemlist}    ref-to-array: list of available items
1865
1866 =cut
1867
1868 sub patronflags {
1869
1870     # Original subroutine for Circ2.pm
1871     my %flags;
1872     my ( $env, $patroninformation, $dbh ) = @_;
1873     my $amount =
1874       checkaccount( $env, $patroninformation->{'borrowernumber'}, $dbh );
1875     if ( $amount > 0 ) {
1876         my %flaginfo;
1877         my $noissuescharge = C4::Context->preference("noissuescharge");
1878         $flaginfo{'message'} = sprintf "Patron owes \$%.02f", $amount;
1879         if ( $amount > $noissuescharge ) {
1880             $flaginfo{'noissues'} = 1;
1881         }
1882         $flags{'CHARGES'} = \%flaginfo;
1883     }
1884     elsif ( $amount < 0 ) {
1885         my %flaginfo;
1886         $flaginfo{'message'} = sprintf "Patron has credit of \$%.02f", -$amount;
1887         $flags{'CHARGES'} = \%flaginfo;
1888     }
1889     if (   $patroninformation->{'gonenoaddress'}
1890         && $patroninformation->{'gonenoaddress'} == 1 )
1891     {
1892         my %flaginfo;
1893         $flaginfo{'message'}  = 'Borrower has no valid address.';
1894         $flaginfo{'noissues'} = 1;
1895         $flags{'GNA'}         = \%flaginfo;
1896     }
1897     if ( $patroninformation->{'lost'} && $patroninformation->{'lost'} == 1 ) {
1898         my %flaginfo;
1899         $flaginfo{'message'}  = 'Borrower\'s card reported lost.';
1900         $flaginfo{'noissues'} = 1;
1901         $flags{'LOST'}        = \%flaginfo;
1902     }
1903     if (   $patroninformation->{'debarred'}
1904         && $patroninformation->{'debarred'} == 1 )
1905     {
1906         my %flaginfo;
1907         $flaginfo{'message'}  = 'Borrower is Debarred.';
1908         $flaginfo{'noissues'} = 1;
1909         $flags{'DBARRED'}     = \%flaginfo;
1910     }
1911     if (   $patroninformation->{'borrowernotes'}
1912         && $patroninformation->{'borrowernotes'} )
1913     {
1914         my %flaginfo;
1915         $flaginfo{'message'} = "$patroninformation->{'borrowernotes'}";
1916         $flags{'NOTES'}      = \%flaginfo;
1917     }
1918     my ( $odues, $itemsoverdue ) =
1919       checkoverdues( $env, $patroninformation->{'borrowernumber'}, $dbh );
1920     if ( $odues > 0 ) {
1921         my %flaginfo;
1922         $flaginfo{'message'}  = "Yes";
1923         $flaginfo{'itemlist'} = $itemsoverdue;
1924         foreach ( sort { $a->{'date_due'} cmp $b->{'date_due'} }
1925             @$itemsoverdue )
1926         {
1927             $flaginfo{'itemlisttext'} .=
1928               "$_->{'date_due'} $_->{'barcode'} $_->{'title'} \n";
1929         }
1930         $flags{'ODUES'} = \%flaginfo;
1931     }
1932     my $itemswaiting =
1933       C4::Reserves2::GetWaitingReserves( $patroninformation->{'borrowernumber'} );
1934     my $nowaiting = scalar @$itemswaiting;
1935     if ( $nowaiting > 0 ) {
1936         my %flaginfo;
1937         $flaginfo{'message'}  = "Reserved items available";
1938         $flaginfo{'itemlist'} = $itemswaiting;
1939         $flags{'WAITING'}     = \%flaginfo;
1940     }
1941     return ( \%flags );
1942 }
1943
1944 =head2 checkoverdues
1945
1946 ( $count, $overdueitems )=checkoverdues( $env, $borrowernumber, $dbh );
1947
1948 Not exported
1949
1950 =cut
1951
1952 sub checkoverdues {
1953
1954 # From Main.pm, modified to return a list of overdueitems, in addition to a count
1955 #checks whether a borrower has overdue items
1956     my ( $env, $borrowernumber, $dbh ) = @_;
1957     my @datearr = localtime;
1958     my $today   =
1959       ( $datearr[5] + 1900 ) . "-" . ( $datearr[4] + 1 ) . "-" . $datearr[3];
1960     my @overdueitems;
1961     my $count = 0;
1962     my $sth   = $dbh->prepare(
1963         "SELECT * FROM issues,biblio,biblioitems,items
1964             WHERE items.biblioitemnumber = biblioitems.biblioitemnumber
1965                 AND items.biblionumber     = biblio.biblionumber
1966                 AND issues.itemnumber      = items.itemnumber
1967                 AND issues.borrowernumber  = ?
1968                 AND issues.returndate is NULL
1969                 AND issues.date_due < ?"
1970     );
1971     $sth->execute( $borrowernumber, $today );
1972     while ( my $data = $sth->fetchrow_hashref ) {
1973         push( @overdueitems, $data );
1974         $count++;
1975     }
1976     $sth->finish;
1977     return ( $count, \@overdueitems );
1978 }
1979
1980 =head2 currentborrower
1981
1982 $borrower=currentborrower($itemnumber)
1983
1984 Not exported
1985
1986 =cut
1987
1988 sub currentborrower {
1989
1990     # Original subroutine for Circ2.pm
1991     my ($itemnumber) = @_;
1992     my $dbh          = C4::Context->dbh;
1993     my $q_itemnumber = $dbh->quote($itemnumber);
1994     my $sth          = $dbh->prepare(
1995         "select borrowers.borrowernumber from
1996     issues,borrowers where issues.itemnumber=$q_itemnumber and
1997     issues.borrowernumber=borrowers.borrowernumber and issues.returndate is
1998     NULL"
1999     );
2000     $sth->execute;
2001     my ($borrower) = $sth->fetchrow;
2002     return ($borrower);
2003 }
2004
2005 =head2 checkreserve_to_delete
2006
2007 ( $resbor, $resrec ) = &checkreserve_to_delete($env,$dbh,$itemnum);
2008
2009 =cut
2010
2011 sub checkreserve_to_delete {
2012
2013     # Stolen from Main.pm
2014     # Check for reserves for biblio
2015     my ( $env, $dbh, $itemnum ) = @_;
2016     my $resbor = "";
2017     my $sth    = $dbh->prepare(
2018         "select * from reserves,items
2019     where (items.itemnumber = ?)
2020     and (reserves.cancellationdate is NULL)
2021     and (items.biblionumber = reserves.biblionumber)
2022     and ((reserves.found = 'W')
2023     or (reserves.found is null))
2024     order by priority"
2025     );
2026     $sth->execute($itemnum);
2027     my $resrec;
2028     my $data = $sth->fetchrow_hashref;
2029     while ( $data && $resbor eq '' ) {
2030         $resrec = $data;
2031         my $const = $data->{'constrainttype'};
2032         if ( $const eq "a" ) {
2033             $resbor = $data->{'borrowernumber'};
2034         }
2035         else {
2036             my $found = 0;
2037             my $csth  = $dbh->prepare(
2038                 "select * from reserveconstraints,items
2039         where (borrowernumber=?)
2040         and reservedate=?
2041         and reserveconstraints.biblionumber=?
2042         and (items.itemnumber=? and
2043         items.biblioitemnumber = reserveconstraints.biblioitemnumber)"
2044             );
2045             $csth->execute(
2046                 $data->{'borrowernumber'},
2047                 $data->{'biblionumber'},
2048                 $data->{'reservedate'}, $itemnum
2049             );
2050             if ( my $cdata = $csth->fetchrow_hashref ) { $found = 1; }
2051             if ( $const eq 'o' ) {
2052                 if ( $found eq 1 ) { $resbor = $data->{'borrowernumber'}; }
2053             }
2054             else {
2055                 if ( $found eq 0 ) { $resbor = $data->{'borrowernumber'}; }
2056             }
2057             $csth->finish();
2058         }
2059         $data = $sth->fetchrow_hashref;
2060     }
2061     $sth->finish;
2062     return ( $resbor, $resrec );
2063 }
2064
2065 =head2 currentissues
2066
2067 $issues = &currentissues($env, $borrower);
2068
2069 Returns a list of books currently on loan to a patron.
2070
2071 If C<$env-E<gt>{todaysissues}> is set and true, C<&currentissues> only
2072 returns information about books issued today. If
2073 C<$env-E<gt>{nottodaysissues}> is set and true, C<&currentissues> only
2074 returns information about books issued before today. If both are
2075 specified, C<$env-E<gt>{todaysissues}> is ignored. If neither is
2076 specified, C<&currentissues> returns all of the patron's issues.
2077
2078 C<$borrower->{borrowernumber}> is the borrower number of the patron
2079 whose issues we want to list.
2080
2081 C<&currentissues> returns a PHP-style array: C<$issues> is a
2082 reference-to-hash whose keys are integers in the range 1...I<n>, where
2083 I<n> is the number of items on issue (either today or before today).
2084 C<$issues-E<gt>{I<n>}> is a reference-to-hash whose keys are all of
2085 the fields of the biblio, biblioitems, items, and issues fields of the
2086 Koha database for that particular item.
2087
2088 =cut
2089
2090 #'
2091 sub currentissues {
2092
2093     # New subroutine for Circ2.pm
2094     my ( $env, $borrower ) = @_;
2095     my $dbh = C4::Context->dbh;
2096     my %currentissues;
2097     my $counter        = 1;
2098     my $borrowernumber = $borrower->{'borrowernumber'};
2099     my $crit           = '';
2100
2101     # Figure out whether to get the books issued today, or earlier.
2102     # FIXME - $env->{todaysissues} and $env->{nottodaysissues} can
2103     # both be specified, but are mutually-exclusive. This is bogus.
2104     # Make this a flag. Or better yet, return everything in (reverse)
2105     # chronological order and let the caller figure out which books
2106     # were issued today.
2107     if ( $env->{'todaysissues'} ) {
2108
2109         # FIXME - Could use
2110         #    $today = POSIX::strftime("%Y%m%d", localtime);
2111         # FIXME - Since $today will be used in either case, move it
2112         # out of the two if-blocks.
2113         my @datearr = localtime( time() );
2114         my $today   = ( 1900 + $datearr[5] ) . sprintf "%02d",
2115           ( $datearr[4] + 1 ) . sprintf "%02d", $datearr[3];
2116
2117         # FIXME - MySQL knows about dates. Just use
2118         #    and issues.timestamp = curdate();
2119         $crit = " and issues.timestamp like '$today%' ";
2120     }
2121     if ( $env->{'nottodaysissues'} ) {
2122
2123         # FIXME - Could use
2124         #    $today = POSIX::strftime("%Y%m%d", localtime);
2125         # FIXME - Since $today will be used in either case, move it
2126         # out of the two if-blocks.
2127         my @datearr = localtime( time() );
2128         my $today   = ( 1900 + $datearr[5] ) . sprintf "%02d",
2129           ( $datearr[4] + 1 ) . sprintf "%02d", $datearr[3];
2130
2131         # FIXME - MySQL knows about dates. Just use
2132         #    and issues.timestamp < curdate();
2133         $crit = " and !(issues.timestamp like '$today%') ";
2134     }
2135
2136     # FIXME - Does the caller really need every single field from all
2137     # four tables?
2138     my $sth = $dbh->prepare(
2139         "select * from issues,items,biblioitems,biblio where
2140     borrowernumber=? and issues.itemnumber=items.itemnumber and
2141     items.biblionumber=biblio.biblionumber and
2142     items.biblioitemnumber=biblioitems.biblioitemnumber and returndate is null
2143     $crit order by issues.date_due"
2144     );
2145     $sth->execute($borrowernumber);
2146     while ( my $data = $sth->fetchrow_hashref ) {
2147
2148         # FIXME - The Dewey code is a string, not a number.
2149         $data->{'dewey'} =~ s/0*$//;
2150         ( $data->{'dewey'} == 0 ) && ( $data->{'dewey'} = '' );
2151
2152         # FIXME - Could use
2153         #    $todaysdate = POSIX::strftime("%Y%m%d", localtime)
2154         # or better yet, just reuse $today which was calculated above.
2155         # This function isn't going to run until midnight, is it?
2156         # Alternately, use
2157         #    $todaysdate = POSIX::strftime("%Y-%m-%d", localtime)
2158         #    if ($data->{'date_due'} lt $todaysdate)
2159         #        ...
2160         # Either way, the date should be be formatted outside of the
2161         # loop.
2162         my @datearr    = localtime( time() );
2163         my $todaysdate =
2164             ( 1900 + $datearr[5] )
2165           . sprintf( "%0.2d", ( $datearr[4] + 1 ) )
2166           . sprintf( "%0.2d", $datearr[3] );
2167         my $datedue = $data->{'date_due'};
2168         $datedue =~ s/-//g;
2169         if ( $datedue < $todaysdate ) {
2170             $data->{'overdue'} = 1;
2171         }
2172         my $itemnumber = $data->{'itemnumber'};
2173
2174         # FIXME - Consecutive integers as hash keys? You have GOT to
2175         # be kidding me! Use an array, fercrissakes!
2176         $currentissues{$counter} = $data;
2177         $counter++;
2178     }
2179     $sth->finish;
2180     return ( \%currentissues );
2181 }
2182
2183 =head2 getissues
2184
2185 $issues = &getissues($borrowernumber);
2186
2187 Returns the set of books currently on loan to a patron.
2188
2189 C<$borrowernumber> is the patron's borrower number.
2190
2191 C<&getissues> returns a PHP-style array: C<$issues> is a
2192 reference-to-hash whose keys are integers in the range 0..I<n>-1,
2193 where I<n> is the number of books the patron currently has on loan.
2194
2195 The values of C<$issues> are references-to-hash whose keys are
2196 selected fields from the issues, items, biblio, and biblioitems tables
2197 of the Koha database.
2198
2199 =cut
2200
2201 #'
2202 sub getissues {
2203
2204     # New subroutine for Circ2.pm
2205     my ($borrower)     = @_;
2206     my $dbh            = C4::Context->dbh;
2207     my $borrowernumber = $borrower->{'borrowernumber'};
2208     my %currentissues;
2209     my $select = "
2210         SELECT  items.*,
2211                 issues.timestamp           AS timestamp,
2212                 issues.date_due            AS date_due,
2213                 items.barcode              AS barcode,
2214                 biblio.title               AS title,
2215                 biblio.author              AS author,
2216                 biblioitems.dewey          AS dewey,
2217                 itemtypes.description      AS itemtype,
2218                 biblioitems.subclass       AS subclass,
2219                 biblioitems.ccode          AS ccode,
2220                 biblioitems.isbn           AS isbn,
2221                 biblioitems.classification AS classification
2222         FROM    items
2223             LEFT JOIN issues ON issues.itemnumber = items.itemnumber
2224             LEFT JOIN biblio ON biblio.biblionumber = items.biblionumber
2225             LEFT JOIN biblioitems ON items.biblioitemnumber = biblioitems.biblioitemnumber
2226             LEFT JOIN itemtypes ON itemtypes.itemtype     = biblioitems.itemtype
2227         WHERE   issues.borrowernumber  = ?
2228             AND issues.returndate IS NULL
2229         ORDER BY issues.date_due DESC
2230     ";
2231     my $sth = $dbh->prepare($select);
2232     $sth->execute($borrowernumber);
2233     my $counter = 0;
2234
2235     while ( my $data = $sth->fetchrow_hashref ) {
2236         $data->{'dewey'} =~ s/0*$//;
2237         ( $data->{'dewey'} == 0 ) && ( $data->{'dewey'} = '' );
2238
2239         # FIXME - The Dewey code is a string, not a number.
2240         # FIXME - Use POSIX::strftime to get a text version of today's
2241         # date. That's what it's for.
2242         # FIXME - Move the date calculation outside of the loop.
2243         my @datearr    = localtime( time() );
2244         my $todaysdate =
2245             ( 1900 + $datearr[5] )
2246           . sprintf( "%0.2d", ( $datearr[4] + 1 ) )
2247           . sprintf( "%0.2d", $datearr[3] );
2248
2249         # FIXME - Instead of converting the due date to YYYYMMDD, just
2250         # use
2251         #    $todaysdate = POSIX::strftime("%Y-%m-%d", localtime);
2252         #    ...
2253         #    if ($date->{date_due} lt $todaysdate)
2254         my $datedue = $data->{'date_due'};
2255         $datedue =~ s/-//g;
2256         if ( $datedue < $todaysdate ) {
2257             $data->{'overdue'} = 1;
2258         }
2259         $currentissues{$counter} = $data;
2260         $counter++;
2261
2262         # FIXME - This is ludicrous. If you want to return an
2263         # array of values, just use an array. That's what
2264         # they're there for.
2265     }
2266     $sth->finish;
2267     return ( \%currentissues );
2268 }
2269
2270 =head2 GetIssuesFromBiblio
2271
2272 $issues = GetIssuesFromBiblio($biblionumber);
2273
2274 this function get all issues from a biblionumber.
2275
2276 Return:
2277 C<$issues> is a reference to array which each value is ref-to-hash. This ref-to-hash containts all column from
2278 tables issues and the firstname,surname & cardnumber from borrowers.
2279
2280 =cut
2281
2282 sub GetIssuesFromBiblio {
2283     my $biblionumber = shift;
2284     return undef unless $biblionumber;
2285     my $dbh   = C4::Context->dbh;
2286     my $query = "
2287         SELECT issues.*,biblio.biblionumber,biblio.title, biblio.author,borrowers.cardnumber,borrowers.surname,borrowers.firstname
2288         FROM issues
2289             LEFT JOIN borrowers ON borrowers.borrowernumber = issues.borrowernumber
2290             LEFT JOIN items ON issues.itemnumber = items.itemnumber
2291             LEFT JOIN biblioitems ON items.itemnumber = biblioitems.biblioitemnumber
2292             LEFT JOIN biblio ON biblio.biblionumber = items.biblioitemnumber
2293         WHERE biblio.biblionumber = ?
2294         ORDER BY issues.timestamp
2295     ";
2296     my $sth = $dbh->prepare($query);
2297     $sth->execute($biblionumber);
2298
2299     my @issues;
2300     while ( my $data = $sth->fetchrow_hashref ) {
2301         push @issues, $data;
2302     }
2303     return \@issues;
2304 }
2305
2306 =head2 renewstatus
2307
2308 $ok = &renewstatus($env, $dbh, $borrowernumber, $itemnumber);
2309
2310 Find out whether a borrowed item may be renewed.
2311
2312 C<$env> is ignored.
2313
2314 C<$dbh> is a DBI handle to the Koha database.
2315
2316 C<$borrowernumber> is the borrower number of the patron who currently
2317 has the item on loan.
2318
2319 C<$itemnumber> is the number of the item to renew.
2320
2321 C<$renewstatus> returns a true value iff the item may be renewed. The
2322 item must currently be on loan to the specified borrower; renewals
2323 must be allowed for the item's type; and the borrower must not have
2324 already renewed the loan.
2325
2326 =cut
2327
2328 sub renewstatus {
2329
2330     # check renewal status
2331     my ( $env, $borrowernumber, $itemno ) = @_;
2332     my $dbh       = C4::Context->dbh;
2333     my $renews    = 1;
2334     my $renewokay = 0;
2335
2336     # Look in the issues table for this item, lent to this borrower,
2337     # and not yet returned.
2338
2339     # FIXME - I think this function could be redone to use only one SQL call.
2340     my $sth1 = $dbh->prepare(
2341         "select * from issues
2342                                 where (borrowernumber = ?)
2343                                 and (itemnumber = ?)
2344                                 and returndate is null"
2345     );
2346     $sth1->execute( $borrowernumber, $itemno );
2347     if ( my $data1 = $sth1->fetchrow_hashref ) {
2348
2349         # Found a matching item
2350
2351         # See if this item may be renewed. This query is convoluted
2352         # because it's a bit messy: given the item number, we need to find
2353         # the biblioitem, which gives us the itemtype, which tells us
2354         # whether it may be renewed.
2355         my $sth2 = $dbh->prepare(
2356             "SELECT renewalsallowed from items,biblioitems,itemtypes
2357         where (items.itemnumber = ?)
2358         and (items.biblioitemnumber = biblioitems.biblioitemnumber)
2359         and (biblioitems.itemtype = itemtypes.itemtype)"
2360         );
2361         $sth2->execute($itemno);
2362         if ( my $data2 = $sth2->fetchrow_hashref ) {
2363             $renews = $data2->{'renewalsallowed'};
2364         }
2365         if ( $renews && $renews > $data1->{'renewals'} ) {
2366             $renewokay = 1;
2367         }
2368         $sth2->finish;
2369         my ( $resfound, $resrec ) = CheckReserves($itemno);
2370         if ($resfound) {
2371             $renewokay = 0;
2372         }
2373         ( $resfound, $resrec ) = CheckReserves($itemno);
2374         if ($resfound) {
2375             $renewokay = 0;
2376         }
2377
2378     }
2379     $sth1->finish;
2380     return ($renewokay);
2381 }
2382
2383 =head2 renewbook
2384
2385 &renewbook($env, $borrowernumber, $itemnumber, $datedue);
2386
2387 Renews a loan.
2388
2389 C<$env-E<gt>{branchcode}> is the code of the branch where the
2390 renewal is taking place.
2391
2392 C<$env-E<gt>{usercode}> is the value to log in C<statistics.usercode>
2393 in the Koha database.
2394
2395 C<$borrowernumber> is the borrower number of the patron who currently
2396 has the item.
2397
2398 C<$itemnumber> is the number of the item to renew.
2399
2400 C<$datedue> can be used to set the due date. If C<$datedue> is the
2401 empty string, C<&renewbook> will calculate the due date automatically
2402 from the book's item type. If you wish to set the due date manually,
2403 C<$datedue> should be in the form YYYY-MM-DD.
2404
2405 =cut
2406
2407 sub renewbook {
2408
2409     # mark book as renewed
2410     my ( $env, $borrowernumber, $itemno, $datedue ) = @_;
2411     my $dbh = C4::Context->dbh;
2412
2413     # If the due date wasn't specified, calculate it by adding the
2414     # book's loan length to today's date.
2415     if ( $datedue eq "" ) {
2416
2417         #debug_msg($env, "getting date");
2418         my $iteminformation = getiteminformation( $itemno, 0 );
2419         my $borrower = getpatroninformation( $env, $borrowernumber, 0 );
2420         my $loanlength = getLoanLength(
2421             $borrower->{'categorycode'},
2422             $iteminformation->{'itemtype'},
2423             $borrower->{'branchcode'}
2424         );
2425         my ( $due_year, $due_month, $due_day ) =
2426           Add_Delta_DHMS( Today_and_Now(), $loanlength, 0, 0, 0 );
2427         $datedue = "$due_year-$due_month-$due_day";
2428
2429         #$datedue = UnixDate(DateCalc("today","$loanlength days"),"%Y-%m-%d");
2430     }
2431
2432     # Find the issues record for this book
2433     my $sth =
2434       $dbh->prepare(
2435 "select * from issues where borrowernumber=? and itemnumber=? and returndate is null"
2436       );
2437     $sth->execute( $borrowernumber, $itemno );
2438     my $issuedata = $sth->fetchrow_hashref;
2439     $sth->finish;
2440
2441     # Update the issues record to have the new due date, and a new count
2442     # of how many times it has been renewed.
2443     my $renews = $issuedata->{'renewals'} + 1;
2444     $sth = $dbh->prepare(
2445         "update issues set date_due = ?, renewals = ?
2446         where borrowernumber=? and itemnumber=? and returndate is null"
2447     );
2448     $sth->execute( $datedue, $renews, $borrowernumber, $itemno );
2449     $sth->finish;
2450
2451     # Log the renewal
2452     UpdateStats( $env, $env->{'branchcode'}, 'renew', '', '', $itemno );
2453
2454     # Charge a new rental fee, if applicable?
2455     my ( $charge, $type ) = calc_charges( $env, $itemno, $borrowernumber );
2456     if ( $charge > 0 ) {
2457         my $accountno = getnextacctno( $env, $borrowernumber, $dbh );
2458         my $item = getiteminformation($itemno);
2459         $sth = $dbh->prepare(
2460 "Insert into accountlines (borrowernumber,accountno,date,amount,description,accounttype,amountoutstanding,itemnumber)
2461                             values (?,?,now(),?,?,?,?,?)"
2462         );
2463         $sth->execute( $borrowernumber, $accountno, $charge,
2464             "Renewal of Rental Item $item->{'title'} $item->{'barcode'}",
2465             'Rent', $charge, $itemno );
2466         $sth->finish;
2467     }
2468
2469     #  return();
2470 }
2471
2472 =head2 calc_charges
2473
2474 ($charge, $item_type) = &calc_charges($env, $itemnumber, $borrowernumber);
2475
2476 Calculate how much it would cost for a given patron to borrow a given
2477 item, including any applicable discounts.
2478
2479 C<$env> is ignored.
2480
2481 C<$itemnumber> is the item number of item the patron wishes to borrow.
2482
2483 C<$borrowernumber> is the patron's borrower number.
2484
2485 C<&calc_charges> returns two values: C<$charge> is the rental charge,
2486 and C<$item_type> is the code for the item's item type (e.g., C<VID>
2487 if it's a video).
2488
2489 =cut
2490
2491 sub calc_charges {
2492
2493     # calculate charges due
2494     my ( $env, $itemno, $borrowernumber ) = @_;
2495     my $charge = 0;
2496     my $dbh    = C4::Context->dbh;
2497     my $item_type;
2498
2499     # Get the book's item type and rental charge (via its biblioitem).
2500     my $sth1 = $dbh->prepare(
2501         "select itemtypes.itemtype,rentalcharge from items,biblioitems,itemtypes
2502                                 where (items.itemnumber =?)
2503                                 and (biblioitems.biblioitemnumber = items.biblioitemnumber)
2504                                 and (biblioitems.itemtype = itemtypes.itemtype)"
2505     );
2506     $sth1->execute($itemno);
2507     if ( my $data1 = $sth1->fetchrow_hashref ) {
2508         $item_type = $data1->{'itemtype'};
2509         $charge    = $data1->{'rentalcharge'};
2510         my $q2 = "select rentaldiscount from issuingrules,borrowers
2511             where (borrowers.borrowernumber = ?)
2512             and (borrowers.categorycode = issuingrules.categorycode)
2513             and (issuingrules.itemtype = ?)";
2514         my $sth2 = $dbh->prepare($q2);
2515         $sth2->execute( $borrowernumber, $item_type );
2516         if ( my $data2 = $sth2->fetchrow_hashref ) {
2517             my $discount = $data2->{'rentaldiscount'};
2518             if ( $discount eq 'NULL' ) {
2519                 $discount = 0;
2520             }
2521             $charge = ( $charge * ( 100 - $discount ) ) / 100;
2522         }
2523         $sth2->finish;
2524     }
2525
2526     $sth1->finish;
2527     return ( $charge, $item_type );
2528 }
2529
2530 =head2 createcharge
2531
2532 &createcharge( $env, $dbh, $itemno, $borrowernumber, $charge )
2533
2534 =cut
2535
2536 # FIXME - A virtually identical function appears in
2537 # C4::Circulation::Issues. Pick one and stick with it.
2538 sub createcharge {
2539
2540     #Stolen from Issues.pm
2541     my ( $env, $dbh, $itemno, $borrowernumber, $charge ) = @_;
2542     my $nextaccntno = getnextacctno( $env, $borrowernumber, $dbh );
2543     my $query ="
2544         INSERT INTO accountlines
2545             (borrowernumber, itemnumber, accountno,
2546             date, amount, description, accounttype,
2547             amountoutstanding)
2548         VALUES (?, ?, ?,now(), ?, 'Rental', 'Rent',?)
2549     ";
2550     my $sth         = $dbh->prepare($query);
2551     $sth->execute( $borrowernumber, $itemno, $nextaccntno, $charge, $charge );
2552     $sth->finish;
2553 }
2554
2555 =head2 find_reserves
2556
2557 ($status, $record) = &find_reserves($itemnumber);
2558
2559 Looks up an item in the reserves.
2560
2561 C<$itemnumber> is the itemnumber to look up.
2562
2563 C<$status> is true iff the search was successful.
2564
2565 C<$record> is a reference-to-hash describing the reserve. Its keys are
2566 the fields from the reserves table of the Koha database.
2567
2568 =cut
2569
2570 #'
2571 # FIXME - This API is bogus: just return the record, or undef if none
2572 # was found.
2573 # FIXME - There's also a &C4::Circulation::Returns::find_reserves, but
2574 # that one looks rather different.
2575 sub find_reserves {
2576
2577     # Stolen from Returns.pm
2578     warn "!!!!! SHOULD NOT BE HERE : Circ2::find_reserves is deprecated !!!";
2579     my ($itemno) = @_;
2580     my %env;
2581     my $dbh = C4::Context->dbh;
2582     my ($itemdata) = getiteminformation( $itemno, 0 );
2583     my $bibno  = $dbh->quote( $itemdata->{'biblionumber'} );
2584     my $bibitm = $dbh->quote( $itemdata->{'biblioitemnumber'} );
2585     my $sth    =
2586       $dbh->prepare(
2587 "select * from reserves where ((found = 'W') or (found is null)) and biblionumber = ? and cancellationdate is NULL order by priority, reservedate"
2588       );
2589     $sth->execute($bibno);
2590     my $resfound = 0;
2591     my $resrec;
2592     my $lastrec;
2593
2594     # print $query;
2595
2596     # FIXME - I'm not really sure what's going on here, but since we
2597     # only want one result, wouldn't it be possible (and far more
2598     # efficient) to do something clever in SQL that only returns one
2599     # set of values?
2600     while ( ( $resrec = $sth->fetchrow_hashref ) && ( not $resfound ) ) {
2601
2602         # FIXME - Unlike Pascal, Perl allows you to exit loops
2603         # early. Take out the "&& (not $resfound)" and just
2604         # use "last" at the appropriate point in the loop.
2605         # (Oh, and just in passing: if you'd used "!" instead
2606         # of "not", you wouldn't have needed the parentheses.)
2607         $lastrec = $resrec;
2608         my $brn   = $dbh->quote( $resrec->{'borrowernumber'} );
2609         my $rdate = $dbh->quote( $resrec->{'reservedate'} );
2610         my $bibno = $dbh->quote( $resrec->{'biblionumber'} );
2611         if ( $resrec->{'found'} eq "W" ) {
2612             if ( $resrec->{'itemnumber'} eq $itemno ) {
2613                 $resfound = 1;
2614             }
2615         }
2616         else {
2617             # FIXME - Use 'elsif' to avoid unnecessary indentation.
2618             if ( $resrec->{'constrainttype'} eq "a" ) {
2619                 $resfound = 1;
2620             }
2621             else {
2622                 my $consth =
2623                   $dbh->prepare(
2624                         "SELECT * FROM reserveconstraints
2625                          WHERE borrowernumber = ?
2626                            AND reservedate = ?
2627                            AND biblionumber = ?
2628                            AND biblioitemnumber = ?"
2629                   );
2630                 $consth->execute( $brn, $rdate, $bibno, $bibitm );
2631                 if ( my $conrec = $consth->fetchrow_hashref ) {
2632                     if ( $resrec->{'constrainttype'} eq "o" ) {
2633                         $resfound = 1;
2634                     }
2635                 }
2636                 $consth->finish;
2637             }
2638         }
2639         if ($resfound) {
2640             my $updsth =
2641               $dbh->prepare(
2642                 "UPDATE reserves
2643                  SET found = 'W',
2644                      itemnumber = ?
2645                  WHERE borrowernumber = ?
2646                    AND reservedate = ?
2647                    AND biblionumber = ?"
2648               );
2649             $updsth->execute( $itemno, $brn, $rdate, $bibno );
2650             $updsth->finish;
2651
2652             # FIXME - "last;" here to break out of the loop early.
2653         }
2654     }
2655     $sth->finish;
2656     return ( $resfound, $lastrec );
2657 }
2658
2659 =head2 fixdate
2660
2661 ( $date, $invalidduedate ) = fixdate( $year, $month, $day );
2662
2663 =cut
2664
2665 sub fixdate {
2666     my ( $year, $month, $day ) = @_;
2667     my $invalidduedate;
2668     my $date;
2669     if ( $year && $month && $day ) {
2670         if ( ( $year eq 0 ) && ( $month eq 0 ) && ( $year eq 0 ) ) {
2671
2672             #    $env{'datedue'}='';
2673         }
2674         else {
2675             if ( ( $year eq 0 ) || ( $month eq 0 ) || ( $year eq 0 ) ) {
2676                 $invalidduedate = 1;
2677             }
2678             else {
2679                 if (
2680                     ( $day > 30 )
2681                     && (   ( $month == 4 )
2682                         || ( $month == 6 )
2683                         || ( $month == 9 )
2684                         || ( $month == 11 ) )
2685                   )
2686                 {
2687                     $invalidduedate = 1;
2688                 }
2689                 elsif ( ( $day > 29 ) && ( $month == 2 ) ) {
2690                     $invalidduedate = 1;
2691                 }
2692                 elsif (
2693                        ( $month == 2 )
2694                     && ( $day > 28 )
2695                     && (   ( $year % 4 )
2696                         && ( ( !( $year % 100 ) || ( $year % 400 ) ) ) )
2697                   )
2698                 {
2699                     $invalidduedate = 1;
2700                 }
2701                 else {
2702                     $date = "$year-$month-$day";
2703                 }
2704             }
2705         }
2706     }
2707     return ( $date, $invalidduedate );
2708 }
2709
2710 =head2 get_current_return_date_of
2711
2712 &get_current_return_date_of(@itemnumber);
2713
2714 =cut
2715
2716 sub get_current_return_date_of {
2717     my (@itemnumbers) = @_;
2718     my $query = '
2719         SELECT
2720             date_due,
2721             itemnumber
2722         FROM issues
2723         WHERE itemnumber IN (' . join( ',', @itemnumbers ) . ')
2724         AND returndate IS NULL
2725     ';
2726     return get_infos_of( $query, 'itemnumber', 'date_due' );
2727 }
2728
2729 =head2 get_transfert_infos
2730
2731 get_transfert_infos($itemnumber);
2732
2733 =cut
2734
2735 sub get_transfert_infos {
2736     my ($itemnumber) = @_;
2737
2738     my $dbh = C4::Context->dbh;
2739
2740     my $query = '
2741         SELECT datesent,
2742                frombranch,
2743                tobranch
2744         FROM branchtransfers
2745         WHERE itemnumber = ?
2746           AND datearrived IS NULL
2747         ';
2748     my $sth = $dbh->prepare($query);
2749     $sth->execute($itemnumber);
2750     my @row = $sth->fetchrow_array();
2751     $sth->finish;
2752     return @row;
2753 }
2754
2755 =head2 DeleteTransfer
2756
2757 &DeleteTransfer($itemnumber);
2758
2759 =cut
2760
2761 sub DeleteTransfer {
2762     my ($itemnumber) = @_;
2763     my $dbh          = C4::Context->dbh;
2764     my $sth          = $dbh->prepare(
2765         "DELETE FROM branchtransfers
2766          WHERE itemnumber=?
2767          AND datearrived IS NULL "
2768     );
2769     $sth->execute($itemnumber);
2770     $sth->finish;
2771 }
2772
2773 =head2 GetTransfersFromBib
2774
2775 @results = GetTransfersFromBib($frombranch,$tobranch);
2776
2777 =cut
2778
2779 sub GetTransfersFromBib {
2780     my ( $frombranch, $tobranch ) = @_;
2781     return unless ( $frombranch && $tobranch );
2782     my $dbh   = C4::Context->dbh;
2783     my $query = "
2784         SELECT itemnumber,datesent,frombranch
2785         FROM   branchtransfers
2786         WHERE  frombranch=?
2787           AND  tobranch=?
2788           AND datearrived IS NULL
2789     ";
2790     my $sth = $dbh->prepare($query);
2791     $sth->execute( $frombranch, $tobranch );
2792     my @gettransfers;
2793     my $i = 0;
2794
2795     while ( my $data = $sth->fetchrow_hashref ) {
2796         $gettransfers[$i] = $data;
2797         $i++;
2798     }
2799     $sth->finish;
2800     return (@gettransfers);
2801 }
2802
2803 =head2 GetReservesToBranch
2804
2805 @transreserv = GetReservesToBranch( $frombranch, $default );
2806
2807 =cut
2808
2809 sub GetReservesToBranch {
2810     my ( $frombranch, $default ) = @_;
2811     my $dbh = C4::Context->dbh;
2812     my $sth = $dbh->prepare(
2813         "SELECT borrowernumber,reservedate,itemnumber,timestamp
2814          FROM reserves
2815          WHERE priority='0' AND cancellationdate is null
2816            AND branchcode=?
2817            AND branchcode!=?
2818            AND found IS NULL "
2819     );
2820     $sth->execute( $frombranch, $default );
2821     my @transreserv;
2822     my $i = 0;
2823     while ( my $data = $sth->fetchrow_hashref ) {
2824         $transreserv[$i] = $data;
2825         $i++;
2826     }
2827     $sth->finish;
2828     return (@transreserv);
2829 }
2830
2831 =head2 GetReservesForBranch
2832
2833 @transreserv = GetReservesForBranch($frombranch);
2834
2835 =cut
2836
2837 sub GetReservesForBranch {
2838     my ($frombranch) = @_;
2839     my $dbh          = C4::Context->dbh;
2840     my $sth          = $dbh->prepare( "
2841         SELECT borrowernumber,reservedate,itemnumber,waitingdate
2842         FROM   reserves
2843         WHERE   priority='0'
2844             AND cancellationdate IS NULL
2845             AND found='W'
2846             AND branchcode=?
2847         ORDER BY waitingdate" );
2848     $sth->execute($frombranch);
2849     my @transreserv;
2850     my $i = 0;
2851     while ( my $data = $sth->fetchrow_hashref ) {
2852         $transreserv[$i] = $data;
2853         $i++;
2854     }
2855     $sth->finish;
2856     return (@transreserv);
2857 }
2858
2859 =head2 checktransferts
2860
2861 @tranferts = checktransferts($itemnumber);
2862
2863 =cut
2864
2865 sub checktransferts {
2866     my ($itemnumber) = @_;
2867     my $dbh          = C4::Context->dbh;
2868     my $sth          = $dbh->prepare(
2869         "SELECT datesent,frombranch,tobranch FROM branchtransfers
2870         WHERE itemnumber = ? AND datearrived IS NULL"
2871     );
2872     $sth->execute($itemnumber);
2873     my @tranferts = $sth->fetchrow_array;
2874     $sth->finish;
2875
2876     return (@tranferts);
2877 }
2878
2879 =head2 CheckItemNotify
2880
2881 Sql request to check if the document has alreday been notified
2882 this function is not exported, only used with GetOverduesForBranch
2883
2884 =cut
2885
2886 sub CheckItemNotify {
2887         my ($notify_id,$notify_level,$itemnumber) = @_;
2888         my $dbh = C4::Context->dbh;
2889         my $sth = $dbh->prepare("
2890           SELECT COUNT(*) FROM notifys
2891  WHERE notify_id  = ?
2892  AND notify_level  = ?
2893   AND  itemnumber  =  ? ");
2894  $sth->execute($notify_id,$notify_level,$itemnumber);
2895         my $notified = $sth->fetchrow;
2896 $sth->finish;
2897 return ($notified);
2898 }
2899
2900 =head2 GetOverduesForBranch
2901
2902 Sql request for display all information for branchoverdues.pl
2903 2 possibilities : with or without departement .
2904 display is filtered by branch
2905
2906 =cut
2907
2908 sub GetOverduesForBranch {
2909     my ( $branch, $departement) = @_;
2910     if ( not $departement ) {
2911         my $dbh = C4::Context->dbh;
2912         my $sth = $dbh->prepare("
2913             SELECT
2914                 borrowers.surname,
2915                 borrowers.firstname,
2916                 biblio.title,
2917                 itemtypes.description,
2918                 issues.date_due,
2919                 issues.returndate,
2920                 branches.branchname,
2921                 items.barcode,
2922                 borrowers.phone,
2923                 borrowers.email,
2924                 items.itemcallnumber,
2925                 borrowers.borrowernumber,
2926                 items.itemnumber,
2927                 biblio.biblionumber,
2928                 issues.branchcode,
2929                 accountlines.notify_id,
2930                 accountlines.notify_level,
2931                 items.location,
2932                 accountlines.amountoutstanding
2933             FROM  issues,borrowers,biblio,biblioitems,itemtypes,items,branches,accountlines
2934             WHERE ( issues.returndate  is null)
2935               AND ( accountlines.amountoutstanding  != '0.000000')
2936               AND ( accountlines.accounttype  = 'FU')
2937               AND ( issues.borrowernumber = accountlines.borrowernumber )
2938               AND ( issues.itemnumber = accountlines.itemnumber )
2939               AND ( borrowers.borrowernumber = issues.borrowernumber )
2940               AND ( biblio.biblionumber = biblioitems.biblionumber )
2941               AND ( biblioitems.biblionumber = items.biblionumber )
2942               AND ( itemtypes.itemtype = biblioitems.itemtype )
2943               AND ( items.itemnumber = issues.itemnumber )
2944               AND ( branches.branchcode = issues.branchcode )
2945               AND (issues.branchcode = ?)
2946               AND (issues.date_due <= NOW())
2947             ORDER BY  borrowers.surname
2948         ");
2949         $sth->execute($branch);
2950         my @getoverdues;
2951         my $i = 0;
2952         while ( my $data = $sth->fetchrow_hashref ) {
2953         #check if the document has already been notified
2954         my $countnotify = CheckItemNotify($data->{'notify_id'},$data->{'notify_level'},$data->{'itemnumber'});
2955         if ($countnotify eq '0'){
2956             $getoverdues[$i] = $data;
2957             $i++;
2958          }
2959         }
2960         return (@getoverdues);
2961         $sth->finish;
2962     }
2963     else {
2964         my $dbh = C4::Context->dbh;
2965         my $sth = $dbh->prepare( "
2966             SELECT  borrowers.surname,
2967                     borrowers.firstname,
2968                     biblio.title,
2969                     itemtypes.description,
2970                     issues.date_due,
2971                     issues.returndate,
2972                     branches.branchname,
2973                     items.barcode,
2974                     borrowers.phone,
2975                     borrowers.email,
2976                     items.itemcallnumber,
2977                     borrowers.borrowernumber,
2978                     items.itemnumber,
2979                     biblio.biblionumber,
2980                     issues.branchcode,
2981                     accountlines.notify_id,
2982                     accountlines.notify_level,
2983                     items.location,
2984                     accountlines.amountoutstanding
2985            FROM  issues,borrowers,biblio,biblioitems,itemtypes,items,branches,accountlines
2986            WHERE ( issues.returndate  is null )
2987              AND ( accountlines.amountoutstanding  != '0.000000')
2988              AND ( accountlines.accounttype  = 'FU')
2989              AND ( issues.borrowernumber = accountlines.borrowernumber )
2990              AND ( issues.itemnumber = accountlines.itemnumber )
2991              AND ( borrowers.borrowernumber = issues.borrowernumber )
2992              AND ( biblio.biblionumber = biblioitems.biblionumber )
2993              AND ( biblioitems.biblionumber = items.biblionumber )
2994              AND ( itemtypes.itemtype = biblioitems.itemtype )
2995              AND ( items.itemnumber = issues.itemnumber )
2996              AND ( branches.branchcode = issues.branchcode )
2997              AND (issues.branchcode = ? AND items.location = ?)
2998              AND (issues.date_due <= NOW())
2999            ORDER BY  borrowers.surname
3000         " );
3001         $sth->execute( $branch, $departement);
3002         my @getoverdues;
3003         my $i = 0;
3004         while ( my $data = $sth->fetchrow_hashref ) {
3005         #check if the document has already been notified
3006           my $countnotify = CheckItemNotify($data->{'notify_id'},$data->{'notify_level'},$data->{'itemnumber'});
3007           if ($countnotify eq '0'){
3008                 $getoverdues[$i] = $data;
3009                  $i++;
3010          }
3011         }
3012         $sth->finish;
3013         return (@getoverdues);
3014     }
3015 }
3016
3017
3018 =head2 AddNotifyLine
3019
3020 &AddNotifyLine($borrowernumber, $itemnumber, $overduelevel, $method, $notifyId)
3021
3022 Creat a line into notify, if the method is phone, the notification_send_date is implemented to
3023
3024 =cut
3025
3026 sub AddNotifyLine {
3027     my ( $borrowernumber, $itemnumber, $overduelevel, $method, $notifyId ) = @_;
3028     if ( $method eq "phone" ) {
3029         my $dbh = C4::Context->dbh;
3030         my $sth = $dbh->prepare(
3031             "INSERT INTO notifys (borrowernumber,itemnumber,notify_date,notify_send_date,notify_level,method,notify_id)
3032         VALUES (?,?,now(),now(),?,?,?)"
3033         );
3034         $sth->execute( $borrowernumber, $itemnumber, $overduelevel, $method,
3035             $notifyId );
3036         $sth->finish;
3037     }
3038     else {
3039         my $dbh = C4::Context->dbh;
3040         my $sth = $dbh->prepare(
3041             "INSERT INTO notifys (borrowernumber,itemnumber,notify_date,notify_level,method,notify_id)
3042         VALUES (?,?,now(),?,?,?)"
3043         );
3044         $sth->execute( $borrowernumber, $itemnumber, $overduelevel, $method,
3045             $notifyId );
3046         $sth->finish;
3047     }
3048     return 1;
3049 }
3050
3051 =head2 RemoveNotifyLine
3052
3053 &RemoveNotifyLine( $borrowernumber, $itemnumber, $notify_date );
3054
3055 Cancel a notification
3056
3057 =cut
3058
3059 sub RemoveNotifyLine {
3060     my ( $borrowernumber, $itemnumber, $notify_date ) = @_;
3061     my $dbh = C4::Context->dbh;
3062     my $sth = $dbh->prepare(
3063         "DELETE FROM notifys
3064             WHERE
3065             borrowernumber=?
3066             AND itemnumber=?
3067             AND notify_date=?"
3068     );
3069     $sth->execute( $borrowernumber, $itemnumber, $notify_date );
3070     $sth->finish;
3071     return 1;
3072 }
3073
3074 =head2 AnonymiseIssueHistory
3075
3076 $rows = AnonymiseIssueHistory($borrowernumber,$date)
3077
3078 This function write NULL instead of C<$borrowernumber> given on input arg into the table issues.
3079 if C<$borrowernumber> is not set, it will delete the issue history for all borrower older than C<$date>.
3080
3081 return the number of affected rows.
3082
3083 =cut
3084
3085 sub AnonymiseIssueHistory {
3086     my $date           = shift;
3087     my $borrowernumber = shift;
3088     my $dbh            = C4::Context->dbh;
3089     my $query          = "
3090         UPDATE issues
3091         SET    borrowernumber = NULL
3092         WHERE  returndate < '".$date."'
3093           AND borrowernumber IS NOT NULL
3094     ";
3095     $query .= " AND borrowernumber = '".$borrowernumber."'" if defined $borrowernumber;
3096     my $rows_affected = $dbh->do($query);
3097     return $rows_affected;
3098 }
3099
3100 =head2 GetItemsLost
3101
3102 $items = GetItemsLost($where,$orderby);
3103
3104 This function get the items lost into C<$items>.
3105
3106 =over 2
3107
3108 =item input:
3109 C<$where> is a hashref. it containts a field of the items table as key
3110 and the value to match as value.
3111 C<$orderby> is a field of the items table.
3112
3113 =item return:
3114 C<$items> is a reference to an array full of hasref which keys are items' table column.
3115
3116 =item usage in the perl script:
3117
3118 my %where;
3119 $where{barcode} = 0001548;
3120 my $items = GetLostItems( \%where, "homebranch" );
3121 $template->param(itemsloop => $items);
3122
3123 =back
3124
3125 =cut
3126
3127 sub GetLostItems {
3128     # Getting input args.
3129     my $where   = shift;
3130     my $orderby = shift;
3131     my $dbh     = C4::Context->dbh;
3132
3133     my $query   = "
3134         SELECT *
3135         FROM   items
3136         WHERE  itemlost IS NOT NULL
3137           AND  itemlost <> 0
3138     ";
3139     foreach my $key (keys %$where) {
3140         $query .= " AND " . $key . " LIKE '%" . $where->{$key} . "%'";
3141     }
3142     $query .= " ORDER BY ".$orderby if defined $orderby;
3143
3144     my $sth = $dbh->prepare($query);
3145     $sth->execute;
3146     my @items;
3147     while ( my $row = $sth->fetchrow_hashref ){
3148         push @items, $row;
3149     }
3150     return \@items;
3151 }
3152
3153 =head2 updateWrongTransfer
3154
3155 $items = updateWrongTransfer($itemNumber,$borrowernumber,$waitingAtLibrary,$FromLibrary);
3156
3157 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
3158
3159 =cut
3160
3161 sub updateWrongTransfer {
3162         my ( $itemNumber,$waitingAtLibrary,$FromLibrary ) = @_;
3163         my $dbh = C4::Context->dbh;
3164 # first step validate the actual line of transfert .
3165         my $sth =
3166                 $dbh->prepare(
3167                         "update branchtransfers set datearrived = now(),tobranch=?,comments='wrongtransfer' where itemnumber= ? AND datearrived IS NULL"
3168                 );
3169                 $sth->execute($FromLibrary,$itemNumber);
3170                 $sth->finish;
3171
3172 # second step create a new line of branchtransfer to the right location .
3173         dotransfer($itemNumber, $FromLibrary, $waitingAtLibrary);
3174
3175 #third step changing holdingbranch of item
3176         UpdateHoldingbranch($FromLibrary,$itemNumber);
3177 }
3178
3179 =head2 UpdateHoldingbranch
3180
3181 $items = UpdateHoldingbranch($branch,$itmenumber);
3182 Simple methode for updating hodlingbranch in items BDD line
3183 =cut
3184
3185 sub UpdateHoldingbranch {
3186         my ( $branch,$itmenumber ) = @_;
3187         my $dbh = C4::Context->dbh;
3188 # first step validate the actual line of transfert .
3189         my $sth =
3190                 $dbh->prepare(
3191                         "update items set holdingbranch = ? where itemnumber= ?"
3192                 );
3193                 $sth->execute($branch,$itmenumber);
3194                 $sth->finish;
3195
3196
3197 }
3198
3199 1;
3200
3201 __END__
3202
3203 =head1 AUTHOR
3204
3205 Koha Developement team <info@koha.org>
3206
3207 =cut
3208