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