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