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