C4/Circulation/Circ2.pm

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