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