1852 lines
60 KiB
Perl
Executable file
1852 lines
60 KiB
Perl
Executable file
package C4::Circulation::Circ2;
|
|
|
|
#package to deal with Returns
|
|
#written 3/11/99 by olwen@katipo.co.nz
|
|
|
|
# $Id$
|
|
|
|
# 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 ¤tissues &getissues &getiteminformation &findborrower &issuebook &returnbook &find_reserves &transferbook &decode
|
|
calc_charges);
|
|
%EXPORT_TAGS = ( ); # eg: TAG => [ qw!name1 name2! ],
|
|
|
|
# your exported package globals go here,
|
|
# as well as any optionally exported functions
|
|
|
|
@EXPORT_OK = qw($Var1 %Hashit); # FIXME - Unused
|
|
|
|
|
|
# non-exported package globals go here
|
|
#use vars qw(@more $stuff);
|
|
|
|
# initalize package globals, first exported ones
|
|
# FIXME - Unused
|
|
my $Var1 = '';
|
|
my %Hashit = ();
|
|
|
|
# then the others (which are still accessible as $Some::Module::stuff)
|
|
# FIXME - Unused
|
|
my $stuff = '';
|
|
my @more = ();
|
|
|
|
# all file-scoped lexicals must be created before
|
|
# the functions below that use them.
|
|
|
|
# file-private lexicals go here
|
|
# FIXME - Unused
|
|
my $priv_var = '';
|
|
my %secret_hash = ();
|
|
|
|
# here's a file-private function as a closure,
|
|
# callable as &$priv_func; it cannot be prototyped.
|
|
# FIXME - Unused
|
|
my $priv_func = sub {
|
|
# stuff goes here.
|
|
};
|
|
|
|
# make all your functions, whether exported or not;
|
|
|
|
=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);
|
|
}
|
|
|
|
=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 $flags = patronflags($env, $borrower, $dbh);
|
|
$sth->finish;
|
|
$borrower->{'flags'}=$flags;
|
|
return($borrower, $flags);
|
|
}
|
|
|
|
=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="Reference item: not for loan.";
|
|
last SWITCH;
|
|
}
|
|
if ($iteminformation->{'wthdrawn'} == 1) {
|
|
$rejected="Item withdrawn.";
|
|
last SWITCH;
|
|
}
|
|
if ($iteminformation->{'restricted'} == 1) {
|
|
$rejected="Restricted item.";
|
|
last SWITCH;
|
|
}
|
|
|
|
# See who, if anyone, currently has this book.
|
|
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;
|
|
# 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'}; # FIXME - This does nothing
|
|
}
|
|
($borrower) = getpatroninformation(\%env, $currentborrower, 0);
|
|
# transfer book to the current branch
|
|
my ($transfered, $mess, $item) = transferbook($branch, $barcode, 1);
|
|
if ($transfered) { # FIXME - perl -wc complains about this line.
|
|
$messages->{'WasTransfered'}; # FIXME - This does nothing
|
|
}
|
|
# fix up the accounts.....
|
|
if ($iteminformation->{'itemlost'}) {
|
|
# Mark the item as not being lost.
|
|
updateitemlost($iteminformation->{'itemnumber'});
|
|
fixaccountforlostandreturned($iteminformation, $borrower);
|
|
$messages->{'WasLost'}; # FIXME - This does nothing
|
|
}
|
|
# fix up the overdues in accounts...
|
|
fixoverduesonreturn($borrower->{'borrowernumber'}, $iteminformation->{'itemnumber'});
|
|
# find reserves.....
|
|
my ($resfound, $resrec) = CheckReserves($iteminformation->{'itemnumber'});
|
|
if ($resfound) {
|
|
$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?
|
|
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 = $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 = ¤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.
|
|
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 $brn =$dbh->quote($borrowernumber);
|
|
my %currentissues;
|
|
my $select = "select issues.timestamp, issues.date_due, items.biblionumber,
|
|
items.barcode, biblio.title, biblio.author, biblioitems.dewey,
|
|
biblioitems.subclass
|
|
from issues,items,biblioitems,biblio
|
|
where issues.borrowernumber = $brn
|
|
and issues.itemnumber = items.itemnumber
|
|
and items.biblionumber = biblio.biblionumber
|
|
and items.biblioitemnumber = biblioitems.biblioitemnumber
|
|
and issues.returndate is null
|
|
order by issues.date_due";
|
|
# warn $select;
|
|
my $sth=$dbh->prepare($select);
|
|
$sth->execute;
|
|
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) 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 $total=0;
|
|
while (my $data=$sth->fetchrow_hashref){
|
|
$total=$total+$data->{'sum(amountoutstanding)'};
|
|
}
|
|
$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);
|
|
}
|
|
|
|
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);
|
|
}
|
|
|
|
sub createcharge {
|
|
#Stolen from Issues.pm
|
|
my ($env,$dbh,$itemno,$bornum,$charge) = @_;
|
|
my $nextaccntno = getnextacctno($env,$bornum,$dbh);
|
|
my $query = "insert into accountlines (borrowernumber,itemnumber,accountno,date,amount, description,accounttype,amountoutstanding) values ($bornum,$itemno,$nextaccntno,now(),$charge,'Rental','Rent',$charge)";
|
|
my $sth = $dbh->prepare($query);
|
|
$sth->execute;
|
|
$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.
|
|
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);
|
|
}
|
|
|
|
END { } # module clean-up code here (global destructor)
|
|
|
|
1;
|
|
__END__
|
|
=back
|
|
|
|
=cut
|