Koha-community/Koha
13
7
Fork 0
Code Issues Releases Wiki Activity
Koha/C4/Circulation/Circ2.pm

1879 lines
62 KiB
Perl
Executable file
Raw Blame History

# -*- tab-width: 8 -*-
# Please use 8-character tabs for this file (indents are every 4 characters)
package C4::Circulation::Circ2;
# $Id$
#package to deal with Returns
#written 3/11/99 by olwen@katipo.co.nz
# 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 DBI;
use C4::Context;
#use C4::Accounts;
#use C4::InterfaceCDK;
#use C4::Circulation::Main;
#use C4::Circulation::Renewals;
#use C4::Scan;
use C4::Stats;
use C4::Reserves2;
#use C4::Search;
#use C4::Print;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
# set the version for version checking
$VERSION = 0.01;
=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.
=head1 FUNCTIONS
=over 2
=cut
@ISA = qw(Exporter);
@EXPORT = qw(&getbranches &getprinters &getpatroninformation
&getbranch &getprinter
&currentissues &getissues &getiteminformation &findborrower
&issuebook &returnbook &find_reserves &transferbook &decode
&calc_charges);
=item getbranches
$branches = &getbranches();
@branch_codes = keys %$branches;
%main_branch_info = %{$branches->{"MAIN"}};
Returns information about existing library branches.
C<$branches> is a reference-to-hash. Its keys are the branch codes for
all of the existing library branches, and its values are
references-to-hash describing that particular branch.
In each branch description (C<%main_branch_info>, above), there is a
key for each field in the branches table of the Koha database. In
addition, there is a key for each branch category code to which the
branch belongs (the category codes are taken from the branchrelations
table).
=cut
#'
# FIXME - This function doesn't feel as if it belongs here. It should
# go in some generic or administrative module, not in circulation.
sub getbranches {
# returns a reference to a hash of references to branches...
my %branches;
my $dbh = C4::Context->dbh;
my $sth=$dbh->prepare("select * from branches");
$sth->execute;
while (my $branch=$sth->fetchrow_hashref) {
my $tmp = $branch->{'branchcode'}; my $brc = $dbh->quote($tmp);
# FIXME - my $brc = $dbh->quote($branch->{"branchcode"});
my $query = "select categorycode from branchrelations where branchcode = $brc";
my $nsth = $dbh->prepare($query);
$nsth->execute;
while (my ($cat) = $nsth->fetchrow_array) {
# FIXME - This seems wrong. It ought to be
# $branch->{categorycodes}{$cat} = 1;
# otherwise, there's a namespace collision if there's a
# category with the same name as a field in the 'branches'
# table (i.e., don't create a category called "issuing").
# In addition, the current structure doesn't really allow
# you to list the categories that a branch belongs to:
# you'd have to list keys %$branch, and remove those keys
# that aren't fields in the "branches" table.
$branch->{$cat} = 1;
}
$nsth->finish;
$branches{$branch->{'branchcode'}}=$branch;
}
return (\%branches);
}
=item getprinters
$printers = &getprinters($env);
@queues = keys %$printers;
Returns information about existing printer queues.
C<$env> is ignored.
C<$printers> is a reference-to-hash whose keys are the print queues
defined in the printers table of the Koha database. The values are
references-to-hash, whose keys are the fields in the printers table.
=cut
#'
# FIXME - Perhaps this really belongs in C4::Print?
sub getprinters {
my ($env) = @_;
my %printers;
my $dbh = C4::Context->dbh;
my $sth=$dbh->prepare("select * from printers");
$sth->execute;
while (my $printer=$sth->fetchrow_hashref) {
$printers{$printer->{'printqueue'}}=$printer;
}
return (\%printers);
}
# FIXME - This function doesn't feel as if it belongs here. It should
# go in some generic or administrative module, not in circulation.
sub getbranch ($$) {
my($query, $branches) = @_; # get branch for this query from branches
my $branch = $query->param('branch');
($branch) || ($branch = $query->cookie('branch'));
($branches->{$branch}) || ($branch=(keys %$branches)[0]);
return $branch;
}
# FIXME - Perhaps this really belongs in C4::Print?
sub getprinter ($$) {
my($query, $printers) = @_; # get printer for this query from printers
my $printer = $query->param('printer');
($printer) || ($printer = $query->cookie('printer'));
($printers->{$printer}) || ($printer = (keys %$printers)[0]);
return $printer;
}
=item getpatroninformation
($borrower, $flags) = &getpatroninformation($env, $borrowernumber,
$cardnumber);
Looks up a patron and returns information about him or her. If
C<$borrowernumber> is true (nonzero), C<&getpatroninformation> looks
up the borrower by number; otherwise, it looks up the borrower by card
number.
C<$env> is effectively ignored, but should be a reference-to-hash.
C<$borrower> is a reference-to-hash whose keys are the fields of the
borrowers table in the Koha database. In addition,
C<$borrower-E<gt>{flags}> is the same as C<$flags>.
C<$flags> is a reference-to-hash giving more detailed information
about the patron. Its keys act as flags: if they are set, then the key
is a reference-to-hash that gives further details:
if (exists($flags->{LOST}))
{
# Patron's card was reported lost
print $flags->{LOST}{message}, "\n";
}
Each flag has a C<message> key, giving a human-readable explanation of
the flag. If the state of a flag means that the patron should not be
allowed to borrow any more books, then it will have a C<noissues> key
with a true value.
The possible flags are:
=over 4
=item CHARGES
Shows the patron's credit or debt, if any.
=item GNA
(Gone, no address.) Set if the patron has left without giving a
forwarding address.
=item LOST
Set if the patron's card has been reported as lost.
=item DBARRED
Set if the patron has been debarred.
=item NOTES
Any additional notes about the patron.
=item ODUES
Set if the patron has overdue items. This flag has several keys:
C<$flags-E<gt>{ODUES}{itemlist}> is a reference-to-array listing the
overdue items. Its elements are references-to-hash, each describing an
overdue item. The keys are selected fields from the issues, biblio,
biblioitems, and items tables of the Koha database.
C<$flags-E<gt>{ODUES}{itemlist}> is a string giving a text listing of
the overdue items, one per line.
=item WAITING
Set if any items that the patron has reserved are available.
C<$flags-E<gt>{WAITING}{itemlist}> is a reference-to-array listing the
available items. Each element is a reference-to-hash whose keys are
fields from the reserves table of the Koha database.
=back
=cut
#'
sub getpatroninformation {
# returns
my ($env, $borrowernumber,$cardnumber) = @_;
my $dbh = C4::Context->dbh;
my $query;
my $sth;
if ($borrowernumber) {
$query = "select * from borrowers where borrowernumber=$borrowernumber";
} elsif ($cardnumber) {
$query = "select * from borrowers where cardnumber=$cardnumber";
} else {
$env->{'apierror'} = "invalid borrower information passed to getpatroninformation subroutine";
return();
}
$env->{'mess'} = $query;
$sth = $dbh->prepare($query);
$sth->execute;
my $borrower = $sth->fetchrow_hashref;
my $amount = checkaccount($env, $borrowernumber, $dbh);
$borrower->{'amountoutstanding'} = $amount;
my $flags = patronflags($env, $borrower, $dbh);
my $accessflagshash;
$sth=$dbh->prepare("select bit,flag from userflags");
$sth->execute;
while (my ($bit, $flag) = $sth->fetchrow) {
if ($borrower->{'flags'} & 2**$bit) {
$accessflagshash->{$flag}=1;
}
}
$sth->finish;
$borrower->{'flags'}=$flags;
return ($borrower, $flags, $accessflagshash);
}
=item decode
$str = &decode($chunk);
Decodes a segment of a string emitted by a CueCat barcode scanner and
returns it.
=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;
}
=item getiteminformation
$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:
=over 4
=item C<date_due>
The due date on this item, if it has been borrowed and not returned
yet. The date is in YYYY-MM-DD format.
=item C<loanlength>
The length of time for which the item can be borrowed, in days.
=item C<notforloan>
True if the item may not be borrowed.
=back
=cut
#'
sub getiteminformation {
# returns a hash of item information given either the itemnumber or the barcode
my ($env, $itemnumber, $barcode) = @_;
my $dbh = C4::Context->dbh;
my $sth;
if ($itemnumber) {
$sth=$dbh->prepare("select * from biblio,items,biblioitems where items.itemnumber=$itemnumber and biblio.biblionumber=items.biblionumber and biblioitems.biblioitemnumber = items.biblioitemnumber");
} elsif ($barcode) {
my $q_barcode=$dbh->quote($barcode);
$sth=$dbh->prepare("select * from biblio,items,biblioitems where items.barcode=$q_barcode and biblio.biblionumber=items.biblionumber and biblioitems.biblioitemnumber = items.biblioitemnumber");
} else {
$env->{'apierror'}="getiteminformation() subroutine must be called with either an itemnumber or a barcode";
# Error condition.
return();
}
$sth->execute;
my $iteminformation=$sth->fetchrow_hashref;
$sth->finish;
# FIXME - Style: instead of putting the entire rest of the
# function in a block, just say
# return undef unless $iteminformation;
# That way, the rest of the function needn't be indented as much.
if ($iteminformation) {
$sth=$dbh->prepare("select date_due from issues where itemnumber=$iteminformation->{'itemnumber'} and isnull(returndate)");
$sth->execute;
my ($date_due) = $sth->fetchrow;
$iteminformation->{'date_due'}=$date_due;
$sth->finish;
# FIXME - The Dewey code is a string, not a number. Besides,
# "000" is a perfectly valid Dewey code.
#$iteminformation->{'dewey'}=~s/0*$//;
($iteminformation->{'dewey'} == 0) && ($iteminformation->{'dewey'}='');
# FIXME - fetchrow_hashref is documented as being inefficient.
# Perhaps this should be rewritten as
# $sth = $dbh->prepare("select loanlength, notforloan ...");
# $sth->execute;
# ($iteminformation->{loanlength},
# $iteminformation->{notforloan}) = fetchrow_array;
$sth=$dbh->prepare("select * from itemtypes where itemtype='$iteminformation->{'itemtype'}'");
$sth->execute;
my $itemtype=$sth->fetchrow_hashref;
$iteminformation->{'loanlength'}=$itemtype->{'loanlength'};
$iteminformation->{'notforloan'}=$itemtype->{'notforloan'};
$sth->finish;
}
return($iteminformation);
}
=item findborrower
$borrowers = &findborrower($env, $key);
print $borrowers->[0]{surname};
Looks up patrons and returns information about them.
C<$env> is ignored.
C<$key> is either a card number or a string. C<&findborrower> tries to
look it up as a card number first. If that fails, C<&findborrower>
looks up all patrons whose surname begins with C<$key>.
C<$borrowers> is a reference-to-array. Each element is a
reference-to-hash whose keys are the fields of the borrowers table in
the Koha database.
=cut
#'
# If you really want to throw a monkey wrench into the works, change
# your last name to "V10000008" :-)
# FIXME - This is different from &C4::Borrower::findborrower, but I
# think that one's obsolete.
sub findborrower {
# returns an array of borrower hash references, given a cardnumber or a partial
# surname
my ($env, $key) = @_;
my $dbh = C4::Context->dbh;
my @borrowers;
my $q_key=$dbh->quote($key);
my $sth=$dbh->prepare("select * from borrowers where cardnumber=$q_key");
$sth->execute;
if ($sth->rows) {
my ($borrower)=$sth->fetchrow_hashref;
push (@borrowers, $borrower);
} else {
$q_key=$dbh->quote("$key%");
$sth->finish;
$sth=$dbh->prepare("select * from borrowers where surname like $q_key");
$sth->execute;
while (my $borrower = $sth->fetchrow_hashref) {
push (@borrowers, $borrower);
}
}
$sth->finish;
return(\@borrowers);
}
=item transferbook
($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:
C<$dotransfer> is true iff the transfer was successful.
C<$messages> is a reference-to-hash which may have any of the
following keys:
=over 4
=item C<BadBarcode>
There is no item in the catalog with the given barcode. The value is
C<$barcode>.
=item 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.
=item 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.
=item 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.
=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>.
=item 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
=cut
#'
# FIXME - This function tries to do too much, and its API is clumsy.
# If it didn't also return books, it could be used to change the home
# branch of a book while the book is on loan.
#
# Is there any point in returning the item information? The caller can
# look that up elsewhere if ve cares.
#
# This leaves the ($dotransfer, $messages) tuple. This seems clumsy.
# If the transfer succeeds, that's all the caller should need to know.
# Thus, this function could simply return 1 or 0 to indicate success
# or failure, and set $C4::Circulation::Circ2::errmsg in case of
# failure. Or this function could return undef if successful, and an
# error message in case of failure (this would feel more like C than
# Perl, though).
sub transferbook {
# transfer book code....
my ($tbr, $barcode, $ignoreRs) = @_;
my $messages;
my %env;
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 ($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);
$messages->{'WasTransfered'} = 1;
}
return ($dotransfer, $messages, $iteminformation);
}
# Not exported
# FIXME - This is only used in &transferbook. Why bother making it a
# separate function?
sub dotransfer {
my ($itm, $fbr, $tbr) = @_;
my $dbh = C4::Context->dbh;
$itm = $dbh->quote($itm);
$fbr = $dbh->quote($fbr);
$tbr = $dbh->quote($tbr);
#new entry in branchtransfers....
$dbh->do(<<EOT);
INSERT INTO branchtransfers
(itemnumber, frombranch, datearrived, tobranch)
VALUES ($itm, $fbr, now(), $tbr)
EOT
#update holdingbranch in items .....
$dbh->do(<<EOT);
UPDATE items
SET datelastseen = now(),
holdingbranch = $tbr
WHERE items.itemnumber = $itm
EOT
return;
}
=item issuebook
($iteminformation, $datedue, $rejected, $question, $questionnumber,
$defaultanswer, $message) =
&issuebook($env, $patroninformation, $barcode, $responses, $date);
Issue a book to a patron.
C<$env-E<gt>{usercode}> will be used in the usercode field of the
statistics table of the Koha database when this transaction is
recorded.
C<$env-E<gt>{datedue}>, if given, specifies the date on which the book
is due back. This should be a string of the form "YYYY-MM-DD".
C<$env-E<gt>{branchcode}> is the code of the branch where this
transaction is taking place.
C<$patroninformation> is a reference-to-hash giving information about
the person borrowing the book. This is the first value returned by
C<&getpatroninformation>.
C<$barcode> is the bar code of the book being issued.
C<$responses> is a reference-to-hash. It represents the answers to the
questions asked by the C<$question>, C<$questionnumber>, and
C<$defaultanswer> return values (see below). The keys are numbers, and
the values can be "Y" or "N".
C<$date> is an optional date in the form "YYYY-MM-DD". If specified,
then only fines and charges up to that date will be considered when
checking to see whether the patron owes too much money to be lent a
book.
C<&issuebook> returns an array of seven values:
C<$iteminformation> is a reference-to-hash describing the item just
issued. This in a form similar to that returned by
C<&getiteminformation>.
C<$datedue> is a string giving the date when the book is due, in the
form "YYYY-MM-DD".
C<$rejected> is either a string, or -1. If it is defined and is a
string, then the book may not be issued, and C<$rejected> gives the
reason for this. If C<$rejected> is -1, then the book may not be
issued, but no reason is given.
If there is a problem or question (e.g., the book is reserved for
another patron), then C<$question>, C<$questionnumber>, and
C<$defaultanswer> will be set. C<$questionnumber> indicates the
problem. C<$question> is a text string asking how to resolve the
problem, as a yes-or-no question, and C<$defaultanswer> is either "Y"
or "N", giving the default answer. The questions, their numbers, and
default answers are:
=over 4
=item 1: "Issued to <name>. Mark as returned?" (Y)
=item 2: "Waiting for <patron> at <branch>. Allow issue?" (N)
=item 3: "Cancel reserve for <patron>?" (N)
=item 4: "Book is issued to this borrower. Renew?" (Y)
=item 5: "Reserved for <patron> at <branch> since <date>. Allow issue?" (N)
=item 6: "Set reserve for <patron> to waiting and transfer to <branch>?" (Y)
This is asked if the answer to question 5 was "N".
=item 7: "Cancel reserve for <patron>?" (N)
=back
C<$message>, if defined, is an additional information message, e.g., a
rental fee notice.
=cut
#'
# FIXME - The business with $responses is absurd. For one thing, these
# questions should have names, not numbers. For another, it'd be
# better to have the last argument be %extras. Then scripts can call
# this function with
# &issuebook(...,
# -renew => 1,
# -mark_returned => 0,
# -cancel_reserve => 1,
# ...
# );
# and the script can use
# if (defined($extras{"-mark_returned"}) && $extras{"-mark_returned"})
# Heck, the $date argument should go in there as well.
#
# Also, there might be several reasons why a book can't be issued, but
# this API only supports asking one question at a time. Perhaps it'd
# be better to return a ref-to-list of problem IDs. Then the calling
# script can display a list of all of the problems at once.
#
# Is it this function's place to decide the default answer to the
# various questions? Why not document the various problems and allow
# the caller to decide?
sub issuebook {
my ($env, $patroninformation, $barcode, $responses, $date) = @_;
my $dbh = C4::Context->dbh;
my $iteminformation = getiteminformation($env, 0, $barcode);
my ($datedue);
my ($rejected,$question,$defaultanswer,$questionnumber, $noissue);
my $message;
# See if there's any reason this book shouldn't be issued to this
# patron.
SWITCH: { # FIXME - Yes, we know it's a switch. Tell us what it's for.
if ($patroninformation->{'gonenoaddress'}) {
$rejected="Patron is gone, with no known address.";
last SWITCH;
}
if ($patroninformation->{'lost'}) {
$rejected="Patron's card has been reported lost.";
last SWITCH;
}
if ($patroninformation->{'debarred'}) {
$rejected="Patron is Debarred";
last SWITCH;
}
my $amount = checkaccount($env,$patroninformation->{'borrowernumber'}, $dbh,$date);
# FIXME - "5" shouldn't be hardcoded. An Italian library might
# be generous enough to lend a book to a patron even if he
# does still owe them 5 lire.
if ($amount > 5 && $patroninformation->{'categorycode'} ne 'L' &&
$patroninformation->{'categorycode'} ne 'W' &&
$patroninformation->{'categorycode'} ne 'I' &&
$patroninformation->{'categorycode'} ne 'B' &&
$patroninformation->{'categorycode'} ne 'P') {
# FIXME - What do these category codes mean?
$rejected = sprintf "Patron owes \$%.02f.", $amount;
last SWITCH;
}
# FIXME - This sort of error-checking should be placed closer
# to the test; in this case, this error-checking should be
# done immediately after the call to &getiteminformation.
unless ($iteminformation) {
$rejected = "$barcode is not a valid barcode.";
last SWITCH;
}
if ($iteminformation->{'notforloan'} == 1) {
$rejected="Item not for loan.";
last SWITCH;
}
if ($iteminformation->{'wthdrawn'} == 1) {
$rejected="Item withdrawn.";
last SWITCH;
}
if ($iteminformation->{'restricted'} == 1) {
$rejected="Restricted item.";
last SWITCH;
}
if ($iteminformation->{'itemtype'} eq 'REF') {
$rejected="Reference item: Not for loan.";
last SWITCH;
}
my ($currentborrower) = currentborrower($iteminformation->{'itemnumber'});
if ($currentborrower eq $patroninformation->{'borrowernumber'}) {
# Already issued to current borrower. Ask whether the loan should
# be renewed.
my ($renewstatus) = renewstatus($env,$dbh,$patroninformation->{'borrowernumber'}, $iteminformation->{'itemnumber'});
if ($renewstatus == 0) {
$rejected="No more renewals allowed for this item.";
last SWITCH;
} else {
if ($responses->{4} eq '') {
$questionnumber = 4;
$question = "Book is issued to this borrower.\nRenew?";
$defaultanswer = 'Y';
last SWITCH;
} elsif ($responses->{4} eq 'Y') {
my $charge = calc_charges($env, $dbh, $iteminformation->{'itemnumber'}, $patroninformation->{'borrowernumber'});
if ($charge > 0) {
createcharge($env, $dbh, $iteminformation->{'itemnumber'}, $patroninformation->{'borrowernumber'}, $charge);
$iteminformation->{'charge'} = $charge;
}
&UpdateStats($env,$env->{'branchcode'},'renew',$charge,'',$iteminformation->{'itemnumber'},$iteminformation->{'itemtype'});
renewbook($env,$dbh, $patroninformation->{'borrowernumber'}, $iteminformation->{'itemnumber'});
$noissue=1;
} else {
$rejected=-1;
last SWITCH;
}
}
} elsif ($currentborrower ne '') {
# This book is currently on loan, but not to the person
# who wants to borrow it now.
my ($currborrower, $cbflags) = getpatroninformation($env,$currentborrower,0);
if ($responses->{1} eq '') {
$questionnumber=1;
$question = "Issued to $currborrower->{'firstname'} $currborrower->{'surname'} ($currborrower->{'cardnumber'}).\nMark as returned?";
$defaultanswer='Y';
last SWITCH;
} elsif ($responses->{1} eq 'Y') {
returnbook($iteminformation->{'barcode'}, $env->{'branch'});
} else {
$rejected=-1;
last SWITCH;
}
}
# See if the item is on reserve.
my ($restype, $res) = CheckReserves($iteminformation->{'itemnumber'});
if ($restype) {
my $resbor = $res->{'borrowernumber'};
if ($resbor eq $patroninformation->{'borrowernumber'}) {
# The item is on reserve to the current patron
FillReserve($res);
} elsif ($restype eq "Waiting") {
# The item is on reserve and waiting, but has been
# reserved by some other patron.
my ($resborrower, $flags)=getpatroninformation($env, $resbor,0);
my $branches = getbranches();
my $branchname = $branches->{$res->{'branchcode'}}->{'branchname'};
if ($responses->{2} eq '') {
$questionnumber=2;
# FIXME - Assumes HTML
$question="<font color=red>Waiting</font> for $resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'}) at $branchname \nAllow issue?";
$defaultanswer='N';
last SWITCH;
} elsif ($responses->{2} eq 'N') {
$rejected=-1;
last SWITCH;
} else {
if ($responses->{3} eq '') {
$questionnumber=3;
$question="Cancel reserve for $resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'})?";
$defaultanswer='N';
last SWITCH;
} elsif ($responses->{3} eq 'Y') {
CancelReserve(0, $res->{'itemnumber'}, $res->{'borrowernumber'});
}
}
} elsif ($restype eq "Reserved") {
# The item is on reserve for someone else.
my ($resborrower, $flags)=getpatroninformation($env, $resbor,0);
my $branches = getbranches();
my $branchname = $branches->{$res->{'branchcode'}}->{'branchname'};
if ($responses->{5} eq '') {
$questionnumber=5;
$question="Reserved for $resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'}) since $res->{'reservedate'} \nAllow issue?";
$defaultanswer='N';
last SWITCH;
} elsif ($responses->{5} eq 'N') {
if ($responses->{6} eq '') {
$questionnumber=6;
$question="Set reserve for $resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'}) to waiting and transfer to $branchname?";
$defaultanswer='N';
} elsif ($responses->{6} eq 'Y') {
my $tobrcd = ReserveWaiting($res->{'itemnumber'}, $res->{'borrowernumber'});
transferbook($tobrcd, $barcode, 1);
$message = "Item should now be waiting at $branchname";
}
$rejected=-1;
last SWITCH;
} else {
if ($responses->{7} eq '') {
$questionnumber=7;
$question="Cancel reserve for $resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'})?";
$defaultanswer='N';
last SWITCH;
} elsif ($responses->{7} eq 'Y') {
CancelReserve(0, $res->{'itemnumber'}, $res->{'borrowernumber'});
}
}
}
}
}
my $dateduef;
unless (($question) || ($rejected) || ($noissue)) {
# There's no reason why the item can't be issued.
# FIXME - my $loanlength = $iteminformation->{loanlength} || 21;
my $loanlength=21;
if ($iteminformation->{'loanlength'}) {
$loanlength=$iteminformation->{'loanlength'};
}
my $ti=time; # FIXME - Never used
my $datedue=time+($loanlength)*86400;
# FIXME - Could just use POSIX::strftime("%Y-%m-%d", localtime);
# That's what it's for. Or, in this case:
# $dateduef = $env->{datedue} ||
# strftime("%Y-%m-%d", localtime(time +
# $loanlength * 86400));
my @datearr = localtime($datedue);
$dateduef = (1900+$datearr[5])."-".($datearr[4]+1)."-".$datearr[3];
if ($env->{'datedue'}) {
$dateduef=$env->{'datedue'};
}
$dateduef=~ s/2001\-4\-25/2001\-4\-26/;
# FIXME - What's this for? Leftover from debugging?
# Record in the database the fact that the book was issued.
# FIXME - Use $dbh->do();
my $sth=$dbh->prepare("insert into issues (borrowernumber, itemnumber, date_due, branchcode) values ($patroninformation->{'borrowernumber'}, $iteminformation->{'itemnumber'}, '$dateduef', '$env->{'branchcode'}')");
$sth->execute;
$sth->finish;
$iteminformation->{'issues'}++;
# FIXME - Use $dbh->do();
$sth=$dbh->prepare("update items set issues=$iteminformation->{'issues'},datelastseen=now() where itemnumber=$iteminformation->{'itemnumber'}");
$sth->execute;
$sth->finish;
# If it costs to borrow this book, charge it to the patron's account.
my $charge=calc_charges($env, $dbh, $iteminformation->{'itemnumber'}, $patroninformation->{'borrowernumber'});
if ($charge > 0) {
createcharge($env, $dbh, $iteminformation->{'itemnumber'}, $patroninformation->{'borrowernumber'}, $charge);
$iteminformation->{'charge'}=$charge;
}
# Record the fact that this book was issued.
&UpdateStats($env,$env->{'branchcode'},'issue',$charge,'',$iteminformation->{'itemnumber'},$iteminformation->{'itemtype'});
}
if ($iteminformation->{'charge'}) {
$message=sprintf "Rental charge of \$%.02f applies.", $iteminformation->{'charge'};
}
return ($iteminformation, $dateduef, $rejected, $question, $questionnumber, $defaultanswer, $message);
}
=item 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 $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) = 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) = getpatroninformation(\%env, $currentborrower, 0);
if ($doreturn) {
doreturn($borrower->{'borrowernumber'}, $iteminformation->{'itemnumber'});
$messages->{'WasReturned'} = 1; # FIXME is the "= 1" right?
}
($borrower) = getpatroninformation(\%env, $currentborrower, 0);
# transfer book to the current branch
my ($transfered, $mess, $item) = transferbook($branch, $barcode, 1);
if ($transfered) {
$messages->{'WasTransfered'} = 1; # FIXME is the "= 1" right?
}
# fix up the accounts.....
if ($iteminformation->{'itemlost'}) {
# Mark the item as not being lost.
updateitemlost($iteminformation->{'itemnumber'});
fixaccountforlostandreturned($iteminformation, $borrower);
$messages->{'WasLost'} = 1; # FIXME is the "= 1" right?
}
# fix up the overdues in accounts...
fixoverduesonreturn($borrower->{'borrowernumber'}, $iteminformation->{'itemnumber'});
# find reserves.....
my ($resfound, $resrec) = CheckReserves($iteminformation->{'itemnumber'});
if ($resfound) {
# my $tobrcd = ReserveWaiting($resrec->{'itemnumber'}, $resrec->{'borrowernumber'});
$resrec->{'ResFound'} = $resfound;
$messages->{'ResFound'} = $resrec;
}
# update stats?
# Record the fact that this book was returned.
UpdateStats(\%env, $branch ,'return','0','',$iteminformation->{'itemnumber'});
return ($doreturn, $messages, $iteminformation, $borrower);
}
# doreturn
# Takes a borrowernumber and an itemnuber.
# Updates the 'issues' table to mark the item as returned (assuming
# that it's currently on loan to the given borrower. Otherwise, the
# item remains on loan.
# Updates items.datelastseen for the item.
# Not exported
# FIXME - This is only used in &returnbook. Why make it into a
# separate function? (is this a recognizable step in the return process? - acli)
sub doreturn {
my ($brn, $itm) = @_;
my $dbh = C4::Context->dbh;
$brn = $dbh->quote($brn);
$itm = $dbh->quote($itm);
my $query = "update issues set returndate = now() where (borrowernumber = $brn)
and (itemnumber = $itm) and (returndate is null)";
my $sth = $dbh->prepare($query);
$sth->execute;
$sth->finish;
$query="update items set datelastseen=now() where itemnumber=$itm";
$sth=$dbh->prepare($query);
$sth->execute;
$sth->finish;
return;
}
# updateitemlost
# Marks an item as not being lost.
# Not exported
sub updateitemlost{
my ($itemno)=@_;
my $dbh = C4::Context->dbh;
$dbh->do(<<EOT);
UPDATE items
SET itemlost = 0
WHERE itemnumber = $itemno
EOT
}
# Not exported
sub fixaccountforlostandreturned {
my ($iteminfo, $borrower) = @_;
my %env;
my $dbh = C4::Context->dbh;
my $itm = $dbh->quote($iteminfo->{'itemnumber'});
# check for charge made for lost book
my $query = "select * from accountlines where (itemnumber = $itm)
and (accounttype='L' or accounttype='Rep') order by date desc";
my $sth = $dbh->prepare($query);
$sth->execute;
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 $uquery = "update accountlines set accounttype = 'LR',amountoutstanding='0'
where (borrowernumber = '$data->{'borrowernumber'}')
and (itemnumber = $itm) and (accountno = '$acctno') ";
my $usth = $dbh->prepare($uquery);
$usth->execute;
$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 $query = "select * from accountlines where (borrowernumber = '$data->{'borrowernumber'}')
and (amountoutstanding >0) order by date";
my $msth = $dbh->prepare($query);
$msth->execute;
# 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 $updquery = "update accountlines set amountoutstanding= '$newamtos'
where (borrowernumber = '$data->{'borrowernumber'}')
and (accountno='$thisacct')";
my $usth = $dbh->prepare($updquery);
$usth->execute;
$usth->finish;
$updquery = "insert into accountoffsets
(borrowernumber, accountno, offsetaccount, offsetamount)
values
('$data->{'borrowernumber'}','$accdata->{'accountno'}','$nextaccntno','$newamtos')";
$usth = $dbh->prepare($updquery);
$usth->execute;
$usth->finish;
}
$msth->finish;
}
if ($amountleft > 0){
$amountleft*=-1;
}
my $desc="Book Returned ".$iteminfo->{'barcode'};
$uquery = "insert into accountlines
(borrowernumber,accountno,date,amount,description,accounttype,amountoutstanding)
values ('$data->{'borrowernumber'}','$nextaccntno',now(),0-$amount,'$desc',
'CR',$amountleft)";
$usth = $dbh->prepare($uquery);
$usth->execute;
$usth->finish;
$uquery = "insert into accountoffsets
(borrowernumber, accountno, offsetaccount, offsetamount)
values ($borrower->{'borrowernumber'},$data->{'accountno'},$nextaccntno,$offset)";
$usth = $dbh->prepare($uquery);
$usth->execute;
$usth->finish;
$uquery = "update items set paidfor='' where itemnumber=$itm";
$usth = $dbh->prepare($uquery);
$usth->execute;
$usth->finish;
}
$sth->finish;
return;
}
# Not exported
sub fixoverduesonreturn {
my ($brn, $itm) = @_;
my $dbh = C4::Context->dbh;
$itm = $dbh->quote($itm);
$brn = $dbh->quote($brn);
# check for overdue fine
my $query = "select * from accountlines where (borrowernumber=$brn)
and (itemnumber = $itm) and (accounttype='FU' or accounttype='O')";
my $sth = $dbh->prepare($query);
$sth->execute;
# alter fine to show that the book has been returned
if (my $data = $sth->fetchrow_hashref) {
my $query = "update accountlines set accounttype='F' where (borrowernumber = $brn)
and (itemnumber = $itm) and (acccountno='$data->{'accountno'}')";
my $usth=$dbh->prepare($query);
$usth->execute();
$usth->finish();
}
$sth->finish;
return;
}
# Not exported
#
# NOTE!: If you change this function, be sure to update the POD for
# &getpatroninformation.
#
# $flags = &patronflags($env, $patron, $dbh);
#
# $flags->{CHARGES}
# {message} Message showing patron's credit or debt
# {noissues} Set if patron owes >$5.00
# {GNA} Set if patron gone w/o address
# {message} "Borrower has no valid address"
# {noissues} Set.
# {LOST} Set if patron's card reported lost
# {message} Message to this effect
# {noissues} Set.
# {DBARRED} Set is patron is debarred
# {message} Message to this effect
# {noissues} Set.
# {NOTES} Set if patron has notes
# {message} Notes about patron
# {ODUES} Set if patron has overdue books
# {message} "Yes"
# {itemlist} ref-to-array: list of overdue books
# {itemlisttext} Text list of overdue items
# {WAITING} Set if there are items available that the
# patron reserved
# {message} Message to this effect
# {itemlist} ref-to-array: list of available items
sub patronflags {
# Original subroutine for Circ2.pm
my %flags;
my ($env, $patroninformation, $dbh) = @_;
my $amount = checkaccount($env, $patroninformation->{'borrowernumber'}, $dbh);
if ($amount > 0) {
my %flaginfo;
$flaginfo{'message'}= sprintf "Patron owes \$%.02f", $amount;
if ($amount > 5) {
$flaginfo{'noissues'} = 1;
}
$flags{'CHARGES'} = \%flaginfo;
} elsif ($amount < 0){
my %flaginfo;
$flaginfo{'message'} = sprintf "Patron has credit of \$%.02f", -$amount;
$flags{'CHARGES'} = \%flaginfo;
}
if ($patroninformation->{'gonenoaddress'} == 1) {
my %flaginfo;
$flaginfo{'message'} = 'Borrower has no valid address.';
$flaginfo{'noissues'} = 1;
$flags{'GNA'} = \%flaginfo;
}
if ($patroninformation->{'lost'} == 1) {
my %flaginfo;
$flaginfo{'message'} = 'Borrower\'s card reported lost.';
$flaginfo{'noissues'} = 1;
$flags{'LOST'} = \%flaginfo;
}
if ($patroninformation->{'debarred'} == 1) {
my %flaginfo;
$flaginfo{'message'} = 'Borrower is Debarred.';
$flaginfo{'noissues'} = 1;
$flags{'DBARRED'} = \%flaginfo;
}
if ($patroninformation->{'borrowernotes'}) {
my %flaginfo;
$flaginfo{'message'} = "$patroninformation->{'borrowernotes'}";
$flags{'NOTES'} = \%flaginfo;
}
my ($odues, $itemsoverdue)
= checkoverdues($env, $patroninformation->{'borrowernumber'}, $dbh);
if ($odues > 0) {
my %flaginfo;
$flaginfo{'message'} = "Yes";
$flaginfo{'itemlist'} = $itemsoverdue;
foreach (sort {$a->{'date_due'} cmp $b->{'date_due'}} @$itemsoverdue) {
$flaginfo{'itemlisttext'}.="$_->{'date_due'} $_->{'barcode'} $_->{'title'} \n";
}
$flags{'ODUES'} = \%flaginfo;
}
my ($nowaiting, $itemswaiting)
= CheckWaiting($patroninformation->{'borrowernumber'});
if ($nowaiting > 0) {
my %flaginfo;
$flaginfo{'message'} = "Reserved items available";
$flaginfo{'itemlist'} = $itemswaiting;
$flags{'WAITING'} = \%flaginfo;
}
return(\%flags);
}
# 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 @datearr = localtime;
my $today = ($datearr[5] + 1900)."-".($datearr[4]+1)."-".$datearr[3];
my @overdueitems;
my $count = 0;
my $query = "SELECT * FROM issues,biblio,biblioitems,items
WHERE items.biblioitemnumber = biblioitems.biblioitemnumber
AND items.biblionumber = biblio.biblionumber
AND issues.itemnumber = items.itemnumber
AND issues.borrowernumber = $bornum
AND issues.returndate is NULL
AND issues.date_due < '$today'";
my $sth = $dbh->prepare($query);
$sth->execute;
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 $q_itemnumber = $dbh->quote($itemnumber);
my $sth=$dbh->prepare("select borrowers.borrowernumber from
issues,borrowers where issues.itemnumber=$q_itemnumber and
issues.borrowernumber=borrowers.borrowernumber and issues.returndate is
NULL");
$sth->execute;
my ($borrower) = $sth->fetchrow;
return($borrower);
}
# FIXME - Not exported, but used in 'updateitem.pl' anyway.
sub checkreserve {
# Stolen from Main.pm
# Check for reserves for biblio
my ($env,$dbh,$itemnum)=@_;
my $resbor = "";
my $query = "select * from reserves,items
where (items.itemnumber = '$itemnum')
and (reserves.cancellationdate is NULL)
and (items.biblionumber = reserves.biblionumber)
and ((reserves.found = 'W')
or (reserves.found is null))
order by priority";
my $sth = $dbh->prepare($query);
$sth->execute();
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 $cquery = "select * from reserveconstraints,items
where (borrowernumber='$data->{'borrowernumber'}')
and reservedate='$data->{'reservedate'}'
and reserveconstraints.biblionumber='$data->{'biblionumber'}'
and (items.itemnumber=$itemnum and
items.biblioitemnumber = reserveconstraints.biblioitemnumber)";
my $csth = $dbh->prepare($cquery);
$csth->execute;
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);
}
=item currentissues
$issues = &currentissues($env, $borrower);
Returns a list of books currently on loan to a patron.
If C<$env-E<gt>{todaysissues}> is set and true, C<&currentissues> only
returns information about books issued today. If
C<$env-E<gt>{nottodaysissues}> is set and true, C<&currentissues> only
returns information about books issued before today. If both are
specified, C<$env-E<gt>{todaysissues}> is ignored. If neither is
specified, C<&currentissues> returns all of the patron's issues.
C<$borrower->{borrowernumber}> is the borrower number of the patron
whose issues we want to list.
C<&currentissues> 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.
if ($env->{'todaysissues'}) {
# FIXME - Could use
# $today = POSIX::strftime("%Y%m%d", localtime);
# FIXME - Since $today will be used in either case, move it
# out of the two if-blocks.
my @datearr = localtime(time());
my $today = (1900+$datearr[5]).sprintf "%02d", ($datearr[4]+1).sprintf "%02d", $datearr[3];
# FIXME - MySQL knows about dates. Just use
# and issues.timestamp = curdate();
$crit=" and issues.timestamp like '$today%' ";
}
if ($env->{'nottodaysissues'}) {
# FIXME - Could use
# $today = POSIX::strftime("%Y%m%d", localtime);
# FIXME - Since $today will be used in either case, move it
# out of the two if-blocks.
my @datearr = localtime(time());
my $today = (1900+$datearr[5]).sprintf "%02d", ($datearr[4]+1).sprintf "%02d", $datearr[3];
# FIXME - MySQL knows about dates. Just use
# and issues.timestamp < curdate();
$crit=" and !(issues.timestamp like '$today%') ";
}
# FIXME - Does the caller really need every single field from all
# four tables?
my $select="select * from issues,items,biblioitems,biblio where
borrowernumber='$borrowernumber' and issues.itemnumber=items.itemnumber and
items.biblionumber=biblio.biblionumber and
items.biblioitemnumber=biblioitems.biblioitemnumber and returndate is null
$crit order by issues.date_due";
# warn $select;
my $sth=$dbh->prepare($select);
$sth->execute;
while (my $data = $sth->fetchrow_hashref) {
# FIXME - The Dewey code is a string, not a number.
$data->{'dewey'}=~s/0*$//;
($data->{'dewey'} == 0) && ($data->{'dewey'}='');
# FIXME - Could use
# $todaysdate = POSIX::strftime("%Y%m%d", localtime)
# or better yet, just reuse $today which was calculated above.
# This function isn't going to run until midnight, is it?
# Alternately, use
# $todaysdate = POSIX::strftime("%Y-%m-%d", localtime)
# if ($data->{'date_due'} lt $todaysdate)
# ...
# Either way, the date should be be formatted outside of the
# loop.
my @datearr = localtime(time());
my $todaysdate = (1900+$datearr[5]).sprintf ("%0.2d", ($datearr[4]
+1)).sprintf ("%0.2d", $datearr[3]);
my $datedue=$data->{'date_due'};
$datedue=~s/-//g;
if ($datedue < $todaysdate) {
$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);
}
=item 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 {
# New subroutine for Circ2.pm
my ($borrower) = @_;
my $dbh = C4::Context->dbh;
my $borrowernumber = $borrower->{'borrowernumber'};
my %currentissues;
my $select = "SELECT issues.timestamp AS timestamp,
issues.date_due AS date_due,
items.biblionumber AS biblionumber,
items.itemnumber AS itemnumber,
items.barcode AS barcode,
biblio.title AS title,
biblio.author AS author,
biblioitems.dewey AS dewey,
itemtypes.description AS itemtype,
biblioitems.subclass AS subclass
FROM issues,items,biblioitems,biblio, itemtypes
WHERE issues.borrowernumber = ?
AND issues.itemnumber = items.itemnumber
AND items.biblionumber = biblio.biblionumber
AND items.biblioitemnumber = biblioitems.biblioitemnumber
AND itemtypes.itemtype = biblioitems.itemtype
AND issues.returndate IS NULL
ORDER BY issues.date_due";
# print $select;
my $sth=$dbh->prepare($select);
$sth->execute($borrowernumber);
my $counter = 0;
while (my $data = $sth->fetchrow_hashref) {
$data->{'dewey'} =~ s/0*$//;
($data->{'dewey'} == 0) && ($data->{'dewey'} = '');
# FIXME - The Dewey code is a string, not a number.
# FIXME - Use POSIX::strftime to get a text version of today's
# date. That's what it's for.
# FIXME - Move the date calculation outside of the loop.
my @datearr = localtime(time());
my $todaysdate = (1900+$datearr[5]).sprintf ("%0.2d", ($datearr[4]+1)).sprintf ("%0.2d", $datearr[3]);
# FIXME - Instead of converting the due date to YYYYMMDD, just
# use
# $todaysdate = POSIX::strftime("%Y-%m-%d", localtime);
# ...
# if ($date->{date_due} lt $todaysdate)
my $datedue = $data->{'date_due'};
$datedue =~ s/-//g;
if ($datedue < $todaysdate) {
$data->{'overdue'} = 1;
}
$currentissues{$counter} = $data;
$counter++;
# FIXME - This is ludicrous. If you want to return an
# array of values, just use an array. That's what
# they're there for.
}
$sth->finish;
return(\%currentissues);
}
# Not exported
sub checkwaiting {
#Stolen from Main.pm
# check for reserves waiting
my ($env,$dbh,$bornum)=@_;
my @itemswaiting;
my $query = "select * from reserves
where (borrowernumber = '$bornum')
and (reserves.found='W') and cancellationdate is NULL";
my $sth = $dbh->prepare($query);
$sth->execute();
my $cnt=0;
if (my $data=$sth->fetchrow_hashref) {
$itemswaiting[$cnt] =$data;
$cnt ++
}
$sth->finish;
return ($cnt,\@itemswaiting);
}
# Not exported
# FIXME - This is nearly-identical to &C4::Accounts::checkaccount
sub checkaccount {
# Stolen from Accounts.pm
#take borrower number
#check accounts and list amounts owing
my ($env,$bornumber,$dbh,$date)=@_;
my $select="SELECT SUM(amountoutstanding) AS total
FROM accountlines
WHERE borrowernumber = $bornumber
AND amountoutstanding<>0";
if ($date ne ''){
$select.=" AND date < '$date'";
}
# print $select;
my $sth=$dbh->prepare($select);
$sth->execute;
my $data=$sth->fetchrow_hashref;
my $total = $data->{'total'};
$sth->finish;
# output(1,2,"borrower owes $total");
#if ($total > 0){
# # output(1,2,"borrower owes $total");
# if ($total > 5){
# reconcileaccount($env,$dbh,$bornumber,$total);
# }
#}
# pause();
return($total);
}
# FIXME - This is identical to &C4::Circulation::Renewals::renewstatus.
# Pick one and stick with it.
sub renewstatus {
# Stolen from Renewals.pm
# check renewal status
my ($env,$dbh,$bornum,$itemno)=@_;
my $renews = 1;
my $renewokay = 0;
my $q1 = "select * from issues
where (borrowernumber = '$bornum')
and (itemnumber = '$itemno')
and returndate is null";
my $sth1 = $dbh->prepare($q1);
$sth1->execute;
if (my $data1 = $sth1->fetchrow_hashref) {
my $q2 = "select renewalsallowed from items,biblioitems,itemtypes
where (items.itemnumber = '$itemno')
and (items.biblioitemnumber = biblioitems.biblioitemnumber)
and (biblioitems.itemtype = itemtypes.itemtype)";
my $sth2 = $dbh->prepare($q2);
$sth2->execute;
if (my $data2=$sth2->fetchrow_hashref) {
$renews = $data2->{'renewalsallowed'};
}
if ($renews > $data1->{'renewals'}) {
$renewokay = 1;
}
$sth2->finish;
}
$sth1->finish;
return($renewokay);
}
sub renewbook {
# Stolen from Renewals.pm
# mark book as renewed
my ($env,$dbh,$bornum,$itemno,$datedue)=@_;
$datedue=$env->{'datedue'};
if ($datedue eq "" ) {
my $loanlength=21;
my $query= "Select * from biblioitems,items,itemtypes
where (items.itemnumber = '$itemno')
and (biblioitems.biblioitemnumber = items.biblioitemnumber)
and (biblioitems.itemtype = itemtypes.itemtype)";
my $sth=$dbh->prepare($query);
$sth->execute;
if (my $data=$sth->fetchrow_hashref) {
$loanlength = $data->{'loanlength'}
}
$sth->finish;
my $ti = time;
my $datedu = time + ($loanlength * 86400);
my @datearr = localtime($datedu);
$datedue = (1900+$datearr[5])."-".($datearr[4]+1)."-".$datearr[3];
}
my @date = split("-",$datedue);
my $odatedue = ($date[2]+0)."-".($date[1]+0)."-".$date[0];
my $issquery = "select * from issues where borrowernumber='$bornum' and
itemnumber='$itemno' and returndate is null";
my $sth=$dbh->prepare($issquery);
$sth->execute;
my $issuedata=$sth->fetchrow_hashref;
$sth->finish;
my $renews = $issuedata->{'renewals'} +1;
my $updquery = "update issues
set date_due = '$datedue', renewals = '$renews'
where borrowernumber='$bornum' and
itemnumber='$itemno' and returndate is null";
$sth=$dbh->prepare($updquery);
$sth->execute;
$sth->finish;
return($odatedue);
}
# FIXME - This is almost, but not quite, identical to
# &C4::Circulation::Issues::calc_charges and
# &C4::Circulation::Renewals2::calc_charges.
# Pick one and stick with it.
sub calc_charges {
# Stolen from Issues.pm
# calculate charges due
my ($env, $dbh, $itemno, $bornum)=@_;
# if (!$dbh){
# $dbh=C4Connect();
# }
my $charge=0;
# open (FILE,">>/tmp/charges");
my $item_type;
my $q1 = "select itemtypes.itemtype,rentalcharge from items,biblioitems,itemtypes
where (items.itemnumber ='$itemno')
and (biblioitems.biblioitemnumber = items.biblioitemnumber)
and (biblioitems.itemtype = itemtypes.itemtype)";
my $sth1= $dbh->prepare($q1);
# print FILE "$q1\n";
$sth1->execute;
if (my $data1=$sth1->fetchrow_hashref) {
$item_type = $data1->{'itemtype'};
$charge = $data1->{'rentalcharge'};
# print FILE "charge is $charge\n";
my $q2 = "select rentaldiscount from borrowers,categoryitem
where (borrowers.borrowernumber = '$bornum')
and (borrowers.categorycode = categoryitem.categorycode)
and (categoryitem.itemtype = '$item_type')";
my $sth2=$dbh->prepare($q2);
# warn $q2;
$sth2->execute;
if (my $data2=$sth2->fetchrow_hashref) {
my $discount = $data2->{'rentaldiscount'};
# print FILE "discount is $discount";
if ($discount eq 'NULL') {
$discount=0;
}
$charge = ($charge *(100 - $discount)) / 100;
}
$sth2->finish;
}
$sth1->finish;
# close FILE;
return ($charge, $item_type);
}
# FIXME - A virtually identical function appears in
# C4::Circulation::Issues. Pick one and stick with it.
sub createcharge {
#Stolen from Issues.pm
my ($env,$dbh,$itemno,$bornum,$charge) = @_;
my $nextaccntno = getnextacctno($env,$bornum,$dbh);
my $sth = $dbh->prepare(<<EOT);
INSERT INTO accountlines
(borrowernumber, itemnumber, accountno,
date, amount, description, accounttype,
amountoutstanding)
VALUES (?, ?, ?,
now(), ?, 'Rental', 'Rent',
?)
EOT
$sth->execute($bornum, $itemno, $nextaccntno, $charge, $charge);
$sth->finish;
}
sub getnextacctno {
# Stolen from Accounts.pm
my ($env,$bornumber,$dbh)=@_;
my $nextaccntno = 1;
my $query = "select * from accountlines where (borrowernumber = '$bornumber') order by accountno desc";
my $sth = $dbh->prepare($query);
$sth->execute;
if (my $accdata=$sth->fetchrow_hashref){
$nextaccntno = $accdata->{'accountno'} + 1;
}
$sth->finish;
return($nextaccntno);
}
=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.
# FIXME - There's also a &C4::Circulation::Returns::find_reserves, but
# that one looks rather different.
sub find_reserves {
# Stolen from Returns.pm
my ($itemno) = @_;
my %env;
my $dbh = C4::Context->dbh;
my ($itemdata) = getiteminformation(\%env, $itemno,0);
my $bibno = $dbh->quote($itemdata->{'biblionumber'});
my $bibitm = $dbh->quote($itemdata->{'biblioitemnumber'});
my $query = "select * from reserves where ((found = 'W') or (found is null))
and biblionumber = $bibno and cancellationdate is NULL
order by priority, reservedate ";
my $sth = $dbh->prepare($query);
$sth->execute;
my $resfound = 0;
my $resrec;
my $lastrec;
# print $query;
# 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) && (not $resfound)) {
# FIXME - Unlike Pascal, Perl allows you to exit loops
# early. Take out the "&& (not $resfound)" and just
# use "last" at the appropriate point in the loop.
# (Oh, and just in passing: if you'd used "!" instead
# of "not", you wouldn't have needed the parentheses.)
$lastrec = $resrec;
my $brn = $dbh->quote($resrec->{'borrowernumber'});
my $rdate = $dbh->quote($resrec->{'reservedate'});
my $bibno = $dbh->quote($resrec->{'biblionumber'});
if ($resrec->{'found'} eq "W") {
if ($resrec->{'itemnumber'} eq $itemno) {
$resfound = 1;
}
} else {
# FIXME - Use 'elsif' to avoid unnecessary indentation.
if ($resrec->{'constrainttype'} eq "a") {
$resfound = 1;
} else {
my $conquery = "select * from reserveconstraints where borrowernumber = $brn
and reservedate = $rdate and biblionumber = $bibno and biblioitemnumber = $bibitm";
my $consth = $dbh->prepare($conquery);
$consth->execute;
if (my $conrec = $consth->fetchrow_hashref) {
if ($resrec->{'constrainttype'} eq "o") {
$resfound = 1;
}
}
$consth->finish;
}
}
if ($resfound) {
my $updquery = "update reserves set found = 'W', itemnumber = '$itemno'
where borrowernumber = $brn and reservedate = $rdate and biblionumber = $bibno";
my $updsth = $dbh->prepare($updquery);
$updsth->execute;
$updsth->finish;
# FIXME - "last;" here to break out of the loop early.
}
}
$sth->finish;
return ($resfound,$lastrec);
}
1;
__END__
=back
=head1 AUTHOR
Koha Developement team <info@koha.org>
=cut
View git blame Copy permalink