[Koha-cvs] koha/intranet/modules/C4/Circulation Circ2.pm C... [rel_TG]
Tumer Garip
tgarip at neu.edu.tr
Sat Mar 10 02:39:27 CET 2007
CVSROOT: /sources/koha
Module name: koha
Branch: rel_TG
Changes by: Tumer Garip <tgarip1957> 07/03/10 01:39:27
Added files:
intranet/modules/C4/Circulation: Circ2.pm Circ3.pm Fines.pm
PrinterConfig.pm
Log message:
fresh files for rel_TG
CVSWeb URLs:
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Circulation/Circ2.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Circulation/Circ3.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Circulation/Fines.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
http://cvs.savannah.gnu.org/viewcvs/koha/intranet/modules/C4/Circulation/PrinterConfig.pm?cvsroot=koha&only_with_tag=rel_TG&rev=1.1.2.1
Patches:
Index: Circ2.pm
===================================================================
RCS file: Circ2.pm
diff -N Circ2.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Circ2.pm 10 Mar 2007 01:39:27 -0000 1.1.2.1
@@ -0,0 +1,2003 @@
+package C4::Circulation::Circ2;
+
+
+# Copyright 2000-2002 Katipo Communications
+#
+# This file is part of Koha.
+#
+# Koha is free software; you can redistribute it and/or modify it under the
+# terms of the GNU General Public License as published by the Free Software
+# Foundation; either version 2 of the License, or (at your option) any later
+# version.
+#
+# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
+# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
+# Suite 330, Boston, MA 02111-1307 USA
+
+use strict;
+require Exporter;
+
+use C4::Context;
+use C4::Stats;
+use C4::Reserves2;
+use C4::Koha;
+use C4::Accounts2;
+use C4::Biblio;
+use C4::Calendar::Calendar;
+use C4::Search;
+use C4::Members;
+use C4::Date;
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+
+# set the version for version checking
+$VERSION = do { my @v = '$Revision: 1.1.2.1 $' =~ /\d+/g; shift(@v).".".join( "_", map { sprintf "%03d", $_ } @v ); };
+
+=head1 NAME
+
+C4::Circulation::Circ2 - Koha circulation module
+
+=head1 SYNOPSIS
+
+ use C4::Circulation::Circ2;
+
+=head1 DESCRIPTION
+
+The functions in this module deal with circulation, issues, and
+returns, as well as general information about the library.
+Also deals with stocktaking.
+
+=head1 FUNCTIONS
+
+=over 2
+
+=cut
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(
+ ¤tissues
+ &getissues
+ &getiteminformation
+ &renewstatus
+ &renewbook
+ &canbookbeissued
+ &issuebook
+ &returnbook
+ &find_reserves
+ &transferbook
+ &decode
+
+ &listitemsforinventory
+ &itemseen
+ &itemseenbarcode
+ &fixdate
+ &itemissues
+
+ &get_current_return_date_of
+ &get_transfert_infos
+ &checktransferts
+ &GetReservesForBranch
+ &GetReservesToBranch
+ &GetTransfersFromBib
+ &getBranchIp);
+
+# &getbranches &getprinters &getbranch &getprinter => moved to C4::Koha.pm
+=item itemissues
+
+ @issues = &itemissues($biblionumber, $biblio);
+
+Looks up information about who has borrowed the bookZ<>(s) with the
+given biblionumber.
+
+C<$biblio> is ignored.
+
+C<&itemissues> returns an array of references-to-hash. The keys
+include the fields from the C<items> table in the Koha database.
+Additional keys include:
+
+=over 4
+
+=item C<date_due>
+
+If the item is currently on loan, this gives the due date.
+
+If the item is not on loan, then this is either "Available" or
+"Cancelled", if the item has been withdrawn.
+
+=item C<card>
+
+If the item is currently on loan, this gives the card number of the
+patron who currently has the item.
+
+=item C<timestamp0>, C<timestamp1>, C<timestamp2>
+
+These give the timestamp for the last three times the item was
+borrowed.
+
+=item C<card0>, C<card1>, C<card2>
+
+The card number of the last three patrons who borrowed this item.
+
+=item C<borrower0>, C<borrower1>, C<borrower2>
+
+The borrower number of the last three patrons who borrowed this item.
+
+=back
+
+=cut
+#'
+sub itemissues {
+ my ($dbh,$data, $itemnumber)=@_;
+
+
+ my $i = 0;
+ my @results;
+
+
+ # Find out who currently has this item.
+ # FIXME - Wouldn't it be better to do this as a left join of
+ # some sort? Currently, this code assumes that if
+ # fetchrow_hashref() fails, then the book is on the shelf.
+ # fetchrow_hashref() can fail for any number of reasons (e.g.,
+ # database server crash), not just because no items match the
+ # search criteria.
+ my $sth2 = $dbh->prepare("select * from issues,borrowers
+where itemnumber = ?
+and returndate is NULL
+and issues.borrowernumber = borrowers.borrowernumber");
+
+ $sth2->execute($itemnumber);
+ if (my $data2 = $sth2->fetchrow_hashref) {
+
+ $data->{'date_due'}=$data2->{'date_due'};
+ $data->{'datelastborrowed'} = $data2->{'issue_date'};
+ $data->{'card'} = $data2->{'cardnumber'};
+ $data->{'borrower'} = $data2->{'borrowernumber'};
+ $data->{issues}++;
+ }
+
+ $sth2->finish;
+ my $sth2 = $dbh->prepare("select * from reserveissue,borrowers
+where itemnumber = ?
+and rettime is NULL
+and reserveissue.borrowernumber = borrowers.borrowernumber");
+
+ $sth2->execute($itemnumber);
+ if (my $data2 = $sth2->fetchrow_hashref) {
+
+ $data->{'date_due'}=$data2->{'duetime'};
+ $data->{'datelastborrowed'} = $data2->{'restime'};
+ $data->{'card'} = $data2->{'cardnumber'};
+ $data->{'borrower'} = $data2->{'borrowernumber'};
+ $data->{issues}++;
+ }
+
+ $sth2->finish;
+ # Find the last 2 people who borrowed this item.
+ $sth2 = $dbh->prepare("select * from issues, borrowers
+ where itemnumber = ?
+ and issues.borrowernumber = borrowers.borrowernumber
+ and returndate is not NULL
+ order by returndate desc,timestamp desc limit 2") ;
+ $sth2->execute($itemnumber) ;
+my $i2=0;
+ while (my $data2 = $sth2->fetchrow_hashref) {
+ $data->{"timestamp$i2"} = $data2->{'timestamp'};
+ $data->{"card$i2"} = $data2->{'cardnumber'};
+ $data->{"borrower$i2"} = $data2->{'borrowernumber'};
+$data->{'datelastborrowed'} = $data2->{'issue_date'} unless $data->{'datelastborrowed'};
+ $i2++;
+ } # while
+
+ $sth2->finish;
+ return($data);
+}
+
+
+
+=head2 itemseen
+
+&itemseen($dbh,$itemnum)
+Mark item as seen. Is called when an item is issued, returned or manually marked during inventory/stocktaking
+C<$itemnum> is the item number
+
+=cut
+
+sub itemseen {
+ my ($dbh,$itemnumber) = @_;
+my $sth=$dbh->prepare("select biblionumber from items where itemnumber=?");
+ $sth->execute($itemnumber);
+my ($biblionumber)=$sth->fetchrow;
+XMLmoditemonefield($dbh,$biblionumber,$itemnumber,'itemlost',"0",1);
+# find today's date
+my ($sec,$min,$hour,$mday,$mon,$year) = localtime();
+ $year += 1900;
+ $mon += 1;
+ my $timestamp = sprintf("%4d%02d%02d%02d%02d%02d.0",
+ $year,$mon,$mday,$hour,$min,$sec);
+XMLmoditemonefield($dbh,$biblionumber,$itemnumber,'datelastseen', $timestamp);
+}
+sub itemseenbarcode {
+ my ($dbh,$barcode) = @_;
+my $sth=$dbh->prepare("select biblionumber,itemnumber from items where barcode=$barcode");
+ $sth->execute();
+my ($biblionumber,$itemnumber)=$sth->fetchrow;
+XMLmoditemonefield($dbh,$biblionumber,$itemnumber,'itemlost',"0",1);
+my ($sec,$min,$hour,$mday,$mon,$year) = localtime();
+ $year += 1900;
+ $mon += 1;
+my $timestamp = sprintf("%4d%02d%02d%02d%02d%02d.0",$year,$mon,$mday,$hour,$min,$sec);
+XMLmoditemonefield($dbh,$biblionumber,$itemnumber,'datelastseen', $timestamp);
+}
+
+
+
+
+
+=head2 decode
+
+=over 4
+
+=head3 $str = &decode($chunk);
+
+=over 4
+
+Decodes a segment of a string emitted by a CueCat barcode scanner and
+returns it.
+
+=back
+
+=back
+
+=cut
+
+# FIXME - At least, I'm pretty sure this is for decoding CueCat stuff.
+sub decode {
+ my ($encoded) = @_;
+ my $seq = 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789+-';
+ my @s = map { index($seq,$_); } split(//,$encoded);
+ my $l = ($#s+1) % 4;
+ if ($l)
+ {
+ if ($l == 1)
+ {
+ print "Error!";
+ return;
+ }
+ $l = 4-$l;
+ $#s += $l;
+ }
+ my $r = '';
+ while ($#s >= 0)
+ {
+ my $n = (($s[0] << 6 | $s[1]) << 6 | $s[2]) << 6 | $s[3];
+ $r .=chr(($n >> 16) ^ 67) .
+ chr(($n >> 8 & 255) ^ 67) .
+ chr(($n & 255) ^ 67);
+ @s = @s[4..$#s];
+ }
+ $r = substr($r,0,length($r)-$l);
+ return $r;
+}
+
+=head2 getiteminformation
+
+=over 4
+
+$item = &getiteminformation($env, $itemnumber, $barcode);
+
+Looks up information about an item, given either its item number or
+its barcode. If C<$itemnumber> is a nonzero value, it is used;
+otherwise, C<$barcode> is used.
+
+C<$env> is effectively ignored, but should be a reference-to-hash.
+
+C<$item> is a reference-to-hash whose keys are fields from the biblio,
+items, and biblioitems tables of the Koha database. It may also
+contain the following keys:
+
+=head3 date_due
+
+=over 4
+
+The due date on this item, if it has been borrowed and not returned
+yet. The date is in YYYY-MM-DD format.
+
+=back
+
+=head3 notforloan
+
+=over 4
+
+True if the item may not be borrowed.
+
+=back
+
+=back
+
+=cut
+
+
+sub getiteminformation {
+# returns a hash of item information together with biblio given either the itemnumber or the barcode
+ my ($env, $itemnumber, $barcode) = @_;
+ my $dbh=C4::Context->dbh;
+ my ($itemrecord)=XMLgetitem($dbh,$itemnumber,$barcode);
+ return undef unless $itemrecord; ## This is to prevent a system crash if barcode does not exist
+ my $itemhash=XML_xml2hash_onerecord($itemrecord);
+ my $iteminformation=XMLmarc2koha_onerecord($dbh,$itemhash,"holdings");
+##Now get full biblio details from MARC
+ if ($iteminformation) {
+my ($record)=XMLgetbiblio($dbh,$iteminformation->{'biblionumber'});
+ my $recordhash=XML_xml2hash_onerecord($record);
+my $biblio=XMLmarc2koha_onerecord($dbh,$recordhash,"biblios");
+ foreach my $field (keys %$biblio){
+ $iteminformation->{$field}=$biblio->{$field};
+ }
+ $iteminformation->{'date_due'}="" if $iteminformation->{'date_due'} eq "0000-00-00";
+ ($iteminformation->{'dewey'} == 0) && ($iteminformation->{'dewey'}='');
+ }
+ return($iteminformation);
+}
+
+=head2 transferbook
+
+=over 4
+
+($dotransfer, $messages, $iteminformation) = &transferbook($newbranch, $barcode, $ignore_reserves);
+
+Transfers an item to a new branch. If the item is currently on loan, it is automatically returned before the actual transfer.
+
+C<$newbranch> is the code for the branch to which the item should be transferred.
+
+C<$barcode> is the barcode of the item to be transferred.
+
+If C<$ignore_reserves> is true, C<&transferbook> ignores reserves.
+Otherwise, if an item is reserved, the transfer fails.
+
+Returns three values:
+
+=head3 $dotransfer
+
+is true if the transfer was successful.
+
+=head3 $messages
+
+is a reference-to-hash which may have any of the following keys:
+
+=over 4
+
+C<BadBarcode>
+
+There is no item in the catalog with the given barcode. The value is C<$barcode>.
+
+C<IsPermanent>
+
+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.
+
+C<DestinationEqualsHolding>
+
+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.
+
+C<WasReturned>
+
+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.
+
+C<ResFound>
+
+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>.
+
+C<WasTransferred>
+
+The item was eligible to be transferred. Barring problems communicating with the database, the transfer should indeed have succeeded. The value should be ignored.
+
+=back
+
+=back
+
+=back
+
+=cut
+
+##This routine is reverted to origional state
+##This routine is used when a book physically arrives at a branch due to user returning it there
+## so record the fact that holdingbranch is changed.
+sub transferbook {
+# transfer book code....
+ my ($tbr, $barcode, $ignoreRs,$user) = @_;
+ my $messages;
+ my %env;
+ my $dbh=C4::Context->dbh;
+ my $dotransfer = 1;
+ my $branches = GetBranches();
+
+ my $iteminformation = getiteminformation(\%env, 0, $barcode);
+ # bad barcode..
+ if (not $iteminformation) {
+ $messages->{'BadBarcode'} = $barcode;
+ $dotransfer = 0;
+ }
+ # get branches of book...
+ my $hbr = $iteminformation->{'homebranch'};
+ my $fbr = $iteminformation->{'holdingbranch'};
+ # if is permanent...
+ if ($hbr && $branches->{$hbr}->{'PE'}) {
+ $messages->{'IsPermanent'} = $hbr;
+ }
+ # can't transfer book if is already there....
+ # FIXME - Why not? Shouldn't it trivially succeed?
+ if ($fbr eq $tbr) {
+ $messages->{'DestinationEqualsHolding'} = 1;
+ $dotransfer = 0;
+ }
+ # check if it is still issued to someone, return it...
+ my ($currentborrower) = currentborrower($iteminformation->{'itemnumber'});
+ if ($currentborrower) {
+ returnbook($barcode, $fbr);
+ $messages->{'WasReturned'} = $currentborrower;
+ }
+ # find reserves.....
+ # FIXME - Don't call &CheckReserves unless $ignoreRs is true.
+ # That'll save a database query.
+ my ($resfound, $resrec) = CheckReserves($iteminformation->{'itemnumber'});
+ if ($resfound and not $ignoreRs) {
+ $resrec->{'ResFound'} = $resfound;
+ $messages->{'ResFound'} = $resrec;
+ $dotransfer = 0;
+ }
+ #actually do the transfer....
+ if ($dotransfer) {
+ dotransfer($iteminformation->{'itemnumber'}, $fbr, $tbr,$user);
+ $messages->{'WasTransfered'} = 1;
+ }
+ return ($dotransfer, $messages, $iteminformation);
+}
+
+# Not exported
+
+sub dotransfer {
+## The book has arrived at this branch because it has been returned there
+## So we update the fact the book is in that branch not that we want to send the book to that branch
+
+ my ($itm, $fbr, $tbr,$user) = @_;
+ my $dbh = C4::Context->dbh;
+
+ #new entry in branchtransfers....
+ my $sth=$dbh->prepare("INSERT INTO branchtransfers (itemnumber, frombranch, datearrived, tobranch,comments) VALUES (?, ?, now(), ?,?)");
+ $sth->execute($itm, $fbr, $tbr,$user);
+ #update holdingbranch in items .....
+ &domarctransfer($dbh,$itm,$tbr);
+## Item seen taken out of this loop to optimize ZEBRA updates
+# &itemseen($dbh,$itm);
+ return;
+}
+
+sub domarctransfer{
+my ($dbh,$itemnumber,$holdingbranch) = @_;
+$itemnumber=~s /\'//g;
+my $sth=$dbh->prepare("select biblionumber from items where itemnumber=$itemnumber");
+ $sth->execute();
+my ($biblionumber)=$sth->fetchrow;
+XMLmoditemonefield($dbh,$biblionumber,$itemnumber,'holdingbranch',$holdingbranch,1);
+ $sth->finish;
+}
+
+=head2 canbookbeissued
+
+Check if a book can be issued.
+
+my ($issuingimpossible,$needsconfirmation) = canbookbeissued($env,$borrower,$barcode,$year,$month,$day);
+
+=over 4
+
+C<$env> Environment variable. Should be empty usually, but used by other subs. Next code cleaning could drop it.
+
+C<$borrower> hash with borrower informations (from getpatroninformation)
+
+C<$barcode> is the bar code of the book being issued.
+
+C<$year> C<$month> C<$day> contains the date of the return (in case it's forced by "stickyduedate".
+
+=back
+
+Returns :
+
+=over 4
+
+C<$issuingimpossible> a reference to a hash. It contains reasons why issuing is impossible.
+Possible values are :
+
+=head3 INVALID_DATE
+
+sticky due date is invalid
+
+=head3 GNA
+
+borrower gone with no address
+
+=head3 CARD_LOST
+
+borrower declared it's card lost
+
+=head3 DEBARRED
+
+borrower debarred
+
+=head3 UNKNOWN_BARCODE
+
+barcode unknown
+
+=head3 NOT_FOR_LOAN
+
+item is not for loan
+
+=head3 WTHDRAWN
+
+item withdrawn.
+
+=head3 RESTRICTED
+
+item is restricted (set by ??)
+
+=back
+
+C<$issuingimpossible> a reference to a hash. It contains reasons why issuing is impossible.
+Possible values are :
+
+=head3 DEBT
+
+borrower has debts.
+
+=head3 RENEW_ISSUE
+
+renewing, not issuing
+
+=head3 ISSUED_TO_ANOTHER
+
+issued to someone else.
+
+=head3 RESERVED
+
+reserved for someone else.
+
+=head3 INVALID_DATE
+
+sticky due date is invalid
+
+=head3 TOO_MANY
+
+if the borrower borrows to much things
+
+=cut
+
+# check if a book can be issued.
+# returns an array with errors if any
+
+
+
+
+
+
+
+
+
+
+
+sub TooMany ($$){
+ my $borrower = shift;
+ my $iteminformation = shift;
+ my $cat_borrower = $borrower->{'categorycode'};
+ my $branch_borrower = $borrower->{'branchcode'};
+ my $dbh = C4::Context->dbh;
+ my $type = $iteminformation->{'ctype'};
+my $sth = $dbh->prepare('select * from issuingrules where categorycode = ? and itemtype = ? and branchcode = ?');
+ my $sth2 = $dbh->prepare("select COUNT(*) from issues i, items it where i.borrowernumber = ? and i.returndate is null and i.itemnumber = it.itemnumber and it.ctype=? ");
+ my $sth3 = $dbh->prepare('select COUNT(*) from issues where borrowernumber = ? and returndate is null');
+ my $alreadyissued;
+
+ # check the 3 parameters
+ #print "content-type: text/plain \n\n";
+ #print "$cat_borrower, $type, $branch_borrower";
+ $sth->execute($cat_borrower, $type, $branch_borrower);
+ my $result = $sth->fetchrow_hashref;
+ if (defined($result->{maxissueqty})) {
+ # print "content-type: text/plain \n\n";
+ #print "$cat_borrower, $type, $branch_borrower";
+ $sth2->execute($borrower->{'borrowernumber'}, $type);
+ my $alreadyissued = $sth2->fetchrow;
+ # print "***" . $alreadyissued;
+ #print "----". $result->{'maxissueqty'};
+ if ($result->{'maxissueqty'} <= $alreadyissued) {
+ return ("$type $alreadyissued / max:".($result->{'maxissueqty'}+0));
+ }
+ }
+# check for itemtype=*
+ $sth->execute($cat_borrower, "*", $branch_borrower);
+ $result = $sth->fetchrow_hashref;
+ if (defined($result->{maxissueqty})) {
+ $sth3->execute($borrower->{'borrowernumber'});
+ my ($alreadyissued) = $sth3->fetchrow;
+ if ($result->{'maxissueqty'} <= $alreadyissued){
+# warn "HERE : $alreadyissued / ($result->{maxissueqty} for $borrower->{'borrowernumber'}";
+ return ("$type $alreadyissued / max:".($result->{'maxissueqty'}+0));
+ } else {
+ return;
+ }
+ }
+ # check for branch=*
+ $sth->execute($cat_borrower, $type, "");
+ $result = $sth->fetchrow_hashref;
+ if (defined($result->{maxissueqty})) {
+ $sth2->execute($borrower->{'borrowernumber'}, $type);
+ my $alreadyissued = $sth2->fetchrow;
+ if ($result->{'maxissueqty'} <= $alreadyissued){
+ return ("$type $alreadyissued / max:".($result->{'maxissueqty'}+0));
+ } else {
+ return;
+ }
+ }
+
+
+
+ #check for borrowertype=*
+ $sth->execute("*", $type, $branch_borrower);
+ $result = $sth->fetchrow_hashref;
+ if (defined($result->{maxissueqty})) {
+ $sth2->execute($borrower->{'borrowernumber'}, "%$type%");
+ my $alreadyissued = $sth2->fetchrow;
+ if ($result->{'maxissueqty'} <= $alreadyissued){
+ return ("$type $alreadyissued / max:".($result->{'maxissueqty'}+0));
+ } else {
+ return;
+ }
+ }
+
+ #check for borrowertype=*;itemtype=*
+ $sth->execute("*", "*", $branch_borrower);
+ $result = $sth->fetchrow_hashref;
+ if (defined($result->{maxissueqty})) {
+ $sth3->execute($borrower->{'borrowernumber'});
+ my $alreadyissued = $sth3->fetchrow;
+ if ($result->{'maxissueqty'} <= $alreadyissued){
+ return ("$type $alreadyissued / max:".($result->{'maxissueqty'}+0));
+ } else {
+ return;
+ }
+ }
+
+ $sth->execute("*", $type, "");
+ $result = $sth->fetchrow_hashref;
+ if (defined($result->{maxissueqty}) && $result->{maxissueqty}>=0) {
+ $sth2->execute($borrower->{'borrowernumber'}, "%$type%");
+ my $alreadyissued = $sth2->fetchrow;
+ if ($result->{'maxissueqty'} <= $alreadyissued){
+ return ("$type $alreadyissued / max:".($result->{'maxissueqty'}+0));
+ } else {
+ return;
+ }
+ }
+
+ $sth->execute($cat_borrower, "*", "");
+ $result = $sth->fetchrow_hashref;
+ if (defined($result->{maxissueqty})) {
+ $sth2->execute($borrower->{'borrowernumber'}, "%$type%");
+ my $alreadyissued = $sth2->fetchrow;
+ if ($result->{'maxissueqty'} <= $alreadyissued){
+ return ("$type $alreadyissued / max:".($result->{'maxissueqty'}+0));
+ } else {
+ return;
+ }
+ }
+
+ $sth->execute("*", "*", "");
+ $result = $sth->fetchrow_hashref;
+ if (defined($result->{maxissueqty})) {
+ $sth3->execute($borrower->{'borrowernumber'});
+ my $alreadyissued = $sth3->fetchrow;
+ if ($result->{'maxissueqty'} <= $alreadyissued){
+ return ("$type $alreadyissued / max:".($result->{'maxissueqty'}+0));
+ } else {
+ return;
+ }
+ }
+ return;
+}
+
+
+
+
+sub canbookbeissued {
+ my ($env,$borrower,$barcode,$year,$month,$day,$inprocess) = @_;
+ my %needsconfirmation; # filled with problems that needs confirmations
+ my %issuingimpossible; # filled with problems that causes the issue to be IMPOSSIBLE
+ my $iteminformation = getiteminformation($env, 0, $barcode);
+ my $dbh = C4::Context->dbh;
+#
+# DUE DATE is OK ?
+#
+ my ($duedate, $invalidduedate) = fixdate($year, $month, $day);
+ $issuingimpossible{INVALID_DATE} = 1 if ($invalidduedate);
+
+#
+# BORROWER STATUS
+#
+ if ($borrower->{flags}->{GNA}) {
+ $issuingimpossible{GNA} = 1;
+ }
+ if ($borrower->{flags}->{'LOST'}) {
+ $issuingimpossible{CARD_LOST} = 1;
+ }
+ if ($borrower->{flags}->{'DBARRED'}) {
+ $issuingimpossible{DEBARRED} = 1;
+ }
+ my $today=get_today();
+ if (DATE_diff($borrower->{expiry},$today)<0) {
+ $issuingimpossible{EXPIRED} = 1;
+ }
+#
+# BORROWER STATUS
+#
+
+# DEBTS
+ my $amount = C4::Accounts2::checkaccount($env,$borrower->{'borrowernumber'}, $dbh,$duedate);
+ if(C4::Context->preference("IssuingInProcess")){
+ my $amountlimit = C4::Context->preference("noissuescharge");
+ if ($amount > $amountlimit && !$inprocess) {
+ $issuingimpossible{DEBT} = sprintf("%.2f",$amount);
+ } elsif ($amount <= $amountlimit && !$inprocess) {
+ $needsconfirmation{DEBT} = sprintf("%.2f",$amount);
+ }
+ } else {
+ if ($amount >0) {
+ $needsconfirmation{DEBT} = $amount;
+ }
+ }
+
+
+#
+# JB34 CHECKS IF BORROWERS DONT HAVE ISSUE TOO MANY BOOKS
+#
+ my $toomany = TooMany($borrower, $iteminformation);
+ $needsconfirmation{TOO_MANY} = $toomany if $toomany;
+ $issuingimpossible{TOO_MANY} = $toomany if $toomany;
+#
+# ITEM CHECKING
+#
+ unless ($iteminformation->{barcode}) {
+ $issuingimpossible{UNKNOWN_BARCODE} = 1;
+ }
+ if ($iteminformation->{'notforloan'} > 0) {
+ $issuingimpossible{NOT_FOR_LOAN} = 1;
+ }
+ if ($iteminformation->{'ctype'} eq 'REF') {
+ $issuingimpossible{NOT_FOR_LOAN} = 1;
+ }
+ if ($iteminformation->{'wthdrawn'} == 1) {
+ $issuingimpossible{WTHDRAWN} = 1;
+ }
+ if ($iteminformation->{'restricted'} == 1) {
+ $issuingimpossible{RESTRICTED} = 1;
+ }
+ if ($iteminformation->{'shelf'} eq 'Res') {
+ $issuingimpossible{IN_RESERVE} = 1;
+ }
+if (C4::Context->preference("IndependantBranches")){
+ my $userenv = C4::Context->userenv;
+ if (($userenv)&&($userenv->{flags} != 1)){
+ $issuingimpossible{NOTSAMEBRANCH} = 1 if ($iteminformation->{'holdingbranch'} ne $userenv->{branch} ) ;
+ }
+ }
+
+#
+# CHECK IF BOOK ALREADY ISSUED TO THIS BORROWER
+#
+ my ($currentborrower) = currentborrower($iteminformation->{'itemnumber'});
+ if ($currentborrower eq $borrower->{'borrowernumber'}) {
+# Already issued to current borrower. Ask whether the loan should
+# be renewed.
+ my ($renewstatus) = renewstatus($env, $borrower->{'borrowernumber'}, $iteminformation->{'itemnumber'});
+ if ($renewstatus == 0) { # no more renewals allowed
+ $issuingimpossible{NO_MORE_RENEWALS} = 1;
+ } else {
+ if (C4::Context->preference("strictrenewals")){
+ ###if this is set do not allow automatic renewals
+ ##the new renew script will do same strict checks as issues and return error codes
+ $needsconfirmation{RENEW_ISSUE} = 1;
+ }
+
+ }
+ } elsif ($currentborrower) {
+# issued to someone else
+ my $currborinfo = C4::Members::getpatroninformation(0,$currentborrower);
+# warn "=>.$currborinfo->{'firstname'} $currborinfo->{'surname'} ($currborinfo->{'cardnumber'})";
+ $needsconfirmation{ISSUED_TO_ANOTHER} = "$currborinfo->{'reservedate'} : $currborinfo->{'firstname'} $currborinfo->{'surname'} ($currborinfo->{'cardnumber'})";
+ }
+ my $returningborrower=currentreturningborrower($iteminformation->{'itemnumber'});
+##Book cannot be reissued if returned within last 24 hrs
+ if ($returningborrower->{borrowernumber}==$borrower->{borrowernumber}){
+ $needsconfirmation{hr_LIMIT} = "$returningborrower->{'firstname'} $returningborrower->{'surname'} ($returningborrower->{'cardnumber'}) returned the book on: $returningborrower->{timestamp}";
+ }
+# See if the item is on RESERVE
+ my ($restype, $res) = CheckReserves($iteminformation->{'itemnumber'});
+ if ($restype) {
+ my $resbor = $res->{'borrowernumber'};
+ my ($resborrower, $flags)=C4::Members::getpatroninformation($env, $resbor,0);
+ my $branches = GetBranches();
+ my $branchname = $branches->{$res->{'branchcode'}}->{'branchname'};
+ if ($resbor ne $borrower->{'borrowernumber'} && $restype eq "Waiting") {
+ # The item is on reserve and waiting, but has been
+ # reserved by some other patron.
+
+
+ $needsconfirmation{RESERVE_WAITING} = "$resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'}, $branchname)";
+ # CancelReserve(0, $res->{'itemnumber'}, $res->{'borrowernumber'});
+ } elsif ($restype eq "Reserved") {
+ # The item is on reserve for someone else.
+
+ $needsconfirmation{RESERVED} = "$res->{'reservedate'} : $resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'})";
+ }
+ }
+ if(C4::Context->preference("LibraryName") eq "Horowhenua Library Trust"){
+ if ($borrower->{'categorycode'} eq 'W'){
+ my %issuingimpossible;
+ return(\%issuingimpossible,\%needsconfirmation);
+ }
+ }
+
+ return(\%issuingimpossible,\%needsconfirmation);
+}
+
+=head2 issuebook
+
+Issue a book. Does no check, they are done in canbookbeissued. If we reach this sub, it means the user confirmed if needed.
+
+&issuebook($env,$borrower,$barcode,$date)
+
+=over 4
+
+C<$env> Environment variable. Should be empty usually, but used by other subs. Next code cleaning could drop it.
+
+C<$borrower> hash with borrower informations (from getpatroninformation)
+
+C<$barcode> is the bar code of the book being issued.
+
+C<$date> contains the max date of return. calculated if empty.
+
+=cut
+
+#
+# issuing book. We already have checked it can be issued, so, just issue it !
+#
+sub issuebook {
+### fix me STOP using koha hashes, change so that XML hash is used
+ my ($env,$borrower,$barcode,$date,$cancelreserve) = @_;
+ my $dbh = C4::Context->dbh;
+ my $itemrecord=XMLgetitemhash($dbh,"",$barcode);
+ my $iteminformation=XMLmarc2koha_onerecord($dbh,$itemrecord,"holdings");
+ $iteminformation->{'itemtype'}=MARCfind_itemtype($dbh,$iteminformation->{biblionumber});
+ my $bibliorecord=XMLgetbibliohash($dbh,$iteminformation->{biblionumber});
+
+ my $error;
+#
+# check if we just renew the issue.
+#
+ my ($currentborrower) = currentborrower($iteminformation->{'itemnumber'});
+ if ($currentborrower eq $borrower->{'borrowernumber'}) {
+ my ($charge,$itemtype) = calc_charges($env, $iteminformation->{'itemnumber'}, $borrower->{'borrowernumber'});
+ if ($charge > 0) {
+ createcharge($env, $dbh, $iteminformation->{'itemnumber'}, $borrower->{'borrowernumber'}, $charge);
+ $iteminformation->{'charge'} = $charge;
+ }
+ &UpdateStats($env,$env->{'branchcode'},'renew',$charge,'',$iteminformation->{'itemnumber'},$iteminformation->{'ctype'},$borrower->{'borrowernumber'});
+ if (C4::Context->preference("strictrenewals")){
+ $error=renewstatus($env, $borrower->{'borrowernumber'}, $iteminformation->{'itemnumber'});
+ renewbook($env, $borrower->{'borrowernumber'}, $iteminformation->{'itemnumber'}) if ($error>1);
+ }else{
+ renewbook($env, $borrower->{'borrowernumber'}, $iteminformation->{'itemnumber'});
+ }
+ } else {
+#
+# NOT a renewal
+#
+ if ($currentborrower ne '') {
+ # This book is currently on loan, but not to the person
+ # who wants to borrow it now. mark it returned before issuing to the new borrower
+ returnbook($iteminformation->{'barcode'}, $env->{'branchcode'});
+#warn "return : ".$borrower->{borrowernumber}." / I : ".$iteminformation->{'itemnumber'};
+
+ }
+ # See if the item is on reserve.
+ my ($restype, $res) = CheckReserves($iteminformation->{'itemnumber'});
+#warn "$restype,$res";
+ if ($restype) {
+ my $resbor = $res->{'borrowernumber'};
+ my ($resborrower, $flags)=C4::Members::getpatroninformation($env, $resbor,0);
+ my $branches = GetBranches();
+ my $branchname = $branches->{$res->{'branchcode'}}->{'branchname'};
+ if ($resbor eq $borrower->{'borrowernumber'}) {
+ # The item is on reserve to the current patron
+ FillReserve($res);
+# warn "FillReserve";
+ } elsif ($restype eq "Waiting") {
+# warn "Waiting";
+ # The item is on reserve and waiting, but has been
+ # reserved by some other patron.
+
+ if ($cancelreserve){
+ CancelReserve(0, $res->{'itemnumber'}, $res->{'borrowernumber'});
+ } else {
+ # set waiting reserve to first in reserve queue as book isn't waiting now
+ UpdateReserve(1, $res->{'biblionumber'}, $res->{'borrowernumber'}, $res->{'branchcode'});
+ }
+ } elsif ($restype eq "Reserved") {
+#warn "Reserved";
+ # The item is on reserve for someone else.
+
+ if ($cancelreserve) {
+ # cancel reserves on this item
+ CancelReserve(0, $res->{'itemnumber'}, $res->{'borrowernumber'});
+ # also cancel reserve on biblio related to this item
+ # my $st_Fbiblio = $dbh->prepare("select biblionumber from items where itemnumber=?");
+ # $st_Fbiblio->execute($res->{'itemnumber'});
+ # my $biblionumber = $st_Fbiblio->fetchrow;
+# CancelReserve($iteminformation->{'biblionumber'},0,$res->{'borrowernumber'});
+# warn "CancelReserve $res->{'itemnumber'}, $res->{'borrowernumber'}";
+ } else {
+ my $tobrcd = ReserveWaiting($res->{'itemnumber'}, $res->{'borrowernumber'});
+ transferbook($tobrcd,$barcode, 1);
+# warn "transferbook";
+ }
+ }
+ }
+
+ my $sth=$dbh->prepare("insert into issues (borrowernumber, itemnumber, date_due, branchcode,issue_date) values (?,?,?,?,NOW())");
+ my $loanlength = getLoanLength($borrower->{'categorycode'},$iteminformation->{'ctype'},$borrower->{'branchcode'});
+ my $dateduef=get_today();
+ my $calendar = C4::Calendar::Calendar->new(branchcode => $borrower->{'branchcode'});
+ my ($yeardue, $monthdue, $daydue) = split /-/, $dateduef;
+ ($daydue, $monthdue, $yeardue) = $calendar->addDate($daydue, $monthdue, $yeardue, $loanlength);
+ $dateduef = "$yeardue-".sprintf ("%0.2d", $monthdue)."-". sprintf("%0.2d",$daydue);
+#warn $dateduef;
+ if ($date) {
+ $dateduef=$date;
+ }
+ # if ReturnBeforeExpiry ON the datedue can't be after borrower expirydate
+ if (C4::Context->preference('ReturnBeforeExpiry') && $dateduef gt $borrower->{expiry}) {
+ $dateduef=$borrower->{expiry};
+ }
+ $sth->execute($borrower->{'borrowernumber'}, $iteminformation->{'itemnumber'}, $dateduef, $env->{'branchcode'});
+ $sth->finish;
+ $iteminformation->{'issues'}++;
+##Record in MARC the new data ,date_due as due date,issue count and the borrowernumber
+ $itemrecord=XML_writeline($itemrecord, "issues", $iteminformation->{'issues'},"holdings");
+ $itemrecord=XML_writeline($itemrecord, "date_due", $dateduef,"holdings");
+ $itemrecord=XML_writeline($itemrecord, "borrowernumber", $borrower->{'borrowernumber'},"holdings");
+ $itemrecord=XML_writeline($itemrecord, "itemlost", "0","holdings");
+ $itemrecord=XML_writeline($itemrecord, "onloan", "1","holdings");
+##Update totalissues of bibliorecord if exist
+ my $totalissue=XML_readline_onerecord($bibliorecord,"totalissue","biblios");
+$totalissue=scalar($totalissue);
+ $totalissue++;
+my $extras=length($totalissue);
+ for (1..(6-$extras)){
+ $totalissue="0".$totalissue;
+ }
+
+ $bibliorecord=XML_writeline($bibliorecord,"totalissue",$totalissue,"biblios");
+ my $frameworkcode=MARCfind_frameworkcode($dbh,$iteminformation->{'biblionumber'});
+ C4::Biblio::OLDmodbiblio($dbh,$bibliorecord,$iteminformation->{'biblionumber'},$frameworkcode);
+###
+ # find today's date as timestamp
+ my ($sec,$min,$hour,$mday,$mon,$year) = localtime();
+ $year += 1900;
+ $mon += 1;
+ my $timestamp = sprintf("%4d%02d%02d%02d%02d%02d.0",
+ $year,$mon,$mday,$hour,$min,$sec);
+ $itemrecord=XML_writeline($itemrecord, "datelastseen", $timestamp,"holdings");
+ ##Now update the zebradb
+ NEWmoditem($dbh,$itemrecord,$iteminformation->{'biblionumber'},$iteminformation->{'itemnumber'});
+ # If it costs to borrow this book, charge it to the patron's account.
+ my ($charge,$itemtype)=calc_charges($env, $iteminformation->{'itemnumber'}, $borrower->{'borrowernumber'});
+ if ($charge > 0) {
+ createcharge($env, $dbh, $iteminformation->{'itemnumber'}, $borrower->{'borrowernumber'}, $charge);
+ $iteminformation->{'charge'}=$charge;
+ }
+ # Record the fact that this book was issued in SQL
+ &UpdateStats($env,$env->{'branchcode'},'issue',$charge,'',$iteminformation->{'itemnumber'},$iteminformation->{'ctype'},$borrower->{'borrowernumber'});
+ }
+return($error);
+}
+
+=head2 getLoanLength
+
+Get loan length for an itemtype, a borrower type and a branch
+
+my $loanlength = &getLoanLength($borrowertype,$itemtype,branchcode)
+
+=cut
+
+sub getLoanLength {
+ my ($borrowertype,$itemtype,$branchcode) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("select issuelength from issuingrules where categorycode=? and itemtype=? and branchcode=?");
+ # try to find issuelength & return the 1st available.
+ # check with borrowertype, itemtype and branchcode, then without one of those parameters
+ $sth->execute($borrowertype,$itemtype,$branchcode);
+ my $loanlength = $sth->fetchrow_hashref;
+ return $loanlength->{issuelength} if defined($loanlength);
+
+ $sth->execute($borrowertype,$itemtype,"");
+ $loanlength = $sth->fetchrow_hashref;
+ return $loanlength->{issuelength} if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
+
+ $sth->execute($borrowertype,"*",$branchcode);
+ $loanlength = $sth->fetchrow_hashref;
+ return $loanlength->{issuelength} if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
+
+ $sth->execute("*",$itemtype,$branchcode);
+ $loanlength = $sth->fetchrow_hashref;
+ return $loanlength->{issuelength} if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
+
+ $sth->execute($borrowertype,"*","");
+ $loanlength = $sth->fetchrow_hashref;
+ return $loanlength->{issuelength} if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
+
+ $sth->execute("*","*",$branchcode);
+ $loanlength = $sth->fetchrow_hashref;
+ return $loanlength->{issuelength} if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
+
+ $sth->execute("*",$itemtype,"");
+ $loanlength = $sth->fetchrow_hashref;
+ return $loanlength->{issuelength} if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
+
+ $sth->execute("*","*","");
+ $loanlength = $sth->fetchrow_hashref;
+ return $loanlength->{issuelength} if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
+
+ # if no rule is set => 21 days (hardcoded)
+ return 21;
+}
+=head2 returnbook
+
+ ($doreturn, $messages, $iteminformation, $borrower) =
+ &returnbook($barcode, $branch);
+
+Returns a book.
+
+C<$barcode> is the bar code of the book being returned. C<$branch> is
+the code of the branch where the book is being returned.
+
+C<&returnbook> returns a list of four items:
+
+C<$doreturn> is true iff the return succeeded.
+
+C<$messages> is a reference-to-hash giving the reason for failure:
+
+=over 4
+
+=item C<BadBarcode>
+
+No item with this barcode exists. The value is C<$barcode>.
+
+=item C<NotIssued>
+
+The book is not currently on loan. The value is C<$barcode>.
+
+=item C<IsPermanent>
+
+The book's home branch is a permanent collection. If you have borrowed
+this book, you are not allowed to return it. The value is the code for
+the book's home branch.
+
+=item C<wthdrawn>
+
+This book has been withdrawn/cancelled. The value should be ignored.
+
+=item C<ResFound>
+
+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>, C<Reserved>, or 0.
+
+=back
+
+C<$borrower> is a reference-to-hash, giving information about the
+patron who last borrowed the book.
+
+=cut
+
+# FIXME - This API is bogus. There's no need to return $borrower and
+# $iteminformation; the caller can ask about those separately, if it
+# cares (it'd be inefficient to make two database calls instead of
+# one, but &getpatroninformation and &getiteminformation can be
+# memoized if this is an issue).
+#
+# The ($doreturn, $messages) tuple is redundant: if the return
+# succeeded, that's all the caller needs to know. So &returnbook can
+# return 1 and 0 on success and failure, and set
+# $C4::Circulation::Circ2::errmsg to indicate the error. Or it can
+# return undef for success, and an error message on error (though this
+# is more C-ish than Perl-ish).
+
+sub returnbook {
+ my ($barcode, $branch) = @_;
+ my %env;
+ my $messages;
+ my $dbh = C4::Context->dbh;
+ my $doreturn = 1;
+ die '$branch not defined' unless defined $branch; # just in case (bug 170)
+ # get information on item
+ my $itemrecord=XMLgetitemhash($dbh,"",$barcode);
+ if (not $itemrecord) {
+ $messages->{'BadBarcode'} = $barcode;
+ $doreturn = 0;
+ return ($doreturn, $messages, undef, undef);
+ }
+ my $iteminformation=XMLmarc2koha_onerecord($dbh,$itemrecord,"holdings");
+ $iteminformation->{'itemtype'}=MARCfind_itemtype($dbh,$iteminformation->{biblionumber});
+
+ # find the borrower
+ my ($currentborrower) = currentborrower($iteminformation->{'itemnumber'});
+ if ((not $currentborrower) && $doreturn) {
+ $messages->{'NotIssued'} = $barcode;
+ $doreturn = 0;
+ }
+ # check if the book is in a permanent collection....
+ my $hbr = $iteminformation->{'homebranch'};
+ my $branches = GetBranches();
+ if ($branches->{$hbr}->{'PE'}) {
+ $messages->{'IsPermanent'} = $hbr;
+ }
+ # check that the book has been cancelled
+ if ($iteminformation->{'wthdrawn'}) {
+ $messages->{'wthdrawn'} = 1;
+ # $doreturn = 0;
+ }
+ # update issues, thereby returning book (should push this out into another subroutine
+ my ($borrower) = C4::Members::getpatroninformation(\%env, $currentborrower, 0);
+ if ($doreturn) {
+ my $sth = $dbh->prepare("update issues set returndate = now() where (itemnumber = ?) and (returndate is null)");
+ $sth->execute( $iteminformation->{'itemnumber'});
+ $messages->{'WasReturned'} = 1; # FIXME is the "= 1" right?
+
+ $sth->finish;
+ }
+ $itemrecord=XML_writeline($itemrecord, "date_due", "","holdings");
+ $itemrecord=XML_writeline($itemrecord, "onloan", "0","holdings");
+ $itemrecord=XML_writeline($itemrecord, "borrowernumber", "","holdings");
+
+ my ($transfered, $mess, $item) = transferbook($branch, $barcode, 1);
+ my ($sec,$min,$hour,$mday,$mon,$year) = localtime();
+ $year += 1900;
+ $mon += 1;
+ my $timestamp = sprintf("%4d%02d%02d%02d%02d%02d.0",
+ $year,$mon,$mday,$hour,$min,$sec);
+ $itemrecord=XML_writeline($itemrecord, "datelastseen", $timestamp,"holdings");
+
+
+ # transfer book to the current branch
+
+ if ($transfered) {
+ $messages->{'WasTransfered'} = 1; # FIXME is the "= 1" right?
+ }
+ # fix up the accounts.....
+ if ($iteminformation->{'itemlost'}) {
+ fixaccountforlostandreturned($iteminformation, $borrower);
+ $messages->{'WasLost'} = 1; # FIXME is the "= 1" right?
+ $itemrecord=XML_writeline($itemrecord, "itemlost", "","holdings");
+ }
+####WARNING-- FIXME#########
+### The following new script is commented out
+## I did not understand what it is supposed to do.
+## If a book is returned at one branch it is automatically recorded being in that branch by
+## transferbook script. This scrip tries to find out whether it was sent thre
+## Well whether sent or not it is physically there and transferbook records this fact in MARCrecord as well
+## If this script is trying to do something else it should be uncommented and also add support for updating MARC record --TG
+# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+# check if we have a transfer for this document
+# my $checktransfer = checktransferts($iteminformation->{'itemnumber'});
+# if we have a return, we update the line of transfers with the datearrived
+# if ($checktransfer){
+# my $sth = $dbh->prepare("update branchtransfers set datearrived = now() where itemnumber= ? AND datearrived IS NULL");
+# $sth->execute($iteminformation->{'itemnumber'});
+# $sth->finish;
+# 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'
+# my $updateWaiting = SetWaitingStatus($iteminformation->{'itemnumber'});
+# }
+# 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 .
+# else {
+# my $checkreserves = CheckReserves($iteminformation->{'itemnumber'});
+# if (($iteminformation->{'homebranch'} ne $iteminformation->{'holdingbranch'}) and (not $checkreserves) and (C4::Context->preference("AutomaticItemReturn") == 1)){
+# my $automatictransfer = dotransfer($iteminformation->{'itemnumber'},$iteminformation->{'holdingbranch'},$iteminformation->{'homebranch'});
+# $messages->{'WasTransfered'} = 1;
+# }
+# }
+# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+ # fix up the overdues in accounts...
+ fixoverduesonreturn($borrower->{'borrowernumber'}, $iteminformation->{'itemnumber'});
+ $itemrecord=XML_writeline($itemrecord, "itemoverdue", "","holdings");
+ # find reserves.....
+ my ($resfound, $resrec) = CheckReserves($iteminformation->{'itemnumber'});
+ if ($resfound) {
+ # my $tobrcd = ReserveWaiting($resrec->{'itemnumber'}, $resrec->{'borrowernumber'});
+ $resrec->{'ResFound'} = $resfound;
+ $messages->{'ResFound'} = $resrec;
+ }
+ ##Now update the zebradb
+ NEWmoditem($dbh,$itemrecord,$iteminformation->{'biblionumber'},$iteminformation->{'itemnumber'});
+ # update stats?
+ # Record the fact that this book was returned.
+ UpdateStats(\%env, $branch ,'return','0','',$iteminformation->{'itemnumber'},$iteminformation->{'ctype'},$borrower->{'borrowernumber'});
+ return ($doreturn, $messages, $iteminformation, $borrower);
+}
+
+=head2 fixaccountforlostandreturned
+
+ &fixaccountforlostandreturned($iteminfo,$borrower);
+
+Calculates the charge for a book lost and returned (Not exported & used only once)
+
+C<$iteminfo> is a hashref to iteminfo. Only {itemnumber} is used.
+
+C<$borrower> is a hashref to borrower. Only {borrowernumber is used.
+
+=cut
+
+sub fixaccountforlostandreturned {
+ my ($iteminfo, $borrower) = @_;
+ my %env;
+ my $dbh = C4::Context->dbh;
+ my $itm = $iteminfo->{'itemnumber'};
+ # check for charge made for lost book
+ my $sth = $dbh->prepare("select * from accountlines where (itemnumber = ?) and (accounttype='L' or accounttype='Rep') order by date desc");
+ $sth->execute($itm);
+ if (my $data = $sth->fetchrow_hashref) {
+ # writeoff this amount
+ my $offset;
+ my $amount = $data->{'amount'};
+ my $acctno = $data->{'accountno'};
+ my $amountleft;
+ if ($data->{'amountoutstanding'} == $amount) {
+ $offset = $data->{'amount'};
+ $amountleft = 0;
+ } else {
+ $offset = $amount - $data->{'amountoutstanding'};
+ $amountleft = $data->{'amountoutstanding'} - $amount;
+ }
+ my $usth = $dbh->prepare("update accountlines set accounttype = 'LR',amountoutstanding='0'
+ where (borrowernumber = ?)
+ and (itemnumber = ?) and (accountno = ?) ");
+ $usth->execute($data->{'borrowernumber'},$itm,$acctno);
+ $usth->finish;
+ #check if any credit is left if so writeoff other accounts
+ my $nextaccntno = getnextacctno(\%env,$data->{'borrowernumber'},$dbh);
+ if ($amountleft < 0){
+ $amountleft*=-1;
+ }
+ if ($amountleft > 0){
+ my $msth = $dbh->prepare("select * from accountlines where (borrowernumber = ?)
+ and (amountoutstanding >0) order by date");
+ $msth->execute($data->{'borrowernumber'});
+ # offset transactions
+ my $newamtos;
+ my $accdata;
+ while (($accdata=$msth->fetchrow_hashref) and ($amountleft>0)){
+ if ($accdata->{'amountoutstanding'} < $amountleft) {
+ $newamtos = 0;
+ $amountleft -= $accdata->{'amountoutstanding'};
+ } else {
+ $newamtos = $accdata->{'amountoutstanding'} - $amountleft;
+ $amountleft = 0;
+ }
+ my $thisacct = $accdata->{'accountno'};
+ my $usth = $dbh->prepare("update accountlines set amountoutstanding= ?
+ where (borrowernumber = ?)
+ and (accountno=?)");
+ $usth->execute($newamtos,$data->{'borrowernumber'},'$thisacct');
+ $usth->finish;
+ $usth = $dbh->prepare("insert into accountoffsets
+ (borrowernumber, accountno, offsetaccount, offsetamount)
+ values
+ (?,?,?,?)");
+ $usth->execute($data->{'borrowernumber'},$accdata->{'accountno'},$nextaccntno,$newamtos);
+ $usth->finish;
+ }
+ $msth->finish;
+ }
+ if ($amountleft > 0){
+ $amountleft*=-1;
+ }
+ my $desc="Book Returned ".$iteminfo->{'barcode'};
+ $usth = $dbh->prepare("insert into accountlines
+ (borrowernumber,accountno,date,amount,description,accounttype,amountoutstanding)
+ values (?,?,now(),?,?,'CR',?)");
+ $usth->execute($data->{'borrowernumber'},$nextaccntno,0-$amount,$desc,$amountleft);
+ $usth->finish;
+ $usth = $dbh->prepare("insert into accountoffsets
+ (borrowernumber, accountno, offsetaccount, offsetamount)
+ values (?,?,?,?)");
+ $usth->execute($borrower->{'borrowernumber'},$data->{'accountno'},$nextaccntno,$offset);
+ $usth->finish;
+# $usth = $dbh->prepare("update items set paidfor='' where itemnumber=?");
+# $usth->execute($itm);
+# $usth->finish;
+ }
+ $sth->finish;
+ return;
+}
+
+=head2 fixoverdueonreturn
+
+ &fixoverdueonreturn($brn,$itm);
+
+??
+
+C<$brn> borrowernumber
+
+C<$itm> itemnumber
+
+=cut
+
+sub fixoverduesonreturn {
+ my ($brn, $itm) = @_;
+ my $dbh = C4::Context->dbh;
+ # check for overdue fine
+ my $sth = $dbh->prepare("select * from accountlines where (borrowernumber = ?) and (itemnumber = ?) and (accounttype='FU' or accounttype='O')");
+ $sth->execute($brn,$itm);
+ # alter fine to show that the book has been returned
+ if (my $data = $sth->fetchrow_hashref) {
+ my $usth=$dbh->prepare("update accountlines set accounttype='F' where (borrowernumber = ?) and (itemnumber = ?) and (accountno = ?)");
+ $usth->execute($brn,$itm,$data->{'accountno'});
+ $usth->finish();
+ }
+ $sth->finish();
+ return;
+}
+
+
+
+
+
+# Not exported
+sub checkoverdues {
+# From Main.pm, modified to return a list of overdueitems, in addition to a count
+ #checks whether a borrower has overdue items
+ my ($env, $bornum, $dbh)=@_;
+ my $today=get_today();
+ my @overdueitems;
+ my $count = 0;
+ my $sth = $dbh->prepare("SELECT issues.* , i.biblionumber as biblionumber,b.* FROM issues, items i,biblio b
+ WHERE i.itemnumber=issues.itemnumber
+ AND i.biblionumber=b.biblionumber
+ AND issues.borrowernumber = ?
+ AND issues.returndate is NULL
+ AND issues.date_due < ?");
+ $sth->execute($bornum,$today);
+ while (my $data = $sth->fetchrow_hashref) {
+
+ push (@overdueitems, $data);
+ $count++;
+ }
+ $sth->finish;
+ return ($count, \@overdueitems);
+}
+
+# Not exported
+sub currentborrower {
+# Original subroutine for Circ2.pm
+ my ($itemnumber) = @_;
+ my $dbh = C4::Context->dbh;
+
+ my $sth=$dbh->prepare("select borrowers.borrowernumber from
+ issues,borrowers where issues.itemnumber=? and
+ issues.borrowernumber=borrowers.borrowernumber and issues.returndate is
+ NULL");
+ $sth->execute($itemnumber);
+ my ($borrower) = $sth->fetchrow;
+ return($borrower);
+}
+# Not exported
+sub currentreturningborrower {
+# Original subroutine for Circ2.pm
+ my ($itemnumber) = @_;
+ my $dbh = C4::Context->dbh;
+
+ my $sth=$dbh->prepare("select * from
+ issues,borrowers where issues.itemnumber=? and
+ issues.borrowernumber=borrowers.borrowernumber and issues.returndate=CURRENT_DATE and ( HOUR(TIMEDIFF(CURRENT_TIMESTAMP,timestamp))<24)");
+ $sth->execute($itemnumber);
+ my ($borrower) = $sth->fetchrow_hashref;
+ return($borrower);
+}
+# FIXME - Not exported, but used in 'updateitem.pl' anyway.
+sub checkreserve_to_delete {
+# Check for reserves for biblio
+ my ($env,$dbh,$itemnum)=@_;
+ my $resbor = "";
+ my $sth = $dbh->prepare("select * from reserves,items
+ where (items.itemnumber = ?)
+ and (reserves.cancellationdate is NULL)
+ and (items.biblionumber = reserves.biblionumber)
+ and ((reserves.found = 'W')
+ or (reserves.found is null))
+ order by priority");
+ $sth->execute($itemnum);
+ my $resrec;
+ my $data=$sth->fetchrow_hashref;
+ while ($data && $resbor eq '') {
+ $resrec=$data;
+ my $const = $data->{'constrainttype'};
+ if ($const eq "a") {
+ $resbor = $data->{'borrowernumber'};
+ } else {
+ my $found = 0;
+ my $csth = $dbh->prepare("select * from reserveconstraints,items
+ where (borrowernumber=?)
+ and reservedate=?
+ and reserveconstraints.biblionumber=?
+ and (items.itemnumber=? )");
+ $csth->execute($data->{'borrowernumber'},$data->{'biblionumber'},$data->{'reservedate'},$itemnum);
+ if (my $cdata=$csth->fetchrow_hashref) {$found = 1;}
+ if ($const eq 'o') {
+ if ($found eq 1) {$resbor = $data->{'borrowernumber'};}
+ } else {
+ if ($found eq 0) {$resbor = $data->{'borrowernumber'};}
+ }
+ $csth->finish();
+ }
+ $data=$sth->fetchrow_hashref;
+ }
+ $sth->finish;
+ return ($resbor,$resrec);
+}
+
+=head2 currentissues
+
+ $issues = ¤tissues($env, $borrower);
+
+Returns a list of books currently on loan to a patron.
+
+If C<$env-E<gt>{todaysissues}> is set and true, C<¤tissues> only
+returns information about books issued today. If
+C<$env-E<gt>{nottodaysissues}> is set and true, C<¤tissues> only
+returns information about books issued before today. If both are
+specified, C<$env-E<gt>{todaysissues}> is ignored. If neither is
+specified, C<¤tissues> returns all of the patron's issues.
+
+C<$borrower->{borrowernumber}> is the borrower number of the patron
+whose issues we want to list.
+
+C<¤tissues> returns a PHP-style array: C<$issues> is a
+reference-to-hash whose keys are integers in the range 1...I<n>, where
+I<n> is the number of items on issue (either today or before today).
+C<$issues-E<gt>{I<n>}> is a reference-to-hash whose keys are all of
+the fields of the biblio, biblioitems, items, and issues fields of the
+Koha database for that particular item.
+
+=cut
+
+#'
+sub currentissues {
+# New subroutine for Circ2.pm
+ my ($env, $borrower) = @_;
+ my $dbh = C4::Context->dbh;
+ my %currentissues;
+ my $counter=1;
+ my $borrowernumber = $borrower->{'borrowernumber'};
+ my $crit='';
+
+ # Figure out whether to get the books issued today, or earlier.
+ # FIXME - $env->{todaysissues} and $env->{nottodaysissues} can
+ # both be specified, but are mutually-exclusive. This is bogus.
+ # Make this a flag. Or better yet, return everything in (reverse)
+ # chronological order and let the caller figure out which books
+ # were issued today.
+ my $today=get_today();
+ if ($env->{'todaysissues'}) {
+
+ $crit=" and issues.timestamp like '$today%' ";
+ }
+ if ($env->{'nottodaysissues'}) {
+
+ $crit=" and !(issues.timestamp like '$today%') ";
+ }
+
+ # FIXME - Does the caller really need every single field from all
+ # four tables?
+ my $sth=$dbh->prepare("select * from issues,items where
+ borrowernumber=? and issues.itemnumber=items.itemnumber and
+ returndate is null
+ $crit order by issues.date_due");
+ $sth->execute($borrowernumber);
+ while (my $data = $sth->fetchrow_hashref) {
+
+
+ if ($data->{'date_due'} lt $today) {
+ $data->{'overdue'}=1;
+ }
+ my $itemnumber=$data->{'itemnumber'};
+ # FIXME - Consecutive integers as hash keys? You have GOT to
+ # be kidding me! Use an array, fercrissakes!
+ $currentissues{$counter}=$data;
+ $counter++;
+ }
+ $sth->finish;
+ return(\%currentissues);
+}
+
+=head2 getissues
+
+ $issues = &getissues($borrowernumber);
+
+Returns the set of books currently on loan to a patron.
+
+C<$borrowernumber> is the patron's borrower number.
+
+C<&getissues> returns a PHP-style array: C<$issues> is a
+reference-to-hash whose keys are integers in the range 0..I<n>-1,
+where I<n> is the number of books the patron currently has on loan.
+
+The values of C<$issues> are references-to-hash whose keys are
+selected fields from the issues, items, biblio, and biblioitems tables
+of the Koha database.
+
+=cut
+#'
+sub getissues {
+ my ($borrower) = @_;
+ my $dbh = C4::Context->dbh;
+ my $borrowernumber = $borrower->{'borrowernumber'};
+ my %currentissues;
+ my $bibliodata;
+ my @results;
+ my $todaysdate=get_today();
+ my $counter = 0;
+ my $select = "SELECT *
+ FROM issues,items,biblio
+ WHERE issues.borrowernumber = ?
+ AND issues.itemnumber = items.itemnumber
+ AND items.biblionumber = biblio.biblionumber
+ AND issues.returndate IS NULL
+ ORDER BY issues.date_due";
+ # print $select;
+ my $sth=$dbh->prepare($select);
+ $sth->execute($borrowernumber);
+ while (my $data = $sth->fetchrow_hashref) {
+ if ($data->{'date_due'} lt $todaysdate) {
+ $data->{'overdue'} = 1;
+ }
+ $currentissues{$counter} = $data;
+ $counter++;
+ }
+ $sth->finish;
+
+ return(\%currentissues);
+}
+
+# Not exported
+sub checkwaiting {
+# check for reserves waiting
+ my ($env,$dbh,$bornum)=@_;
+ my @itemswaiting;
+ my $sth = $dbh->prepare("select * from reserves where (borrowernumber = ?) and (reserves.found='W') and cancellationdate is NULL");
+ $sth->execute($bornum);
+ my $cnt=0;
+ if (my $data=$sth->fetchrow_hashref) {
+ $itemswaiting[$cnt] =$data;
+ $cnt ++
+ }
+ $sth->finish;
+ return ($cnt,\@itemswaiting);
+}
+
+=head2 renewstatus
+
+ $ok = &renewstatus($env, $dbh, $borrowernumber, $itemnumber);
+
+Find out whether a borrowed item may be renewed.
+
+C<$env> is ignored.
+
+C<$dbh> is a DBI handle to the Koha database.
+
+C<$borrowernumber> is the borrower number of the patron who currently
+has the item on loan.
+
+C<$itemnumber> is the number of the item to renew.
+
+C<$renewstatus> returns a true value iff the item may be renewed. The
+item must currently be on loan to the specified borrower; renewals
+must be allowed for the item's type; and the borrower must not have
+already renewed the loan.
+
+=cut
+
+sub renewstatus {
+ # check renewal status
+ ##If system preference "strictrenewals" is used This script will try to return $renewok=2 or $renewok=3 as error messages
+ ##
+ my ($env,$bornum,$itemnumber)=@_;
+ my $dbh=C4::Context->dbh;
+ my $renews = 1;
+ my $resfound;
+ my $resrec;
+ my $renewokay=0; ##
+ # Look in the issues table for this item, lent to this borrower,
+ # and not yet returned.
+my $borrower=C4::Members::getpatroninformation($dbh,$bornum,undef);
+
+ # FIXME - I think this function could be redone to use only one SQL call.
+ my $data1=getiteminformation($dbh,$itemnumber);
+ if ($data1 ) {
+ # Found a matching item
+ ##privileged get renewal whatever the case may be
+ if ($borrower->{'categorycode'} eq 'P'){
+ $renewokay = 1;
+ return $renewokay;
+ }
+
+ ##Find renewals of this item
+ my $rsth=$dbh->prepare("Select renewals from issues where itemnumber=? and borrowernumber=? and returndate is null");
+ $rsth->execute($data1->{itemnumber},$borrower->{borrowernumber});
+ $data1->{'renewals'}=$rsth->fetchrow;
+ $rsth->finish;
+ # See if this item may be renewed.
+ my $sth2 = $dbh->prepare("select renewalsallowed from itemtypes where itemtypes.itemtype=?");
+ $sth2->execute($data1->{ctype});
+ if (my $data2=$sth2->fetchrow_hashref) {
+ $renews = $data2->{'renewalsallowed'};
+ }
+ if ($renews > $data1->{'renewals'}) {
+ $renewokay= 1;
+ }else{
+ if (C4::Context->preference("strictrenewals")){
+ $renewokay=3 ;
+ }
+ }
+ $sth2->finish;
+ ($resfound, $resrec) = CheckReserves($itemnumber);
+ if ($resfound) {
+ if (C4::Context->preference("strictrenewals")){
+ $renewokay=4;
+ }else{
+ $renewokay = 0;
+ }
+ }
+ ($resfound, $resrec) = CheckReserves($itemnumber);
+ if ($resfound) {
+ if (C4::Context->preference("strictrenewals")){
+ $renewokay=4;
+ }else{
+ $renewokay = 0;
+ }
+ }
+ if (C4::Context->preference("strictrenewals")){
+ ### A new system pref "allowRenewalsBefore" prevents the renewal before a set amount of days left before expiry
+ ## Try to find whether book can be renewed at this date
+ my $loanlength;
+
+ my $allowRenewalsBefore = C4::Context->preference("allowRenewalsBefore");
+ my $today=get_today();
+
+ # Find the issues record for this book###
+ my $sth=$dbh->prepare("select SUBDATE(date_due, $allowRenewalsBefore) from issues where itemnumber=? and returndate is null");
+ $sth->execute($itemnumber);
+ my $startdate=$sth->fetchrow;
+ $sth->finish;
+
+ my $difference = DATE_diff($today,$startdate);
+ if ($difference < 0) {
+ $renewokay=2 ;
+ }
+ }##strictrenewals
+ }##item found
+# $sth1->finish;
+
+ return($renewokay);
+}
+
+=head2 renewbook
+
+ &renewbook($env, $borrowernumber, $itemnumber, $datedue);
+
+Renews a loan.
+
+C<$env-E<gt>{branchcode}> is the code of the branch where the
+renewal is taking place.
+
+C<$env-E<gt>{usercode}> is the value to log in C<statistics.usercode>
+in the Koha database.
+
+C<$borrowernumber> is the borrower number of the patron who currently
+has the item.
+
+C<$itemnumber> is the number of the item to renew.
+
+C<$datedue> can be used to set the due date. If C<$datedue> is the
+empty string, C<&renewbook> will calculate the due date automatically
+from the book's item type. If you wish to set the due date manually,
+C<$datedue> should be in the form YYYY-MM-DD.
+
+=cut
+
+sub renewbook {
+ my ($env,$bornum,$itemnumber,$datedue)=@_;
+ # mark book as renewed
+
+ my $loanlength;
+my $dbh=C4::Context->dbh;
+my $sth;
+my $iteminformation = getiteminformation($env, $itemnumber,0);
+
+
+
+if ($datedue eq "" ) {
+
+ my $borrower = C4::Members::getpatroninformation($env,$bornum,0);
+ $loanlength = getLoanLength($borrower->{'categorycode'},$iteminformation->{'ctype'},$borrower->{'branchcode'});
+
+ my $datedue=get_today();
+ my $calendar = C4::Calendar::Calendar->new(branchcode => $borrower->{'branchcode'});
+ my ($yeardue, $monthdue, $daydue) = split /-/, $datedue;
+ ($daydue, $monthdue, $yeardue) = $calendar->addDate($daydue, $monthdue, $yeardue, $loanlength);
+ $datedue = "$yeardue-".sprintf ("%0.2d", $monthdue)."-". sprintf("%0.2d",$daydue);
+
+ # Update the issues record to have the new due date, and a new count
+ # of how many times it has been renewed.
+
+ $sth=$dbh->prepare("update issues set date_due = ?, renewals = renewals+1
+ where borrowernumber=? and itemnumber=? and returndate is null");
+ $sth->execute($datedue,$bornum,$itemnumber);
+ $sth->finish;
+
+ ## Update items and marc record with new date -T.G
+ &XMLmoditemonefield($dbh,$iteminformation->{'biblionumber'},$iteminformation->{'itemnumber'},'date_due',$datedue);
+
+ # Log the renewal
+ UpdateStats($env,$env->{'branchcode'},'renew','','',$itemnumber,$iteminformation->{'ctype'},$bornum);
+
+ # Charge a new rental fee, if applicable?
+ my ($charge,$type)=calc_charges($env, $itemnumber, $bornum);
+ if ($charge > 0){
+ my $accountno=getnextacctno($env,$bornum,$dbh);
+ $sth=$dbh->prepare("Insert into accountlines (borrowernumber,accountno,date,amount,description,accounttype,amountoutstanding,itemnumber)
+ values (?,?,now(),?,?,?,?,?)");
+ $sth->execute($bornum,$accountno,$charge,"Renewal of Rental Item $iteminformation->{'title'} $iteminformation->{'barcode'}",'Rent',$charge,$itemnumber);
+ $sth->finish;
+ # print $account;
+ }# end of rental charge
+
+ return format_date($datedue);
+ }
+
+
+
+}
+
+
+
+
+
+
+
+
+=item find_reserves
+
+ ($status, $record) = &find_reserves($itemnumber);
+
+Looks up an item in the reserves.
+
+C<$itemnumber> is the itemnumber to look up.
+
+C<$status> is true iff the search was successful.
+
+C<$record> is a reference-to-hash describing the reserve. Its keys are
+the fields from the reserves table of the Koha database.
+
+=cut
+#'
+# FIXME - This API is bogus: just return the record, or undef if none
+# was found.
+
+sub find_reserves {
+ my ($itemnumber) = @_;
+ my $dbh = C4::Context->dbh;
+ my ($itemdata) = getiteminformation("", $itemnumber,0);
+ my $sth = $dbh->prepare("select * from reserves where ((found = 'W') or (found is null)) and biblionumber = ? and cancellationdate is NULL order by priority, reservedate");
+ $sth->execute($itemdata->{'biblionumber'});
+ my $resfound = 0;
+ my $resrec;
+ my $lastrec;
+
+ # FIXME - I'm not really sure what's going on here, but since we
+ # only want one result, wouldn't it be possible (and far more
+ # efficient) to do something clever in SQL that only returns one
+ # set of values?
+while ($resrec = $sth->fetchrow_hashref) {
+ $lastrec = $resrec;
+ if ($resrec->{'found'} eq "W") {
+ if ($resrec->{'itemnumber'} eq $itemnumber) {
+ $resfound = 1;
+ }
+ } else {
+ # FIXME - Use 'elsif' to avoid unnecessary indentation.
+ if ($resrec->{'constrainttype'} eq "a") {
+ $resfound = 1;
+ } else {
+ my $consth = $dbh->prepare("select * from reserveconstraints where borrowernumber = ? and reservedate = ? and biblionumber = ? ");
+ $consth->execute($resrec->{'borrowernumber'},$resrec->{'reservedate'},$resrec->{'biblionumber'});
+ if (my $conrec = $consth->fetchrow_hashref) {
+ if ($resrec->{'constrainttype'} eq "o") {
+ $resfound = 1;
+
+ }
+ }
+ $consth->finish;
+ }
+ }
+ if ($resfound) {
+ my $updsth = $dbh->prepare("update reserves set found = 'W', itemnumber = ? where borrowernumber = ? and reservedate = ? and biblionumber = ?");
+ $updsth->execute($itemnumber,$resrec->{'borrowernumber'},$resrec->{'reservedate'},$resrec->{'biblionumber'});
+ $updsth->finish;
+ last;
+ }
+ }
+ $sth->finish;
+ return ($resfound,$lastrec);
+}
+
+sub fixdate {
+ my ($year, $month, $day) = @_;
+ my $invalidduedate;
+ my $date;
+ if (($year eq 0) && ($month eq 0) && ($year eq 0)) {
+# $env{'datedue'}='';
+ } else {
+ if (($year eq 0) || ($month eq 0) || ($year eq 0)) {
+ $invalidduedate=1;
+ } else {
+ if (($day>30) && (($month==4) || ($month==6) || ($month==9) || ($month==11))) {
+ $invalidduedate = 1;
+ } elsif (($day > 29) && ($month == 2)) {
+ $invalidduedate=1;
+ } elsif (($month == 2) && ($day > 28) && (($year%4) && ((!($year%100) || ($year%400))))) {
+ $invalidduedate=1;
+ } else {
+ $date="$year-$month-$day";
+ }
+ }
+ }
+ return ($date, $invalidduedate);
+}
+
+sub get_current_return_date_of {
+ my (@itemnumbers) = @_;
+
+ my $query = '
+SELECT date_due,
+ itemnumber
+ FROM issues
+ WHERE itemnumber IN ('.join(',', @itemnumbers).') AND returndate IS NULL
+';
+ return get_infos_of($query, 'itemnumber', 'date_due');
+}
+
+sub get_transfert_infos {
+ my ($itemnumber) = @_;
+
+ my $dbh = C4::Context->dbh;
+
+ my $query = '
+SELECT datesent,
+ frombranch,
+ tobranch
+ FROM branchtransfers
+ WHERE itemnumber = ?
+ AND datearrived IS NULL
+';
+ my $sth = $dbh->prepare($query);
+ $sth->execute($itemnumber);
+
+ my @row = $sth->fetchrow_array();
+
+ $sth->finish;
+
+ return @row;
+}
+
+
+sub DeleteTransfer {
+ my($itemnumber) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth=$dbh->prepare("DELETE FROM branchtransfers
+ where itemnumber=?
+ AND datearrived is null ");
+ $sth->execute($itemnumber);
+ $sth->finish;
+}
+
+sub GetTransfersFromBib {
+ my($frombranch,$tobranch) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth=$dbh->prepare("SELECT itemnumber,datesent,frombranch FROM
+ branchtransfers
+ where frombranch=?
+ AND tobranch=?
+ AND datearrived is null ");
+ $sth->execute($frombranch,$tobranch);
+ my @gettransfers;
+ my $i=0;
+ while (my $data=$sth->fetchrow_hashref){
+ $gettransfers[$i]=$data;
+ $i++;
+ }
+ $sth->finish;
+ return(@gettransfers);
+}
+
+sub GetReservesToBranch {
+ my($frombranch,$default) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth=$dbh->prepare("SELECT borrowernumber,reservedate,itemnumber,timestamp FROM
+ reserves
+ where priority='0' AND cancellationdate is null
+ AND branchcode=?
+ AND branchcode!=?
+ AND found is null ");
+ $sth->execute($frombranch,$default);
+ my @transreserv;
+ my $i=0;
+ while (my $data=$sth->fetchrow_hashref){
+ $transreserv[$i]=$data;
+ $i++;
+ }
+ $sth->finish;
+ return(@transreserv);
+}
+
+sub GetReservesForBranch {
+ my($frombranch) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth=$dbh->prepare("SELECT borrowernumber,reservedate,itemnumber,waitingdate FROM
+ reserves
+ where priority='0' AND cancellationdate is null
+ AND found='W'
+ AND branchcode=? order by reservedate");
+ $sth->execute($frombranch);
+ my @transreserv;
+ my $i=0;
+ while (my $data=$sth->fetchrow_hashref){
+ $transreserv[$i]=$data;
+ $i++;
+ }
+ $sth->finish;
+ return(@transreserv);
+}
+
+sub checktransferts{
+ my($itemnumber) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth=$dbh->prepare("SELECT datesent,frombranch,tobranch FROM branchtransfers
+ WHERE itemnumber = ? AND datearrived IS NULL");
+ $sth->execute($itemnumber);
+ my @tranferts = $sth->fetchrow_array;
+ $sth->finish;
+
+ return (@tranferts);
+}
+
+
+1;
+__END__
+
+=back
+
+=head1 AUTHOR
+
+Koha Developement team <info at koha.org>
+
+=cut
Index: Circ3.pm
===================================================================
RCS file: Circ3.pm
diff -N Circ3.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Circ3.pm 10 Mar 2007 01:39:27 -0000 1.1.2.1
@@ -0,0 +1,577 @@
+# -*- tab-width: 8 -*-
+# Please use 8-character tabs for this file (indents are every 4 characters)
+
+package C4::Circulation::Circ3;
+
+# $Id: Circ3.pm,v 1.1.2.1 2007/03/10 01:39:27 tgarip1957 Exp $
+
+#package to deal with reserve section Returns
+#
+
+# Copyright 2000-2002 Katipo Communications
+#
+# This file is part of Koha.
+#
+# Koha is free software; you can redistribute it and/or modify it under the
+# terms of the GNU General Public License as published by the Free Software
+# Foundation; either version 2 of the License, or (at your option) any later
+# version.
+#
+# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
+# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
+# Suite 330, Boston, MA 02111-1307 USA
+
+use strict;
+# use warnings;
+require Exporter;
+
+use C4::Context;
+use C4::Stats;
+use C4::Reserves2;
+use C4::Koha;
+use C4::Accounts2;
+use C4::Date;
+use C4::Biblio;
+use C4::Search;
+use C4::Circulation::Circ2;
+use C4::Members;
+use C4::Circulation::Fines;
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+
+# set the version for version checking
+$VERSION = 0.01;
+
+=head1 NAME
+
+C4::Circulation::Circ3 - Koha circulation module for NEU RESERVE section
+
+=head1 SYNOPSIS
+
+ use C4::Circulation::Circ3;
+
+=head1 DESCRIPTION
+
+The functions in this module deal with circulation, issues, and
+returns, as well as general information about the library.
+Also deals with stocktaking.
+
+=head1 FUNCTIONS
+
+=over 2
+
+=cut
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(
+ &getissuesr
+ &canbookbeissuedr &issuebookr &returnbookr
+ );
+
+
+=head2 canbookbeissued
+
+Check if a book can be issued.
+
+my ($issuingimpossible,$needsconfirmation) = canbookbeissuedr($env,$borrower,$barcode,$year,$month,$day);
+
+=over 4
+
+C<$env> Environment variable. Should be empty usually, but used by other subs. Next code cleaning could drop it.
+
+C<$borrower> hash with borrower informations (from getpatroninformation)
+
+C<$barcode> is the bar code of the book being issued.
+
+C<$year> C<$month> C<$day> contains the date of the return (in case it's forced by "stickyduedate".
+
+=back
+
+Returns :
+
+=over 4
+
+C<$issuingimpossible> a reference to a hash. It contains reasons why issuing is impossible.
+Possible values are :
+
+=head3 INVALID_DATE
+
+sticky due date is invalid
+
+=head3 GNA
+
+borrower gone with no address
+
+=head3 CARD_LOST
+
+borrower declared it's card lost
+
+=head3 DEBARRED
+
+borrower debarred
+
+=head3 UNKNOWN_BARCODE
+
+barcode unknown
+
+=head3 NOT_FOR_LOAN
+
+item is not for loan
+
+=head3 WTHDRAWN
+
+item withdrawn.
+
+=head3 RESTRICTED
+
+item is restricted (set by ??)
+
+=back
+
+C<$issuingimpossible> a reference to a hash. It contains reasons why issuing is impossible.
+Possible values are :
+
+=head3 DEBT
+
+borrower has debts.
+
+=head3 RENEW_ISSUE
+
+renewing, not issuing
+
+=head3 ISSUED_TO_ANOTHER
+
+issued to someone else.
+
+=head3 RESERVED
+
+reserved for someone else.
+
+=head3 INVALID_DATE
+
+sticky due date is invalid
+
+=head3 TOO_MANY
+
+if the borrower borrows to much things
+
+=cut
+
+# check if a book can be issued.
+# returns an array with errors if any
+
+
+
+sub canbookbeissuedr {
+ my ($env,$borrower,$barcode,$year,$month,$day,$renew) = @_;
+ my %needsconfirmation; # filled with problems that needs confirmations
+ my %issuingimpossible; # filled with problems that causes the issue to be IMPOSSIBLE
+ my $iteminformation = C4::Circulation::Circ2::getiteminformation($env, 0, $barcode);
+ my $dbh = C4::Context->dbh;
+#
+# DUE DATE is OK ?
+#
+# my ($duedate, $invalidduedate) = fixdate($year, $month, $day);
+# $issuingimpossible{INVALID_DATE} = 1 if ($invalidduedate);
+my $duedate;
+#
+# BORROWER STATUS
+#
+ if ($borrower->{flags}->{GNA}) {
+ $issuingimpossible{GNA} = 1;
+ }
+ if ($borrower->{flags}->{'LOST'}) {
+ $issuingimpossible{CARD_LOST} = 1;
+ }
+ if ($borrower->{flags}->{'DBARRED'}) {
+ $issuingimpossible{DEBARRED} = 1;
+ }
+ my $today=get_today();
+ if (DATE_diff($borrower->{expiry},$today)<0) {
+ $issuingimpossible{EXPIRED} = 1;
+ }
+#
+# BORROWER STATUS
+#
+
+# DEBTS
+ my $amount = C4::Accounts2::checkaccount($env,$borrower->{'borrowernumber'}, $dbh,$duedate);
+ if ($amount >0) {
+ $needsconfirmation{DEBT} = $amount;
+ }
+
+
+#
+# JB34 CHECKS IF BORROWERS DONT HAVE ISSUE TOO MANY BOOKS
+#
+ my $sth2 = $dbh->prepare("select COUNT(*) from reserveissue i where i.borrowernumber = ? and i.rettime is null ");
+ $sth2->execute($borrower->{'borrowernumber'});
+ my $toomany=$sth2->fetchrow;
+ $needsconfirmation{TOO_MANY} = $toomany if $toomany;
+
+#
+# ITEM CHECKING
+#
+ unless ($iteminformation->{barcode}) {
+ $issuingimpossible{UNKNOWN_BARCODE} = 1;
+ }
+ if (uc($iteminformation->{'shelf'}) ne 'RES') {
+ $issuingimpossible{NOT_INRESERVE} = 1;
+ }
+ if ($iteminformation->{'ctype'} eq 'REF') {
+ $issuingimpossible{NOT_FOR_LOAN} = 1;
+ }
+ if ($iteminformation->{'wthdrawn'} == 1) {
+ $issuingimpossible{WTHDRAWN} = 1;
+ }
+ if ($iteminformation->{'restricted'} == 1) {
+ $issuingimpossible{RESTRICTED} = 1;
+ }
+
+
+
+#
+# CHECK IF BOOK ALREADY ISSUED TO THIS BORROWER
+#
+ my ($currentborrower) = currentresborrower($iteminformation->{'itemnumber'});
+ if ($currentborrower eq $borrower->{'borrowernumber'}) {
+# Already issued to current borrower. Ask whether the loan should
+# be renewed.
+# my ($renewstatus) = renewstatus($env, $borrower->{'borrowernumber'}, $iteminformation->{'itemnumber'});
+# if ($renewstatus == 0) { # no more renewals allowed
+ $issuingimpossible{NO_MORE_RENEWALS} = 1;
+# } else {
+#warn "renew:$renew";
+# if (!$renew){ $needsconfirmation{RENEW_ISSUE} = 1;
+# }
+
+# }
+ } elsif ($currentborrower) {
+# issued to someone else
+ my $currborinfo = C4::Members::getpatroninformation(0,$currentborrower);
+# warn "=>.$currborinfo->{'firstname'} $currborinfo->{'surname'} ($currborinfo->{'cardnumber'})";
+ $needsconfirmation{ISSUED_TO_ANOTHER} = "$currborinfo->{'reservedate'} : $currborinfo->{'firstname'} $currborinfo->{'surname'} ($currborinfo->{'cardnumber'})";
+ }
+
+ return(\%issuingimpossible,\%needsconfirmation);
+}
+
+=head2 issuebook
+
+Issue a book. Does no check, they are done in canbookbeissued. If we reach this sub, it means the user confirmed if needed.
+
+&issuebookr($env,$borrower,$barcode,$date)
+
+=over 4
+
+C<$env> Environment variable. Should be empty usually, but used by other subs. Next code cleaning could drop it.
+
+C<$borrower> hash with borrower informations (from getpatroninformation)
+
+C<$barcode> is the bar code of the book being issued.
+
+C<$date> contains the max date of return. calculated if empty.
+
+=cut
+
+#
+# issuing book. We already have checked it can be issued, so, just issue it !
+#
+sub issuebookr {
+ my ($env,$borrower,$barcode,$cancelreserve) = @_;
+ my $dbh = C4::Context->dbh;
+
+
+ my $iteminformation = getiteminformation($env, 0, $barcode);
+ my $bibliorecord=XMLgetbibliohash($dbh,$iteminformation->{biblionumber});
+
+#
+# check if we just renew the issue.
+#
+ my ($currentborrower) = currentresborrower($iteminformation->{'itemnumber'});
+ if ($currentborrower eq $borrower->{'borrowernumber'}) {
+ my ($charge,$itemtype) = calc_charges($env, $iteminformation->{'itemnumber'}, $borrower->{'borrowernumber'});
+ if ($charge > 0) {
+ createcharge($env, $dbh, $iteminformation->{'itemnumber'}, $borrower->{'borrowernumber'}, $charge);
+ $iteminformation->{'charge'} = $charge;
+ }
+ &UpdateStats($env,$env->{'branchcode'},'renew',$charge,'',$iteminformation->{'itemnumber'},$iteminformation->{'ctype'},$borrower->{'borrowernumber'});
+ renewbook($env, $borrower->{'borrowernumber'}, $iteminformation->{'itemnumber'});
+ } else {
+#
+# NOT a renewal
+#
+ if ($currentborrower ne '') {
+ # This book is currently on loan, but not to the person
+ # who wants to borrow it now. mark it returned before issuing to the new borrower
+ returnbookr($iteminformation->{'barcode'}, $env->{'branchcode'});
+ }
+
+ # Record in the database the fact that the book was issued.
+ my $sth=$dbh->prepare("insert into reserveissue (borrowernumber, itemnumber, duetime,restime) values (?,?,?,now())");
+ my $loanlength = C4::Context->preference('Reserveperiod');
+ my $datedue=time+($loanlength)*3600+900;
+ my @datearr = localtime($datedue);
+ my $dateduef = (1900+$datearr[5])."-".sprintf ("%0.2d",$datearr[4]+1)."-".sprintf ("%0.2d",$datearr[3])." ".sprintf ("%0.2d",$datearr[2]).":".sprintf ("%0.2d",$datearr[1]).":".sprintf ("%0.2d",$datearr[0]);
+# if ($date) {
+# $dateduef=$date;
+# }
+ $sth->execute($borrower->{'borrowernumber'}, $iteminformation->{'itemnumber'}, $dateduef);
+ $sth->finish;
+##Update totalissues of bibliorecord if exist
+ my $totalissue=XML_readline_onerecord($bibliorecord,"totalissue","biblios");
+$totalissue=scalar($totalissue);
+ $totalissue++;
+my $extras=length($totalissue);
+ for (1..(6-$extras)){
+ $totalissue="0".$totalissue;
+ }
+ $bibliorecord=XML_writeline($bibliorecord,"totalissue",$totalissue,"biblios");
+ my $frameworkcode=MARCfind_frameworkcode($dbh,$iteminformation->{'biblionumber'});
+ C4::Biblio::OLDmodbiblio($dbh,$bibliorecord,$iteminformation->{'biblionumber'},$frameworkcode);
+###
+
+ $iteminformation->{'issues'}++;
+ &XMLmoditemonefield($dbh,$iteminformation->{'biblionumber'},$iteminformation->{'itemnumber'},'date_due',$dateduef,1);
+ &XMLmoditemonefield($dbh,$iteminformation->{'biblionumber'},$iteminformation->{'itemnumber'},'issues',$iteminformation->{'issues'},1);
+ &XMLmoditemonefield($dbh,$iteminformation->{'biblionumber'},$iteminformation->{'itemnumber'},'onloan','1',1);
+
+ &itemseen($dbh,$iteminformation->{'itemnumber'});
+ # If it costs to borrow this book, charge it to the patron's account.
+ my ($charge,$itemtype)=calc_charges($env, $iteminformation->{'itemnumber'}, $borrower->{'borrowernumber'});
+ if ($charge > 0) {
+ createcharge($env, $dbh, $iteminformation->{'itemnumber'}, $borrower->{'borrowernumber'}, $charge);
+ $iteminformation->{'charge'}=$charge;
+ }
+ # Record the fact that this book was issued.
+ &UpdateStats($env,$env->{'branchcode'},'issue',$charge,'',$iteminformation->{'itemnumber'},$iteminformation->{'ctype'},$borrower->{'borrowernumber'});
+ }
+}
+
+=head2 getLoanLength
+
+Get loan length for an itemtype, a borrower type and a branch
+
+my $loanlength = &getLoanLength($borrowertype,$itemtype,branchcode)
+
+=cut
+
+=head2 returnbook
+
+ ($doreturn, $messages, $iteminformation, $borrower) =
+ &returnbookr($barcode, $branch);
+
+Returns a book.
+
+C<$barcode> is the bar code of the book being returned. C<$branch> is
+the code of the branch where the book is being returned.
+
+C<&returnbook> returns a list of four items:
+
+C<$doreturn> is true iff the return succeeded.
+
+C<$messages> is a reference-to-hash giving the reason for failure:
+
+=over 4
+
+=item C<BadBarcode>
+
+No item with this barcode exists. The value is C<$barcode>.
+
+=item C<NotIssued>
+
+The book is not currently on loan. The value is C<$barcode>.
+
+=item C<IsPermanent>
+
+The book's home branch is a permanent collection. If you have borrowed
+this book, you are not allowed to return it. The value is the code for
+the book's home branch.
+
+=item C<wthdrawn>
+
+This book has been withdrawn/cancelled. The value should be ignored.
+
+=item C<ResFound>
+
+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>, C<Reserved>, or 0.
+
+=back
+
+C<$borrower> is a reference-to-hash, giving information about the
+patron who last borrowed the book.
+
+=cut
+
+# FIXME - This API is bogus. There's no need to return $borrower and
+# $iteminformation; the caller can ask about those separately, if it
+# cares (it'd be inefficient to make two database calls instead of
+# one, but &getpatroninformation and &getiteminformation can be
+# memoized if this is an issue).
+#
+# The ($doreturn, $messages) tuple is redundant: if the return
+# succeeded, that's all the caller needs to know. So &returnbook can
+# return 1 and 0 on success and failure, and set
+# $C4::Circulation::Circ2::errmsg to indicate the error. Or it can
+# return undef for success, and an error message on error (though this
+# is more C-ish than Perl-ish).
+
+sub returnbookr {
+ my ($barcode, $branch) = @_;
+ my %env;
+ my $messages;
+ my $dbh = C4::Context->dbh;
+ my $doreturn = 1;
+ die '$branch not defined' unless defined $branch; # just in case (bug 170)
+ # get information on item
+ my ($iteminformation) = getiteminformation(\%env, 0, $barcode);
+ if (not $iteminformation) {
+ $messages->{'BadBarcode'} = $barcode;
+ $doreturn = 0;
+ }
+ # find the borrower
+ my ($currentborrower) = currentresborrower($iteminformation->{'itemnumber'});
+
+ if ((not $currentborrower) && $doreturn) {
+ $messages->{'NotIssued'} = $barcode;
+ $doreturn = 0;
+ }
+my ($od,$issue,$fines,$resfine)=borrdata3(\%env,$currentborrower);
+if ($resfine>0){
+ UpdateFine($iteminformation->{'itemnumber'},$currentborrower,$resfine,'RES',$iteminformation->{'duetime'});
+}
+ # check if the book is in a permanent collection....
+ my $hbr = $iteminformation->{'homebranch'};
+ my $branches = GetBranches();
+ if ($branches->{$hbr}->{'PE'}) {
+ $messages->{'IsPermanent'} = $hbr;
+ }
+ # check that the book has been cancelled
+ if ($iteminformation->{'wthdrawn'}) {
+ $messages->{'wthdrawn'} = 1;
+ $doreturn = 0;
+ }
+ # update issues, thereby returning book (should push this out into another subroutine
+ my ($borrower) = C4::Members::getpatroninformation(\%env, $currentborrower, 0);
+ if ($doreturn) {
+ my $sth = $dbh->prepare("update reserveissue set rettime = now() where (borrowernumber = ?) and (itemnumber = ?) and (rettime is null)");
+ $sth->execute( $currentborrower, $iteminformation->{'itemnumber'});
+ $messages->{'WasReturned'} = 1; # FIXME is the "= 1" right?
+
+ &XMLmoditemonefield($dbh,$iteminformation->{'biblionumber'},$iteminformation->{'itemnumber'},'date_due','',1);
+ &XMLmoditemonefield($dbh,$iteminformation->{'biblionumber'},$iteminformation->{'itemnumber'},'onloan','0',1);
+ }
+ my ($transfered, $mess, $item) = transferbook($branch, $barcode, 1);
+ itemseen($dbh,$iteminformation->{'itemnumber'});
+# ($borrower) = getpatroninformation(\%env, $currentborrower, 0);
+ # transfer book to the current branch
+
+ if ($transfered) {
+ $messages->{'WasTransfered'} = 1; # FIXME is the "= 1" right?
+ }
+ # fix up the accounts.....
+ if ($iteminformation->{'itemlost'}) {
+# fixaccountforlostandreturned($iteminformation, $currentborrower);
+ $messages->{'WasLost'} = 1; # FIXME is the "= 1" right?
+ }
+ # fix up the overdues in accounts...
+ fixoverduesonreturnres($currentborrower, $iteminformation->{'itemnumber'});
+ # find reserves.....
+ # update stats?
+ # Record the fact that this book was returned.
+ UpdateStats(\%env, $branch ,'return','0','',$iteminformation->{'itemnumber'},$iteminformation->{'ctype'},$borrower->{'borrowernumber'});
+ return ($doreturn, $messages, $iteminformation, $borrower);
+}
+sub fixoverduesonreturnres {
+ my ($brn, $itm) = @_;
+ my $dbh = C4::Context->dbh;
+ # check for overdue fine
+ my $sth = $dbh->prepare("select * from accountlines where (borrowernumber = ?) and (itemnumber = ?) and (accounttype='FU' or accounttype='O')");
+ $sth->execute($brn,$itm);
+ # alter fine to show that the book has been returned
+ if (my $data = $sth->fetchrow_hashref) {
+ my $usth=$dbh->prepare("update accountlines set accounttype='F' where (borrowernumber = ?) and (itemnumber = ?) and (accountno = ?)");
+ $usth->execute($brn,$itm,$data->{'accountno'});
+ $usth->finish();
+ }
+ $sth->finish();
+ return;
+}
+# Not exported
+sub currentresborrower {
+
+ my ($itemnumber) = @_;
+
+ my $dbh = C4::Context->dbh;
+ my $sth=$dbh->prepare("select borrowernumber from reserveissue where itemnumber=? and rettime is NULL");
+ $sth->execute($itemnumber);
+ my ($borrower) = $sth->fetchrow;
+ return($borrower);
+}
+=head2 getissues
+
+ $issues = &getissuesr($borrowernumber);
+
+Returns the set of books currently on loan to a patron.
+
+C<$borrowernumber> is the patron's borrower number.
+
+C<&getissues> returns a PHP-style array: C<$issues> is a
+reference-to-hash whose keys are integers in the range 0..I<n>-1,
+where I<n> is the number of books the patron currently has on loan.
+
+The values of C<$issues> are references-to-hash whose keys are
+selected fields from the issues, items, biblio, and biblioitems tables
+of the Koha database.
+
+=cut
+#'
+sub getissuesr {
+# New subroutine for Circ3.pm
+ my ($borrower) = @_;
+ my $dbh = C4::Context->dbh;
+ my $borrowernumber = $borrower->{'borrowernumber'};
+ my %currentissues;
+ my $select = "SELECT *,
+ timediff(now(), reserveissue.duetime ) as elapsed
+
+ FROM reserveissue,items,biblio
+ WHERE reserveissue.borrowernumber = ?
+ AND items.biblionumber=biblio.biblionumber
+ AND reserveissue.itemnumber = items.itemnumber
+ AND reserveissue.rettime IS NULL
+ ";
+ # print $select;
+ my $sth=$dbh->prepare($select);
+ $sth->execute($borrowernumber);
+ my $counter = 0;
+ while (my $data = $sth->fetchrow_hashref) {
+ if ($data->{'elapsed'}>0) {
+ $data->{'overdue'} = 1;
+ }
+ $currentissues{$counter} = $data;
+ $counter++;
+ }
+ $sth->finish;
+ return(\%currentissues);
+}
+
+
+
+
+1;
+__END__
+
+=back
+
+=head1 AUTHOR
+
+Koha Developement team <info at koha.org>
+
+=cut
Index: Fines.pm
===================================================================
RCS file: Fines.pm
diff -N Fines.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Fines.pm 10 Mar 2007 01:39:27 -0000 1.1.2.1
@@ -0,0 +1,304 @@
+package C4::Circulation::Fines;
+
+# $Id: Fines.pm,v 1.1.2.1 2007/03/10 01:39:27 tgarip1957 Exp $
+
+# Copyright 2000-2002 Katipo Communications
+#
+# This file is part of Koha.
+#
+# Koha is free software; you can redistribute it and/or modify it under the
+# terms of the GNU General Public License as published by the Free Software
+# Foundation; either version 2 of the License, or (at your option) any later
+# version.
+#
+# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
+# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
+# Suite 330, Boston, MA 02111-1307 USA
+
+use strict;
+require Exporter;
+
+use C4::Context;
+use C4::Biblio;
+use vars qw($VERSION @ISA @EXPORT);
+
+# set the version for version checking
+$VERSION = 0.01;
+
+=head1 NAME
+
+C4::Circulation::Fines - Koha module dealing with fines
+
+=head1 SYNOPSIS
+
+ use C4::Circulation::Fines;
+
+=head1 DESCRIPTION
+
+This module contains several functions for dealing with fines for
+overdue items. It is primarily used by the 'misc/fines2.pl' script.
+
+=head1 FUNCTIONS
+
+=over 2
+
+=cut
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(&Getoverdues &CalcFine &BorType &UpdateFine &ReplacementCost);
+
+=item Getoverdues
+
+ ($count, $overdues) = &Getoverdues();
+
+Returns the list of all overdue books.
+
+C<$count> is the number of elements in C<@{$overdues}>.
+
+C<$overdues> is a reference-to-array. Each element is a
+reference-to-hash whose keys are the fields of the issues table in the
+Koha database.
+
+=cut
+#'
+sub Getoverdues{
+ my $dbh = C4::Context->dbh;
+ my $sth=$dbh->prepare("Select * from issues where date_due < now() and returndate is NULL order by borrowernumber");
+ $sth->execute;
+ # FIXME - Use push @results
+ my $i=0;
+ my @results;
+ while (my $data=$sth->fetchrow_hashref){
+ push @results,$data;
+ $i++;
+ }
+ $sth->finish;
+ return($i,\@results);
+}
+
+=item CalcFine
+
+ ($amount, $chargename, $message) =
+ &CalcFine($itemnumber, $borrowercode, $days_overdue);
+
+Calculates the fine for a book.
+
+The issuingrules table in the Koha database is a fine matrix, listing
+the penalties for each type of patron for each type of item and each branch (e.g., the
+standard fine for books might be $0.50, but $1.50 for DVDs, or staff
+members might get a longer grace period between the first and second
+reminders that a book is overdue).
+
+
+
+C<$itemnumber> is the book's item number.
+
+C<$borrowercode> is the borrower code of the patron who currently has
+the book.
+
+C<$days_overdue> is the number of days elapsed since the book's due
+date.
+
+C<&CalcFine> returns a list of three values:
+
+C<$amount> is the fine owed by the patron (see above).
+
+C<$chargename> is the chargename field from the applicable record in
+the issuingrules table, whatever that is.
+
+C<$message> is a text message, either "First Notice", "Second Notice",
+or "Final Notice".
+
+=cut
+#'
+sub CalcFine {
+ my ($itemnumber,$bortype,$difference)=@_;
+ my $dbh = C4::Context->dbh;
+ # Look up the issuingrules record for this book's item type and the
+ # given borrwer type.
+
+
+ my $sth=$dbh->prepare("Select * from items,itemtypes,issuingrules where items.itemnumber=?
+ and items.ctype=itemtypes.itemtype and
+ issuingrules.itemtype=itemtypes.itemtype and
+ issuingrules.categorycode=? ");
+# print $query;
+ $sth->execute($itemnumber,$bortype);
+ my $data=$sth->fetchrow_hashref;
+ # FIXME - Error-checking: the item might be lost, or there
+ # might not be an entry in 'issuingrules' for this item type
+ # or borrower type.
+ $sth->finish;
+ my $amount=0;
+ my $printout;
+
+ if ($difference > $data->{'firstremind'}){
+ # Yes. Set the fine as listed.
+$amount=$data->{'fine'}* $difference;
+
+ $printout="First Notice";
+ }
+
+ # Is it time to send out a second reminder?
+ my $second=$data->{'firstremind'}+$data->{chargeperiod};
+ if ($difference == $second){
+$amount=$data->{'fine'}* $difference;
+
+ $printout="Second Notice";
+ }
+
+ # Is it time to send the account to a collection agency?
+ # FIXME -This $data->{'accountsent'} is not seemed to be set in the DB
+ if ($difference == $data->{'accountsent'}){
+ $amount=$data->{'fine'}* $difference;
+
+ $printout="Final Notice";
+ }
+ return($amount,$data->{'chargename'},$printout);
+}
+
+=item UpdateFine
+
+ &UpdateFine($itemnumber, $borrowernumber, $amount, $type, $description);
+
+(Note: the following is mostly conjecture and guesswork.)
+
+Updates the fine owed on an overdue book.
+
+C<$itemnumber> is the book's item number.
+
+C<$borrowernumber> is the borrower number of the patron who currently
+has the book on loan.
+
+C<$amount> is the current amount owed by the patron.
+
+C<$type> will be used in the description of the fine.
+
+C<$description> is a string that must be present in the description of
+the fine. I think this is expected to be a date in DD/MM/YYYY format.
+
+C<&UpdateFine> looks up the amount currently owed on the given item
+and sets it to C<$amount>, creating, if necessary, a new entry in the
+accountlines table of the Koha database.
+
+=cut
+#'
+# FIXME - This API doesn't look right: why should the caller have to
+# specify both the item number and the borrower number? A book can't
+# be on loan to two different people, so the item number should be
+# sufficient.
+sub UpdateFine {
+ my ($itemnum,$bornum,$amount,$type,$due)=@_;
+ my $dbh = C4::Context->dbh;
+ # FIXME - What exactly is this query supposed to do? It looks up an
+ # entry in accountlines that matches the given item and borrower
+ # numbers, where the description contains $due, and where the
+ # account type has one of several values, but what does this _mean_?
+ # Does it look up existing fines for this item?
+ # FIXME - What are these various account types? ("FU", "O", "F", "M")
+
+ my $sth=$dbh->prepare("Select * from accountlines where itemnumber=? and
+ borrowernumber=? and (accounttype='FU' or accounttype='O' or
+ accounttype='F' or accounttype='M') ");
+ $sth->execute($itemnum,$bornum);
+
+ if (my $data=$sth->fetchrow_hashref){
+ # I think this if-clause deals with the case where we're updating
+ # an existing fine.
+# print "in accounts ...";
+ if ($data->{'amount'} != $amount){
+
+# print "updating";
+ my $diff=$amount - $data->{'amount'};
+ my $out=$data->{'amountoutstanding'}+$diff;
+ my $sth2=$dbh->prepare("update accountlines set date=now(), amount=?,
+ amountoutstanding=?,accounttype='FU' where
+ accountid=?");
+ $sth2->execute($amount,$out,$data->{'accountid'});
+ $sth2->finish;
+ } else {
+ # print "no update needed $data->{'amount'} \n";
+ }
+ } else {
+ # I think this else-clause deals with the case where we're adding
+ # a new fine.
+ my $sth4=$dbh->prepare("select title from biblio ,items where items.itemnumber=?
+ and biblio.biblionumber=items.biblionumber");
+ $sth4->execute($itemnum);
+ my $title=$sth4->fetchrow;
+ $sth4->finish;
+ # print "not in account";
+ my $sth3=$dbh->prepare("Select max(accountno) from accountlines");
+ $sth3->execute;
+ # FIXME - Make $accountno a scalar.
+ my $accountno=$sth3->fetchrow;
+ $sth3->finish;
+ $accountno++;
+ my $sth2=$dbh->prepare("Insert into accountlines
+ (borrowernumber,itemnumber,date,amount,
+ description,accounttype,amountoutstanding,accountno) values
+ (?,?,now(),?,?,'FU',?,?)");
+ $sth2->execute($bornum,$itemnum,$amount,"$type $title $due",$amount,$accountno);
+ $sth2->finish;
+ }
+ $sth->finish;
+}
+
+
+
+=item BorType
+
+ $borrower = &BorType($borrowernumber);
+
+Looks up a patron by borrower number.
+
+C<$borrower> is a reference-to-hash whose keys are all of the fields
+from the borrowers and categories tables of the Koha database. Thus,
+C<$borrower> contains all information about both the borrower and
+category he or she belongs to.
+
+=cut
+#'
+sub BorType {
+ my ($borrowernumber)=@_;
+ my $dbh = C4::Context->dbh;
+ my $sth=$dbh->prepare("Select * from borrowers,categories where
+ borrowernumber=? and
+borrowers.categorycode=categories.categorycode");
+ $sth->execute($borrowernumber);
+ my $data=$sth->fetchrow_hashref;
+ $sth->finish;
+ return($data);
+}
+
+=item ReplacementCost
+
+ $cost = &ReplacementCost($itemnumber);
+
+Returns the replacement cost of the item with the given item number.
+
+=cut
+#'
+sub ReplacementCost{
+ my ($itemnumber)=@_;
+ my $dbh = C4::Context->dbh;
+ my ($itemrecord)=XMLgetitem($dbh,$itemnumber);
+$itemrecord=XML_xml2hash_onerecord($itemrecord);
+ my $replacementprice=XML_readline_onerecord($itemrecord,"replacementprice","holdings");
+ return($replacementprice);
+}
+
+1;
+__END__
+
+=back
+
+=head1 AUTHOR
+
+Koha Developement team <info at koha.org>
+
+=cut
Index: PrinterConfig.pm
===================================================================
RCS file: PrinterConfig.pm
diff -N PrinterConfig.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ PrinterConfig.pm 10 Mar 2007 01:39:27 -0000 1.1.2.1
@@ -0,0 +1,111 @@
+package C4::Barcodes::PrinterConfig;
+
+# This package is used to deal with labels in a pdf file. Giving some parameters,
+# this package takes care of every label considering the environment of the pdf
+# file.
+
+use strict;
+require Exporter;
+use vars qw(@EXPORT);
+ at EXPORT = qw(&labelsPage &getLabelPosition setPositionsForX setPositionsForY);
+
+use PDF::API2;
+use PDF::API2::Page;
+
+
+my @positionsForX; # Take all the X positions of the pdf file.
+my @positionsForY; # Take all the Y positions of the pdf file.
+my $firstLabel = 1; # Test if the label passed as a parameter is the first label to be printed into the pdf file.
+
+# ***************************** ROUTINES DEFINITIONS ********************************** #
+
+# Calculate and stores all tha X positions across the pdf page.
+sub setPositionsForX {
+ my ($marginLeft, $labelWidth, $columns, $pageType) = @_;
+ my $defaultDpi = 72/25.4; # By default we know 25.4 mm -> 1 inch -> 72 dots per inch
+ my $whereToStart = ($marginLeft + ($labelWidth/2));
+ my $firstLabel = $whereToStart*$defaultDpi;
+ my $spaceBetweenLabels = $labelWidth*$defaultDpi;
+ my @positions;
+ for (my $i = 0; $i < $columns ; $i++) {
+ push @positions, ($firstLabel+($spaceBetweenLabels*$i));
+ }
+ @positionsForX = @positions;
+}
+
+# Calculate and stores all tha Y positions across the pdf page.
+sub setPositionsForY {
+ my ($marginBottom, $labelHeigth, $rows, $pageType) = @_;
+ my $defaultDpi = 72/25.4; # By default we know 25.4 mm -> 1 inch -> 72 dots per inch
+ my $whereToStart = ($marginBottom + ($labelHeigth/2));
+ my $firstLabel = $whereToStart*$defaultDpi;
+ my $spaceBetweenLabels = $labelHeigth*$defaultDpi;
+ my @positions;
+ for (my $i = 0; $i < $rows; $i++) {
+ unshift @positions, ($firstLabel+($spaceBetweenLabels*$i));
+ }
+ @positionsForY = @positions;
+}
+
+# Return the (x,y) position of the label that you are going to print considering the environment.
+sub getLabelPosition {
+ my ($labelNum, $pdf, $page, $gfxObject, $textObject, $fontObject, $pageType) = @_;
+ my $indexX = $labelNum % @positionsForX;
+ my $indexY = int($labelNum / @positionsForX);
+ # Calculates the next label position and return that label number
+ my $nextIndexX = $labelNum % @positionsForX;
+ my $nextIndexY = $labelNum % @positionsForY;
+ if ($firstLabel) {
+ $page = $pdf->page;
+ $page->mediabox($pageType);
+ $gfxObject = $page->gfx;
+ $textObject = $page->text;
+ $textObject->font($fontObject, 7);
+ $firstLabel = 0;
+ } elsif (($nextIndexX == 0) && ($nextIndexY == 0)) {
+ $page = $pdf->page;
+ $page->mediabox($pageType);
+ $gfxObject = $page->gfx;
+ $textObject = $page->text;
+ $textObject->font($fontObject, 7);
+ }
+ $labelNum = $labelNum + 1;
+ if ($labelNum == (@positionsForX*@positionsForY)) {
+ $labelNum = 0;
+ }
+ return ($positionsForX[$indexX], $positionsForY[$indexY], $pdf, $page, $gfxObject, $textObject, $fontObject, $labelNum);
+}
+
+# This function will help you to build the labels panel, where you can choose
+# wich label position do you want to start the printer process.
+sub labelsPage{
+ my ($rows, $columns) = @_;
+ my @pageType;
+ my $tagname = 0;
+ my $labelname = 1;
+ my $check;
+ for (my $i = 1; $i <= $rows; $i++) {
+ my @column;
+ for (my $j = 1; $j <= $columns; $j++) {
+ my %cell;
+ if ($tagname == 0) {
+ $check = 'checked';
+ } else {
+ $check = '';
+ }
+ %cell = (check => $check,
+ tagname => $tagname,
+ labelname => $labelname);
+ $tagname = $tagname + 1;
+ $labelname = $labelname + 1;
+ push @column, \%cell;
+ }
+ my %columns = (columns => \@column);
+ push @pageType, \%columns;
+ }
+ return @pageType;
+}
+
+
+1;
+__END__
\ No newline at end of file
More information about the Koha-cvs
mailing list