C4/Circulation/Circ2.pm

   1 # -*- tab-width: 8 -*-
   2 # Please use 8-character tabs for this file (indents are every 4 characters)
   3
   4 package C4::Circulation::Circ2;
   5
   6 # $Id$
   7
   8 #package to deal with Returns
   9 #written 3/11/99 by olwen@katipo.co.nz
  10
  11
  12 # Copyright 2000-2002 Katipo Communications
  13 #
  14 # This file is part of Koha.
  15 #
  16 # Koha is free software; you can redistribute it and/or modify it under the
  17 # terms of the GNU General Public License as published by the Free Software
  18 # Foundation; either version 2 of the License, or (at your option) any later
  19 # version.
  20 #
  21 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
  22 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  23 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
  24 #
  25 # You should have received a copy of the GNU General Public License along with
  26 # Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
  27 # Suite 330, Boston, MA  02111-1307 USA
  28
  29 use strict;
  30 # use warnings;
  31 require Exporter;
  32 use DBI;
  33 use C4::Context;
  34 use C4::Stats;
  35 use C4::Reserves2;
  36 use C4::Koha;
  37 use C4::Accounts2;
  38 use Date::Manip;
  39 use C4::Biblio;
  40
  41 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  42
  43 # set the version for version checking
  44 $VERSION = 0.01;
  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 =over 2
  63
  64 =cut
  65
  66 @ISA = qw(Exporter);
  67 @EXPORT = qw(
  68                 &getpatroninformation
  69                 &currentissues
  70                 &getissues
  71                 &getiteminformation
  72                 &renewstatus
  73                 &renewbook
  74                 &canbookbeissued
  75                 &issuebook
  76                 &returnbook
  77                 &find_reserves
  78                 &transferbook
  79                 &decode
  80                 &calc_charges
  81                 &listitemsforinventory
  82                 &itemseen
  83                 &fixdate
  84                 get_return_date_of
  85                 get_transfert_infos
  86                 &checktransferts
  87                 &GetReservesForBranch
  88                 &GetReservesToBranch
  89                 &GetTransfersFromBib
  90                 &getBranchIp
  91                 &dotranfer
  92         );
  93 # &getbranches &getprinters &getbranch &getprinter => moved to C4::Koha.pm
  94
  95 =head2 itemseen
  96
  97 &itemseen($itemnum)
  98 Mark item as seen. Is called when an item is issued, returned or manually marked during inventory/stocktaking
  99 C<$itemnum> is the item number
 100
 101 =cut
 102
 103 sub itemseen {
 104         my ($itemnum) = @_;
 105         my $dbh = C4::Context->dbh;
 106         my $sth = $dbh->prepare("update items set itemlost=0, datelastseen  = now() where items.itemnumber = ?");
 107         $sth->execute($itemnum);
 108         return;
 109 }
 110
 111 =head2 itemborrowed
 112
 113 &itemseen($itemnum)
 114 Mark item as borrowed. Is called when an item is issued.
 115 C<$itemnum> is the item number
 116
 117 =cut
 118
 119 sub itemborrowed {
 120         my ($itemnum) = @_;
 121         my $dbh = C4::Context->dbh;
 122         my $sth = $dbh->prepare("update items set itemlost=0, datelastborrowed  = now() where items.itemnumber = ?");
 123         $sth->execute($itemnum);
 124         return;
 125 }
 126
 127 sub listitemsforinventory {
 128         my ($minlocation,$maxlocation,$datelastseen,$offset,$size) = @_;
 129         my $dbh = C4::Context->dbh;
 130         my $sth = $dbh->prepare("select itemnumber,barcode,itemcallnumber,title,author from items,biblio where items.biblionumber=biblio.biblionumber and itemcallnumber>= ? and itemcallnumber <=? and (datelastseen< ? or datelastseen is null) order by itemcallnumber,title");
 131         $sth->execute($minlocation,$maxlocation,$datelastseen);
 132         my @results;
 133         while (my $row = $sth->fetchrow_hashref) {
 134                 $offset-- if ($offset);
 135                 if ((!$offset) && $size) {
 136                         push @results,$row;
 137                         $size--;
 138                 }
 139         }
 140         return \@results;
 141 }
 142
 143 =head2 getpatroninformation
 144
 145   ($borrower, $flags) = &getpatroninformation($env, $borrowernumber, $cardnumber);
 146
 147 Looks up a patron and returns information about him or her. If
 148 C<$borrowernumber> is true (nonzero), C<&getpatroninformation> looks
 149 up the borrower by number; otherwise, it looks up the borrower by card
 150 number.
 151
 152 C<$env> is effectively ignored, but should be a reference-to-hash.
 153
 154 C<$borrower> is a reference-to-hash whose keys are the fields of the
 155 borrowers table in the Koha database. In addition,
 156 C<$borrower-E<gt>{flags}> is a hash giving more detailed information
 157 about the patron. Its keys act as flags :
 158
 159         if $borrower->{flags}->{LOST} {
 160                 # Patron's card was reported lost
 161         }
 162
 163 Each flag has a C<message> key, giving a human-readable explanation of
 164 the flag. If the state of a flag means that the patron should not be
 165 allowed to borrow any more books, then it will have a C<noissues> key
 166 with a true value.
 167
 168 The possible flags are:
 169
 170 =head3 CHARGES
 171
 172 =over 4
 173
 174 Shows the patron's credit or debt, if any.
 175
 176 =back
 177
 178 =head3 GNA
 179
 180 =over 4
 181
 182 (Gone, no address.) Set if the patron has left without giving a
 183 forwarding address.
 184
 185 =back
 186
 187 =head3 LOST
 188
 189 =over 4
 190
 191 Set if the patron's card has been reported as lost.
 192
 193 =back
 194
 195 =head3 DBARRED
 196
 197 =over 4
 198
 199 Set if the patron has been debarred.
 200
 201 =back
 202
 203 =head3 NOTES
 204
 205 =over 4
 206
 207 Any additional notes about the patron.
 208
 209 =back
 210
 211 =head3 ODUES
 212
 213 =over 4
 214
 215 Set if the patron has overdue items. This flag has several keys:
 216
 217 C<$flags-E<gt>{ODUES}{itemlist}> is a reference-to-array listing the
 218 overdue items. Its elements are references-to-hash, each describing an
 219 overdue item. The keys are selected fields from the issues, biblio,
 220 biblioitems, and items tables of the Koha database.
 221
 222 C<$flags-E<gt>{ODUES}{itemlist}> is a string giving a text listing of
 223 the overdue items, one per line.
 224
 225 =back
 226
 227 =head3 WAITING
 228
 229 =over 4
 230
 231 Set if any items that the patron has reserved are available.
 232
 233 C<$flags-E<gt>{WAITING}{itemlist}> is a reference-to-array listing the
 234 available items. Each element is a reference-to-hash whose keys are
 235 fields from the reserves table of the Koha database.
 236
 237 =back
 238
 239 =back
 240
 241 =cut
 242
 243
 244 sub getpatroninformation {
 245 # returns
 246         my ($env, $borrowernumber,$cardnumber) = @_;
 247         my $dbh = C4::Context->dbh;
 248         my $query;
 249         my $sth;
 250         if ($borrowernumber) {
 251                 $sth = $dbh->prepare("select * from borrowers where borrowernumber=?");
 252                 $sth->execute($borrowernumber);
 253         } elsif ($cardnumber) {
 254                 $sth = $dbh->prepare("select * from borrowers where cardnumber=?");
 255                 $sth->execute($cardnumber);
 256         } else {
 257                 $env->{'apierror'} = "invalid borrower information passed to getpatroninformation subroutine";
 258                 return();
 259         }
 260         my $borrower = $sth->fetchrow_hashref;
 261         my $amount = checkaccount($env, $borrowernumber, $dbh);
 262         $borrower->{'amountoutstanding'} = $amount;
 263         my $flags = patronflags($env, $borrower, $dbh);
 264         my $accessflagshash;
 265
 266         $sth=$dbh->prepare("select bit,flag from userflags");
 267         $sth->execute;
 268         while (my ($bit, $flag) = $sth->fetchrow) {
 269                 if ($borrower->{'flags'} && $borrower->{'flags'} & 2**$bit) {
 270                 $accessflagshash->{$flag}=1;
 271                 }
 272         }
 273         $sth->finish;
 274         $borrower->{'flags'}=$flags;
 275         $borrower->{'authflags'} = $accessflagshash;
 276         return ($borrower); #, $flags, $accessflagshash);
 277 }
 278
 279 =head2 decode
 280
 281 =over 4
 282
 283 =head3 $str = &decode($chunk);
 284
 285 =over 4
 286
 287 Decodes a segment of a string emitted by a CueCat barcode scanner and
 288 returns it.
 289
 290 =back
 291
 292 =back
 293
 294 =cut
 295
 296 # FIXME - At least, I'm pretty sure this is for decoding CueCat stuff.
 297 sub decode {
 298         my ($encoded) = @_;
 299         my $seq = 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789+-';
 300         my @s = map { index($seq,$_); } split(//,$encoded);
 301         my $l = ($#s+1) % 4;
 302         if ($l)
 303         {
 304                 if ($l == 1)
 305                 {
 306                         print "Error!";
 307                         return;
 308                 }
 309                 $l = 4-$l;
 310                 $#s += $l;
 311         }
 312         my $r = '';
 313         while ($#s >= 0)
 314         {
 315                 my $n = (($s[0] << 6 | $s[1]) << 6 | $s[2]) << 6 | $s[3];
 316                 $r .=chr(($n >> 16) ^ 67) .
 317                 chr(($n >> 8 & 255) ^ 67) .
 318                 chr(($n & 255) ^ 67);
 319                 @s = @s[4..$#s];
 320         }
 321         $r = substr($r,0,length($r)-$l);
 322         return $r;
 323 }
 324
 325 =head2 getiteminformation
 326
 327 =over 4
 328
 329 $item = &getiteminformation($env, $itemnumber, $barcode);
 330
 331 Looks up information about an item, given either its item number or
 332 its barcode. If C<$itemnumber> is a nonzero value, it is used;
 333 otherwise, C<$barcode> is used.
 334
 335 C<$env> is effectively ignored, but should be a reference-to-hash.
 336
 337 C<$item> is a reference-to-hash whose keys are fields from the biblio,
 338 items, and biblioitems tables of the Koha database. It may also
 339 contain the following keys:
 340
 341 =head3 date_due
 342
 343 =over 4
 344
 345 The due date on this item, if it has been borrowed and not returned
 346 yet. The date is in YYYY-MM-DD format.
 347
 348 =back
 349
 350 =head3 notforloan
 351
 352 =over 4
 353
 354 True if the item may not be borrowed.
 355
 356 =back
 357
 358 =back
 359
 360 =cut
 361
 362
 363 sub getiteminformation {
 364 # returns a hash of item information given either the itemnumber or the barcode
 365         my ($env, $itemnumber, $barcode) = @_;
 366         my $dbh = C4::Context->dbh;
 367         my $sth;
 368         if ($itemnumber) {
 369                 $sth=$dbh->prepare("select * from biblio,items,biblioitems where items.itemnumber=? and biblio.biblionumber=items.biblionumber and biblioitems.biblioitemnumber = items.biblioitemnumber");
 370                 $sth->execute($itemnumber);
 371         } elsif ($barcode) {
 372                 $sth=$dbh->prepare("select * from biblio,items,biblioitems where items.barcode=? and biblio.biblionumber=items.biblionumber and biblioitems.biblioitemnumber = items.biblioitemnumber");
 373                 $sth->execute($barcode);
 374         } else {
 375                 $env->{'apierror'}="getiteminformation() subroutine must be called with either an itemnumber or a barcode";
 376                 # Error condition.
 377                 return();
 378         }
 379         my $iteminformation=$sth->fetchrow_hashref;
 380         $sth->finish;
 381         if ($iteminformation) {
 382                 $sth=$dbh->prepare("select date_due from issues where itemnumber=? and isnull(returndate)");
 383                 $sth->execute($iteminformation->{'itemnumber'});
 384                 my ($date_due) = $sth->fetchrow;
 385                 $iteminformation->{'date_due'}=$date_due;
 386                 $sth->finish;
 387                 ($iteminformation->{'dewey'} == 0) && ($iteminformation->{'dewey'}='');
 388                 $sth=$dbh->prepare("select * from itemtypes where itemtype=?");
 389                 $sth->execute($iteminformation->{'itemtype'});
 390                 my $itemtype=$sth->fetchrow_hashref;
 391                 # if specific item notforloan, don't use itemtype notforloan field.
 392                 # otherwise, use itemtype notforloan value to see if item can be issued.
 393                 $iteminformation->{'notforloan'}=$itemtype->{'notforloan'} unless $iteminformation->{'notforloan'};
 394                 $sth->finish;
 395         }
 396         return($iteminformation);
 397 }
 398
 399 =head2 transferbook
 400
 401 =over 4
 402
 403 ($dotransfer, $messages, $iteminformation) = &transferbook($newbranch, $barcode, $ignore_reserves);
 404
 405 Transfers an item to a new branch. If the item is currently on loan, it is automatically returned before the actual transfer.
 406
 407 C<$newbranch> is the code for the branch to which the item should be transferred.
 408
 409 C<$barcode> is the barcode of the item to be transferred.
 410
 411 If C<$ignore_reserves> is true, C<&transferbook> ignores reserves.
 412 Otherwise, if an item is reserved, the transfer fails.
 413
 414 Returns three values:
 415
 416 =head3 $dotransfer
 417
 418 is true if the transfer was successful.
 419
 420 =head3 $messages
 421
 422 is a reference-to-hash which may have any of the following keys:
 423
 424 =over 4
 425
 426 C<BadBarcode>
 427
 428 There is no item in the catalog with the given barcode. The value is C<$barcode>.
 429
 430 C<IsPermanent>
 431
 432 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.
 433
 434 C<DestinationEqualsHolding>
 435
 436 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.
 437
 438 C<WasReturned>
 439
 440 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.
 441
 442 C<ResFound>
 443
 444 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>.
 445
 446 C<WasTransferred>
 447
 448 The item was eligible to be transferred. Barring problems communicating with the database, the transfer should indeed have succeeded. The value should be ignored.
 449
 450 =back
 451
 452 =back
 453
 454 =back
 455
 456 =cut
 457
 458 #'
 459 # FIXME - This function tries to do too much, and its API is clumsy.
 460 # If it didn't also return books, it could be used to change the home
 461 # branch of a book while the book is on loan.
 462 #
 463 # Is there any point in returning the item information? The caller can
 464 # look that up elsewhere if ve cares.
 465 #
 466 # This leaves the ($dotransfer, $messages) tuple. This seems clumsy.
 467 # If the transfer succeeds, that's all the caller should need to know.
 468 # Thus, this function could simply return 1 or 0 to indicate success
 469 # or failure, and set $C4::Circulation::Circ2::errmsg in case of
 470 # failure. Or this function could return undef if successful, and an
 471 # error message in case of failure (this would feel more like C than
 472 # Perl, though).
 473 sub transferbook {
 474 # transfer book code....
 475         my ($tbr, $barcode, $ignoreRs) = @_;
 476         my $messages;
 477         my %env;
 478         my $dotransfer = 1;
 479         my $branches = getbranches();
 480         my $iteminformation = getiteminformation(\%env, 0, $barcode);
 481         # bad barcode..
 482         if (not $iteminformation) {
 483                 $messages->{'BadBarcode'} = $barcode;
 484                 $dotransfer = 0;
 485         }
 486         # get branches of book...
 487         my $hbr = $iteminformation->{'homebranch'};
 488         my $fbr = $iteminformation->{'holdingbranch'};
 489         # if is permanent...
 490         if ($hbr && $branches->{$hbr}->{'PE'}) {
 491                 $messages->{'IsPermanent'} = $hbr;
 492         }
 493         # can't transfer book if is already there....
 494         # FIXME - Why not? Shouldn't it trivially succeed?
 495         if ($fbr eq $tbr) {
 496                 $messages->{'DestinationEqualsHolding'} = 1;
 497                 $dotransfer = 0;
 498         }
 499         # check if it is still issued to someone, return it...
 500         my ($currentborrower) = currentborrower($iteminformation->{'itemnumber'});
 501         if ($currentborrower) {
 502                 returnbook($barcode, $fbr);
 503                 $messages->{'WasReturned'} = $currentborrower;
 504         }
 505         # find reserves.....
 506         # FIXME - Don't call &CheckReserves unless $ignoreRs is true.
 507         # That'll save a database query.
 508         my ($resfound, $resrec) = CheckReserves($iteminformation->{'itemnumber'});
 509         if ($resfound and not $ignoreRs) {
 510                 $resrec->{'ResFound'} = $resfound;
 511 #               $messages->{'ResFound'} = $resrec;
 512                 $dotransfer = 1;
 513         }
 514
 515         if ($dotransfer and not $resfound) {
 516                 dotransfer($iteminformation->{'itemnumber'}, $fbr, $tbr);
 517                 $messages->{'WasTransfered'} = 1;
 518         }
 519         return ($dotransfer, $messages, $iteminformation);
 520 }
 521
 522 # Not exported
 523 # FIXME - This is only used in &transferbook. Why bother making it a
 524 # separate function?
 525 sub dotransfer {
 526         my ($itm, $fbr, $tbr) = @_;
 527         my $dbh = C4::Context->dbh;
 528         $itm = $dbh->quote($itm);
 529         $fbr = $dbh->quote($fbr);
 530         $tbr = $dbh->quote($tbr);
 531         #new entry in branchtransfers....
 532         $dbh->do("INSERT INTO branchtransfers (itemnumber, frombranch, datesent, tobranch)
 533                                         VALUES ($itm, $fbr, now(), $tbr)");
 534         #update holdingbranch in items .....
 535         $dbh->do("UPDATE items set holdingbranch = $tbr WHERE items.itemnumber = $itm");
 536         &itemseen($itm);
 537         &domarctransfer($dbh,$itm);
 538         return;
 539 }
 540
 541 ##New sub to dotransfer in marc tables as well. Not exported -TG 10/04/2006
 542 sub domarctransfer{
 543
 544 my ($dbh,$itemnumber) = @_;
 545 $itemnumber=~s /\'//g; ##itemnumber seems to come with quotes-TG
 546 my $sth=$dbh->prepare("select biblionumber,holdingbranch from items where itemnumber=$itemnumber");
 547         $sth->execute();
 548 while (my ($biblionumber,$holdingbranch)=$sth->fetchrow ){
 549 &MARCmoditemonefield($dbh,$biblionumber,$itemnumber,'items.holdingbranch',$holdingbranch,0);
 550 }
 551 return;
 552 }
 553
 554 =head2 canbookbeissued
 555
 556 Check if a book can be issued.
 557
 558 my ($issuingimpossible,$needsconfirmation) = canbookbeissued($env,$borrower,$barcode,$year,$month,$day);
 559
 560 =over 4
 561
 562 C<$env> Environment variable. Should be empty usually, but used by other subs. Next code cleaning could drop it.
 563
 564 C<$borrower> hash with borrower informations (from getpatroninformation)
 565
 566 C<$barcode> is the bar code of the book being issued.
 567
 568 C<$year> C<$month> C<$day> contains the date of the return (in case it's forced by "stickyduedate".
 569
 570 =back
 571
 572 Returns :
 573
 574 =over 4
 575
 576 C<$issuingimpossible> a reference to a hash. It contains reasons why issuing is impossible.
 577 Possible values are :
 578
 579 =head3 INVALID_DATE
 580
 581 sticky due date is invalid
 582
 583 =head3 GNA
 584
 585 borrower gone with no address
 586
 587 =head3 CARD_LOST
 588
 589 borrower declared it's card lost
 590
 591 =head3 DEBARRED
 592
 593 borrower debarred
 594
 595 =head3 UNKNOWN_BARCODE
 596
 597 barcode unknown
 598
 599 =head3 NOT_FOR_LOAN
 600
 601 item is not for loan
 602
 603 =head3 WTHDRAWN
 604
 605 item withdrawn.
 606
 607 =head3 RESTRICTED
 608
 609 item is restricted (set by ??)
 610
 611 =back
 612
 613 C<$issuingimpossible> a reference to a hash. It contains reasons why issuing is impossible.
 614 Possible values are :
 615
 616 =head3 DEBT
 617
 618 borrower has debts.
 619
 620 =head3 RENEW_ISSUE
 621
 622 renewing, not issuing
 623
 624 =head3 ISSUED_TO_ANOTHER
 625
 626 issued to someone else.
 627
 628 =head3 RESERVED
 629
 630 reserved for someone else.
 631
 632 =head3 INVALID_DATE
 633
 634 sticky due date is invalid
 635
 636 =head3 TOO_MANY
 637
 638 if the borrower borrows to much things
 639
 640 =cut
 641
 642 # check if a book can be issued.
 643 # returns an array with errors if any
 644
 645 sub TooMany ($$){
 646         my $borrower = shift;
 647         my $iteminformation = shift;
 648         my $cat_borrower = $borrower->{'categorycode'};
 649         my $branch_borrower = $borrower->{'branchcode'};
 650         my $dbh = C4::Context->dbh;
 651
 652
 653         my $sth = $dbh->prepare('select itemtype from biblioitems where biblionumber = ?');
 654         $sth->execute($iteminformation->{'biblionumber'});
 655         my $type = $sth->fetchrow;
 656         $sth = $dbh->prepare('select * from issuingrules where categorycode = ? and itemtype = ? and branchcode = ?');
 657 #       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 ?");
 658         my $sth2 = $dbh->prepare("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");
 659         my $sth3 = $dbh->prepare('select COUNT(*) from issues where borrowernumber = ? and returndate is null');
 660         my $alreadyissued;
 661         # check the 3 parameters
 662         $sth->execute($cat_borrower, $type, $branch_borrower);
 663         my $result = $sth->fetchrow_hashref;
 664 #       warn "==>".$result->{maxissueqty};
 665         if (defined($result)) {
 666                 $sth2->execute($borrower->{'borrowernumber'}, "%$type%");
 667                 my $alreadyissued = $sth2->fetchrow;
 668                 return ("a $alreadyissued / ".($result->{maxissueqty}+0)) if ($result->{'maxissueqty'} <= $alreadyissued);
 669         }
 670         # check for branch=*
 671         $sth->execute($cat_borrower, $type, "");
 672         $result = $sth->fetchrow_hashref;
 673         if (defined($result)) {
 674                 $sth2->execute($borrower->{'borrowernumber'}, "%$type%");
 675                 my $alreadyissued = $sth2->fetchrow;
 676                 return ("b $alreadyissued / ".($result->{maxissueqty}+0)) if ($result->{'maxissueqty'} <= $alreadyissued);
 677         }
 678         # check for itemtype=*
 679         $sth->execute($cat_borrower, "*", $branch_borrower);
 680         $result = $sth->fetchrow_hashref;
 681         if (defined($result)) {
 682                 $sth3->execute($borrower->{'borrowernumber'});
 683                 my ($alreadyissued) = $sth3->fetchrow;
 684                 warn "HERE : $alreadyissued / ($result->{maxissueqty} for $borrower->{'borrowernumber'}";
 685                 return ("c $alreadyissued / ".($result->{maxissueqty}+0)) if ($result->{'maxissueqty'} <= $alreadyissued);
 686         }
 687         #check for borrowertype=*
 688         $sth->execute("*", $type, $branch_borrower);
 689         $result = $sth->fetchrow_hashref;
 690         if (defined($result)) {
 691                 $sth2->execute($borrower->{'borrowernumber'}, "%$type%");
 692                 my $alreadyissued = $sth2->fetchrow;
 693                 return ("d $alreadyissued / ".($result->{maxissueqty}+0)) if ($result->{'maxissueqty'} <= $alreadyissued);
 694         }
 695
 696         $sth->execute("*", "*", $branch_borrower);
 697         $result = $sth->fetchrow_hashref;
 698         if (defined($result)) {
 699                 $sth3->execute($borrower->{'borrowernumber'});
 700                 my $alreadyissued = $sth3->fetchrow;
 701                 return ("e $alreadyissued / ".($result->{maxissueqty}+0)) if ($result->{'maxissueqty'} <= $alreadyissued);
 702         }
 703
 704         $sth->execute("*", $type, "");
 705         $result = $sth->fetchrow_hashref;
 706         if (defined($result) && $result->{maxissueqty}>=0) {
 707                 $sth2->execute($borrower->{'borrowernumber'}, "%$type%");
 708                 my $alreadyissued = $sth2->fetchrow;
 709                 return ("f $alreadyissued / ".($result->{maxissueqty}+0)) if ($result->{'maxissueqty'} <= $alreadyissued);
 710         }
 711
 712         $sth->execute($cat_borrower, "*", "");
 713         $result = $sth->fetchrow_hashref;
 714         if (defined($result)) {
 715                 $sth2->execute($borrower->{'borrowernumber'}, "%$type%");
 716                 my $alreadyissued = $sth2->fetchrow;
 717                 return ("g $alreadyissued / ".($result->{maxissueqty}+0)) if ($result->{'maxissueqty'} <= $alreadyissued);
 718         }
 719
 720         $sth->execute("*", "*", "");
 721         $result = $sth->fetchrow_hashref;
 722         if (defined($result)) {
 723                 $sth3->execute($borrower->{'borrowernumber'});
 724                 my $alreadyissued = $sth3->fetchrow;
 725                 return ("h $alreadyissued / ".($result->{maxissueqty}+0)) if ($result->{'maxissueqty'} <= $alreadyissued);
 726         }
 727         return;
 728 }
 729
 730
 731 sub canbookbeissued {
 732         my ($env,$borrower,$barcode,$year,$month,$day) = @_;
 733         my %needsconfirmation; # filled with problems that needs confirmations
 734         my %issuingimpossible; # filled with problems that causes the issue to be IMPOSSIBLE
 735         my $iteminformation = getiteminformation($env, 0, $barcode);
 736         my $dbh = C4::Context->dbh;
 737 #
 738 # DUE DATE is OK ?
 739 #
 740         my ($duedate, $invalidduedate) = fixdate($year, $month, $day);
 741         $issuingimpossible{INVALID_DATE} = 1 if ($invalidduedate);
 742
 743 #
 744 # BORROWER STATUS
 745 #
 746         if ($borrower->{flags}->{GNA}) {
 747                 $issuingimpossible{GNA} = 1;
 748         }
 749         if ($borrower->{flags}->{'LOST'}) {
 750                 $issuingimpossible{CARD_LOST} = 1;
 751         }
 752         if ($borrower->{flags}->{'DBARRED'}) {
 753                 $issuingimpossible{DEBARRED} = 1;
 754         }
 755         if (&Date_Cmp(&ParseDate($borrower->{dateexpiry}),&ParseDate("today"))<0) {
 756                 $issuingimpossible{EXPIRED} = 1;
 757         }
 758 #
 759 # BORROWER STATUS
 760 #
 761
 762 # DEBTS
 763         my $amount = checkaccount($env,$borrower->{'borrowernumber'}, $dbh,$duedate);
 764         if ($amount >0) {
 765                 $needsconfirmation{DEBT} = $amount;
 766         }
 767
 768
 769 #
 770 # JB34 CHECKS IF BORROWERS DONT HAVE ISSUE TOO MANY BOOKS
 771 #
 772         my $toomany = TooMany($borrower, $iteminformation);
 773         $needsconfirmation{TOO_MANY} =  $toomany if $toomany;
 774
 775 #
 776 # ITEM CHECKING
 777 #
 778         unless ($iteminformation->{barcode}) {
 779                 $issuingimpossible{UNKNOWN_BARCODE} = 1;
 780         }
 781         if ($iteminformation->{'notforloan'} && $iteminformation->{'notforloan'} > 0) {
 782                 $issuingimpossible{NOT_FOR_LOAN} = 1;
 783         }
 784         if ($iteminformation->{'itemtype'} &&$iteminformation->{'itemtype'} eq 'REF') {
 785                 $issuingimpossible{NOT_FOR_LOAN} = 1;
 786         }
 787         if ($iteminformation->{'wthdrawn'} && $iteminformation->{'wthdrawn'} == 1) {
 788                 $issuingimpossible{WTHDRAWN} = 1;
 789         }
 790         if ($iteminformation->{'restricted'} && $iteminformation->{'restricted'} == 1) {
 791                 $issuingimpossible{RESTRICTED} = 1;
 792         }
 793
 794
 795
 796 #
 797 # CHECK IF BOOK ALREADY ISSUED TO THIS BORROWER
 798 #
 799         my ($currentborrower) = currentborrower($iteminformation->{'itemnumber'});
 800         if ($currentborrower && $currentborrower eq $borrower->{'borrowernumber'}) {
 801 # Already issued to current borrower. Ask whether the loan should
 802 # be renewed.
 803                 my ($renewstatus) = renewstatus($env, $borrower->{'borrowernumber'}, $iteminformation->{'itemnumber'});
 804                 if ($renewstatus == 0) { # no more renewals allowed
 805                         $issuingimpossible{NO_MORE_RENEWALS} = 1;
 806                 } else {
 807                         $needsconfirmation{RENEW_ISSUE} = 1;
 808                 }
 809         } elsif ($currentborrower) {
 810 # issued to someone else
 811                 my $currborinfo = getpatroninformation(0,$currentborrower);
 812 #               warn "=>.$currborinfo->{'firstname'} $currborinfo->{'surname'} ($currborinfo->{'cardnumber'})";
 813                 $needsconfirmation{ISSUED_TO_ANOTHER} = "$currborinfo->{'reservedate'} : $currborinfo->{'firstname'} $currborinfo->{'surname'} ($currborinfo->{'cardnumber'})";
 814         }
 815 # See if the item is on reserve.
 816         my ($restype, $res) = CheckReserves($iteminformation->{'itemnumber'});
 817         if ($restype) {
 818                 my $resbor = $res->{'borrowernumber'};
 819                 if ($resbor ne $borrower->{'borrowernumber'} && $restype eq "Waiting") {
 820                         # The item is on reserve and waiting, but has been
 821                         # reserved by some other patron.
 822                         my ($resborrower, $flags)=getpatroninformation($env, $resbor,0);
 823                         my $branches = getbranches();
 824                         my $branchname = $branches->{$res->{'branchcode'}}->{'branchname'};
 825                         $needsconfirmation{RESERVE_WAITING} = "$resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'}, $branchname)";
 826                         # CancelReserve(0, $res->{'itemnumber'}, $res->{'borrowernumber'}); Doesn't belong in a checking subroutine.
 827                 } elsif ($restype eq "Reserved") {
 828                         # The item is on reserve for someone else.
 829                         my ($resborrower, $flags)=getpatroninformation($env, $resbor,0);
 830                         my $branches = getbranches();
 831                         my $branchname = $branches->{$res->{'branchcode'}}->{'branchname'};
 832                         $needsconfirmation{RESERVED} = "$res->{'reservedate'} : $resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'})";
 833                 }
 834         }
 835         return(\%issuingimpossible,\%needsconfirmation);
 836 }
 837
 838 =head2 issuebook
 839
 840 Issue a book. Does no check, they are done in canbookbeissued. If we reach this sub, it means the user confirmed if needed.
 841
 842 &issuebook($env,$borrower,$barcode,$date)
 843
 844 =over 4
 845
 846 C<$env> Environment variable. Should be empty usually, but used by other subs. Next code cleaning could drop it.
 847
 848 C<$borrower> hash with borrower informations (from getpatroninformation)
 849
 850 C<$barcode> is the bar code of the book being issued.
 851
 852 C<$date> contains the max date of return. calculated if empty.
 853
 854 =cut
 855
 856 #
 857 # issuing book. We already have checked it can be issued, so, just issue it !
 858 #
 859 sub issuebook {
 860         my ($env,$borrower,$barcode,$date,$cancelreserve) = @_;
 861         my $dbh = C4::Context->dbh;
 862 #       my ($borrower, $flags) = &getpatroninformation($env, $borrowernumber, 0);
 863         my $iteminformation = getiteminformation($env, 0, $barcode);
 864 #               warn "B : ".$borrower->{borrowernumber}." / I : ".$iteminformation->{'itemnumber'};
 865 #
 866 # check if we just renew the issue.
 867 #
 868         my ($currentborrower) = currentborrower($iteminformation->{'itemnumber'});
 869         if ($currentborrower eq $borrower->{'borrowernumber'}) {
 870                 my ($charge,$itemtype) = calc_charges($env, $iteminformation->{'itemnumber'}, $borrower->{'borrowernumber'});
 871                 if ($charge > 0) {
 872                         createcharge($env, $dbh, $iteminformation->{'itemnumber'}, $borrower->{'borrowernumber'}, $charge);
 873                         $iteminformation->{'charge'} = $charge;
 874                 }
 875                 &UpdateStats($env,$env->{'branchcode'},'renew',$charge,'',$iteminformation->{'itemnumber'},$iteminformation->{'itemtype'},$borrower->{'borrowernumber'});
 876                 renewbook($env, $borrower->{'borrowernumber'}, $iteminformation->{'itemnumber'});
 877         } else {
 878 #
 879 # NOT a renewal
 880 #
 881                 if ($currentborrower ne '') {
 882                         # This book is currently on loan, but not to the person
 883                         # who wants to borrow it now. mark it returned before issuing to the new borrower
 884                         returnbook($iteminformation->{'barcode'}, $env->{'branchcode'});
 885                 }
 886                 # See if the item is on reserve.
 887                 my ($restype, $res) = CheckReserves($iteminformation->{'itemnumber'});
 888                 if ($restype) {
 889                         my $resbor = $res->{'borrowernumber'};
 890                         if ($resbor eq $borrower->{'borrowernumber'}) {
 891                                 # The item is on reserve to the current patron
 892                                 FillReserve($res);
 893                                 warn "FillReserve";
 894                         } elsif ($restype eq "Waiting") {
 895                                 warn "Waiting";
 896                                 # The item is on reserve and waiting, but has been
 897                                 # reserved by some other patron.
 898                                 my ($resborrower, $flags)=getpatroninformation($env, $resbor,0);
 899                                 my $branches = getbranches();
 900                                 my $branchname = $branches->{$res->{'branchcode'}}->{'branchname'};
 901                 if ($cancelreserve){
 902                                 CancelReserve(0, $res->{'itemnumber'}, $res->{'borrowernumber'});
 903                 }
 904                         } elsif ($restype eq "Reserved") {
 905 #                               warn "Reserved";
 906                                 # The item is on reserve for someone else.
 907                                 my ($resborrower, $flags)=getpatroninformation($env, $resbor,0);
 908                                 my $branches = getbranches();
 909                                 my $branchname = $branches->{$res->{'branchcode'}}->{'branchname'};
 910                                 if ($cancelreserve) {
 911                                         # cancel reserves on this item
 912                                         CancelReserve(0, $res->{'itemnumber'}, $res->{'borrowernumber'});
 913                                         # also cancel reserve on biblio related to this item
 914                                         #my $st_Fbiblio = $dbh->prepare("select biblionumber from items where itemnumber=?");
 915                                         #$st_Fbiblio->execute($res->{'itemnumber'});
 916                                         #my $biblionumber = $st_Fbiblio->fetchrow;
 917                                         #CancelReserve($biblionumber,0,$res->{'borrowernumber'});
 918                                         #warn "CancelReserve $res->{'itemnumber'}, $res->{'borrowernumber'}";
 919                                 } else {
 920 #                                       my $tobrcd = ReserveWaiting($res->{'itemnumber'}, $res->{'borrowernumber'});
 921 #                                       transferbook($tobrcd,$barcode, 1);
 922 #                                       warn "transferbook";
 923                                 }
 924                         }
 925                 }
 926                 # Record in the database the fact that the book was issued.
 927                 my $sth=$dbh->prepare("insert into issues (borrowernumber, itemnumber, date_due, branchcode) values (?,?,?,?)");
 928                 my $loanlength = getLoanLength($borrower->{'categorycode'},$iteminformation->{'itemtype'},$borrower->{'branchcode'});
 929                 my $datedue=time+($loanlength)*86400;
 930                 my @datearr = localtime($datedue);
 931                 my $dateduef = (1900+$datearr[5])."-".($datearr[4]+1)."-".$datearr[3];
 932                 if ($date) {
 933                         $dateduef=$date;
 934                 }
 935                 # if ReturnBeforeExpiry ON the datedue can't be after borrower expirydate
 936                 if (C4::Context->preference('ReturnBeforeExpiry') && $dateduef gt $borrower->{expiry}) {
 937                         $dateduef=$borrower->{expiry};
 938                 }
 939                 $sth->execute($borrower->{'borrowernumber'}, $iteminformation->{'itemnumber'}, $dateduef, $env->{'branchcode'});
 940                 $sth->finish;
 941                 $iteminformation->{'issues'}++;
 942                 $sth=$dbh->prepare("update items set issues=?, holdingbranch=? where itemnumber=?");
 943                 $sth->execute($iteminformation->{'issues'},C4::Context->userenv->{'branch'},$iteminformation->{'itemnumber'});
 944                 $sth->finish;
 945                 &itemseen($iteminformation->{'itemnumber'});
 946                 itemborrowed($iteminformation->{'itemnumber'});
 947                 # If it costs to borrow this book, charge it to the patron's account.
 948                 my ($charge,$itemtype)=calc_charges($env, $iteminformation->{'itemnumber'}, $borrower->{'borrowernumber'});
 949                 if ($charge > 0) {
 950                         createcharge($env, $dbh, $iteminformation->{'itemnumber'}, $borrower->{'borrowernumber'}, $charge);
 951                         $iteminformation->{'charge'}=$charge;
 952                 }
 953                 # Record the fact that this book was issued.
 954                 &UpdateStats($env,$env->{'branchcode'},'issue',$charge,'',$iteminformation->{'itemnumber'},$iteminformation->{'itemtype'},$borrower->{'borrowernumber'});
 955         }
 956 }
 957
 958 =head2 getLoanLength
 959
 960 Get loan length for an itemtype, a borrower type and a branch
 961
 962 my $loanlength = &getLoanLength($borrowertype,$itemtype,branchcode)
 963
 964 =cut
 965
 966 sub getLoanLength {
 967         my ($borrowertype,$itemtype,$branchcode) = @_;
 968         my $dbh = C4::Context->dbh;
 969         my $sth = $dbh->prepare("select issuelength from issuingrules where categorycode=? and itemtype=? and branchcode=?");
 970         # try to find issuelength & return the 1st available.
 971         # check with borrowertype, itemtype and branchcode, then without one of those parameters
 972         $sth->execute($borrowertype,$itemtype,$branchcode);
 973         my $loanlength = $sth->fetchrow_hashref;
 974         return $loanlength->{issuelength} if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
 975
 976         $sth->execute($borrowertype,$itemtype,"");
 977         $loanlength = $sth->fetchrow_hashref;
 978         return $loanlength->{issuelength} if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
 979
 980         $sth->execute($borrowertype,"*",$branchcode);
 981         $loanlength = $sth->fetchrow_hashref;
 982         return $loanlength->{issuelength} if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
 983
 984         $sth->execute("*",$itemtype,$branchcode);
 985         $loanlength = $sth->fetchrow_hashref;
 986         return $loanlength->{issuelength} if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
 987
 988         $sth->execute($borrowertype,"*","");
 989         $loanlength = $sth->fetchrow_hashref;
 990         return $loanlength->{issuelength} if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
 991
 992         $sth->execute("*","*",$branchcode);
 993         $loanlength = $sth->fetchrow_hashref;
 994         return $loanlength->{issuelength} if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
 995
 996         $sth->execute("*",$itemtype,"");
 997         $loanlength = $sth->fetchrow_hashref;
 998         return $loanlength->{issuelength} if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
 999
1000         $sth->execute("*","*","");
1001         $loanlength = $sth->fetchrow_hashref;
1002         return $loanlength->{issuelength} if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
1003
1004         # if no rule is set => 21 days (hardcoded)
1005         return 21;
1006 }
1007 =head2 returnbook
1008
1009   ($doreturn, $messages, $iteminformation, $borrower) =
1010           &returnbook($barcode, $branch);
1011
1012 Returns a book.
1013
1014 C<$barcode> is the bar code of the book being returned. C<$branch> is
1015 the code of the branch where the book is being returned.
1016
1017 C<&returnbook> returns a list of four items:
1018
1019 C<$doreturn> is true iff the return succeeded.
1020
1021 C<$messages> is a reference-to-hash giving the reason for failure:
1022
1023 =over 4
1024
1025 =item C<BadBarcode>
1026
1027 No item with this barcode exists. The value is C<$barcode>.
1028
1029 =item C<NotIssued>
1030
1031 The book is not currently on loan. The value is C<$barcode>.
1032
1033 =item C<IsPermanent>
1034
1035 The book's home branch is a permanent collection. If you have borrowed
1036 this book, you are not allowed to return it. The value is the code for
1037 the book's home branch.
1038
1039 =item C<wthdrawn>
1040
1041 This book has been withdrawn/cancelled. The value should be ignored.
1042
1043 =item C<ResFound>
1044
1045 The item was reserved. The value is a reference-to-hash whose keys are
1046 fields from the reserves table of the Koha database, and
1047 C<biblioitemnumber>. It also has the key C<ResFound>, whose value is
1048 either C<Waiting>, C<Reserved>, or 0.
1049
1050 =back
1051
1052 C<$borrower> is a reference-to-hash, giving information about the
1053 patron who last borrowed the book.
1054
1055 =cut
1056
1057 # FIXME - This API is bogus. There's no need to return $borrower and
1058 # $iteminformation; the caller can ask about those separately, if it
1059 # cares (it'd be inefficient to make two database calls instead of
1060 # one, but &getpatroninformation and &getiteminformation can be
1061 # memoized if this is an issue).
1062 #
1063 # The ($doreturn, $messages) tuple is redundant: if the return
1064 # succeeded, that's all the caller needs to know. So &returnbook can
1065 # return 1 and 0 on success and failure, and set
1066 # $C4::Circulation::Circ2::errmsg to indicate the error. Or it can
1067 # return undef for success, and an error message on error (though this
1068 # is more C-ish than Perl-ish).
1069
1070 sub returnbook {
1071         my ($barcode, $branch) = @_;
1072         my %env;
1073         my $messages;
1074         my $dbh = C4::Context->dbh;
1075         my $doreturn = 1;
1076         die '$branch not defined' unless defined $branch; # just in case (bug 170)
1077         # get information on item
1078         my ($iteminformation) = getiteminformation(\%env, 0, $barcode);
1079         if (not $iteminformation) {
1080                 $messages->{'BadBarcode'} = $barcode;
1081                 $doreturn = 0;
1082         }
1083         # find the borrower
1084         my ($currentborrower) = currentborrower($iteminformation->{'itemnumber'});
1085         if ((not $currentborrower) && $doreturn) {
1086                 $messages->{'NotIssued'} = $barcode;
1087                 $doreturn = 0;
1088         }
1089         # check if the book is in a permanent collection....
1090         my $hbr = $iteminformation->{'homebranch'};
1091         my $branches = getbranches();
1092         if ($hbr && $branches->{$hbr}->{'PE'}) {
1093                 $messages->{'IsPermanent'} = $hbr;
1094         }
1095         # check that the book has been cancelled
1096         if ($iteminformation->{'wthdrawn'}) {
1097                 $messages->{'wthdrawn'} = 1;
1098                 $doreturn = 0;
1099         }
1100 #       new op dev : if the book returned in an other branch update the holding branch
1101
1102         # update issues, thereby returning book (should push this out into another subroutine
1103         my ($borrower) = getpatroninformation(\%env, $currentborrower, 0);
1104         if ($doreturn) {
1105                 my $sth = $dbh->prepare("update issues set returndate = now() where (borrowernumber = ?) and (itemnumber = ?) and (returndate is null)");
1106                 $sth->execute($borrower->{'borrowernumber'}, $iteminformation->{'itemnumber'});
1107
1108 #       FIXME the holdingbranch is updated if the document is returned in an other location .
1109                 if ( $iteminformation->{'holdingbranch'} ne C4::Context->userenv->{'branch'}){
1110                 my $sth_upd_location = $dbh->prepare("UPDATE items SET holdingbranch=? WHERE itemnumber=?");
1111                 $sth_upd_location->execute(C4::Context->userenv->{'branch'},$iteminformation->{'itemnumber'});
1112                 $sth_upd_location->finish;
1113                 $iteminformation->{'holdingbranch'} = C4::Context->userenv->{'branch'};
1114                 }
1115
1116                 $messages->{'WasReturned'} = 1; # FIXME is the "= 1" right?
1117         }
1118         itemseen($iteminformation->{'itemnumber'});
1119         ($borrower) = getpatroninformation(\%env, $currentborrower, 0);
1120         # transfer book to the current branch
1121
1122 # FIXME function transfered still always used ????
1123 #       my ($transfered, $mess, $item) = transferbook($branch, $barcode, 1);
1124 #       if ($transfered) {
1125 #               $messages->{'WasTransfered'} = 1; # FIXME is the "= 1" right?
1126 #       }
1127
1128         # fix up the accounts.....
1129         if ($iteminformation->{'itemlost'}) {
1130                 fixaccountforlostandreturned($iteminformation, $borrower);
1131                 $messages->{'WasLost'} = 1; # FIXME is the "= 1" right?
1132         }
1133 # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
1134 #       check if we have a transfer for this document
1135         my $checktransfer = checktransferts($iteminformation->{'itemnumber'});
1136 #       if we have a return, we update the line of transfers with the datearrived
1137         if ($checktransfer){
1138                 my $sth = $dbh->prepare("update branchtransfers set datearrived = now() where itemnumber= ? AND datearrived IS NULL");
1139                 $sth->execute($iteminformation->{'itemnumber'});
1140                 $sth->finish;
1141 #               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'
1142                 my $updateWaiting = SetWaitingStatus($iteminformation->{'itemnumber'});
1143         }
1144 #       if we don't have a transfer on run, we check if the document is not in his homebranch and there is not a reservation, we transfer this one to his home branch directly .
1145         else {
1146         #       new op dev
1147                 my $checkreserves = CheckReserves($iteminformation->{'itemnumber'});
1148                 if (($iteminformation->{'homebranch'} ne $iteminformation->{'holdingbranch'}) and (not $checkreserves)){
1149                         my $automatictransfer = dotransfer($iteminformation->{'itemnumber'},$iteminformation->{'holdingbranch'},$iteminformation->{'homebranch'});
1150                         $messages->{'WasTransfered'} = 1;
1151                 }
1152         }
1153 # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
1154         # fix up the overdues in accounts...
1155         fixoverduesonreturn($borrower->{'borrowernumber'}, $iteminformation->{'itemnumber'});
1156         # find reserves.....
1157 #       if we don't have a reserve with the status W, we launch the Checkreserves routine
1158         my ($resfound, $resrec) = CheckReserves($iteminformation->{'itemnumber'});
1159         if ($resfound) {
1160         #       my $tobrcd = ReserveWaiting($resrec->{'itemnumber'}, $resrec->{'borrowernumber'});
1161                 $resrec->{'ResFound'} = $resfound;
1162                 $messages->{'ResFound'} = $resrec;
1163         }
1164         # update stats?
1165         # Record the fact that this book was returned.
1166         UpdateStats(\%env, $branch ,'return','0','',$iteminformation->{'itemnumber'},$iteminformation->{'itemtype'},$borrower->{'borrowernumber'});
1167         return ($doreturn, $messages, $iteminformation, $borrower);
1168 }
1169
1170 =head2 fixaccountforlostandreturned
1171
1172         &fixaccountforlostandreturned($iteminfo,$borrower);
1173
1174 Calculates the charge for a book lost and returned (Not exported & used only once)
1175
1176 C<$iteminfo> is a hashref to iteminfo. Only {itemnumber} is used.
1177
1178 C<$borrower> is a hashref to borrower. Only {borrowernumber is used.
1179
1180 =cut
1181
1182 sub fixaccountforlostandreturned {
1183         my ($iteminfo, $borrower) = @_;
1184         my %env;
1185         my $dbh = C4::Context->dbh;
1186         my $itm = $iteminfo->{'itemnumber'};
1187         # check for charge made for lost book
1188         my $sth = $dbh->prepare("select * from accountlines where (itemnumber = ?) and (accounttype='L' or accounttype='Rep') order by date desc");
1189         $sth->execute($itm);
1190         if (my $data = $sth->fetchrow_hashref) {
1191         # writeoff this amount
1192                 my $offset;
1193                 my $amount = $data->{'amount'};
1194                 my $acctno = $data->{'accountno'};
1195                 my $amountleft;
1196                 if ($data->{'amountoutstanding'} == $amount) {
1197                 $offset = $data->{'amount'};
1198                 $amountleft = 0;
1199                 } else {
1200                 $offset = $amount - $data->{'amountoutstanding'};
1201                 $amountleft = $data->{'amountoutstanding'} - $amount;
1202                 }
1203                 my $usth = $dbh->prepare("update accountlines set accounttype = 'LR',amountoutstanding='0'
1204                         where (borrowernumber = ?)
1205                         and (itemnumber = ?) and (accountno = ?) ");
1206                 $usth->execute($data->{'borrowernumber'},$itm,$acctno);
1207                 $usth->finish;
1208         #check if any credit is left if so writeoff other accounts
1209                 my $nextaccntno = getnextacctno(\%env,$data->{'borrowernumber'},$dbh);
1210                 if ($amountleft < 0){
1211                 $amountleft*=-1;
1212                 }
1213                 if ($amountleft > 0){
1214                 my $msth = $dbh->prepare("select * from accountlines where (borrowernumber = ?)
1215                                                         and (amountoutstanding >0) order by date");
1216                 $msth->execute($data->{'borrowernumber'});
1217         # offset transactions
1218                 my $newamtos;
1219                 my $accdata;
1220                 while (($accdata=$msth->fetchrow_hashref) and ($amountleft>0)){
1221                         if ($accdata->{'amountoutstanding'} < $amountleft) {
1222                         $newamtos = 0;
1223                         $amountleft -= $accdata->{'amountoutstanding'};
1224                         }  else {
1225                         $newamtos = $accdata->{'amountoutstanding'} - $amountleft;
1226                         $amountleft = 0;
1227                         }
1228                         my $thisacct = $accdata->{'accountno'};
1229                         my $usth = $dbh->prepare("update accountlines set amountoutstanding= ?
1230                                         where (borrowernumber = ?)
1231                                         and (accountno=?)");
1232                         $usth->execute($newamtos,$data->{'borrowernumber'},'$thisacct');
1233                         $usth->finish;
1234                         $usth = $dbh->prepare("insert into accountoffsets
1235                                 (borrowernumber, accountno, offsetaccount,  offsetamount)
1236                                 values
1237                                 (?,?,?,?)");
1238                         $usth->execute($data->{'borrowernumber'},$accdata->{'accountno'},$nextaccntno,$newamtos);
1239                         $usth->finish;
1240                 }
1241                 $msth->finish;
1242                 }
1243                 if ($amountleft > 0){
1244                         $amountleft*=-1;
1245                 }
1246                 my $desc="Book Returned ".$iteminfo->{'barcode'};
1247                 $usth = $dbh->prepare("insert into accountlines
1248                         (borrowernumber,accountno,date,amount,description,accounttype,amountoutstanding)
1249                         values (?,?,now(),?,?,'CR',?)");
1250                 $usth->execute($data->{'borrowernumber'},$nextaccntno,0-$amount,$desc,$amountleft);
1251                 $usth->finish;
1252                 $usth = $dbh->prepare("insert into accountoffsets
1253                         (borrowernumber, accountno, offsetaccount,  offsetamount)
1254                         values (?,?,?,?)");
1255                 $usth->execute($borrower->{'borrowernumber'},$data->{'accountno'},$nextaccntno,$offset);
1256                 $usth->finish;
1257                 $usth = $dbh->prepare("update items set paidfor='' where itemnumber=?");
1258                 $usth->execute($itm);
1259                 $usth->finish;
1260         }
1261         $sth->finish;
1262         return;
1263 }
1264
1265 =head2 fixoverdueonreturn
1266
1267         &fixoverdueonreturn($brn,$itm);
1268
1269 ??
1270
1271 C<$brn> borrowernumber
1272
1273 C<$itm> itemnumber
1274
1275 =cut
1276
1277 sub fixoverduesonreturn {
1278         my ($brn, $itm) = @_;
1279         my $dbh = C4::Context->dbh;
1280         # check for overdue fine
1281         my $sth = $dbh->prepare("select * from accountlines where (borrowernumber = ?) and (itemnumber = ?) and (accounttype='FU' or accounttype='O')");
1282         $sth->execute($brn,$itm);
1283         # alter fine to show that the book has been returned
1284         if (my $data = $sth->fetchrow_hashref) {
1285                 my $usth=$dbh->prepare("update accountlines set accounttype='F' where (borrowernumber = ?) and (itemnumber = ?) and (acccountno = ?)");
1286                 $usth->execute($brn,$itm,$data->{'accountno'});
1287                 $usth->finish();
1288         }
1289         $sth->finish();
1290         return;
1291 }
1292
1293 # Not exported
1294 #
1295 # NOTE!: If you change this function, be sure to update the POD for
1296 # &getpatroninformation.
1297 #
1298 # $flags = &patronflags($env, $patron, $dbh);
1299 #
1300 # $flags->{CHARGES}
1301 #               {message}       Message showing patron's credit or debt
1302 #               {noissues}      Set if patron owes >$5.00
1303 #         {GNA}                 Set if patron gone w/o address
1304 #               {message}       "Borrower has no valid address"
1305 #               {noissues}      Set.
1306 #         {LOST}                Set if patron's card reported lost
1307 #               {message}       Message to this effect
1308 #               {noissues}      Set.
1309 #         {DBARRED}             Set is patron is debarred
1310 #               {message}       Message to this effect
1311 #               {noissues}      Set.
1312 #         {NOTES}               Set if patron has notes
1313 #               {message}       Notes about patron
1314 #         {ODUES}               Set if patron has overdue books
1315 #               {message}       "Yes"
1316 #               {itemlist}      ref-to-array: list of overdue books
1317 #               {itemlisttext}  Text list of overdue items
1318 #         {WAITING}             Set if there are items available that the
1319 #                               patron reserved
1320 #               {message}       Message to this effect
1321 #               {itemlist}      ref-to-array: list of available items
1322 sub patronflags {
1323 # Original subroutine for Circ2.pm
1324         my %flags;
1325         my ($env, $patroninformation, $dbh) = @_;
1326         my $amount = checkaccount($env, $patroninformation->{'borrowernumber'}, $dbh);
1327         if ($amount > 0) {
1328                 my %flaginfo;
1329                 my $noissuescharge = C4::Context->preference("noissuescharge");
1330                 $flaginfo{'message'}= sprintf "Patron owes \$%.02f", $amount;
1331                 if ($amount > $noissuescharge) {
1332                 $flaginfo{'noissues'} = 1;
1333                 }
1334                 $flags{'CHARGES'} = \%flaginfo;
1335         } elsif ($amount < 0){
1336         my %flaginfo;
1337         $flaginfo{'message'} = sprintf "Patron has credit of \$%.02f", -$amount;
1338                 $flags{'CHARGES'} = \%flaginfo;
1339         }
1340         if ($patroninformation->{'gonenoaddress'} && $patroninformation->{'gonenoaddress'} == 1) {
1341                 my %flaginfo;
1342                 $flaginfo{'message'} = 'Borrower has no valid address.';
1343                 $flaginfo{'noissues'} = 1;
1344                 $flags{'GNA'} = \%flaginfo;
1345         }
1346         if ($patroninformation->{'lost'} && $patroninformation->{'lost'} == 1) {
1347                 my %flaginfo;
1348                 $flaginfo{'message'} = 'Borrower\'s card reported lost.';
1349                 $flaginfo{'noissues'} = 1;
1350                 $flags{'LOST'} = \%flaginfo;
1351         }
1352         if ($patroninformation->{'debarred'} && $patroninformation->{'debarred'} == 1) {
1353                 my %flaginfo;
1354                 $flaginfo{'message'} = 'Borrower is Debarred.';
1355                 $flaginfo{'noissues'} = 1;
1356                 $flags{'DBARRED'} = \%flaginfo;
1357         }
1358         if ($patroninformation->{'borrowernotes'} && $patroninformation->{'borrowernotes'}) {
1359                 my %flaginfo;
1360                 $flaginfo{'message'} = "$patroninformation->{'borrowernotes'}";
1361                 $flags{'NOTES'} = \%flaginfo;
1362         }
1363         my ($odues, $itemsoverdue)
1364                         = checkoverdues($env, $patroninformation->{'borrowernumber'}, $dbh);
1365         if ($odues > 0) {
1366                 my %flaginfo;
1367                 $flaginfo{'message'} = "Yes";
1368                 $flaginfo{'itemlist'} = $itemsoverdue;
1369                 foreach (sort {$a->{'date_due'} cmp $b->{'date_due'}} @$itemsoverdue) {
1370                 $flaginfo{'itemlisttext'}.="$_->{'date_due'} $_->{'barcode'} $_->{'title'} \n";
1371                 }
1372                 $flags{'ODUES'} = \%flaginfo;
1373         }
1374         my ($nowaiting, $itemswaiting)
1375                         = CheckWaiting($patroninformation->{'borrowernumber'});
1376         if ($nowaiting > 0) {
1377                 my %flaginfo;
1378                 $flaginfo{'message'} = "Reserved items available";
1379                 $flaginfo{'itemlist'} = $itemswaiting;
1380                 $flags{'WAITING'} = \%flaginfo;
1381         }
1382         return(\%flags);
1383 }
1384
1385
1386 # Not exported
1387 sub checkoverdues {
1388 # From Main.pm, modified to return a list of overdueitems, in addition to a count
1389   #checks whether a borrower has overdue items
1390         my ($env, $bornum, $dbh)=@_;
1391         my @datearr = localtime;
1392         my $today = ($datearr[5] + 1900)."-".($datearr[4]+1)."-".$datearr[3];
1393         my @overdueitems;
1394         my $count = 0;
1395         my $sth = $dbh->prepare("SELECT * FROM issues,biblio,biblioitems,items
1396                         WHERE items.biblioitemnumber = biblioitems.biblioitemnumber
1397                                 AND items.biblionumber     = biblio.biblionumber
1398                                 AND issues.itemnumber      = items.itemnumber
1399                                 AND issues.borrowernumber  = ?
1400                                 AND issues.returndate is NULL
1401                                 AND issues.date_due < ?");
1402         $sth->execute($bornum,$today);
1403         while (my $data = $sth->fetchrow_hashref) {
1404         push (@overdueitems, $data);
1405         $count++;
1406         }
1407         $sth->finish;
1408         return ($count, \@overdueitems);
1409 }
1410
1411 # Not exported
1412 sub currentborrower {
1413 # Original subroutine for Circ2.pm
1414         my ($itemnumber) = @_;
1415         my $dbh = C4::Context->dbh;
1416         my $q_itemnumber = $dbh->quote($itemnumber);
1417         my $sth=$dbh->prepare("select borrowers.borrowernumber from
1418         issues,borrowers where issues.itemnumber=$q_itemnumber and
1419         issues.borrowernumber=borrowers.borrowernumber and issues.returndate is
1420         NULL");
1421         $sth->execute;
1422         my ($borrower) = $sth->fetchrow;
1423         return($borrower);
1424 }
1425
1426 # FIXME - Not exported, but used in 'updateitem.pl' anyway.
1427 sub checkreserve_to_delete {
1428 # Stolen from Main.pm
1429 # Check for reserves for biblio
1430         my ($env,$dbh,$itemnum)=@_;
1431         my $resbor = "";
1432         my $sth = $dbh->prepare("select * from reserves,items
1433         where (items.itemnumber = ?)
1434         and (reserves.cancellationdate is NULL)
1435         and (items.biblionumber = reserves.biblionumber)
1436         and ((reserves.found = 'W')
1437         or (reserves.found is null))
1438         order by priority");
1439         $sth->execute($itemnum);
1440         my $resrec;
1441         my $data=$sth->fetchrow_hashref;
1442         while ($data && $resbor eq '') {
1443         $resrec=$data;
1444         my $const = $data->{'constrainttype'};
1445         if ($const eq "a") {
1446         $resbor = $data->{'borrowernumber'};
1447         } else {
1448         my $found = 0;
1449         my $csth = $dbh->prepare("select * from reserveconstraints,items
1450                 where (borrowernumber=?)
1451                 and reservedate=?
1452                 and reserveconstraints.biblionumber=?
1453                 and (items.itemnumber=? and
1454                 items.biblioitemnumber = reserveconstraints.biblioitemnumber)");
1455         $csth->execute($data->{'borrowernumber'},$data->{'biblionumber'},$data->{'reservedate'},$itemnum);
1456         if (my $cdata=$csth->fetchrow_hashref) {$found = 1;}
1457         if ($const eq 'o') {
1458                 if ($found eq 1) {$resbor = $data->{'borrowernumber'};}
1459         } else {
1460                 if ($found eq 0) {$resbor = $data->{'borrowernumber'};}
1461         }
1462         $csth->finish();
1463         }
1464         $data=$sth->fetchrow_hashref;
1465         }
1466         $sth->finish;
1467         return ($resbor,$resrec);
1468 }
1469
1470 =head2 currentissues
1471
1472   $issues = &currentissues($env, $borrower);
1473
1474 Returns a list of books currently on loan to a patron.
1475
1476 If C<$env-E<gt>{todaysissues}> is set and true, C<&currentissues> only
1477 returns information about books issued today. If
1478 C<$env-E<gt>{nottodaysissues}> is set and true, C<&currentissues> only
1479 returns information about books issued before today. If both are
1480 specified, C<$env-E<gt>{todaysissues}> is ignored. If neither is
1481 specified, C<&currentissues> returns all of the patron's issues.
1482
1483 C<$borrower->{borrowernumber}> is the borrower number of the patron
1484 whose issues we want to list.
1485
1486 C<&currentissues> returns a PHP-style array: C<$issues> is a
1487 reference-to-hash whose keys are integers in the range 1...I<n>, where
1488 I<n> is the number of items on issue (either today or before today).
1489 C<$issues-E<gt>{I<n>}> is a reference-to-hash whose keys are all of
1490 the fields of the biblio, biblioitems, items, and issues fields of the
1491 Koha database for that particular item.
1492
1493 =cut
1494
1495 #'
1496 sub currentissues {
1497 # New subroutine for Circ2.pm
1498         my ($env, $borrower) = @_;
1499         my $dbh = C4::Context->dbh;
1500         my %currentissues;
1501         my $counter=1;
1502         my $borrowernumber = $borrower->{'borrowernumber'};
1503         my $crit='';
1504
1505         # Figure out whether to get the books issued today, or earlier.
1506         # FIXME - $env->{todaysissues} and $env->{nottodaysissues} can
1507         # both be specified, but are mutually-exclusive. This is bogus.
1508         # Make this a flag. Or better yet, return everything in (reverse)
1509         # chronological order and let the caller figure out which books
1510         # were issued today.
1511         if ($env->{'todaysissues'}) {
1512                 # FIXME - Could use
1513                 #       $today = POSIX::strftime("%Y%m%d", localtime);
1514                 # FIXME - Since $today will be used in either case, move it
1515                 # out of the two if-blocks.
1516                 my @datearr = localtime(time());
1517                 my $today = (1900+$datearr[5]).sprintf "%02d", ($datearr[4]+1).sprintf "%02d", $datearr[3];
1518                 # FIXME - MySQL knows about dates. Just use
1519                 #       and issues.timestamp = curdate();
1520                 $crit=" and issues.timestamp like '$today%' ";
1521         }
1522         if ($env->{'nottodaysissues'}) {
1523                 # FIXME - Could use
1524                 #       $today = POSIX::strftime("%Y%m%d", localtime);
1525                 # FIXME - Since $today will be used in either case, move it
1526                 # out of the two if-blocks.
1527                 my @datearr = localtime(time());
1528                 my $today = (1900+$datearr[5]).sprintf "%02d", ($datearr[4]+1).sprintf "%02d", $datearr[3];
1529                 # FIXME - MySQL knows about dates. Just use
1530                 #       and issues.timestamp < curdate();
1531                 $crit=" and !(issues.timestamp like '$today%') ";
1532         }
1533
1534         # FIXME - Does the caller really need every single field from all
1535         # four tables?
1536         my $sth=$dbh->prepare("select * from issues,items,biblioitems,biblio where
1537         borrowernumber=? and issues.itemnumber=items.itemnumber and
1538         items.biblionumber=biblio.biblionumber and
1539         items.biblioitemnumber=biblioitems.biblioitemnumber and returndate is null
1540         $crit order by issues.date_due");
1541         $sth->execute($borrowernumber);
1542         while (my $data = $sth->fetchrow_hashref) {
1543                 # FIXME - The Dewey code is a string, not a number.
1544                 $data->{'dewey'}=~s/0*$//;
1545                 ($data->{'dewey'} == 0) && ($data->{'dewey'}='');
1546                 # FIXME - Could use
1547                 #       $todaysdate = POSIX::strftime("%Y%m%d", localtime)
1548                 # or better yet, just reuse $today which was calculated above.
1549                 # This function isn't going to run until midnight, is it?
1550                 # Alternately, use
1551                 #       $todaysdate = POSIX::strftime("%Y-%m-%d", localtime)
1552                 #       if ($data->{'date_due'} lt $todaysdate)
1553                 #               ...
1554                 # Either way, the date should be be formatted outside of the
1555                 # loop.
1556                 my @datearr = localtime(time());
1557                 my $todaysdate = (1900+$datearr[5]).sprintf ("%0.2d", ($datearr[4]+1)).sprintf ("%0.2d", $datearr[3]);
1558                 my $datedue=$data->{'date_due'};
1559                 $datedue=~s/-//g;
1560                 if ($datedue < $todaysdate) {
1561                         $data->{'overdue'}=1;
1562                 }
1563                 my $itemnumber=$data->{'itemnumber'};
1564                 # FIXME - Consecutive integers as hash keys? You have GOT to
1565                 # be kidding me! Use an array, fercrissakes!
1566                 $currentissues{$counter}=$data;
1567                 $counter++;
1568         }
1569         $sth->finish;
1570         return(\%currentissues);
1571 }
1572
1573 =head2 getissues
1574
1575   $issues = &getissues($borrowernumber);
1576
1577 Returns the set of books currently on loan to a patron.
1578
1579 C<$borrowernumber> is the patron's borrower number.
1580
1581 C<&getissues> returns a PHP-style array: C<$issues> is a
1582 reference-to-hash whose keys are integers in the range 0..I<n>-1,
1583 where I<n> is the number of books the patron currently has on loan.
1584
1585 The values of C<$issues> are references-to-hash whose keys are
1586 selected fields from the issues, items, biblio, and biblioitems tables
1587 of the Koha database.
1588
1589 =cut
1590 #'
1591 sub getissues {
1592 # New subroutine for Circ2.pm
1593         my ($borrower) = @_;
1594         my $dbh = C4::Context->dbh;
1595         my $borrowernumber = $borrower->{'borrowernumber'};
1596         my %currentissues;
1597         my $select = "SELECT items.*,issues.timestamp      AS timestamp,
1598                                 issues.date_due       AS date_due,
1599                                 items.barcode         AS barcode,
1600                                 biblio.title          AS title,
1601                                 biblio.author         AS author,
1602                                 biblioitems.dewey     AS dewey,
1603                                 itemtypes.description AS itemtype,
1604                                 biblioitems.subclass  AS subclass,
1605                                 biblioitems.classification AS classification
1606                         FROM issues,items,biblioitems,biblio, itemtypes
1607                         WHERE issues.borrowernumber  = ?
1608                         AND issues.itemnumber      = items.itemnumber
1609                         AND items.biblionumber     = biblio.biblionumber
1610                         AND items.biblioitemnumber = biblioitems.biblioitemnumber
1611                         AND itemtypes.itemtype     = biblioitems.itemtype
1612                         AND issues.returndate      IS NULL
1613                         ORDER BY issues.date_due";
1614         #    print $select;
1615         my $sth=$dbh->prepare($select);
1616         $sth->execute($borrowernumber);
1617         my $counter = 0;
1618         while (my $data = $sth->fetchrow_hashref) {
1619                 $data->{'dewey'} =~ s/0*$//;
1620                 ($data->{'dewey'} == 0) && ($data->{'dewey'} = '');
1621                         # FIXME - The Dewey code is a string, not a number.
1622                 # FIXME - Use POSIX::strftime to get a text version of today's
1623                 # date. That's what it's for.
1624                 # FIXME - Move the date calculation outside of the loop.
1625                 my @datearr = localtime(time());
1626                 my $todaysdate = (1900+$datearr[5]).sprintf ("%0.2d", ($datearr[4]+1)).sprintf ("%0.2d", $datearr[3]);
1627
1628                 # FIXME - Instead of converting the due date to YYYYMMDD, just
1629                 # use
1630                 #       $todaysdate = POSIX::strftime("%Y-%m-%d", localtime);
1631                 #       ...
1632                 #       if ($date->{date_due} lt $todaysdate)
1633                 my $datedue = $data->{'date_due'};
1634                 $datedue =~ s/-//g;
1635                 if ($datedue < $todaysdate) {
1636                         $data->{'overdue'} = 1;
1637                 }
1638                 $currentissues{$counter} = $data;
1639                 $counter++;
1640                         # FIXME - This is ludicrous. If you want to return an
1641                         # array of values, just use an array. That's what
1642                         # they're there for.
1643         }
1644         $sth->finish;
1645         return(\%currentissues);
1646 }
1647
1648 # Not exported
1649 sub checkwaiting {
1650 #Stolen from Main.pm
1651 # check for reserves waiting
1652         my ($env,$dbh,$bornum)=@_;
1653         my @itemswaiting;
1654         my $sth = $dbh->prepare("select * from reserves where (borrowernumber = ?) and (reserves.found='W') and cancellationdate is NULL");
1655         $sth->execute($bornum);
1656         my $cnt=0;
1657         if (my $data=$sth->fetchrow_hashref) {
1658                 $itemswaiting[$cnt] =$data;
1659                 $cnt ++
1660         }
1661         $sth->finish;
1662         return ($cnt,\@itemswaiting);
1663 }
1664
1665 =head2 renewstatus
1666
1667   $ok = &renewstatus($env, $dbh, $borrowernumber, $itemnumber);
1668
1669 Find out whether a borrowed item may be renewed.
1670
1671 C<$env> is ignored.
1672
1673 C<$dbh> is a DBI handle to the Koha database.
1674
1675 C<$borrowernumber> is the borrower number of the patron who currently
1676 has the item on loan.
1677
1678 C<$itemnumber> is the number of the item to renew.
1679
1680 C<$renewstatus> returns a true value iff the item may be renewed. The
1681 item must currently be on loan to the specified borrower; renewals
1682 must be allowed for the item's type; and the borrower must not have
1683 already renewed the loan.
1684
1685 =cut
1686
1687 sub renewstatus {
1688         # check renewal status
1689         my ($env,$bornum,$itemno)=@_;
1690         my $dbh = C4::Context->dbh;
1691         my $renews = 1;
1692         my $renewokay = 0;
1693         # Look in the issues table for this item, lent to this borrower,
1694         # and not yet returned.
1695
1696         # FIXME - I think this function could be redone to use only one SQL call.
1697         my $sth1 = $dbh->prepare("select * from issues
1698                                                                 where (borrowernumber = ?)
1699                                                                 and (itemnumber = ?)
1700                                                                 and returndate is null");
1701         $sth1->execute($bornum,$itemno);
1702         if (my $data1 = $sth1->fetchrow_hashref) {
1703                 # Found a matching item
1704
1705                 # See if this item may be renewed. This query is convoluted
1706                 # because it's a bit messy: given the item number, we need to find
1707                 # the biblioitem, which gives us the itemtype, which tells us
1708                 # whether it may be renewed.
1709                 my $sth2 = $dbh->prepare("select renewalsallowed from items,biblioitems,itemtypes
1710                 where (items.itemnumber = ?)
1711                 and (items.biblioitemnumber = biblioitems.biblioitemnumber)
1712                 and (biblioitems.itemtype = itemtypes.itemtype)");
1713                 $sth2->execute($itemno);
1714                 if (my $data2=$sth2->fetchrow_hashref) {
1715                         $renews = $data2->{'renewalsallowed'};
1716                 }
1717                 if ($renews && $renews > $data1->{'renewals'}) {
1718                         $renewokay = 1;
1719                 }
1720                 $sth2->finish;
1721                 my ($resfound, $resrec) = CheckReserves($itemno);
1722                 if ($resfound) {
1723                         $renewokay = 0;
1724                 }
1725                 ($resfound, $resrec) = CheckReserves($itemno);
1726                 if ($resfound) {
1727                         $renewokay = 0;
1728                 }
1729
1730         }
1731         $sth1->finish;
1732         return($renewokay);
1733 }
1734
1735 =head2 renewbook
1736
1737   &renewbook($env, $borrowernumber, $itemnumber, $datedue);
1738
1739 Renews a loan.
1740
1741 C<$env-E<gt>{branchcode}> is the code of the branch where the
1742 renewal is taking place.
1743
1744 C<$env-E<gt>{usercode}> is the value to log in C<statistics.usercode>
1745 in the Koha database.
1746
1747 C<$borrowernumber> is the borrower number of the patron who currently
1748 has the item.
1749
1750 C<$itemnumber> is the number of the item to renew.
1751
1752 C<$datedue> can be used to set the due date. If C<$datedue> is the
1753 empty string, C<&renewbook> will calculate the due date automatically
1754 from the book's item type. If you wish to set the due date manually,
1755 C<$datedue> should be in the form YYYY-MM-DD.
1756
1757 =cut
1758
1759 sub renewbook {
1760         # mark book as renewed
1761         my ($env,$bornum,$itemno,$datedue)=@_;
1762         my $dbh = C4::Context->dbh;
1763
1764         # If the due date wasn't specified, calculate it by adding the
1765         # book's loan length to today's date.
1766         if ($datedue eq "" ) {
1767                 #debug_msg($env, "getting date");
1768                 my $iteminformation = getiteminformation($env, $itemno,0);
1769                 my $borrower = getpatroninformation($env,$bornum,0);
1770                 my $loanlength = getLoanLength($borrower->{'categorycode'},$iteminformation->{'itemtype'},$borrower->{'branchcode'});
1771                 $datedue = UnixDate(DateCalc("today","$loanlength days"),"%Y-%m-%d");
1772         }
1773
1774         # Find the issues record for this book
1775         my $sth=$dbh->prepare("select * from issues where borrowernumber=? and itemnumber=? and returndate is null");
1776         $sth->execute($bornum,$itemno);
1777         my $issuedata=$sth->fetchrow_hashref;
1778         $sth->finish;
1779
1780         # Update the issues record to have the new due date, and a new count
1781         # of how many times it has been renewed.
1782         my $renews = $issuedata->{'renewals'} +1;
1783         $sth=$dbh->prepare("update issues set date_due = ?, renewals = ?
1784                 where borrowernumber=? and itemnumber=? and returndate is null");
1785         $sth->execute($datedue,$renews,$bornum,$itemno);
1786         $sth->finish;
1787
1788         # Log the renewal
1789         UpdateStats($env,$env->{'branchcode'},'renew','','',$itemno);
1790
1791         # Charge a new rental fee, if applicable?
1792         my ($charge,$type)=calc_charges($env, $itemno, $bornum);
1793         if ($charge > 0){
1794                 my $accountno=getnextacctno($env,$bornum,$dbh);
1795                 my $item=getiteminformation($env, $itemno);
1796                 $sth=$dbh->prepare("Insert into accountlines (borrowernumber,accountno,date,amount,description,accounttype,amountoutstanding,itemnumber)
1797                                                         values (?,?,now(),?,?,?,?,?)");
1798                 $sth->execute($bornum,$accountno,$charge,"Renewal of Rental Item $item->{'title'} $item->{'barcode'}",'Rent',$charge,$itemno);
1799                 $sth->finish;
1800         #     print $account;
1801         }
1802
1803         #  return();
1804 }
1805
1806
1807
1808 =item calc_charges
1809
1810   ($charge, $item_type) = &calc_charges($env, $itemnumber, $borrowernumber);
1811
1812 Calculate how much it would cost for a given patron to borrow a given
1813 item, including any applicable discounts.
1814
1815 C<$env> is ignored.
1816
1817 C<$itemnumber> is the item number of item the patron wishes to borrow.
1818
1819 C<$borrowernumber> is the patron's borrower number.
1820
1821 C<&calc_charges> returns two values: C<$charge> is the rental charge,
1822 and C<$item_type> is the code for the item's item type (e.g., C<VID>
1823 if it's a video).
1824
1825 =cut
1826
1827 sub calc_charges {
1828         # calculate charges due
1829         my ($env, $itemno, $bornum)=@_;
1830         my $charge=0;
1831         my $dbh = C4::Context->dbh;
1832         my $item_type;
1833
1834         # Get the book's item type and rental charge (via its biblioitem).
1835         my $sth1= $dbh->prepare("select itemtypes.itemtype,rentalcharge from items,biblioitems,itemtypes
1836                                                                 where (items.itemnumber =?)
1837                                                                 and (biblioitems.biblioitemnumber = items.biblioitemnumber)
1838                                                                 and (biblioitems.itemtype = itemtypes.itemtype)");
1839         $sth1->execute($itemno);
1840         my $data1=$sth1->fetchrow_hashref;
1841         $item_type = $data1->{'itemtype'};
1842         $charge = $data1->{'rentalcharge'};
1843         $sth1->finish;
1844         return ($charge,$item_type);
1845 }
1846
1847
1848 # FIXME - A virtually identical function appears in
1849 # C4::Circulation::Issues. Pick one and stick with it.
1850 sub createcharge {
1851 #Stolen from Issues.pm
1852     my ($env,$dbh,$itemno,$bornum,$charge) = @_;
1853     my $nextaccntno = getnextacctno($env,$bornum,$dbh);
1854     my $sth = $dbh->prepare(<<EOT);
1855         INSERT INTO     accountlines
1856                         (borrowernumber, itemnumber, accountno,
1857                          date, amount, description, accounttype,
1858                          amountoutstanding)
1859         VALUES          (?, ?, ?,
1860                          now(), ?, 'Rental', 'Rent',
1861                          ?)
1862 EOT
1863     $sth->execute($bornum, $itemno, $nextaccntno, $charge, $charge);
1864     $sth->finish;
1865 }
1866
1867
1868 =item find_reserves
1869
1870   ($status, $record) = &find_reserves($itemnumber);
1871
1872 Looks up an item in the reserves.
1873
1874 C<$itemnumber> is the itemnumber to look up.
1875
1876 C<$status> is true iff the search was successful.
1877
1878 C<$record> is a reference-to-hash describing the reserve. Its keys are
1879 the fields from the reserves table of the Koha database.
1880
1881 =cut
1882 #'
1883 # FIXME - This API is bogus: just return the record, or undef if none
1884 # was found.
1885 # FIXME - There's also a &C4::Circulation::Returns::find_reserves, but
1886 # that one looks rather different.
1887 sub find_reserves {
1888 # Stolen from Returns.pm
1889     my ($itemno) = @_;
1890     my %env;
1891     my $dbh = C4::Context->dbh;
1892     my ($itemdata) = getiteminformation(\%env, $itemno,0);
1893     my $bibno = $dbh->quote($itemdata->{'biblionumber'});
1894     my $bibitm = $dbh->quote($itemdata->{'biblioitemnumber'});
1895     my $sth = $dbh->prepare("select * from reserves where ((found = 'W') or (found is null)) and biblionumber = ? and cancellationdate is NULL order by priority, reservedate");
1896     $sth->execute($bibno);
1897     my $resfound = 0;
1898     my $resrec;
1899     my $lastrec;
1900 # print $query;
1901
1902     # FIXME - I'm not really sure what's going on here, but since we
1903     # only want one result, wouldn't it be possible (and far more
1904     # efficient) to do something clever in SQL that only returns one
1905     # set of values?
1906     while (($resrec = $sth->fetchrow_hashref) && (not $resfound)) {
1907                 # FIXME - Unlike Pascal, Perl allows you to exit loops
1908                 # early. Take out the "&& (not $resfound)" and just
1909                 # use "last" at the appropriate point in the loop.
1910                 # (Oh, and just in passing: if you'd used "!" instead
1911                 # of "not", you wouldn't have needed the parentheses.)
1912         $lastrec = $resrec;
1913         my $brn = $dbh->quote($resrec->{'borrowernumber'});
1914         my $rdate = $dbh->quote($resrec->{'reservedate'});
1915         my $bibno = $dbh->quote($resrec->{'biblionumber'});
1916         if ($resrec->{'found'} eq "W") {
1917             if ($resrec->{'itemnumber'} eq $itemno) {
1918                 $resfound = 1;
1919             }
1920         } else {
1921             # FIXME - Use 'elsif' to avoid unnecessary indentation.
1922             if ($resrec->{'constrainttype'} eq "a") {
1923                 $resfound = 1;
1924             } else {
1925                         my $consth = $dbh->prepare("select * from reserveconstraints where borrowernumber = ? and reservedate = ? and biblionumber = ? and biblioitemnumber = ?");
1926                         $consth->execute($brn,$rdate,$bibno,$bibitm);
1927                         if (my $conrec = $consth->fetchrow_hashref) {
1928                                 if ($resrec->{'constrainttype'} eq "o") {
1929                                 $resfound = 1;
1930                                 }
1931                         }
1932                 $consth->finish;
1933                 }
1934         }
1935         if ($resfound) {
1936             my $updsth = $dbh->prepare("update reserves set found = 'W', itemnumber = ? where borrowernumber = ? and reservedate = ? and biblionumber = ?");
1937             $updsth->execute($itemno,$brn,$rdate,$bibno);
1938             $updsth->finish;
1939             # FIXME - "last;" here to break out of the loop early.
1940         }
1941     }
1942     $sth->finish;
1943     return ($resfound,$lastrec);
1944 }
1945
1946 sub fixdate {
1947     my ($year, $month, $day) = @_;
1948     my $invalidduedate;
1949     my $date;
1950     if ($year && $month && $day){
1951         if (($year eq 0 ) && ($month eq 0) && ($year eq 0)) {
1952 #       $env{'datedue'}='';
1953         } else {
1954             if (($year eq 0) || ($month eq 0) || ($year eq 0)) {
1955                 $invalidduedate=1;
1956             } else {
1957                 if (($day>30) && (($month==4) || ($month==6) || ($month==9) || ($month==11))) {
1958                     $invalidduedate = 1;
1959                 }
1960                 elsif (($day > 29) && ($month == 2)) {
1961                     $invalidduedate=1;
1962                 }
1963                 elsif (($month == 2) && ($day > 28) && (($year%4) && ((!($year%100) || ($year%400))))) {
1964                     $invalidduedate=1;
1965                 }
1966                 else {
1967                 $date="$year-$month-$day";
1968                 }
1969             }
1970         }
1971     }
1972     return ($date, $invalidduedate);
1973
1974 }
1975
1976 sub get_return_date_of {
1977     my (@itemnumbers) = @_;
1978
1979     my $query = '
1980 SELECT date_due,
1981        itemnumber
1982   FROM issues
1983   WHERE itemnumber IN ('.join(',', @itemnumbers).')
1984 ';
1985     return get_infos_of($query, 'itemnumber', 'date_due');
1986 }
1987
1988 sub get_transfert_infos {
1989     my ($itemnumber) = @_;
1990
1991     my $dbh = C4::Context->dbh;
1992
1993     my $query = '
1994 SELECT datesent,
1995        frombranch,
1996        tobranch
1997   FROM branchtransfers
1998   WHERE itemnumber = ?
1999     AND datearrived IS NULL
2000 ';
2001     my $sth = $dbh->prepare($query);
2002     $sth->execute($itemnumber);
2003
2004     my @row = $sth->fetchrow_array();
2005
2006     $sth->finish;
2007
2008     return @row;
2009 }
2010
2011
2012 sub DeleteTransfer {
2013         my($itemnumber) = @_;
2014         my $dbh = C4::Context->dbh;
2015         my $sth=$dbh->prepare("DELETE FROM branchtransfers
2016         where itemnumber=?
2017         AND datearrived is null ");
2018         $sth->execute($itemnumber);
2019         $sth->finish;
2020 }
2021
2022 sub GetTransfersFromBib {
2023         my($frombranch,$tobranch) = @_;
2024         my $dbh = C4::Context->dbh;
2025         my $sth=$dbh->prepare("SELECT itemnumber,datesent,frombranch FROM
2026          branchtransfers
2027         where frombranch=?
2028         AND tobranch=?
2029         AND datearrived is null ");
2030         $sth->execute($frombranch,$tobranch);
2031         my @gettransfers;
2032         my $i=0;
2033         while (my $data=$sth->fetchrow_hashref){
2034                 $gettransfers[$i]=$data;
2035                 $i++;
2036         }
2037         $sth->finish;
2038         return(@gettransfers);
2039 }
2040
2041 sub GetReservesToBranch {
2042         my($frombranch,$default) = @_;
2043         my $dbh = C4::Context->dbh;
2044         my $sth=$dbh->prepare("SELECT borrowernumber,reservedate,itemnumber,timestamp FROM
2045          reserves
2046         where priority='0' AND cancellationdate is null
2047         AND branchcode=?
2048         AND branchcode!=?
2049         AND found is null ");
2050         $sth->execute($frombranch,$default);
2051         my @transreserv;
2052         my $i=0;
2053         while (my $data=$sth->fetchrow_hashref){
2054                 $transreserv[$i]=$data;
2055                 $i++;
2056         }
2057         $sth->finish;
2058         return(@transreserv);
2059 }
2060
2061 sub GetReservesForBranch {
2062         my($frombranch) = @_;
2063         my $dbh = C4::Context->dbh;
2064         my $sth=$dbh->prepare("SELECT borrowernumber,reservedate,itemnumber,waitingdate FROM
2065          reserves
2066         where priority='0' AND cancellationdate is null
2067         AND found='W'
2068         AND branchcode=? order by reservedate");
2069         $sth->execute($frombranch);
2070         my @transreserv;
2071         my $i=0;
2072         while (my $data=$sth->fetchrow_hashref){
2073                 $transreserv[$i]=$data;
2074                 $i++;
2075         }
2076         $sth->finish;
2077         return(@transreserv);
2078 }
2079
2080 sub checktransferts{
2081         my($itemnumber) = @_;
2082         my $dbh = C4::Context->dbh;
2083         my $sth=$dbh->prepare("SELECT datesent,frombranch,tobranch FROM branchtransfers
2084         WHERE itemnumber = ? AND datearrived IS NULL");
2085         $sth->execute($itemnumber);
2086         my @tranferts = $sth->fetchrow_array;
2087         $sth->finish;
2088
2089         return (@tranferts);
2090 }
2091
2092 1;
2093 __END__
2094
2095 =back
2096
2097 =head1 AUTHOR
2098
2099 Koha Developement team <info@koha.org>
2100
2101 =cut
2102