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
  38 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  39
  40 # set the version for version checking
  41 $VERSION = 0.01;
  42
  43 =head1 NAME
  44
  45 C4::Circulation::Circ2 - Koha circulation module
  46
  47 =head1 SYNOPSIS
  48
  49   use C4::Circulation::Circ2;
  50
  51 =head1 DESCRIPTION
  52
  53 The functions in this module deal with circulation, issues, and
  54 returns, as well as general information about the library.
  55
  56 =head1 FUNCTIONS
  57
  58 =over 2
  59
  60 =cut
  61
  62 @ISA = qw(Exporter);
  63 @EXPORT = qw(&getpatroninformation
  64         &currentissues &getissues &getiteminformation
  65         &issuebook &returnbook &find_reserves &transferbook &decode
  66         &calc_charges);
  67
  68 # &getbranches &getprinters &getbranch &getprinter => moved to C4::Koha.pm
  69
  70 =item getpatroninformation
  71
  72   ($borrower, $flags) = &getpatroninformation($env, $borrowernumber,
  73                                         $cardnumber);
  74
  75 Looks up a patron and returns information about him or her. If
  76 C<$borrowernumber> is true (nonzero), C<&getpatroninformation> looks
  77 up the borrower by number; otherwise, it looks up the borrower by card
  78 number.
  79
  80 C<$env> is effectively ignored, but should be a reference-to-hash.
  81
  82 C<$borrower> is a reference-to-hash whose keys are the fields of the
  83 borrowers table in the Koha database. In addition,
  84 C<$borrower-E<gt>{flags}> is the same as C<$flags>.
  85
  86 C<$flags> is a reference-to-hash giving more detailed information
  87 about the patron. Its keys act as flags: if they are set, then the key
  88 is a reference-to-hash that gives further details:
  89
  90   if (exists($flags->{LOST}))
  91   {
  92           # Patron's card was reported lost
  93           print $flags->{LOST}{message}, "\n";
  94   }
  95
  96 Each flag has a C<message> key, giving a human-readable explanation of
  97 the flag. If the state of a flag means that the patron should not be
  98 allowed to borrow any more books, then it will have a C<noissues> key
  99 with a true value.
 100
 101 The possible flags are:
 102
 103 =over 4
 104
 105 =item CHARGES
 106
 107 Shows the patron's credit or debt, if any.
 108
 109 =item GNA
 110
 111 (Gone, no address.) Set if the patron has left without giving a
 112 forwarding address.
 113
 114 =item LOST
 115
 116 Set if the patron's card has been reported as lost.
 117
 118 =item DBARRED
 119
 120 Set if the patron has been debarred.
 121
 122 =item NOTES
 123
 124 Any additional notes about the patron.
 125
 126 =item ODUES
 127
 128 Set if the patron has overdue items. This flag has several keys:
 129
 130 C<$flags-E<gt>{ODUES}{itemlist}> is a reference-to-array listing the
 131 overdue items. Its elements are references-to-hash, each describing an
 132 overdue item. The keys are selected fields from the issues, biblio,
 133 biblioitems, and items tables of the Koha database.
 134
 135 C<$flags-E<gt>{ODUES}{itemlist}> is a string giving a text listing of
 136 the overdue items, one per line.
 137
 138 =item WAITING
 139
 140 Set if any items that the patron has reserved are available.
 141
 142 C<$flags-E<gt>{WAITING}{itemlist}> is a reference-to-array listing the
 143 available items. Each element is a reference-to-hash whose keys are
 144 fields from the reserves table of the Koha database.
 145
 146 =back
 147
 148 =cut
 149 #'
 150 sub getpatroninformation {
 151 # returns
 152         my ($env, $borrowernumber,$cardnumber) = @_;
 153         my $dbh = C4::Context->dbh;
 154         my $query;
 155         my $sth;
 156         if ($borrowernumber) {
 157                 $sth = $dbh->prepare("select * from borrowers where borrowernumber=?");
 158                 $sth->execute($borrowernumber);
 159         } elsif ($cardnumber) {
 160                 $sth = $dbh->prepare("select * from borrowers where cardnumber=?");
 161                 $sth->execute($cardnumber);
 162         } else {
 163                 $env->{'apierror'} = "invalid borrower information passed to getpatroninformation subroutine";
 164                 return();
 165         }
 166         $env->{'mess'} = $query;
 167         my $borrower = $sth->fetchrow_hashref;
 168         my $amount = checkaccount($env, $borrowernumber, $dbh);
 169         $borrower->{'amountoutstanding'} = $amount;
 170         my $flags = patronflags($env, $borrower, $dbh);
 171         my $accessflagshash;
 172
 173         $sth=$dbh->prepare("select bit,flag from userflags");
 174         $sth->execute;
 175         while (my ($bit, $flag) = $sth->fetchrow) {
 176                 if ($borrower->{'flags'} & 2**$bit) {
 177                 $accessflagshash->{$flag}=1;
 178                 }
 179         }
 180         $sth->finish;
 181         $borrower->{'flags'}=$flags;
 182         return ($borrower, $flags, $accessflagshash);
 183 }
 184
 185 =item decode
 186
 187   $str = &decode($chunk);
 188
 189 Decodes a segment of a string emitted by a CueCat barcode scanner and
 190 returns it.
 191
 192 =cut
 193 #'
 194 # FIXME - At least, I'm pretty sure this is for decoding CueCat stuff.
 195 sub decode {
 196         my ($encoded) = @_;
 197         my $seq = 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789+-';
 198         my @s = map { index($seq,$_); } split(//,$encoded);
 199         my $l = ($#s+1) % 4;
 200         if ($l)
 201         {
 202                 if ($l == 1)
 203                 {
 204                         print "Error!";
 205                         return;
 206                 }
 207                 $l = 4-$l;
 208                 $#s += $l;
 209         }
 210         my $r = '';
 211         while ($#s >= 0)
 212         {
 213                 my $n = (($s[0] << 6 | $s[1]) << 6 | $s[2]) << 6 | $s[3];
 214                 $r .=chr(($n >> 16) ^ 67) .
 215                 chr(($n >> 8 & 255) ^ 67) .
 216                 chr(($n & 255) ^ 67);
 217                 @s = @s[4..$#s];
 218         }
 219         $r = substr($r,0,length($r)-$l);
 220         return $r;
 221 }
 222
 223 =item getiteminformation
 224
 225   $item = &getiteminformation($env, $itemnumber, $barcode);
 226
 227 Looks up information about an item, given either its item number or
 228 its barcode. If C<$itemnumber> is a nonzero value, it is used;
 229 otherwise, C<$barcode> is used.
 230
 231 C<$env> is effectively ignored, but should be a reference-to-hash.
 232
 233 C<$item> is a reference-to-hash whose keys are fields from the biblio,
 234 items, and biblioitems tables of the Koha database. It may also
 235 contain the following keys:
 236
 237 =over 4
 238
 239 =item C<date_due>
 240
 241 The due date on this item, if it has been borrowed and not returned
 242 yet. The date is in YYYY-MM-DD format.
 243
 244 =item C<loanlength>
 245
 246 The length of time for which the item can be borrowed, in days.
 247
 248 =item C<notforloan>
 249
 250 True if the item may not be borrowed.
 251
 252 =back
 253
 254 =cut
 255 #'
 256 sub getiteminformation {
 257 # returns a hash of item information given either the itemnumber or the barcode
 258         my ($env, $itemnumber, $barcode) = @_;
 259         my $dbh = C4::Context->dbh;
 260         my $sth;
 261         if ($itemnumber) {
 262                 $sth=$dbh->prepare("select * from biblio,items,biblioitems where items.itemnumber=? and biblio.biblionumber=items.biblionumber and biblioitems.biblioitemnumber = items.biblioitemnumber");
 263                 $sth->execute($itemnumber);
 264         } elsif ($barcode) {
 265                 $sth=$dbh->prepare("select * from biblio,items,biblioitems where items.barcode=? and biblio.biblionumber=items.biblionumber and biblioitems.biblioitemnumber = items.biblioitemnumber");
 266                 $sth->execute($barcode);
 267         } else {
 268                 $env->{'apierror'}="getiteminformation() subroutine must be called with either an itemnumber or a barcode";
 269                 # Error condition.
 270                 return();
 271         }
 272         my $iteminformation=$sth->fetchrow_hashref;
 273         $sth->finish;
 274         # FIXME - Style: instead of putting the entire rest of the
 275         # function in a block, just say
 276         #       return undef unless $iteminformation;
 277         # That way, the rest of the function needn't be indented as much.
 278         if ($iteminformation) {
 279                 $sth=$dbh->prepare("select date_due from issues where itemnumber=? and isnull(returndate)");
 280                 $sth->execute($iteminformation->{'itemnumber'});
 281                 my ($date_due) = $sth->fetchrow;
 282                 $iteminformation->{'date_due'}=$date_due;
 283                 $sth->finish;
 284                 # FIXME - The Dewey code is a string, not a number. Besides,
 285                 # "000" is a perfectly valid Dewey code.
 286                 #$iteminformation->{'dewey'}=~s/0*$//;
 287                 ($iteminformation->{'dewey'} == 0) && ($iteminformation->{'dewey'}='');
 288                 # FIXME - fetchrow_hashref is documented as being inefficient.
 289                 # Perhaps this should be rewritten as
 290                 #       $sth = $dbh->prepare("select loanlength, notforloan ...");
 291                 #       $sth->execute;
 292                 #       ($iteminformation->{loanlength},
 293                 #        $iteminformation->{notforloan}) = fetchrow_array;
 294                 $sth=$dbh->prepare("select * from itemtypes where itemtype=?");
 295                 $sth->execute($iteminformation->{'itemtype'});
 296                 my $itemtype=$sth->fetchrow_hashref;
 297                 $iteminformation->{'loanlength'}=$itemtype->{'loanlength'};
 298                 # if specific item notforloan, don't use itemtype notforloan field.
 299                 # otherwise, use itemtype notforloan value to see if item can be issued.
 300                 $iteminformation->{'notforloan'}=$itemtype->{'notforloan'} unless $iteminformation->{'notforloan'};
 301                 $sth->finish;
 302         }
 303         return($iteminformation);
 304 }
 305
 306 =item transferbook
 307
 308   ($dotransfer, $messages, $iteminformation) =
 309         &transferbook($newbranch, $barcode, $ignore_reserves);
 310
 311 Transfers an item to a new branch. If the item is currently on loan,
 312 it is automatically returned before the actual transfer.
 313
 314 C<$newbranch> is the code for the branch to which the item should be
 315 transferred.
 316
 317 C<$barcode> is the barcode of the item to be transferred.
 318
 319 If C<$ignore_reserves> is true, C<&transferbook> ignores reserves.
 320 Otherwise, if an item is reserved, the transfer fails.
 321
 322 Returns three values:
 323
 324 C<$dotransfer> is true iff the transfer was successful.
 325
 326 C<$messages> is a reference-to-hash which may have any of the
 327 following keys:
 328
 329 =over 4
 330
 331 =item C<BadBarcode>
 332
 333 There is no item in the catalog with the given barcode. The value is
 334 C<$barcode>.
 335
 336 =item C<IsPermanent>
 337
 338 The item's home branch is permanent. This doesn't prevent the item
 339 from being transferred, though. The value is the code of the item's
 340 home branch.
 341
 342 =item C<DestinationEqualsHolding>
 343
 344 The item is already at the branch to which it is being transferred.
 345 The transfer is nonetheless considered to have failed. The value
 346 should be ignored.
 347
 348 =item C<WasReturned>
 349
 350 The item was on loan, and C<&transferbook> automatically returned it
 351 before transferring it. The value is the borrower number of the patron
 352 who had the item.
 353
 354 =item C<ResFound>
 355
 356 The item was reserved. The value is a reference-to-hash whose keys are
 357 fields from the reserves table of the Koha database, and
 358 C<biblioitemnumber>. It also has the key C<ResFound>, whose value is
 359 either C<Waiting> or C<Reserved>.
 360
 361 =item C<WasTransferred>
 362
 363 The item was eligible to be transferred. Barring problems
 364 communicating with the database, the transfer should indeed have
 365 succeeded. The value should be ignored.
 366
 367 =back
 368
 369 =cut
 370 #'
 371 # FIXME - This function tries to do too much, and its API is clumsy.
 372 # If it didn't also return books, it could be used to change the home
 373 # branch of a book while the book is on loan.
 374 #
 375 # Is there any point in returning the item information? The caller can
 376 # look that up elsewhere if ve cares.
 377 #
 378 # This leaves the ($dotransfer, $messages) tuple. This seems clumsy.
 379 # If the transfer succeeds, that's all the caller should need to know.
 380 # Thus, this function could simply return 1 or 0 to indicate success
 381 # or failure, and set $C4::Circulation::Circ2::errmsg in case of
 382 # failure. Or this function could return undef if successful, and an
 383 # error message in case of failure (this would feel more like C than
 384 # Perl, though).
 385 sub transferbook {
 386 # transfer book code....
 387         my ($tbr, $barcode, $ignoreRs) = @_;
 388         my $messages;
 389         my %env;
 390         my $dotransfer = 1;
 391         my $branches = getbranches();
 392         my $iteminformation = getiteminformation(\%env, 0, $barcode);
 393         # bad barcode..
 394         if (not $iteminformation) {
 395                 $messages->{'BadBarcode'} = $barcode;
 396                 $dotransfer = 0;
 397         }
 398         # get branches of book...
 399         my $hbr = $iteminformation->{'homebranch'};
 400         my $fbr = $iteminformation->{'holdingbranch'};
 401         # if is permanent...
 402         if ($branches->{$hbr}->{'PE'}) {
 403                 $messages->{'IsPermanent'} = $hbr;
 404         }
 405         # can't transfer book if is already there....
 406         # FIXME - Why not? Shouldn't it trivially succeed?
 407         if ($fbr eq $tbr) {
 408                 $messages->{'DestinationEqualsHolding'} = 1;
 409                 $dotransfer = 0;
 410         }
 411         # check if it is still issued to someone, return it...
 412         my ($currentborrower) = currentborrower($iteminformation->{'itemnumber'});
 413         if ($currentborrower) {
 414                 returnbook($barcode, $fbr);
 415                 $messages->{'WasReturned'} = $currentborrower;
 416         }
 417         # find reserves.....
 418         # FIXME - Don't call &CheckReserves unless $ignoreRs is true.
 419         # That'll save a database query.
 420         my ($resfound, $resrec) = CheckReserves($iteminformation->{'itemnumber'});
 421         if ($resfound and not $ignoreRs) {
 422                 $resrec->{'ResFound'} = $resfound;
 423                 $messages->{'ResFound'} = $resrec;
 424                 $dotransfer = 0;
 425         }
 426         #actually do the transfer....
 427         if ($dotransfer) {
 428                 dotransfer($iteminformation->{'itemnumber'}, $fbr, $tbr);
 429                 $messages->{'WasTransfered'} = 1;
 430         }
 431         return ($dotransfer, $messages, $iteminformation);
 432 }
 433
 434 # Not exported
 435 # FIXME - This is only used in &transferbook. Why bother making it a
 436 # separate function?
 437 sub dotransfer {
 438         my ($itm, $fbr, $tbr) = @_;
 439         my $dbh = C4::Context->dbh;
 440         $itm = $dbh->quote($itm);
 441         $fbr = $dbh->quote($fbr);
 442         $tbr = $dbh->quote($tbr);
 443         #new entry in branchtransfers....
 444         $dbh->do("INSERT INTO   branchtransfers (itemnumber, frombranch, datearrived, tobranch)
 445                                         VALUES ($itm, $fbr, now(), $tbr)");
 446         #update holdingbranch in items .....
 447         $dbh->do("UPDATE items SET      datelastseen  = now(), holdingbranch = $tbr WHERE       items.itemnumber = $itm");
 448         return;
 449 }
 450
 451 =item issuebook
 452
 453   ($iteminformation, $datedue, $rejected, $question, $questionnumber,
 454    $defaultanswer, $message) =
 455         &issuebook($env, $patroninformation, $barcode, $responses, $date);
 456
 457 Issue a book to a patron.
 458
 459 C<$env-E<gt>{usercode}> will be used in the usercode field of the
 460 statistics table of the Koha database when this transaction is
 461 recorded.
 462
 463 C<$env-E<gt>{datedue}>, if given, specifies the date on which the book
 464 is due back. This should be a string of the form "YYYY-MM-DD".
 465
 466 C<$env-E<gt>{branchcode}> is the code of the branch where this
 467 transaction is taking place.
 468
 469 C<$patroninformation> is a reference-to-hash giving information about
 470 the person borrowing the book. This is the first value returned by
 471 C<&getpatroninformation>.
 472
 473 C<$barcode> is the bar code of the book being issued.
 474
 475 C<$responses> is a reference-to-hash. It represents the answers to the
 476 questions asked by the C<$question>, C<$questionnumber>, and
 477 C<$defaultanswer> return values (see below). The keys are numbers, and
 478 the values can be "Y" or "N".
 479
 480 C<$date> is an optional date in the form "YYYY-MM-DD". If specified,
 481 then only fines and charges up to that date will be considered when
 482 checking to see whether the patron owes too much money to be lent a
 483 book.
 484
 485 C<&issuebook> returns an array of seven values:
 486
 487 C<$iteminformation> is a reference-to-hash describing the item just
 488 issued. This in a form similar to that returned by
 489 C<&getiteminformation>.
 490
 491 C<$datedue> is a string giving the date when the book is due, in the
 492 form "YYYY-MM-DD".
 493
 494 C<$rejected> is either a string, or -1. If it is defined and is a
 495 string, then the book may not be issued, and C<$rejected> gives the
 496 reason for this. If C<$rejected> is -1, then the book may not be
 497 issued, but no reason is given.
 498
 499 If there is a problem or question (e.g., the book is reserved for
 500 another patron), then C<$question>, C<$questionnumber>, and
 501 C<$defaultanswer> will be set. C<$questionnumber> indicates the
 502 problem. C<$question> is a text string asking how to resolve the
 503 problem, as a yes-or-no question, and C<$defaultanswer> is either "Y"
 504 or "N", giving the default answer. The questions, their numbers, and
 505 default answers are:
 506
 507 =over 4
 508
 509 =item 1: "Issued to <name>. Mark as returned?" (Y)
 510
 511 =item 2: "Waiting for <patron> at <branch>. Allow issue?" (N)
 512
 513 =item 3: "Cancel reserve for <patron>?" (N)
 514
 515 =item 4: "Book is issued to this borrower. Renew?" (Y)
 516
 517 =item 5: "Reserved for <patron> at <branch> since <date>. Allow issue?" (N)
 518
 519 =item 6: "Set reserve for <patron> to waiting and transfer to <branch>?" (Y)
 520
 521 This is asked if the answer to question 5 was "N".
 522
 523 =item 7: "Cancel reserve for <patron>?" (N)
 524
 525 =back
 526
 527 C<$message>, if defined, is an additional information message, e.g., a
 528 rental fee notice.
 529
 530 =cut
 531 #'
 532 # FIXME - The business with $responses is absurd. For one thing, these
 533 # questions should have names, not numbers. For another, it'd be
 534 # better to have the last argument be %extras. Then scripts can call
 535 # this function with
 536 #       &issuebook(...,
 537 #               -renew          => 1,
 538 #               -mark_returned  => 0,
 539 #               -cancel_reserve => 1,
 540 #               ...
 541 #               );
 542 # and the script can use
 543 #       if (defined($extras{"-mark_returned"}) && $extras{"-mark_returned"})
 544 # Heck, the $date argument should go in there as well.
 545 #
 546 # Also, there might be several reasons why a book can't be issued, but
 547 # this API only supports asking one question at a time. Perhaps it'd
 548 # be better to return a ref-to-list of problem IDs. Then the calling
 549 # script can display a list of all of the problems at once.
 550 #
 551 # Is it this function's place to decide the default answer to the
 552 # various questions? Why not document the various problems and allow
 553 # the caller to decide?
 554 sub issuebook {
 555         my ($env, $patroninformation, $barcode, $responses, $date) = @_;
 556         my $dbh = C4::Context->dbh;
 557         my $iteminformation = getiteminformation($env, 0, $barcode);
 558         my ($datedue);
 559         my ($rejected,$question,$defaultanswer,$questionnumber, $noissue);
 560         my $message;
 561
 562         # See if there's any reason this book shouldn't be issued to this
 563         # patron.
 564         SWITCH: {       # FIXME - Yes, we know it's a switch. Tell us what it's for.
 565                 if ($patroninformation->{'gonenoaddress'}) {
 566                         $rejected="Patron is gone, with no known address.";
 567                         last SWITCH;
 568                 }
 569                 if ($patroninformation->{'lost'}) {
 570                         $rejected="Patron's card has been reported lost.";
 571                         last SWITCH;
 572                 }
 573                 if ($patroninformation->{'debarred'}) {
 574                         $rejected="Patron is Debarred";
 575                         last SWITCH;
 576                 }
 577                 my $amount = checkaccount($env,$patroninformation->{'borrowernumber'}, $dbh,$date);
 578                 # FIXME - "5" shouldn't be hardcoded. An Italian library might
 579                 # be generous enough to lend a book to a patron even if he
 580                 # does still owe them 5 lire.
 581                 if ($amount > 5 && $patroninformation->{'categorycode'} ne 'L' &&
 582                                                                 $patroninformation->{'categorycode'} ne 'W' &&
 583                                                                 $patroninformation->{'categorycode'} ne 'I' &&
 584                                                                 $patroninformation->{'categorycode'} ne 'B' &&
 585                                                                 $patroninformation->{'categorycode'} ne 'P') {
 586                 # FIXME - What do these category codes mean?
 587                 $rejected = sprintf "Patron owes \$%.02f.", $amount;
 588                 last SWITCH;
 589                 }
 590                 # FIXME - This sort of error-checking should be placed closer
 591                 # to the test; in this case, this error-checking should be
 592                 # done immediately after the call to &getiteminformation.
 593                 unless ($iteminformation) {
 594                         $rejected = "$barcode is not a valid barcode.";
 595                         last SWITCH;
 596                 }
 597                 if ($iteminformation->{'notforloan'} == 1) {
 598                         $rejected="Item not for loan.";
 599                         last SWITCH;
 600                 }
 601                 if ($iteminformation->{'wthdrawn'} == 1) {
 602                         $rejected="Item withdrawn.";
 603                         last SWITCH;
 604                 }
 605                 if ($iteminformation->{'restricted'} == 1) {
 606                         $rejected="Restricted item.";
 607                         last SWITCH;
 608                 }
 609                 if ($iteminformation->{'itemtype'} eq 'REF') {
 610                         $rejected="Reference item:  Not for loan.";
 611                         last SWITCH;
 612                 }
 613                 my ($currentborrower) = currentborrower($iteminformation->{'itemnumber'});
 614                 if ($currentborrower eq $patroninformation->{'borrowernumber'}) {
 615         # Already issued to current borrower. Ask whether the loan should
 616         # be renewed.
 617                         my ($renewstatus) = renewstatus($env,$dbh,$patroninformation->{'borrowernumber'}, $iteminformation->{'itemnumber'});
 618                         if ($renewstatus == 0) {
 619                                 $rejected="No more renewals allowed for this item.";
 620                                 last SWITCH;
 621                         } else {
 622                                 if ($responses->{4} eq '') {
 623                                         $questionnumber = 4;
 624                                         $question = "Book is issued to this borrower.\nRenew?";
 625                                         $defaultanswer = 'Y';
 626                                         last SWITCH;
 627                                 } elsif ($responses->{4} eq 'Y') {
 628                                         my ($charge,$itemtype) = calc_charges($env, $dbh, $iteminformation->{'itemnumber'}, $patroninformation->{'borrowernumber'});
 629                                         if ($charge > 0) {
 630                                                 createcharge($env, $dbh, $iteminformation->{'itemnumber'}, $patroninformation->{'borrowernumber'}, $charge);
 631                                                 $iteminformation->{'charge'} = $charge;
 632                                         }
 633                                         &UpdateStats($env,$env->{'branchcode'},'renew',$charge,'',$iteminformation->{'itemnumber'},$iteminformation->{'itemtype'},$patroninformation->{'borrowernumber'});
 634                                         renewbook($env,$dbh, $patroninformation->{'borrowernumber'}, $iteminformation->{'itemnumber'});
 635                                         $noissue=1;
 636                                 } else {
 637                                         $rejected="Item on issue to this borrower, and you have chosen not to renew";
 638                                         last SWITCH;
 639                                 }
 640                         }
 641                 } elsif ($currentborrower ne '') {
 642                         # This book is currently on loan, but not to the person
 643                         # who wants to borrow it now.
 644                         my ($currborrower, $cbflags) = getpatroninformation($env,$currentborrower,0);
 645                         if ($responses->{1} eq '') {
 646                                 $questionnumber=1;
 647                                 $question = "Issued to $currborrower->{'firstname'} $currborrower->{'surname'} ($currborrower->{'cardnumber'}).\nMark as returned?";
 648                                 $defaultanswer='Y';
 649                                 last SWITCH;
 650                         } elsif ($responses->{1} eq 'Y') {
 651                                 returnbook($iteminformation->{'barcode'}, $env->{'branchcode'});
 652                         } else {
 653                                 $rejected=-1;
 654                                 last SWITCH;
 655                         }
 656                 }
 657
 658                 # See if the item is on reserve.
 659                 my ($restype, $res) = CheckReserves($iteminformation->{'itemnumber'});
 660                 if ($restype) {
 661                         my $resbor = $res->{'borrowernumber'};
 662                         if ($resbor eq $patroninformation->{'borrowernumber'}) {
 663                                 # The item is on reserve to the current patron
 664                                 FillReserve($res);
 665                         } elsif ($restype eq "Waiting") {
 666                                 # The item is on reserve and waiting, but has been
 667                                 # reserved by some other patron.
 668                                 my ($resborrower, $flags)=getpatroninformation($env, $resbor,0);
 669                                 my $branches = getbranches();
 670                                 my $branchname = $branches->{$res->{'branchcode'}}->{'branchname'};
 671                                 if ($responses->{2} eq '' && $responses->{3} eq '') {
 672                                         $questionnumber=2;
 673                                         # FIXME - Assumes HTML
 674                                         $question="<font color=red>Waiting</font> for $resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'}) at $branchname \nAllow issue?";
 675                                         $defaultanswer='N';
 676                                         last SWITCH;
 677                                 } elsif ($responses->{2} eq 'N') {
 678                                         $rejected="Issue cancelled";
 679                                         last SWITCH;
 680                                 } else {
 681                                         if ($responses->{3} eq '') {
 682                                                 $questionnumber=3;
 683                                                 $question="Cancel reserve for $resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'})?";
 684                                                 $defaultanswer='N';
 685                                                 last SWITCH;
 686                                         } elsif ($responses->{3} eq 'Y') {
 687                                                 CancelReserve(0, $res->{'itemnumber'}, $res->{'borrowernumber'});
 688                                         }
 689
 690 }
 691                         } elsif ($restype eq "Reserved") {
 692                                 # The item is on reserve for someone else.
 693                                 my ($resborrower, $flags)=getpatroninformation($env, $resbor,0);
 694                                 my $branches = getbranches();
 695                                 my $branchname = $branches->{$res->{'branchcode'}}->{'branchname'};
 696                                 if ($responses->{5} eq '' && $responses->{7} eq '') {
 697                                         $questionnumber=5;
 698                                         $question="Reserved for $resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'}) since $res->{'reservedate'} \nAllow issue?";
 699                                         $defaultanswer='N';
 700                                         if ($responses->{6} eq 'Y') {
 701                                            my $tobrcd = ReserveWaiting($res->{'itemnumber'}, $res->{'borrowernumber'});
 702                                            transferbook($tobrcd,$barcode, 1);
 703                                            $message = "Item should now be waiting at $branchname";
 704                                         }
 705                                         last SWITCH;
 706                                 } elsif ($responses->{5} eq 'N') {
 707                                         if ($responses->{6} eq '') {
 708                                                 $questionnumber=6;
 709                                                 $question="Set reserve for $resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'}) to waiting and transfer to $branchname?";
 710                                                 $defaultanswer='N';
 711                                         } elsif ($responses->{6} eq 'Y') {
 712                                                 my $tobrcd = ReserveWaiting($res->{'itemnumber'}, $res->{'borrowernumber'});
 713                                                 transferbook($tobrcd, $barcode, 1);
 714                                                 $message = "Item should now be waiting at $branchname";
 715                                         }
 716                                         $rejected=-1;
 717                                         last SWITCH;
 718                                 } else {
 719                                         if ($responses->{7} eq '') {
 720                                                 $questionnumber=7;
 721                                                 $question="Cancel reserve for $resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'})?";
 722                                                 $defaultanswer='N';
 723                                                 last SWITCH;
 724                                         } elsif ($responses->{7} eq 'Y') {
 725                                                 CancelReserve(0, $res->{'itemnumber'}, $res->{'borrowernumber'});
 726                                         }
 727                                 }
 728                         }
 729                 }
 730         }
 731     my $dateduef;
 732     unless (($question) || ($rejected) || ($noissue)) {
 733                 # There's no reason why the item can't be issued.
 734                 # FIXME - my $loanlength = $iteminformation->{loanlength} || 21;
 735                 my $loanlength=21;
 736                 if ($iteminformation->{'loanlength'}) {
 737                         $loanlength=$iteminformation->{'loanlength'};
 738                 }
 739                 my $ti=time;            # FIXME - Never used
 740                 my $datedue=time+($loanlength)*86400;
 741                 # FIXME - Could just use POSIX::strftime("%Y-%m-%d", localtime);
 742                 # That's what it's for. Or, in this case:
 743                 #       $dateduef = $env->{datedue} ||
 744                 #               strftime("%Y-%m-%d", localtime(time +
 745                 #                                    $loanlength * 86400));
 746                 my @datearr = localtime($datedue);
 747                 $dateduef = (1900+$datearr[5])."-".($datearr[4]+1)."-".$datearr[3];
 748                 if ($env->{'datedue'}) {
 749                         $dateduef=$env->{'datedue'};
 750                 }
 751                 $dateduef=~ s/2001\-4\-25/2001\-4\-26/;
 752                         # FIXME - What's this for? Leftover from debugging?
 753
 754                 # Record in the database the fact that the book was issued.
 755                 my $sth=$dbh->prepare("insert into issues (borrowernumber, itemnumber, date_due, branchcode) values (?,?,?,?)");
 756                 $sth->execute($patroninformation->{'borrowernumber'}, $iteminformation->{'itemnumber'}, $dateduef, $env->{'branchcode'});
 757                 $sth->finish;
 758                 $iteminformation->{'issues'}++;
 759                 $sth=$dbh->prepare("update items set issues=?,datelastseen=now() where itemnumber=?");
 760                 $sth->execute($iteminformation->{'issues'},$iteminformation->{'itemnumber'});
 761                 $sth->finish;
 762                 # If it costs to borrow this book, charge it to the patron's account.
 763                 my ($charge,$itemtype)=calc_charges($env, $dbh, $iteminformation->{'itemnumber'}, $patroninformation->{'borrowernumber'});
 764                 if ($charge > 0) {
 765                         createcharge($env, $dbh, $iteminformation->{'itemnumber'}, $patroninformation->{'borrowernumber'}, $charge);
 766                         $iteminformation->{'charge'}=$charge;
 767                 }
 768                 # Record the fact that this book was issued.
 769                 &UpdateStats($env,$env->{'branchcode'},'issue',$charge,'',$iteminformation->{'itemnumber'},$iteminformation->{'itemtype'},$patroninformation->{'borrowernumber'});
 770         }
 771
 772         if ($iteminformation->{'charge'}) {
 773                 $message=sprintf "Rental charge of \$%.02f applies.", $iteminformation->{'charge'};
 774         }
 775         return ($iteminformation, $dateduef, $rejected, $question, $questionnumber, $defaultanswer, $message);
 776 }
 777
 778
 779
 780 =item returnbook
 781
 782   ($doreturn, $messages, $iteminformation, $borrower) =
 783           &returnbook($barcode, $branch);
 784
 785 Returns a book.
 786
 787 C<$barcode> is the bar code of the book being returned. C<$branch> is
 788 the code of the branch where the book is being returned.
 789
 790 C<&returnbook> returns a list of four items:
 791
 792 C<$doreturn> is true iff the return succeeded.
 793
 794 C<$messages> is a reference-to-hash giving the reason for failure:
 795
 796 =over 4
 797
 798 =item C<BadBarcode>
 799
 800 No item with this barcode exists. The value is C<$barcode>.
 801
 802 =item C<NotIssued>
 803
 804 The book is not currently on loan. The value is C<$barcode>.
 805
 806 =item C<IsPermanent>
 807
 808 The book's home branch is a permanent collection. If you have borrowed
 809 this book, you are not allowed to return it. The value is the code for
 810 the book's home branch.
 811
 812 =item C<wthdrawn>
 813
 814 This book has been withdrawn/cancelled. The value should be ignored.
 815
 816 =item C<ResFound>
 817
 818 The item was reserved. The value is a reference-to-hash whose keys are
 819 fields from the reserves table of the Koha database, and
 820 C<biblioitemnumber>. It also has the key C<ResFound>, whose value is
 821 either C<Waiting>, C<Reserved>, or 0.
 822
 823 =back
 824
 825 C<$borrower> is a reference-to-hash, giving information about the
 826 patron who last borrowed the book.
 827
 828 =cut
 829 #'
 830 # FIXME - This API is bogus. There's no need to return $borrower and
 831 # $iteminformation; the caller can ask about those separately, if it
 832 # cares (it'd be inefficient to make two database calls instead of
 833 # one, but &getpatroninformation and &getiteminformation can be
 834 # memoized if this is an issue).
 835 #
 836 # The ($doreturn, $messages) tuple is redundant: if the return
 837 # succeeded, that's all the caller needs to know. So &returnbook can
 838 # return 1 and 0 on success and failure, and set
 839 # $C4::Circulation::Circ2::errmsg to indicate the error. Or it can
 840 # return undef for success, and an error message on error (though this
 841 # is more C-ish than Perl-ish).
 842 sub returnbook {
 843         my ($barcode, $branch) = @_;
 844         my %env;
 845         my $messages;
 846         my $doreturn = 1;
 847         die '$branch not defined' unless defined $branch; # just in case (bug 170)
 848         # get information on item
 849         my ($iteminformation) = getiteminformation(\%env, 0, $barcode);
 850         if (not $iteminformation) {
 851                 $messages->{'BadBarcode'} = $barcode;
 852                 $doreturn = 0;
 853         }
 854         # find the borrower
 855         my ($currentborrower) = currentborrower($iteminformation->{'itemnumber'});
 856         if ((not $currentborrower) && $doreturn) {
 857                 $messages->{'NotIssued'} = $barcode;
 858                 $doreturn = 0;
 859         }
 860         # check if the book is in a permanent collection....
 861         my $hbr = $iteminformation->{'homebranch'};
 862         my $branches = getbranches();
 863         if ($branches->{$hbr}->{'PE'}) {
 864                 $messages->{'IsPermanent'} = $hbr;
 865         }
 866         # check that the book has been cancelled
 867         if ($iteminformation->{'wthdrawn'}) {
 868                 $messages->{'wthdrawn'} = 1;
 869                 $doreturn = 0;
 870         }
 871         # update issues, thereby returning book (should push this out into another subroutine
 872         my ($borrower) = getpatroninformation(\%env, $currentborrower, 0);
 873         if ($doreturn) {
 874                 doreturn($borrower->{'borrowernumber'}, $iteminformation->{'itemnumber'});
 875                 $messages->{'WasReturned'} = 1; # FIXME is the "= 1" right?
 876         }
 877         ($borrower) = getpatroninformation(\%env, $currentborrower, 0);
 878         # transfer book to the current branch
 879         my ($transfered, $mess, $item) = transferbook($branch, $barcode, 1);
 880         if ($transfered) {
 881                 $messages->{'WasTransfered'} = 1; # FIXME is the "= 1" right?
 882         }
 883         # fix up the accounts.....
 884         if ($iteminformation->{'itemlost'}) {
 885                 # Mark the item as not being lost.
 886                 updateitemlost($iteminformation->{'itemnumber'});
 887                 fixaccountforlostandreturned($iteminformation, $borrower);
 888                 $messages->{'WasLost'} = 1; # FIXME is the "= 1" right?
 889         }
 890         # fix up the overdues in accounts...
 891         fixoverduesonreturn($borrower->{'borrowernumber'}, $iteminformation->{'itemnumber'});
 892         # find reserves.....
 893         my ($resfound, $resrec) = CheckReserves($iteminformation->{'itemnumber'});
 894         if ($resfound) {
 895         #       my $tobrcd = ReserveWaiting($resrec->{'itemnumber'}, $resrec->{'borrowernumber'});
 896                 $resrec->{'ResFound'} = $resfound;
 897                 $messages->{'ResFound'} = $resrec;
 898         }
 899         # update stats?
 900         # Record the fact that this book was returned.
 901         UpdateStats(\%env, $branch ,'return','0','',$iteminformation->{'itemnumber'},$iteminformation->{'itemtype'},$borrower->{'borrowernumber'});
 902         return ($doreturn, $messages, $iteminformation, $borrower);
 903 }
 904
 905 # doreturn
 906 # Takes a borrowernumber and an itemnuber.
 907 # Updates the 'issues' table to mark the item as returned (assuming
 908 # that it's currently on loan to the given borrower. Otherwise, the
 909 # item remains on loan.
 910 # Updates items.datelastseen for the item.
 911 # Not exported
 912 # FIXME - This is only used in &returnbook. Why make it into a
 913 # separate function? (is this a recognizable step in the return process? - acli)
 914 sub doreturn {
 915         my ($brn, $itm) = @_;
 916         my $dbh = C4::Context->dbh;
 917         my $sth = $dbh->prepare("update issues set returndate = now() where (borrowernumber = ?)
 918                 and (itemnumber = ?) and (returndate is null)");
 919         $sth->execute($brn,$itm);
 920         $sth->finish;
 921         $sth=$dbh->prepare("update items set datelastseen=now() where itemnumber=?");
 922         $sth->execute($itm);
 923         $sth->finish;
 924         return;
 925 }
 926
 927 # updateitemlost
 928 # Marks an item as not being lost.
 929 # Not exported
 930 sub updateitemlost{
 931         my ($itemno)=@_;
 932         my $dbh = C4::Context->dbh;
 933
 934         my $sth = $dbh->prepare("UPDATE items SET itemlost = 0 WHERE    itemnumber =?");
 935         $sth->execute($itemno);
 936         $sth->finish();
 937 }
 938
 939 # Not exported
 940 sub fixaccountforlostandreturned {
 941         my ($iteminfo, $borrower) = @_;
 942         my %env;
 943         my $dbh = C4::Context->dbh;
 944         my $itm = $iteminfo->{'itemnumber'};
 945         # check for charge made for lost book
 946         my $sth = $dbh->prepare("select * from accountlines where (itemnumber = ?)
 947                                 and (accounttype='L' or accounttype='Rep') order by date desc");
 948         $sth->execute($itm);
 949         if (my $data = $sth->fetchrow_hashref) {
 950         # writeoff this amount
 951                 my $offset;
 952                 my $amount = $data->{'amount'};
 953                 my $acctno = $data->{'accountno'};
 954                 my $amountleft;
 955                 if ($data->{'amountoutstanding'} == $amount) {
 956                 $offset = $data->{'amount'};
 957                 $amountleft = 0;
 958                 } else {
 959                 $offset = $amount - $data->{'amountoutstanding'};
 960                 $amountleft = $data->{'amountoutstanding'} - $amount;
 961                 }
 962                 my $usth = $dbh->prepare("update accountlines set accounttype = 'LR',amountoutstanding='0'
 963                         where (borrowernumber = ?)
 964                         and (itemnumber = ?) and (accountno = ?) ");
 965                 $usth->execute($data->{'borrowernumber'},$itm,$acctno);
 966                 $usth->finish;
 967         #check if any credit is left if so writeoff other accounts
 968                 my $nextaccntno = getnextacctno(\%env,$data->{'borrowernumber'},$dbh);
 969                 if ($amountleft < 0){
 970                 $amountleft*=-1;
 971                 }
 972                 if ($amountleft > 0){
 973                 my $msth = $dbh->prepare("select * from accountlines where (borrowernumber = ?)
 974                                                         and (amountoutstanding >0) order by date");
 975                 $msth->execute($data->{'borrowernumber'});
 976         # offset transactions
 977                 my $newamtos;
 978                 my $accdata;
 979                 while (($accdata=$msth->fetchrow_hashref) and ($amountleft>0)){
 980                         if ($accdata->{'amountoutstanding'} < $amountleft) {
 981                         $newamtos = 0;
 982                         $amountleft -= $accdata->{'amountoutstanding'};
 983                         }  else {
 984                         $newamtos = $accdata->{'amountoutstanding'} - $amountleft;
 985                         $amountleft = 0;
 986                         }
 987                         my $thisacct = $accdata->{'accountno'};
 988                         my $usth = $dbh->prepare("update accountlines set amountoutstanding= ?
 989                                         where (borrowernumber = ?)
 990                                         and (accountno=?)");
 991                         $usth->execute($newamtos,$data->{'borrowernumber'},'$thisacct');
 992                         $usth->finish;
 993                         $usth = $dbh->prepare("insert into accountoffsets
 994                                 (borrowernumber, accountno, offsetaccount,  offsetamount)
 995                                 values
 996                                 (?,?,?,?)");
 997                         $usth->execute($data->{'borrowernumber'},$accdata->{'accountno'},$nextaccntno,$newamtos);
 998                         $usth->finish;
 999                 }
1000                 $msth->finish;
1001                 }
1002                 if ($amountleft > 0){
1003                         $amountleft*=-1;
1004                 }
1005                 my $desc="Book Returned ".$iteminfo->{'barcode'};
1006                 $usth = $dbh->prepare("insert into accountlines
1007                         (borrowernumber,accountno,date,amount,description,accounttype,amountoutstanding)
1008                         values (?,?,now(),?,?,'CR',?)");
1009                 $usth->execute($data->{'borrowernumber'},$nextaccntno,0-$amount,$desc,$amountleft);
1010                 $usth->finish;
1011                 $usth = $dbh->prepare("insert into accountoffsets
1012                         (borrowernumber, accountno, offsetaccount,  offsetamount)
1013                         values (?,?,?,?)");
1014                 $usth->execute($borrower->{'borrowernumber'},$data->{'accountno'},$nextaccntno,$offset);
1015                 $usth->finish;
1016                 $usth = $dbh->prepare("update items set paidfor='' where itemnumber=?");
1017                 $usth->execute($itm);
1018                 $usth->finish;
1019         }
1020         $sth->finish;
1021         return;
1022 }
1023
1024 # Not exported
1025 sub fixoverduesonreturn {
1026         my ($brn, $itm) = @_;
1027         my $dbh = C4::Context->dbh;
1028         # check for overdue fine
1029         my $sth = $dbh->prepare("select * from accountlines where (borrowernumber = ?) and (itemnumber = ?) and (accounttype='FU' or accounttype='O')");
1030         $sth->execute($brn,$itm);
1031         # alter fine to show that the book has been returned
1032         if (my $data = $sth->fetchrow_hashref) {
1033                 my $usth=$dbh->prepare("update accountlines set accounttype='F' where (borrowernumber = ?) and (itemnumber = ?) and (acccountno = ?)");
1034                 $usth->execute($brn,$itm,$data->{'accountno'});
1035                 $usth->finish();
1036         }
1037         $sth->finish();
1038         return;
1039 }
1040
1041 # Not exported
1042 #
1043 # NOTE!: If you change this function, be sure to update the POD for
1044 # &getpatroninformation.
1045 #
1046 # $flags = &patronflags($env, $patron, $dbh);
1047 #
1048 # $flags->{CHARGES}
1049 #               {message}       Message showing patron's credit or debt
1050 #               {noissues}      Set if patron owes >$5.00
1051 #         {GNA}                 Set if patron gone w/o address
1052 #               {message}       "Borrower has no valid address"
1053 #               {noissues}      Set.
1054 #         {LOST}                Set if patron's card reported lost
1055 #               {message}       Message to this effect
1056 #               {noissues}      Set.
1057 #         {DBARRED}             Set is patron is debarred
1058 #               {message}       Message to this effect
1059 #               {noissues}      Set.
1060 #         {NOTES}               Set if patron has notes
1061 #               {message}       Notes about patron
1062 #         {ODUES}               Set if patron has overdue books
1063 #               {message}       "Yes"
1064 #               {itemlist}      ref-to-array: list of overdue books
1065 #               {itemlisttext}  Text list of overdue items
1066 #         {WAITING}             Set if there are items available that the
1067 #                               patron reserved
1068 #               {message}       Message to this effect
1069 #               {itemlist}      ref-to-array: list of available items
1070 sub patronflags {
1071 # Original subroutine for Circ2.pm
1072         my %flags;
1073         my ($env, $patroninformation, $dbh) = @_;
1074         my $amount = checkaccount($env, $patroninformation->{'borrowernumber'}, $dbh);
1075         if ($amount > 0) {
1076                 my %flaginfo;
1077                 my $noissuescharge = C4::Context->preference("noissuescharge");
1078                 $flaginfo{'message'}= sprintf "Patron owes \$%.02f", $amount;
1079                 if ($amount > $noissuescharge) {
1080                 $flaginfo{'noissues'} = 1;
1081                 }
1082                 $flags{'CHARGES'} = \%flaginfo;
1083         } elsif ($amount < 0){
1084         my %flaginfo;
1085         $flaginfo{'message'} = sprintf "Patron has credit of \$%.02f", -$amount;
1086                 $flags{'CHARGES'} = \%flaginfo;
1087         }
1088         if ($patroninformation->{'gonenoaddress'} == 1) {
1089                 my %flaginfo;
1090                 $flaginfo{'message'} = 'Borrower has no valid address.';
1091                 $flaginfo{'noissues'} = 1;
1092                 $flags{'GNA'} = \%flaginfo;
1093         }
1094         if ($patroninformation->{'lost'} == 1) {
1095                 my %flaginfo;
1096                 $flaginfo{'message'} = 'Borrower\'s card reported lost.';
1097                 $flaginfo{'noissues'} = 1;
1098                 $flags{'LOST'} = \%flaginfo;
1099         }
1100         if ($patroninformation->{'debarred'} == 1) {
1101                 my %flaginfo;
1102                 $flaginfo{'message'} = 'Borrower is Debarred.';
1103                 $flaginfo{'noissues'} = 1;
1104                 $flags{'DBARRED'} = \%flaginfo;
1105         }
1106         if ($patroninformation->{'borrowernotes'}) {
1107                 my %flaginfo;
1108                 $flaginfo{'message'} = "$patroninformation->{'borrowernotes'}";
1109                 $flags{'NOTES'} = \%flaginfo;
1110         }
1111         my ($odues, $itemsoverdue)
1112                         = checkoverdues($env, $patroninformation->{'borrowernumber'}, $dbh);
1113         if ($odues > 0) {
1114                 my %flaginfo;
1115                 $flaginfo{'message'} = "Yes";
1116                 $flaginfo{'itemlist'} = $itemsoverdue;
1117                 foreach (sort {$a->{'date_due'} cmp $b->{'date_due'}} @$itemsoverdue) {
1118                 $flaginfo{'itemlisttext'}.="$_->{'date_due'} $_->{'barcode'} $_->{'title'} \n";
1119                 }
1120                 $flags{'ODUES'} = \%flaginfo;
1121         }
1122         my ($nowaiting, $itemswaiting)
1123                         = CheckWaiting($patroninformation->{'borrowernumber'});
1124         if ($nowaiting > 0) {
1125                 my %flaginfo;
1126                 $flaginfo{'message'} = "Reserved items available";
1127                 $flaginfo{'itemlist'} = $itemswaiting;
1128                 $flags{'WAITING'} = \%flaginfo;
1129         }
1130         return(\%flags);
1131 }
1132
1133
1134 # Not exported
1135 sub checkoverdues {
1136 # From Main.pm, modified to return a list of overdueitems, in addition to a count
1137   #checks whether a borrower has overdue items
1138         my ($env, $bornum, $dbh)=@_;
1139         my @datearr = localtime;
1140         my $today = ($datearr[5] + 1900)."-".($datearr[4]+1)."-".$datearr[3];
1141         my @overdueitems;
1142         my $count = 0;
1143         my $sth = $dbh->prepare("SELECT * FROM issues,biblio,biblioitems,items
1144                         WHERE items.biblioitemnumber = biblioitems.biblioitemnumber
1145                                 AND items.biblionumber     = biblio.biblionumber
1146                                 AND issues.itemnumber      = items.itemnumber
1147                                 AND issues.borrowernumber  = ?
1148                                 AND issues.returndate is NULL
1149                                 AND issues.date_due < ?");
1150         $sth->execute($bornum,$today);
1151         while (my $data = $sth->fetchrow_hashref) {
1152         push (@overdueitems, $data);
1153         $count++;
1154         }
1155         $sth->finish;
1156         return ($count, \@overdueitems);
1157 }
1158
1159 # Not exported
1160 sub currentborrower {
1161 # Original subroutine for Circ2.pm
1162         my ($itemnumber) = @_;
1163         my $dbh = C4::Context->dbh;
1164         my $q_itemnumber = $dbh->quote($itemnumber);
1165         my $sth=$dbh->prepare("select borrowers.borrowernumber from
1166         issues,borrowers where issues.itemnumber=$q_itemnumber and
1167         issues.borrowernumber=borrowers.borrowernumber and issues.returndate is
1168         NULL");
1169         $sth->execute;
1170         my ($borrower) = $sth->fetchrow;
1171         return($borrower);
1172 }
1173
1174 # FIXME - Not exported, but used in 'updateitem.pl' anyway.
1175 sub checkreserve {
1176 # Stolen from Main.pm
1177 # Check for reserves for biblio
1178         my ($env,$dbh,$itemnum)=@_;
1179         my $resbor = "";
1180         my $sth = $dbh->prepare("select * from reserves,items
1181         where (items.itemnumber = ?)
1182         and (reserves.cancellationdate is NULL)
1183         and (items.biblionumber = reserves.biblionumber)
1184         and ((reserves.found = 'W')
1185         or (reserves.found is null))
1186         order by priority");
1187         $sth->execute($itemnum);
1188         my $resrec;
1189         my $data=$sth->fetchrow_hashref;
1190         while ($data && $resbor eq '') {
1191         $resrec=$data;
1192         my $const = $data->{'constrainttype'};
1193         if ($const eq "a") {
1194         $resbor = $data->{'borrowernumber'};
1195         } else {
1196         my $found = 0;
1197         my $csth = $dbh->prepare("select * from reserveconstraints,items
1198                 where (borrowernumber=?)
1199                 and reservedate=?
1200                 and reserveconstraints.biblionumber=?
1201                 and (items.itemnumber=? and
1202                 items.biblioitemnumber = reserveconstraints.biblioitemnumber)");
1203         $csth->execute($data->{'borrowernumber'},$data->{'biblionumber'},$data->{'reservedate'},$itemnum);
1204         if (my $cdata=$csth->fetchrow_hashref) {$found = 1;}
1205         if ($const eq 'o') {
1206                 if ($found eq 1) {$resbor = $data->{'borrowernumber'};}
1207         } else {
1208                 if ($found eq 0) {$resbor = $data->{'borrowernumber'};}
1209         }
1210         $csth->finish();
1211         }
1212         $data=$sth->fetchrow_hashref;
1213         }
1214         $sth->finish;
1215         return ($resbor,$resrec);
1216 }
1217
1218 =item currentissues
1219
1220   $issues = &currentissues($env, $borrower);
1221
1222 Returns a list of books currently on loan to a patron.
1223
1224 If C<$env-E<gt>{todaysissues}> is set and true, C<&currentissues> only
1225 returns information about books issued today. If
1226 C<$env-E<gt>{nottodaysissues}> is set and true, C<&currentissues> only
1227 returns information about books issued before today. If both are
1228 specified, C<$env-E<gt>{todaysissues}> is ignored. If neither is
1229 specified, C<&currentissues> returns all of the patron's issues.
1230
1231 C<$borrower->{borrowernumber}> is the borrower number of the patron
1232 whose issues we want to list.
1233
1234 C<&currentissues> returns a PHP-style array: C<$issues> is a
1235 reference-to-hash whose keys are integers in the range 1...I<n>, where
1236 I<n> is the number of items on issue (either today or before today).
1237 C<$issues-E<gt>{I<n>}> is a reference-to-hash whose keys are all of
1238 the fields of the biblio, biblioitems, items, and issues fields of the
1239 Koha database for that particular item.
1240
1241 =cut
1242 #'
1243 sub currentissues {
1244 # New subroutine for Circ2.pm
1245         my ($env, $borrower) = @_;
1246         my $dbh = C4::Context->dbh;
1247         my %currentissues;
1248         my $counter=1;
1249         my $borrowernumber = $borrower->{'borrowernumber'};
1250         my $crit='';
1251
1252         # Figure out whether to get the books issued today, or earlier.
1253         # FIXME - $env->{todaysissues} and $env->{nottodaysissues} can
1254         # both be specified, but are mutually-exclusive. This is bogus.
1255         # Make this a flag. Or better yet, return everything in (reverse)
1256         # chronological order and let the caller figure out which books
1257         # were issued today.
1258         if ($env->{'todaysissues'}) {
1259                 # FIXME - Could use
1260                 #       $today = POSIX::strftime("%Y%m%d", localtime);
1261                 # FIXME - Since $today will be used in either case, move it
1262                 # out of the two if-blocks.
1263                 my @datearr = localtime(time());
1264                 my $today = (1900+$datearr[5]).sprintf "%02d", ($datearr[4]+1).sprintf "%02d", $datearr[3];
1265                 # FIXME - MySQL knows about dates. Just use
1266                 #       and issues.timestamp = curdate();
1267                 $crit=" and issues.timestamp like '$today%' ";
1268         }
1269         if ($env->{'nottodaysissues'}) {
1270                 # FIXME - Could use
1271                 #       $today = POSIX::strftime("%Y%m%d", localtime);
1272                 # FIXME - Since $today will be used in either case, move it
1273                 # out of the two if-blocks.
1274                 my @datearr = localtime(time());
1275                 my $today = (1900+$datearr[5]).sprintf "%02d", ($datearr[4]+1).sprintf "%02d", $datearr[3];
1276                 # FIXME - MySQL knows about dates. Just use
1277                 #       and issues.timestamp < curdate();
1278                 $crit=" and !(issues.timestamp like '$today%') ";
1279         }
1280
1281         # FIXME - Does the caller really need every single field from all
1282         # four tables?
1283         my $sth=$dbh->prepare("select * from issues,items,biblioitems,biblio where
1284         borrowernumber=? and issues.itemnumber=items.itemnumber and
1285         items.biblionumber=biblio.biblionumber and
1286         items.biblioitemnumber=biblioitems.biblioitemnumber and returndate is null
1287         $crit order by issues.date_due");
1288         $sth->execute($borrowernumber);
1289         while (my $data = $sth->fetchrow_hashref) {
1290                 # FIXME - The Dewey code is a string, not a number.
1291                 $data->{'dewey'}=~s/0*$//;
1292                 ($data->{'dewey'} == 0) && ($data->{'dewey'}='');
1293                 # FIXME - Could use
1294                 #       $todaysdate = POSIX::strftime("%Y%m%d", localtime)
1295                 # or better yet, just reuse $today which was calculated above.
1296                 # This function isn't going to run until midnight, is it?
1297                 # Alternately, use
1298                 #       $todaysdate = POSIX::strftime("%Y-%m-%d", localtime)
1299                 #       if ($data->{'date_due'} lt $todaysdate)
1300                 #               ...
1301                 # Either way, the date should be be formatted outside of the
1302                 # loop.
1303                 my @datearr = localtime(time());
1304                 my $todaysdate = (1900+$datearr[5]).sprintf ("%0.2d", ($datearr[4]+1)).sprintf ("%0.2d", $datearr[3]);
1305                 my $datedue=$data->{'date_due'};
1306                 $datedue=~s/-//g;
1307                 if ($datedue < $todaysdate) {
1308                         $data->{'overdue'}=1;
1309                 }
1310                 my $itemnumber=$data->{'itemnumber'};
1311                 # FIXME - Consecutive integers as hash keys? You have GOT to
1312                 # be kidding me! Use an array, fercrissakes!
1313                 $currentissues{$counter}=$data;
1314                 $counter++;
1315         }
1316         $sth->finish;
1317         return(\%currentissues);
1318 }
1319
1320 =item getissues
1321
1322   $issues = &getissues($borrowernumber);
1323
1324 Returns the set of books currently on loan to a patron.
1325
1326 C<$borrowernumber> is the patron's borrower number.
1327
1328 C<&getissues> returns a PHP-style array: C<$issues> is a
1329 reference-to-hash whose keys are integers in the range 0..I<n>-1,
1330 where I<n> is the number of books the patron currently has on loan.
1331
1332 The values of C<$issues> are references-to-hash whose keys are
1333 selected fields from the issues, items, biblio, and biblioitems tables
1334 of the Koha database.
1335
1336 =cut
1337 #'
1338 sub getissues {
1339 # New subroutine for Circ2.pm
1340         my ($borrower) = @_;
1341         my $dbh = C4::Context->dbh;
1342         my $borrowernumber = $borrower->{'borrowernumber'};
1343         my %currentissues;
1344         my $select = "SELECT issues.timestamp      AS timestamp,
1345                                 issues.date_due       AS date_due,
1346                                 items.biblionumber    AS biblionumber,
1347                                 items.itemnumber    AS itemnumber,
1348                                 items.barcode         AS barcode,
1349                                 biblio.title          AS title,
1350                                 biblio.author         AS author,
1351                                 biblioitems.dewey     AS dewey,
1352                                 itemtypes.description AS itemtype,
1353                                 biblioitems.subclass  AS subclass,
1354                                 biblioitems.classification AS classification
1355                         FROM issues,items,biblioitems,biblio, itemtypes
1356                         WHERE issues.borrowernumber  = ?
1357                         AND issues.itemnumber      = items.itemnumber
1358                         AND items.biblionumber     = biblio.biblionumber
1359                         AND items.biblioitemnumber = biblioitems.biblioitemnumber
1360                         AND itemtypes.itemtype     = biblioitems.itemtype
1361                         AND issues.returndate      IS NULL
1362                         ORDER BY issues.date_due";
1363         #    print $select;
1364         my $sth=$dbh->prepare($select);
1365         $sth->execute($borrowernumber);
1366         my $counter = 0;
1367         while (my $data = $sth->fetchrow_hashref) {
1368                 $data->{'dewey'} =~ s/0*$//;
1369                 ($data->{'dewey'} == 0) && ($data->{'dewey'} = '');
1370                         # FIXME - The Dewey code is a string, not a number.
1371                 # FIXME - Use POSIX::strftime to get a text version of today's
1372                 # date. That's what it's for.
1373                 # FIXME - Move the date calculation outside of the loop.
1374                 my @datearr = localtime(time());
1375                 my $todaysdate = (1900+$datearr[5]).sprintf ("%0.2d", ($datearr[4]+1)).sprintf ("%0.2d", $datearr[3]);
1376
1377                 # FIXME - Instead of converting the due date to YYYYMMDD, just
1378                 # use
1379                 #       $todaysdate = POSIX::strftime("%Y-%m-%d", localtime);
1380                 #       ...
1381                 #       if ($date->{date_due} lt $todaysdate)
1382                 my $datedue = $data->{'date_due'};
1383                 $datedue =~ s/-//g;
1384                 if ($datedue < $todaysdate) {
1385                         $data->{'overdue'} = 1;
1386                 }
1387                 $currentissues{$counter} = $data;
1388                 $counter++;
1389                         # FIXME - This is ludicrous. If you want to return an
1390                         # array of values, just use an array. That's what
1391                         # they're there for.
1392         }
1393         $sth->finish;
1394         return(\%currentissues);
1395 }
1396
1397 # Not exported
1398 sub checkwaiting {
1399 #Stolen from Main.pm
1400 # check for reserves waiting
1401         my ($env,$dbh,$bornum)=@_;
1402         my @itemswaiting;
1403         my $sth = $dbh->prepare("select * from reserves where (borrowernumber = ?) and (reserves.found='W') and cancellationdate is NULL");
1404         $sth->execute($bornum);
1405         my $cnt=0;
1406         if (my $data=$sth->fetchrow_hashref) {
1407                 $itemswaiting[$cnt] =$data;
1408                 $cnt ++
1409         }
1410         $sth->finish;
1411         return ($cnt,\@itemswaiting);
1412 }
1413
1414 # Not exported
1415 # FIXME - This is nearly-identical to &C4::Accounts::checkaccount
1416 sub checkaccount  {
1417 # Stolen from Accounts.pm
1418   #take borrower number
1419   #check accounts and list amounts owing
1420         my ($env,$bornumber,$dbh,$date)=@_;
1421         my $select="SELECT SUM(amountoutstanding) AS total
1422                         FROM accountlines
1423                 WHERE borrowernumber = ?
1424                         AND amountoutstanding<>0";
1425         my @bind = ($bornumber);
1426         if ($date ne ''){
1427         $select.=" AND date < ?";
1428         push(@bind,$date);
1429         }
1430         #  print $select;
1431         my $sth=$dbh->prepare($select);
1432         $sth->execute(@bind);
1433         my $data=$sth->fetchrow_hashref;
1434         my $total = $data->{'total'};
1435         $sth->finish;
1436         # output(1,2,"borrower owes $total");
1437         #if ($total > 0){
1438         #  # output(1,2,"borrower owes $total");
1439         #  if ($total > 5){
1440         #    reconcileaccount($env,$dbh,$bornumber,$total);
1441         #  }
1442         #}
1443         #  pause();
1444         return($total);
1445 }
1446
1447 # FIXME - This is identical to &C4::Circulation::Renewals::renewstatus.
1448 # Pick one and stick with it.
1449 sub renewstatus {
1450 # Stolen from Renewals.pm
1451   # check renewal status
1452   my ($env,$dbh,$bornum,$itemno)=@_;
1453   my $renews = 1;
1454   my $renewokay = 0;
1455   my $sth1 = $dbh->prepare("select * from issues
1456     where (borrowernumber = ?)
1457     and (itemnumber = ?)
1458     and returndate is null");
1459   $sth1->execute($bornum,$itemno);
1460   if (my $data1 = $sth1->fetchrow_hashref) {
1461     my $sth2 = $dbh->prepare("select renewalsallowed from items,biblioitems,itemtypes
1462        where (items.itemnumber = ?)
1463        and (items.biblioitemnumber = biblioitems.biblioitemnumber)
1464        and (biblioitems.itemtype = itemtypes.itemtype)");
1465     $sth2->execute($itemno);
1466     if (my $data2=$sth2->fetchrow_hashref) {
1467       $renews = $data2->{'renewalsallowed'};
1468     }
1469     if ($renews > $data1->{'renewals'}) {
1470       $renewokay = 1;
1471     }
1472     $sth2->finish;
1473   }
1474   $sth1->finish;
1475   return($renewokay);
1476 }
1477
1478 sub renewbook {
1479 # Stolen from Renewals.pm
1480   # mark book as renewed
1481   my ($env,$dbh,$bornum,$itemno,$datedue)=@_;
1482   $datedue=$env->{'datedue'};
1483   if ($datedue eq "" ) {
1484     my $loanlength=21;
1485     my $sth=$dbh->prepare("Select * from biblioitems,items,itemtypes
1486        where (items.itemnumber = ?)
1487        and (biblioitems.biblioitemnumber = items.biblioitemnumber)
1488        and (biblioitems.itemtype = itemtypes.itemtype)");
1489     $sth->execute($itemno);
1490     if (my $data=$sth->fetchrow_hashref) {
1491       $loanlength = $data->{'loanlength'}
1492     }
1493     $sth->finish;
1494     my $ti = time;
1495     my $datedu = time + ($loanlength * 86400);
1496     my @datearr = localtime($datedu);
1497     $datedue = (1900+$datearr[5])."-".($datearr[4]+1)."-".$datearr[3];
1498   }
1499   my @date = split("-",$datedue);
1500   my $odatedue = ($date[2]+0)."-".($date[1]+0)."-".$date[0];
1501   my $sth=$dbh->prepare("select * from issues where borrowernumber=? and
1502     itemnumber=? and returndate is null");
1503   $sth->execute($bornum,$itemno);
1504   my $issuedata=$sth->fetchrow_hashref;
1505   $sth->finish;
1506   my $renews = $issuedata->{'renewals'} +1;
1507   $sth=$dbh->prepare("update issues
1508     set date_due = ?, renewals = ?
1509     where borrowernumber=? and
1510     itemnumber=? and returndate is null");
1511
1512   $sth->execute($datedue,$renews,$bornum,$itemno);
1513   $sth->finish;
1514   return($odatedue);
1515 }
1516
1517 # FIXME - This is almost, but not quite, identical to
1518 # &C4::Circulation::Issues::calc_charges and
1519 # &C4::Circulation::Renewals2::calc_charges.
1520 # Pick one and stick with it.
1521 sub calc_charges {
1522 # Stolen from Issues.pm
1523 # calculate charges due
1524     my ($env, $dbh, $itemno, $bornum)=@_;
1525 #    if (!$dbh){
1526 #      $dbh=C4Connect();
1527 #    }
1528     my $charge=0;
1529 #    open (FILE,">>/tmp/charges");
1530     my $item_type;
1531     my $sth1= $dbh->prepare("select itemtypes.itemtype,rentalcharge from items,biblioitems,itemtypes
1532     where (items.itemnumber =?)
1533     and (biblioitems.biblioitemnumber = items.biblioitemnumber)
1534     and (biblioitems.itemtype = itemtypes.itemtype)");
1535 #    print FILE "$q1\n";
1536     $sth1->execute($itemno);
1537     if (my $data1=$sth1->fetchrow_hashref) {
1538         $item_type = $data1->{'itemtype'};
1539         $charge = $data1->{'rentalcharge'};
1540 #       print FILE "charge is $charge\n";
1541         my $sth2=$dbh->prepare("select rentaldiscount from borrowers,categoryitem
1542         where (borrowers.borrowernumber = ?)
1543         and (borrowers.categorycode = categoryitem.categorycode)
1544         and (categoryitem.itemtype = ?)");
1545 #       warn $q2;
1546         $sth2->execute($bornum,$item_type);
1547         if (my $data2=$sth2->fetchrow_hashref) {
1548             my $discount = $data2->{'rentaldiscount'};
1549 #           print FILE "discount is $discount";
1550             if ($discount eq 'NULL') {
1551               $discount=0;
1552             }
1553             $charge = ($charge *(100 - $discount)) / 100;
1554         }
1555         $sth2->finish;
1556     }
1557     $sth1->finish;
1558 #    close FILE;
1559     return ($charge, $item_type);
1560 }
1561
1562 # FIXME - A virtually identical function appears in
1563 # C4::Circulation::Issues. Pick one and stick with it.
1564 sub createcharge {
1565 #Stolen from Issues.pm
1566     my ($env,$dbh,$itemno,$bornum,$charge) = @_;
1567     my $nextaccntno = getnextacctno($env,$bornum,$dbh);
1568     my $sth = $dbh->prepare(<<EOT);
1569         INSERT INTO     accountlines
1570                         (borrowernumber, itemnumber, accountno,
1571                          date, amount, description, accounttype,
1572                          amountoutstanding)
1573         VALUES          (?, ?, ?,
1574                          now(), ?, 'Rental', 'Rent',
1575                          ?)
1576 EOT
1577     $sth->execute($bornum, $itemno, $nextaccntno, $charge, $charge);
1578     $sth->finish;
1579 }
1580
1581
1582 sub getnextacctno {
1583 # Stolen from Accounts.pm
1584     my ($env,$bornumber,$dbh)=@_;
1585     my $nextaccntno = 1;
1586     my $sth = $dbh->prepare("select * from accountlines where (borrowernumber = ?) order by accountno desc");
1587     $sth->execute($bornumber);
1588     if (my $accdata=$sth->fetchrow_hashref){
1589         $nextaccntno = $accdata->{'accountno'} + 1;
1590     }
1591     $sth->finish;
1592     return($nextaccntno);
1593 }
1594
1595 =item find_reserves
1596
1597   ($status, $record) = &find_reserves($itemnumber);
1598
1599 Looks up an item in the reserves.
1600
1601 C<$itemnumber> is the itemnumber to look up.
1602
1603 C<$status> is true iff the search was successful.
1604
1605 C<$record> is a reference-to-hash describing the reserve. Its keys are
1606 the fields from the reserves table of the Koha database.
1607
1608 =cut
1609 #'
1610 # FIXME - This API is bogus: just return the record, or undef if none
1611 # was found.
1612 # FIXME - There's also a &C4::Circulation::Returns::find_reserves, but
1613 # that one looks rather different.
1614 sub find_reserves {
1615 # Stolen from Returns.pm
1616     my ($itemno) = @_;
1617     my %env;
1618     my $dbh = C4::Context->dbh;
1619     my ($itemdata) = getiteminformation(\%env, $itemno,0);
1620     my $bibno = $dbh->quote($itemdata->{'biblionumber'});
1621     my $bibitm = $dbh->quote($itemdata->{'biblioitemnumber'});
1622     my $sth = $dbh->prepare("select * from reserves where ((found = 'W') or (found is null)) and biblionumber = ? and cancellationdate is NULL order by priority, reservedate");
1623     $sth->execute($bibno);
1624     my $resfound = 0;
1625     my $resrec;
1626     my $lastrec;
1627 # print $query;
1628
1629     # FIXME - I'm not really sure what's going on here, but since we
1630     # only want one result, wouldn't it be possible (and far more
1631     # efficient) to do something clever in SQL that only returns one
1632     # set of values?
1633     while (($resrec = $sth->fetchrow_hashref) && (not $resfound)) {
1634                 # FIXME - Unlike Pascal, Perl allows you to exit loops
1635                 # early. Take out the "&& (not $resfound)" and just
1636                 # use "last" at the appropriate point in the loop.
1637                 # (Oh, and just in passing: if you'd used "!" instead
1638                 # of "not", you wouldn't have needed the parentheses.)
1639         $lastrec = $resrec;
1640         my $brn = $dbh->quote($resrec->{'borrowernumber'});
1641         my $rdate = $dbh->quote($resrec->{'reservedate'});
1642         my $bibno = $dbh->quote($resrec->{'biblionumber'});
1643         if ($resrec->{'found'} eq "W") {
1644             if ($resrec->{'itemnumber'} eq $itemno) {
1645                 $resfound = 1;
1646             }
1647         } else {
1648             # FIXME - Use 'elsif' to avoid unnecessary indentation.
1649             if ($resrec->{'constrainttype'} eq "a") {
1650                 $resfound = 1;
1651             } else {
1652                         my $consth = $dbh->prepare("select * from reserveconstraints where borrowernumber = ? and reservedate = ? and biblionumber = ? and biblioitemnumber = ?");
1653                         $consth->execute($brn,$rdate,$bibno,$bibitm);
1654                         if (my $conrec = $consth->fetchrow_hashref) {
1655                                 if ($resrec->{'constrainttype'} eq "o") {
1656                                 $resfound = 1;
1657                                 }
1658                         }
1659                 $consth->finish;
1660                 }
1661         }
1662         if ($resfound) {
1663             my $updsth = $dbh->prepare("update reserves set found = 'W', itemnumber = ? where borrowernumber = ? and reservedate = ? and biblionumber = ?");
1664             $updsth->execute($itemno,$brn,$rdate,$bibno);
1665             $updsth->finish;
1666             # FIXME - "last;" here to break out of the loop early.
1667         }
1668     }
1669     $sth->finish;
1670     return ($resfound,$lastrec);
1671 }
1672
1673 1;
1674 __END__
1675
1676 =back
1677
1678 =head1 AUTHOR
1679
1680 Koha Developement team <info@koha.org>
1681
1682 =cut