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