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