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