-# -*- 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; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
# Suite 330, Boston, MA 02111-1307 USA
+# $Id$
+
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 C4::Koha;
+use C4::Biblio;
+use C4::Accounts2;
+use Date::Calc qw(
+ Today
+ Today_and_Now
+ Add_Delta_YM
+ Add_Delta_DHMS
+ Date_to_Days
+);
+use POSIX qw(strftime);
+use C4::Branch; # GetBranches
+use C4::Log; # logaction
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
# set the version for version checking
-$VERSION = 0.01;
+$VERSION = do { my @v = '$Revision$' =~ /\d+/g; shift(@v).".".join( "_", map { sprintf "%03d", $_ } @v ); };
=head1 NAME
=head1 SYNOPSIS
- use C4::Circulation::Circ2;
+use C4::Circulation::Circ2;
=head1 DESCRIPTION
The functions in this module deal with circulation, issues, and
returns, as well as general information about the library.
+Also deals with stocktaking.
=head1 FUNCTIONS
-=over 2
-
=cut
-@ISA = qw(Exporter);
-@EXPORT = qw(&getbranches &getprinters &getpatroninformation
- &getbranch &getprinter
- ¤tissues &getissues &getiteminformation &findborrower
- &issuebook &returnbook &find_reserves &transferbook &decode
- &calc_charges);
-
-=item getbranches
+@ISA = qw(Exporter);
+@EXPORT = qw(
+ &getpatroninformation
+ ¤tissues
+ &getissues
+ &getiteminformation
+ &renewstatus
+ &renewbook
+ &canbookbeissued
+ &issuebook
+ &returnbook
+ &find_reserves
+ &transferbook
+ &decode
+ &calc_charges
+ &GetItemsForInventory
+ &itemseen
+ &fixdate
+ &get_current_return_date_of
+ &get_transfert_infos
+ &checktransferts
+ &GetReservesForBranch
+ &GetReservesToBranch
+ &GetTransfersFromBib
+ &getBranchIp
+ &dotransfer
+ &GetOverduesForBranch
+ &AddNotifyLine
+ &RemoveNotifyLine
+ &GetIssuesFromBiblio
+ &AnonymiseIssueHistory
+ &GetLostItems
+ &itemissues
+ &updateWrongTransfer
+);
+
+=head2 itemseen
+
+&itemseen($itemnum)
+Mark item as seen. Is called when an item is issued, returned or manually marked during inventory/stocktaking
+C<$itemnum> is the item number
- $branches = &getbranches();
- @branch_codes = keys %$branches;
- %main_branch_info = %{$branches->{"MAIN"}};
+=cut
-Returns information about existing library branches.
+sub itemseen {
+ my ($itemnum) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth =
+ $dbh->prepare(
+ "update items set itemlost=0, datelastseen = now() where items.itemnumber = ?"
+ );
+ $sth->execute($itemnum);
+ return;
+}
-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.
+=head2 itemborrowed
-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).
+&itemseen($itemnum)
+Mark item as borrowed. Is called when an item is issued.
+C<$itemnum> is the item number
=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);
+
+sub itemborrowed {
+ my ($itemnum) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth =
+ $dbh->prepare(
+ "update items set itemlost=0, datelastborrowed = now() where items.itemnumber = ?"
+ );
+ $sth->execute($itemnum);
+ return;
}
-=item getprinters
+=head2 GetItemsForInventory
- $printers = &getprinters($env);
- @queues = keys %$printers;
+$itemlist = GetItemsForInventory($minlocation,$maxlocation,$datelastseen,$offset,$size)
-Returns information about existing printer queues.
+Retrieve a list of title/authors/barcode/callnumber, for biblio inventory.
-C<$env> is ignored.
+The sub returns a list of hashes, containing itemnumber, author, title, barcode & item callnumber.
+It is ordered by callnumber,title.
-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.
+The minlocation & maxlocation parameters are used to specify a range of item callnumbers
+the datelastseen can be used to specify that you want to see items not seen since a past date only.
+offset & size can be used to retrieve only a part of the whole listing (defaut behaviour)
=cut
-#'
-# FIXME - Perhaps this really belongs in C4::Print?
-sub getprinters {
- my ($env) = @_;
- my %printers;
+
+sub GetItemsForInventory {
+ my ( $minlocation, $maxlocation, $datelastseen, $branch, $offset, $size ) = @_;
my $dbh = C4::Context->dbh;
- my $sth=$dbh->prepare("select * from printers");
- $sth->execute;
- while (my $printer=$sth->fetchrow_hashref) {
- $printers{$printer->{'printqueue'}}=$printer;
+ my $sth;
+ if ($datelastseen) {
+ my $query =
+ "SELECT itemnumber,barcode,itemcallnumber,title,author,datelastseen
+ FROM items
+ LEFT JOIN biblio ON items.biblionumber=biblio.biblionumber
+ WHERE itemcallnumber>= ?
+ AND itemcallnumber <=?
+ AND (datelastseen< ? OR datelastseen IS NULL)";
+ $query.= " AND items.homebranch=".$dbh->quote($branch) if $branch;
+ $query .= " ORDER BY itemcallnumber,title";
+ $sth = $dbh->prepare($query);
+ $sth->execute( $minlocation, $maxlocation, $datelastseen );
}
- 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;
+ else {
+ my $query ="
+ SELECT itemnumber,barcode,itemcallnumber,title,author,datelastseen
+ FROM items
+ LEFT JOIN biblio ON items.biblionumber=biblio.biblionumber
+ WHERE itemcallnumber>= ?
+ AND itemcallnumber <=?";
+ $query.= " AND items.homebranch=".$dbh->quote($branch) if $branch;
+ $query .= " ORDER BY itemcallnumber,title";
+ $sth = $dbh->prepare($query);
+ $sth->execute( $minlocation, $maxlocation );
+ }
+ my @results;
+ while ( my $row = $sth->fetchrow_hashref ) {
+ $offset-- if ($offset);
+ if ( ( !$offset ) && $size ) {
+ push @results, $row;
+ $size--;
+ }
+ }
+ return \@results;
}
-=item getpatroninformation
+=head2 getpatroninformation
- ($borrower, $flags) = &getpatroninformation($env, $borrowernumber,
- $cardnumber);
+($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
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:
+C<$borrower-E<gt>{flags}> is a hash giving more detailed information
+about the patron. Its keys act as flags :
- if (exists($flags->{LOST}))
- {
- # Patron's card was reported lost
- print $flags->{LOST}{message}, "\n";
- }
+ if $borrower->{flags}->{LOST} {
+ # Patron's card was reported lost
+ }
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
The possible flags are:
+=head3 CHARGES
+
=over 4
-=item CHARGES
+=item Shows the patron's credit or debt, if any.
+
+=back
-Shows the patron's credit or debt, if any.
+=head3 GNA
-=item GNA
+=over 4
-(Gone, no address.) Set if the patron has left without giving a
+=item (Gone, no address.) Set if the patron has left without giving a
forwarding address.
-=item LOST
+=back
+
+=head3 LOST
+
+=over 4
+
+=item Set if the patron's card has been reported as lost.
+
+=back
+
+=head3 DBARRED
+
+=over 4
+
+=item Set if the patron has been debarred.
-Set if the patron's card has been reported as lost.
+=back
+
+=head3 NOTES
-=item DBARRED
+=over 4
-Set if the patron has been debarred.
+=item Any additional notes about the patron.
-=item NOTES
+=back
-Any additional notes about the patron.
+=head3 ODUES
-=item ODUES
+=over 4
-Set if the patron has overdue items. This flag has several keys:
+=item 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
C<$flags-E<gt>{ODUES}{itemlist}> is a string giving a text listing of
the overdue items, one per line.
-=item WAITING
+=back
+
+=head3 WAITING
+
+=over 4
-Set if any items that the patron has reserved are available.
+=item 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
=back
=cut
-#'
+
sub getpatroninformation {
-# returns
- my ($env, $borrowernumber,$cardnumber) = @_;
+ 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;
+ $sth = $dbh->prepare("select * from borrowers where borrowernumber=?");
+ $sth->execute($borrowernumber);
+ }
+ elsif ($cardnumber) {
+ $sth = $dbh->prepare("select * from borrowers where cardnumber=?");
+ $sth->execute($cardnumber);
+ }
+ else {
+ return undef;
+ }
my $borrower = $sth->fetchrow_hashref;
- my $amount = checkaccount($env, $borrowernumber, $dbh);
+ my $amount = checkaccount( $env, $borrowernumber, $dbh );
$borrower->{'amountoutstanding'} = $amount;
- my $flags = patronflags($env, $borrower, $dbh);
+ my $flags = patronflags( $env, $borrower, $dbh );
my $accessflagshash;
- $sth=$dbh->prepare("select bit,flag from userflags");
+ $sth = $dbh->prepare("select bit,flag from userflags");
$sth->execute;
- while (my ($bit, $flag) = $sth->fetchrow) {
- if ($borrower->{'flags'} & 2**$bit) {
- $accessflagshash->{$flag}=1;
- }
+ while ( my ( $bit, $flag ) = $sth->fetchrow ) {
+ if ( $borrower->{'flags'} && $borrower->{'flags'} & 2**$bit ) {
+ $accessflagshash->{$flag} = 1;
+ }
}
$sth->finish;
- $borrower->{'flags'}=$flags;
- return ($borrower, $flags, $accessflagshash);
+ $borrower->{'flags'} = $flags;
+ $borrower->{'authflags'} = $accessflagshash;
+
+ # find out how long the membership lasts
+ $sth =
+ $dbh->prepare(
+ "select enrolmentperiod from categories where categorycode = ?");
+ $sth->execute( $borrower->{'categorycode'} );
+ my $enrolment = $sth->fetchrow;
+ $borrower->{'enrolmentperiod'} = $enrolment;
+ return ($borrower); #, $flags, $accessflagshash);
}
-=item decode
+=head2 decode
- $str = &decode($chunk);
+=head3 $str = &decode($chunk);
-Decodes a segment of a string emitted by a CueCat barcode scanner and
+=over 4
+
+=item Decodes a segment of a string emitted by a CueCat barcode scanner and
returns it.
+=back
+
=cut
-#'
+
# FIXME - At least, I'm pretty sure this is for decoding CueCat stuff.
sub decode {
my ($encoded) = @_;
- my $seq = 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789+-';
- my @s = map { index($seq,$_); } split(//,$encoded);
- my $l = ($#s+1) % 4;
- if ($l)
- {
- if ($l == 1)
- {
- print "Error!";
- return;
- }
- $l = 4-$l;
- $#s += $l;
+ my $seq =
+ 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789+-';
+ my @s = map { index( $seq, $_ ); } split( //, $encoded );
+ my $l = ( $#s + 1 ) % 4;
+ if ($l) {
+ if ( $l == 1 ) {
+ warn "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];
+ 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);
+ $r = substr( $r, 0, length($r) - $l );
return $r;
}
-=item getiteminformation
+=head2 getiteminformation
- $item = &getiteminformation($env, $itemnumber, $barcode);
+$item = &getiteminformation($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
+=head3 date_due
-=item C<date_due>
+=over 4
-The due date on this item, if it has been borrowed and not returned
+=item 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>
+=back
-The length of time for which the item can be borrowed, in days.
+=head3 notforloan
-=item C<notforloan>
+=over 4
-True if the item may not be borrowed.
+=item 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) = @_;
+
+ # returns a hash of item information given either the itemnumber or the barcode
+ my ( $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 =
+ $dbh->prepare(
+ "select *
+ from biblio,items,biblioitems
+ where items.itemnumber=? and biblio.biblionumber=items.biblionumber and biblioitems.biblioitemnumber = items.biblioitemnumber"
+ );
+ $sth->execute($itemnumber);
}
- $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;
+ elsif ($barcode) {
+ $sth =
+ $dbh->prepare(
+ "select * from biblio,items,biblioitems where items.barcode=? and biblio.biblionumber=items.biblionumber and biblioitems.biblioitemnumber = items.biblioitemnumber"
+ );
+ $sth->execute($barcode);
}
- 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);
- }
+ else {
+ return undef;
}
+ my $iteminformation = $sth->fetchrow_hashref;
$sth->finish;
- return(\@borrowers);
+ if ($iteminformation) {
+ $sth =
+ $dbh->prepare("select date_due from issues where itemnumber=? and isnull(returndate)");
+ $sth->execute( $iteminformation->{'itemnumber'} );
+ my ($date_due) = $sth->fetchrow;
+ $iteminformation->{'date_due'} = $date_due;
+ $sth->finish;
+ ( $iteminformation->{'dewey'} == 0 )
+ && ( $iteminformation->{'dewey'} = '' );
+ $sth = $dbh->prepare("select * from itemtypes where itemtype=?");
+ $sth->execute( $iteminformation->{'itemtype'} );
+ my $itemtype = $sth->fetchrow_hashref;
+
+ # if specific item notforloan, don't use itemtype notforloan field.
+ # otherwise, use itemtype notforloan value to see if item can be issued.
+ $iteminformation->{'notforloan'} = $itemtype->{'notforloan'}
+ unless $iteminformation->{'notforloan'};
+ $sth->finish;
+ }
+ return ($iteminformation);
}
+=head2 transferbook
-=item transferbook
-
- ($dotransfer, $messages, $iteminformation) =
- &transferbook($newbranch, $barcode, $ignore_reserves);
+($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.
+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<$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.
Returns three values:
-C<$dotransfer> is true iff the transfer was successful.
+=head3 $dotransfer
+
+is true if the transfer was successful.
+
+=head3 $messages
-C<$messages> is a reference-to-hash which may have any of the
-following keys:
+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>.
+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.
+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.
+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.
+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>.
+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.
+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
# 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 ( $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 $dotransfer = 1;
+ my $branches = GetBranches();
+ my $iteminformation = getiteminformation( 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 is permanent...
+ if ( $hbr && $branches->{$hbr}->{'PE'} ) {
+ $messages->{'IsPermanent'} = $hbr;
+ }
+
+ # can't transfer book if is already there....
+ # FIXME - Why not? Shouldn't it trivially succeed?
+ if ( $fbr eq $tbr ) {
+ $messages->{'DestinationEqualsHolding'} = 1;
+ $dotransfer = 0;
+ }
+
+ # check if it is still issued to someone, return it...
+ my ($currentborrower) = currentborrower( $iteminformation->{'itemnumber'} );
if ($currentborrower) {
- returnbook($barcode, $fbr);
- $messages->{'WasReturned'} = $currentborrower;
+ returnbook( $barcode, $fbr );
+ $messages->{'WasReturned'} = $currentborrower;
}
-# find reserves.....
+
+ # 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;
+ my ( $resfound, $resrec ) =
+ CheckReserves( $iteminformation->{'itemnumber'} );
+ if ( $resfound and not $ignoreRs ) {
+ $resrec->{'ResFound'} = $resfound;
+
+ # $messages->{'ResFound'} = $resrec;
+ $dotransfer = 1;
}
-#actually do the transfer....
+
+ #actually do the transfer....
if ($dotransfer) {
- dotransfer($iteminformation->{'itemnumber'}, $fbr, $tbr);
- $messages->{'WasTransfered'} = 1;
+ dotransfer( $iteminformation->{'itemnumber'}, $fbr, $tbr );
+
+ # don't need to update MARC anymore, we do it in batch now
+ $messages->{'WasTransfered'} = 1;
}
- return ($dotransfer, $messages, $iteminformation);
+ 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 ( $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
+ $dbh->do(
+"INSERT INTO branchtransfers (itemnumber, frombranch, datesent, tobranch)
+ VALUES ($itm, $fbr, now(), $tbr)"
+ );
#update holdingbranch in items .....
- $dbh->do(<<EOT);
- UPDATE items
- SET datelastseen = now(),
- holdingbranch = $tbr
- WHERE items.itemnumber = $itm
-EOT
+ $dbh->do(
+ "UPDATE items set holdingbranch = $tbr WHERE items.itemnumber = $itm");
+ &itemseen($itm);
+ &domarctransfer( $dbh, $itm );
+ return;
+}
+
+##New sub to dotransfer in marc tables as well. Not exported -TG 10/04/2006
+sub domarctransfer {
+ my ( $dbh, $itemnumber ) = @_;
+ $itemnumber =~ s /\'//g; ##itemnumber seems to come with quotes-TG
+ my $sth =
+ $dbh->prepare(
+ "select biblionumber,holdingbranch from items where itemnumber=$itemnumber"
+ );
+ $sth->execute();
+ while ( my ( $biblionumber, $holdingbranch ) = $sth->fetchrow ) {
+ &MARCmoditemonefield( $biblionumber, $itemnumber,
+ 'items.holdingbranch', $holdingbranch, 0 );
+ }
return;
}
-=item issuebook
+=head2 canbookbeissued
- ($iteminformation, $datedue, $rejected, $question, $questionnumber,
- $defaultanswer, $message) =
- &issuebook($env, $patroninformation, $barcode, $responses, $date);
+Check if a book can be issued.
-Issue a book to a patron.
+my ($issuingimpossible,$needsconfirmation) = canbookbeissued($env,$borrower,$barcode,$year,$month,$day);
-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.
+=over 4
+
+=item C<$env> Environment variable. Should be empty usually, but used by other subs. Next code cleaning could drop it.
-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".
+=item C<$borrower> hash with borrower informations (from getpatroninformation)
-C<$env-E<gt>{branchcode}> is the code of the branch where this
-transaction is taking place.
+=item C<$barcode> is the bar code of the book being issued.
-C<$patroninformation> is a reference-to-hash giving information about
-the person borrowing the book. This is the first value returned by
-C<&getpatroninformation>.
+=item C<$year> C<$month> C<$day> contains the date of the return (in case it's forced by "stickyduedate".
+
+=back
-C<$barcode> is the bar code of the book being issued.
+Returns :
-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".
+=over 4
-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.
+=item C<$issuingimpossible> a reference to a hash. It contains reasons why issuing is impossible.
+Possible values are :
-C<&issuebook> returns an array of seven values:
+=back
-C<$iteminformation> is a reference-to-hash describing the item just
-issued. This in a form similar to that returned by
-C<&getiteminformation>.
+=head3 INVALID_DATE
-C<$datedue> is a string giving the date when the book is due, in the
-form "YYYY-MM-DD".
+sticky due date is invalid
-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.
+=head3 GNA
-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:
+borrower gone with no address
-=over 4
+=head3 CARD_LOST
-=item 1: "Issued to <name>. Mark as returned?" (Y)
+borrower declared it's card lost
-=item 2: "Waiting for <patron> at <branch>. Allow issue?" (N)
+=head3 DEBARRED
-=item 3: "Cancel reserve for <patron>?" (N)
+borrower debarred
-=item 4: "Book is issued to this borrower. Renew?" (Y)
+=head3 UNKNOWN_BARCODE
-=item 5: "Reserved for <patron> at <branch> since <date>. Allow issue?" (N)
+barcode unknown
-=item 6: "Set reserve for <patron> to waiting and transfer to <branch>?" (Y)
+=head3 NOT_FOR_LOAN
-This is asked if the answer to question 5 was "N".
+item is not for loan
-=item 7: "Cancel reserve for <patron>?" (N)
+=head3 WTHDRAWN
-=back
+item withdrawn.
+
+=head3 RESTRICTED
+
+item is restricted (set by ??)
+
+C<$issuingimpossible> a reference to a hash. It contains reasons why issuing is impossible.
+Possible values are :
+
+=head3 DEBT
+
+borrower has debts.
+
+=head3 RENEW_ISSUE
+
+renewing, not issuing
+
+=head3 ISSUED_TO_ANOTHER
-C<$message>, if defined, is an additional information message, e.g., a
-rental fee notice.
+issued to someone else.
+
+=head3 RESERVED
+
+reserved for someone else.
+
+=head3 INVALID_DATE
+
+sticky due date is invalid
+
+=head3 TOO_MANY
+
+if the borrower borrows to much things
=cut
-#'
-# 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'});
- }
- }
- }
- }
+# check if a book can be issued.
+# returns an array with errors if any
+
+sub TooMany ($$) {
+ my $borrower = shift;
+ my $iteminformation = shift;
+ my $cat_borrower = $borrower->{'categorycode'};
+ my $branch_borrower = $borrower->{'branchcode'};
+ my $dbh = C4::Context->dbh;
+
+ my $sth =
+ $dbh->prepare('select itemtype from biblioitems where biblionumber = ?');
+ $sth->execute( $iteminformation->{'biblionumber'} );
+ my $type = $sth->fetchrow;
+ $sth =
+ $dbh->prepare(
+'select * from issuingrules where categorycode = ? and itemtype = ? and branchcode = ?'
+ );
+
+# my $sth2 = $dbh->prepare("select COUNT(*) from issues i, biblioitems s where i.borrowernumber = ? and i.returndate is null and i.itemnumber = s.biblioitemnumber and s.itemtype like ?");
+ my $sth2 =
+ $dbh->prepare(
+"select COUNT(*) from issues i, biblioitems s1, items s2 where i.borrowernumber = ? and i.returndate is null and i.itemnumber = s2.itemnumber and s1.itemtype like ? and s1.biblioitemnumber = s2.biblioitemnumber"
+ );
+ my $sth3 =
+ $dbh->prepare(
+'select COUNT(*) from issues where borrowernumber = ? and returndate is null'
+ );
+ my $alreadyissued;
+
+ # check the 3 parameters
+ $sth->execute( $cat_borrower, $type, $branch_borrower );
+ my $result = $sth->fetchrow_hashref;
+
+ # warn "==>".$result->{maxissueqty};
+
+# Currently, using defined($result) ie on an entire hash reports whether memory
+# for that aggregate has ever been allocated. As $result is used all over the place
+# it would rarely return as undefined.
+ if ( defined( $result->{maxissueqty} ) ) {
+ $sth2->execute( $borrower->{'borrowernumber'}, "%$type%" );
+ my $alreadyissued = $sth2->fetchrow;
+ if ( $result->{'maxissueqty'} <= $alreadyissued ) {
+ return ( "a $alreadyissued / ".( $result->{maxissueqty} + 0 ) );
+ }
+ else {
+ return;
+ }
}
- 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'});
+ # check for branch=*
+ $sth->execute( $cat_borrower, $type, "" );
+ $result = $sth->fetchrow_hashref;
+ if ( defined( $result->{maxissueqty} ) ) {
+ $sth2->execute( $borrower->{'borrowernumber'}, "%$type%" );
+ my $alreadyissued = $sth2->fetchrow;
+ if ( $result->{'maxissueqty'} <= $alreadyissued ) {
+ return ( "b $alreadyissued / ".( $result->{maxissueqty} + 0 ) );
+ }
+ else {
+ return;
+ }
+ }
+
+ # check for itemtype=*
+ $sth->execute( $cat_borrower, "*", $branch_borrower );
+ $result = $sth->fetchrow_hashref;
+ if ( defined( $result->{maxissueqty} ) ) {
+ $sth3->execute( $borrower->{'borrowernumber'} );
+ my ($alreadyissued) = $sth3->fetchrow;
+ if ( $result->{'maxissueqty'} <= $alreadyissued ) {
+
+# warn "HERE : $alreadyissued / ($result->{maxissueqty} for $borrower->{'borrowernumber'}";
+ return ( "c $alreadyissued / " . ( $result->{maxissueqty} + 0 ) );
+ }
+ else {
+ return;
+ }
}
- if ($iteminformation->{'charge'}) {
- $message=sprintf "Rental charge of \$%.02f applies.", $iteminformation->{'charge'};
+
+ # check for borrowertype=*
+ $sth->execute( "*", $type, $branch_borrower );
+ $result = $sth->fetchrow_hashref;
+ if ( defined( $result->{maxissueqty} ) ) {
+ $sth2->execute( $borrower->{'borrowernumber'}, "%$type%" );
+ my $alreadyissued = $sth2->fetchrow;
+ if ( $result->{'maxissueqty'} <= $alreadyissued ) {
+ return ( "d $alreadyissued / " . ( $result->{maxissueqty} + 0 ) );
+ }
+ else {
+ return;
+ }
}
- return ($iteminformation, $dateduef, $rejected, $question, $questionnumber, $defaultanswer, $message);
-}
+ $sth->execute( "*", "*", $branch_borrower );
+ $result = $sth->fetchrow_hashref;
+ if ( defined( $result->{maxissueqty} ) ) {
+ $sth3->execute( $borrower->{'borrowernumber'} );
+ my $alreadyissued = $sth3->fetchrow;
+ if ( $result->{'maxissueqty'} <= $alreadyissued ) {
+ return ( "e $alreadyissued / " . ( $result->{maxissueqty} + 0 ) );
+ }
+ else {
+ return;
+ }
+ }
+ $sth->execute( "*", $type, "" );
+ $result = $sth->fetchrow_hashref;
+ if ( defined( $result->{maxissueqty} ) && $result->{maxissueqty} >= 0 ) {
+ $sth2->execute( $borrower->{'borrowernumber'}, "%$type%" );
+ my $alreadyissued = $sth2->fetchrow;
+ if ( $result->{'maxissueqty'} <= $alreadyissued ) {
+ return ( "f $alreadyissued / " . ( $result->{maxissueqty} + 0 ) );
+ }
+ else {
+ return;
+ }
+ }
-=item returnbook
+ $sth->execute( $cat_borrower, "*", "" );
+ $result = $sth->fetchrow_hashref;
+ if ( defined( $result->{maxissueqty} ) ) {
+ $sth2->execute( $borrower->{'borrowernumber'}, "%$type%" );
+ my $alreadyissued = $sth2->fetchrow;
+ if ( $result->{'maxissueqty'} <= $alreadyissued ) {
+ return ( "g $alreadyissued / " . ( $result->{maxissueqty} + 0 ) );
+ }
+ else {
+ return;
+ }
+ }
- ($doreturn, $messages, $iteminformation, $borrower) =
- &returnbook($barcode, $branch);
+ $sth->execute( "*", "*", "" );
+ $result = $sth->fetchrow_hashref;
+ if ( defined( $result->{maxissueqty} ) ) {
+ $sth3->execute( $borrower->{'borrowernumber'} );
+ my $alreadyissued = $sth3->fetchrow;
+ if ( $result->{'maxissueqty'} <= $alreadyissued ) {
+ return ( "h $alreadyissued / " . ( $result->{maxissueqty} + 0 ) );
+ }
+ else {
+ return;
+ }
+ }
+ return;
+}
-Returns a book.
+=head2 itemissues
-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.
+ @issues = &itemissues($biblioitemnumber, $biblio);
-C<&returnbook> returns a list of four items:
+Looks up information about who has borrowed the bookZ<>(s) with the
+given biblioitemnumber.
-C<$doreturn> is true iff the return succeeded.
+C<$biblio> is ignored.
-C<$messages> is a reference-to-hash giving the reason for failure:
+C<&itemissues> returns an array of references-to-hash. The keys
+include the fields from the C<items> table in the Koha database.
+Additional keys include:
=over 4
-=item C<BadBarcode>
+=item C<date_due>
-No item with this barcode exists. The value is C<$barcode>.
+If the item is currently on loan, this gives the due date.
-=item C<NotIssued>
+If the item is not on loan, then this is either "Available" or
+"Cancelled", if the item has been withdrawn.
-The book is not currently on loan. The value is C<$barcode>.
+=item C<card>
-=item C<IsPermanent>
+If the item is currently on loan, this gives the card number of the
+patron who currently has the item.
-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<timestamp0>, C<timestamp1>, C<timestamp2>
-=item C<wthdrawn>
+These give the timestamp for the last three times the item was
+borrowed.
-This book has been withdrawn/cancelled. The value should be ignored.
+=item C<card0>, C<card1>, C<card2>
-=item C<ResFound>
+The card number of the last three patrons who borrowed this item.
-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.
+=item C<borrower0>, C<borrower1>, C<borrower2>
-=back
+The borrower number of the last three patrons who borrowed this item.
-C<$borrower> is a reference-to-hash, giving information about the
-patron who last borrowed the book.
+=back
=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'}; # 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
+sub itemissues {
+ my ( $bibitem, $biblio ) = @_;
+ my $dbh = C4::Context->dbh;
+
+ # FIXME - If this function die()s, the script will abort, and the
+ # user won't get anything; depending on how far the script has
+ # gotten, the user might get a blank page. It would be much better
+ # to at least print an error message. The easiest way to do this
+ # is to set $SIG{__DIE__}.
+ my $sth =
+ $dbh->prepare("Select * from items where items.biblioitemnumber = ?")
+ || die $dbh->errstr;
+ my $i = 0;
+ my @results;
+
+ $sth->execute($bibitem) || die $sth->errstr;
+
+ while ( my $data = $sth->fetchrow_hashref ) {
+
+ # Find out who currently has this item.
+ # FIXME - Wouldn't it be better to do this as a left join of
+ # some sort? Currently, this code assumes that if
+ # fetchrow_hashref() fails, then the book is on the shelf.
+ # fetchrow_hashref() can fail for any number of reasons (e.g.,
+ # database server crash), not just because no items match the
+ # search criteria.
+ my $sth2 = $dbh->prepare(
+ "select * from issues,borrowers
+where itemnumber = ?
+and returndate is NULL
+and issues.borrowernumber = borrowers.borrowernumber"
+ );
+
+ $sth2->execute( $data->{'itemnumber'} );
+ if ( my $data2 = $sth2->fetchrow_hashref ) {
+ $data->{'date_due'} = $data2->{'date_due'};
+ $data->{'card'} = $data2->{'cardnumber'};
+ $data->{'borrower'} = $data2->{'borrowernumber'};
+ }
+ else {
+ if ( $data->{'wthdrawn'} eq '1' ) {
+ $data->{'date_due'} = 'Cancelled';
+ }
+ else {
+ $data->{'date_due'} = 'Available';
+ } # else
+ } # else
+
+ $sth2->finish;
+
+ # Find the last 3 people who borrowed this item.
+ $sth2 = $dbh->prepare(
+ "select * from issues, borrowers
+ where itemnumber = ?
+ and issues.borrowernumber = borrowers.borrowernumber
+ and returndate is not NULL
+ order by returndate desc,timestamp desc"
+ );
+
+# $sth2 = $dbh->prepare("
+# SELECT *
+# FROM issues
+# LEFT JOIN borrowers ON issues.borrowernumber = borrowers.borrowernumber
+# WHERE itemnumber = ?
+# AND returndate is not NULL
+# ORDER BY returndate DESC,timestamp DESC
+# ");
+
+ $sth2->execute( $data->{'itemnumber'} );
+ for ( my $i2 = 0 ; $i2 < 2 ; $i2++ )
+ { # FIXME : error if there is less than 3 pple borrowing this item
+ if ( my $data2 = $sth2->fetchrow_hashref ) {
+ $data->{"timestamp$i2"} = $data2->{'timestamp'};
+ $data->{"card$i2"} = $data2->{'cardnumber'};
+ $data->{"borrower$i2"} = $data2->{'borrowernumber'};
+ } # if
+ } # for
+
+ $sth2->finish;
+ $results[$i] = $data;
+ $i++;
}
-# 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;
+ return (@results);
}
-# 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
-}
+=head2 canbookbeissued
-# 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;
- }
+$issuingimpossible, $needsconfirmation =
+ canbookbeissued( $env, $borrower, $barcode, $year, $month, $day, $inprocess );
+
+C<$issuingimpossible> and C<$needsconfirmation> are some hashref.
+
+=cut
+
+sub canbookbeissued {
+ my ( $env, $borrower, $barcode, $year, $month, $day, $inprocess ) = @_;
+ my %needsconfirmation; # filled with problems that needs confirmations
+ my %issuingimpossible
+ ; # filled with problems that causes the issue to be IMPOSSIBLE
+ my $iteminformation = getiteminformation( 0, $barcode );
+ my $dbh = C4::Context->dbh;
+
+ #
+ # DUE DATE is OK ?
+ #
+ my ( $duedate, $invalidduedate ) = fixdate( $year, $month, $day );
+ $issuingimpossible{INVALID_DATE} = 1 if ($invalidduedate);
+
+ #
+ # BORROWER STATUS
+ #
+ if ( $borrower->{flags}->{GNA} ) {
+ $issuingimpossible{GNA} = 1;
+ }
+ if ( $borrower->{flags}->{'LOST'} ) {
+ $issuingimpossible{CARD_LOST} = 1;
+ }
+ if ( $borrower->{flags}->{'DBARRED'} ) {
+ $issuingimpossible{DEBARRED} = 1;
+ }
+ if ( Date_to_Days(Today) >
+ Date_to_Days( split "-", $borrower->{'dateexpiry'} ) )
+ {
+
+ #
+ #if (&Date_Cmp(&ParseDate($borrower->{expiry}),&ParseDate("today"))<0) {
+ $issuingimpossible{EXPIRED} = 1;
+ }
+
+ #
+ # BORROWER STATUS
+ #
+
+ # DEBTS
+ my $amount =
+ checkaccount( $env, $borrower->{'borrowernumber'}, $dbh, $duedate );
+ if ( C4::Context->preference("IssuingInProcess") ) {
+ my $amountlimit = C4::Context->preference("noissuescharge");
+ if ( $amount > $amountlimit && !$inprocess ) {
+ $issuingimpossible{DEBT} = sprintf( "%.2f", $amount );
+ }
+ elsif ( $amount <= $amountlimit && !$inprocess ) {
+ $needsconfirmation{DEBT} = sprintf( "%.2f", $amount );
+ }
+ }
+ else {
+ if ( $amount > 0 ) {
+ $needsconfirmation{DEBT} = $amount;
+ }
+ }
+
+ #
+ # JB34 CHECKS IF BORROWERS DONT HAVE ISSUE TOO MANY BOOKS
+ #
+ my $toomany = TooMany( $borrower, $iteminformation );
+ $needsconfirmation{TOO_MANY} = $toomany if $toomany;
+
+ #
+ # ITEM CHECKING
+ #
+ unless ( $iteminformation->{barcode} ) {
+ $issuingimpossible{UNKNOWN_BARCODE} = 1;
+ }
+ if ( $iteminformation->{'notforloan'}
+ && $iteminformation->{'notforloan'} > 0 )
+ {
+ $issuingimpossible{NOT_FOR_LOAN} = 1;
+ }
+ if ( $iteminformation->{'itemtype'}
+ && $iteminformation->{'itemtype'} eq 'REF' )
+ {
+ $issuingimpossible{NOT_FOR_LOAN} = 1;
+ }
+ if ( $iteminformation->{'wthdrawn'} && $iteminformation->{'wthdrawn'} == 1 )
+ {
+ $issuingimpossible{WTHDRAWN} = 1;
+ }
+ if ( $iteminformation->{'restricted'}
+ && $iteminformation->{'restricted'} == 1 )
+ {
+ $issuingimpossible{RESTRICTED} = 1;
+ }
+ if ( C4::Context->preference("IndependantBranches") ) {
+ my $userenv = C4::Context->userenv;
+ if ( ($userenv) && ( $userenv->{flags} != 1 ) ) {
+ $issuingimpossible{NOTSAMEBRANCH} = 1
+ if ( $iteminformation->{'holdingbranch'} ne $userenv->{branch} );
+ }
+ }
+
+ #
+ # CHECK IF BOOK ALREADY ISSUED TO THIS BORROWER
+ #
+ my ($currentborrower) = currentborrower( $iteminformation->{'itemnumber'} );
+ if ( $currentborrower && $currentborrower eq $borrower->{'borrowernumber'} )
+ {
+
+ # Already issued to current borrower. Ask whether the loan should
+ # be renewed.
+ my ($renewstatus) = renewstatus(
+ $env,
+ $borrower->{'borrowernumber'},
+ $iteminformation->{'itemnumber'}
+ );
+ if ( $renewstatus == 0 ) { # no more renewals allowed
+ $issuingimpossible{NO_MORE_RENEWALS} = 1;
+ }
+ else {
+
+ # $needsconfirmation{RENEW_ISSUE} = 1;
+ }
+ }
+ elsif ($currentborrower) {
+
+ # issued to someone else
+ my $currborinfo = getpatroninformation( 0, $currentborrower );
+
+# warn "=>.$currborinfo->{'firstname'} $currborinfo->{'surname'} ($currborinfo->{'cardnumber'})";
+ $needsconfirmation{ISSUED_TO_ANOTHER} =
+"$currborinfo->{'reservedate'} : $currborinfo->{'firstname'} $currborinfo->{'surname'} ($currborinfo->{'cardnumber'})";
+ }
+
+ # See if the item is on reserve.
+ my ( $restype, $res ) = CheckReserves( $iteminformation->{'itemnumber'} );
+ if ($restype) {
+ my $resbor = $res->{'borrowernumber'};
+ if ( $resbor ne $borrower->{'borrowernumber'} && $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'};
+ $needsconfirmation{RESERVE_WAITING} =
+"$resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'}, $branchname)";
+
+# CancelReserve(0, $res->{'itemnumber'}, $res->{'borrowernumber'}); Doesn't belong in a checking subroutine.
+ }
+ 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'};
+ $needsconfirmation{RESERVED} =
+"$res->{'reservedate'} : $resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'})";
+ }
+ }
+ if ( C4::Context->preference("LibraryName") eq "Horowhenua Library Trust" )
+ {
+ if ( $borrower->{'categorycode'} eq 'W' ) {
+ my %issuingimpossible;
+ return ( \%issuingimpossible, \%needsconfirmation );
+ }
+ else {
+ return ( \%issuingimpossible, \%needsconfirmation );
+ }
+ }
+ else {
+ return ( \%issuingimpossible, \%needsconfirmation );
+ }
+}
+
+=head2 issuebook
+
+Issue a book. Does no check, they are done in canbookbeissued. If we reach this sub, it means the user confirmed if needed.
+
+&issuebook($env,$borrower,$barcode,$date)
+
+=over 4
+
+=item C<$env> Environment variable. Should be empty usually, but used by other subs. Next code cleaning could drop it.
+
+=item C<$borrower> hash with borrower informations (from getpatroninformation)
+
+=item C<$barcode> is the bar code of the book being issued.
+
+=item C<$date> contains the max date of return. calculated if empty.
+
+=back
+
+=cut
+
+sub issuebook {
+ my ( $env, $borrower, $barcode, $date, $cancelreserve ) = @_;
+ my $dbh = C4::Context->dbh;
+
+# my ($borrower, $flags) = &getpatroninformation($env, $borrowernumber, 0);
+ my $iteminformation = getiteminformation( 0, $barcode );
+
+#
+# check if we just renew the issue.
+#
+ my ($currentborrower) = currentborrower( $iteminformation->{'itemnumber'} );
+ if ( $currentborrower eq $borrower->{'borrowernumber'} ) {
+ my ( $charge, $itemtype ) = calc_charges(
+ $env,
+ $iteminformation->{'itemnumber'},
+ $borrower->{'borrowernumber'}
+ );
+ if ( $charge > 0 ) {
+ createcharge(
+ $env, $dbh,
+ $iteminformation->{'itemnumber'},
+ $borrower->{'borrowernumber'}, $charge
+ );
+ $iteminformation->{'charge'} = $charge;
+ }
+ &UpdateStats(
+ $env, $env->{'branchcode'},
+ 'renew', $charge,
+ '', $iteminformation->{'itemnumber'},
+ $iteminformation->{'itemtype'}, $borrower->{'borrowernumber'}
+ );
+ renewbook(
+ $env,
+ $borrower->{'borrowernumber'},
+ $iteminformation->{'itemnumber'}
+ );
+ }
+ else {
+
+ #
+ # NOT a renewal
+ #
+ if ( $currentborrower ne '' ) {
+
+# This book is currently on loan, but not to the person
+# who wants to borrow it now. mark it returned before issuing to the new borrower
+ returnbook(
+ $iteminformation->{'barcode'},
+ C4::Context->userenv->{'branch'}
+ );
+ }
+
+ # See if the item is on reserve.
+ my ( $restype, $res ) =
+ CheckReserves( $iteminformation->{'itemnumber'} );
+ if ($restype) {
+ my $resbor = $res->{'borrowernumber'};
+ if ( $resbor eq $borrower->{'borrowernumber'} ) {
+
+ # The item is on reserve to the current patron
+ FillReserve($res);
+ }
+ elsif ( $restype eq "Waiting" ) {
+
+ # warn "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 ($cancelreserve) {
+ CancelReserve( 0, $res->{'itemnumber'},
+ $res->{'borrowernumber'} );
+ }
+ else {
+
+ # set waiting reserve to first in reserve queue as book isn't waiting now
+ UpdateReserve(
+ 1,
+ $res->{'biblionumber'},
+ $res->{'borrowernumber'},
+ $res->{'branchcode'}
+ );
+ }
+ }
+ elsif ( $restype eq "Reserved" ) {
+
+ # warn "Reserved";
+ # The item is on reserve for someone else.
+ my ( $resborrower, $flags ) =
+ getpatroninformation( $env, $resbor, 0 );
+ my $branches = GetBranches();
+ my $branchname =
+ $branches->{ $res->{'branchcode'} }->{'branchname'};
+ if ($cancelreserve) {
+
+ # cancel reserves on this item
+ CancelReserve( 0, $res->{'itemnumber'},
+ $res->{'borrowernumber'} );
+
+# also cancel reserve on biblio related to this item
+#my $st_Fbiblio = $dbh->prepare("select biblionumber from items where itemnumber=?");
+#$st_Fbiblio->execute($res->{'itemnumber'});
+#my $biblionumber = $st_Fbiblio->fetchrow;
+#CancelReserve($biblionumber,0,$res->{'borrowernumber'});
+#warn "CancelReserve $res->{'itemnumber'}, $res->{'borrowernumber'}";
+ }
+ else {
+
+# my $tobrcd = ReserveWaiting($res->{'itemnumber'}, $res->{'borrowernumber'});
+# transferbook($tobrcd,$barcode, 1);
+# warn "transferbook";
+ }
+ }
+ }
+# END OF THE RESTYPE WORK
+
+# Starting process for transfer job (checking transfert and validate it if we have one)
+
+ my ($datesent) = get_transfert_infos($iteminformation->{'itemnumber'});
+
+ if ($datesent) {
+# updating line of branchtranfert to finish it, and changing the to branch value, implement a comment for lisibility of this case (maybe for stats ....)
+ my $sth =
+ $dbh->prepare(
+ "update branchtransfers set datearrived = now(),
+ tobranch = ?,
+ comments = 'Forced branchtransfert'
+ where
+ itemnumber= ? AND datearrived IS NULL"
+ );
+ $sth->execute(C4::Context->userenv->{'branch'},$iteminformation->{'itemnumber'});
+ $sth->finish;
+ }
+
+# Ending process for transfert check
+
+ # Record in the database the fact that the book was issued.
+ my $sth =
+ $dbh->prepare(
+"insert into issues (borrowernumber, itemnumber,issuedate, date_due, branchcode) values (?,?,?,?,?)"
+ );
+ my $loanlength = getLoanLength(
+ $borrower->{'categorycode'},
+ $iteminformation->{'itemtype'},
+ $borrower->{'branchcode'}
+ );
+ my $datedue = time + ($loanlength) * 86400;
+ my @datearr = localtime($datedue);
+ my $dateduef =
+ ( 1900 + $datearr[5] ) . "-"
+ . ( $datearr[4] + 1 ) . "-"
+ . $datearr[3];
+ if ($date) {
+ $dateduef = $date;
+ }
+
+ # if ReturnBeforeExpiry ON the datedue can't be after borrower expirydate
+ if ( C4::Context->preference('ReturnBeforeExpiry')
+ && $dateduef gt $borrower->{dateexpiry} )
+ {
+ $dateduef = $borrower->{dateexpiry};
+ }
+ $sth->execute(
+ $borrower->{'borrowernumber'},
+ $iteminformation->{'itemnumber'},
+ strftime( "%Y-%m-%d", localtime ),$dateduef, $env->{'branchcode'}
+ );
+ $sth->finish;
+ $iteminformation->{'issues'}++;
+ $sth =
+ $dbh->prepare(
+ "update items set issues=?, holdingbranch=? where itemnumber=?");
+ $sth->execute(
+ $iteminformation->{'issues'},
+ C4::Context->userenv->{'branch'},
+ $iteminformation->{'itemnumber'}
+ );
+ $sth->finish;
+ &itemseen( $iteminformation->{'itemnumber'} );
+ itemborrowed( $iteminformation->{'itemnumber'} );
+
+ # If it costs to borrow this book, charge it to the patron's account.
+ my ( $charge, $itemtype ) = calc_charges(
+ $env,
+ $iteminformation->{'itemnumber'},
+ $borrower->{'borrowernumber'}
+ );
+ if ( $charge > 0 ) {
+ createcharge(
+ $env, $dbh,
+ $iteminformation->{'itemnumber'},
+ $borrower->{'borrowernumber'}, $charge
+ );
+ $iteminformation->{'charge'} = $charge;
+ }
+
+ # Record the fact that this book was issued.
+ &UpdateStats(
+ $env, $env->{'branchcode'},
+ 'issue', $charge,
+ '', $iteminformation->{'itemnumber'},
+ $iteminformation->{'itemtype'}, $borrower->{'borrowernumber'}
+ );
+ }
+
+ &logaction(C4::Context->userenv->{'number'},"CIRCULATION","ISSUE",$borrower->{'borrowernumber'},$iteminformation->{'biblionumber'})
+ if C4::Context->preference("IssueLog");
+
+}
+
+=head2 getLoanLength
+
+Get loan length for an itemtype, a borrower type and a branch
+
+my $loanlength = &getLoanLength($borrowertype,$itemtype,branchcode)
+
+=cut
+
+sub getLoanLength {
+ my ( $borrowertype, $itemtype, $branchcode ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth =
+ $dbh->prepare(
+"select issuelength from issuingrules where categorycode=? and itemtype=? and branchcode=?"
+ );
+
+# try to find issuelength & return the 1st available.
+# check with borrowertype, itemtype and branchcode, then without one of those parameters
+ $sth->execute( $borrowertype, $itemtype, $branchcode );
+ my $loanlength = $sth->fetchrow_hashref;
+ return $loanlength->{issuelength}
+ if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
+
+ $sth->execute( $borrowertype, $itemtype, "" );
+ $loanlength = $sth->fetchrow_hashref;
+ return $loanlength->{issuelength}
+ if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
+
+ $sth->execute( $borrowertype, "*", $branchcode );
+ $loanlength = $sth->fetchrow_hashref;
+ return $loanlength->{issuelength}
+ if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
+
+ $sth->execute( "*", $itemtype, $branchcode );
+ $loanlength = $sth->fetchrow_hashref;
+ return $loanlength->{issuelength}
+ if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
+
+ $sth->execute( $borrowertype, "*", "" );
+ $loanlength = $sth->fetchrow_hashref;
+ return $loanlength->{issuelength}
+ if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
+
+ $sth->execute( "*", "*", $branchcode );
+ $loanlength = $sth->fetchrow_hashref;
+ return $loanlength->{issuelength}
+ if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
+
+ $sth->execute( "*", $itemtype, "" );
+ $loanlength = $sth->fetchrow_hashref;
+ return $loanlength->{issuelength}
+ if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
+
+ $sth->execute( "*", "*", "" );
+ $loanlength = $sth->fetchrow_hashref;
+ return $loanlength->{issuelength}
+ if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
+
+ # if no rule is set => 21 days (hardcoded)
+ return 21;
+}
+
+=head2 returnbook
+
+($doreturn, $messages, $iteminformation, $borrower) =
+ &returnbook($barcode, $branch);
+
+Returns a book.
+
+C<$barcode> is the bar code of the book being returned. C<$branch> is
+the code of the branch where the book is being returned.
+
+C<&returnbook> returns a list of four items:
+
+C<$doreturn> is true iff the return succeeded.
+
+C<$messages> is a reference-to-hash giving the reason for failure:
+
+=over 4
+
+=item C<BadBarcode>
+
+No item with this barcode exists. The value is C<$barcode>.
+
+=item C<NotIssued>
+
+The book is not currently on loan. The value is C<$barcode>.
+
+=item C<IsPermanent>
+
+The book's home branch is a permanent collection. If you have borrowed
+this book, you are not allowed to return it. The value is the code for
+the book's home branch.
+
+=item C<wthdrawn>
+
+This book has been withdrawn/cancelled. The value should be ignored.
+
+=item C<ResFound>
+
+The item was reserved. The value is a reference-to-hash whose keys are
+fields from the reserves table of the Koha database, and
+C<biblioitemnumber>. It also has the key C<ResFound>, whose value is
+either C<Waiting>, C<Reserved>, or 0.
+
+=back
+
+C<$borrower> is a reference-to-hash, giving information about the
+patron who last borrowed the book.
+
+=cut
+
+# FIXME - This API is bogus. There's no need to return $borrower and
+# $iteminformation; the caller can ask about those separately, if it
+# cares (it'd be inefficient to make two database calls instead of
+# one, but &getpatroninformation and &getiteminformation can be
+# memoized if this is an issue).
+#
+# The ($doreturn, $messages) tuple is redundant: if the return
+# succeeded, that's all the caller needs to know. So &returnbook can
+# return 1 and 0 on success and failure, and set
+# $C4::Circulation::Circ2::errmsg to indicate the error. Or it can
+# return undef for success, and an error message on error (though this
+# is more C-ish than Perl-ish).
+
+sub returnbook {
+ my ( $barcode, $branch ) = @_;
+ my %env;
+ my $messages;
+ my $dbh = C4::Context->dbh;
+ my $doreturn = 1;
+ my $validTransfert = 0;
+ my $reserveDone = 0;
+
+ die '$branch not defined' unless defined $branch; # just in case (bug 170)
+ # get information on item
+ my ($iteminformation) = getiteminformation( 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 ( $hbr && $branches->{$hbr}->{'PE'} ) {
+ $messages->{'IsPermanent'} = $hbr;
+ }
+
+ # check that the book has been cancelled
+ if ( $iteminformation->{'wthdrawn'} ) {
+ $messages->{'wthdrawn'} = 1;itemnumber
+ $doreturn = 0;
+ }
+
+# new op dev : if the book returned in an other branch update the holding branch
+
+# update issues, thereby returning book (should push this out into another subroutine
+ my ($borrower) = getpatroninformation( \%env, $currentborrower, 0 );
+
+# case of a return of document (deal with issues and holdingbranch)
+
+ if ($doreturn) {
+ my $sth =
+ $dbh->prepare(
+"update issues set returndate = now() where (borrowernumber = ?) and (itemnumber = ?) and (returndate is null)"
+ );
+ $sth->execute( $borrower->{'borrowernumber'},
+ $iteminformation->{'itemnumber'} );
+ $messages->{'WasReturned'} = 1; # FIXME is the "= 1" right?
+ }
+
+# continue to deal with returns cases, but not only if we have an issue
+
+# the holdingbranch is updated if the document is returned in an other location .
+if ( $iteminformation->{'holdingbranch'} ne C4::Context->userenv->{'branch'} )
+ {
+ UpdateHoldingbranch(C4::Context->userenv->{'branch'},$iteminformation->{'itemnumber'});
+# reload iteminformation holdingbranch with the userenv value
+ $iteminformation->{'holdingbranch'} = C4::Context->userenv->{'branch'};
+ }
+ itemseen( $iteminformation->{'itemnumber'} );
+ ($borrower) = getpatroninformation( \%env, $currentborrower, 0 );
+
+ # fix up the accounts.....
+ if ( $iteminformation->{'itemlost'} ) {
+ fixaccountforlostandreturned( $iteminformation, $borrower );
+ $messages->{'WasLost'} = 1; # FIXME is the "= 1" right?
+ }
+
+ # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+ # check if we have a transfer for this document
+ my ($datesent,$frombranch,$tobranch) = checktransferts( $iteminformation->{'itemnumber'} );
+
+ # if we have a return, we update the line of transfers with the datearrived
+ if ($datesent) {
+ if ( $tobranch eq C4::Context->userenv->{'branch'} ) {
+ my $sth =
+ $dbh->prepare(
+ "update branchtransfers set datearrived = now() where itemnumber= ? AND datearrived IS NULL"
+ );
+ $sth->execute( $iteminformation->{'itemnumber'} );
+ $sth->finish;
+# now we check if there is a reservation with the validate of transfer if we have one, we can set it with the status 'W'
+ SetWaitingStatus( $iteminformation->{'itemnumber'} );
+ }
+ else {
+ $messages->{'WrongTransfer'} = $tobranch;
+ $messages->{'WrongTransferItem'} = $iteminformation->{'itemnumber'};
+ }
+ $validTransfert = 1;
+ }
+
+# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
+# fix up the overdues in accounts...
+ fixoverduesonreturn( $borrower->{'borrowernumber'},
+ $iteminformation->{'itemnumber'} );
+
+# find reserves.....
+# if we don't have a reserve with the status W, we launch the Checkreserves routine
+ my ( $resfound, $resrec ) =
+ CheckReserves( $iteminformation->{'itemnumber'} );
+ if ($resfound) {
+
+# my $tobrcd = ReserveWaiting($resrec->{'itemnumber'}, $resrec->{'borrowernumber'});
+ $resrec->{'ResFound'} = $resfound;
+ $messages->{'ResFound'} = $resrec;
+ $reserveDone = 1;
+ }
+
+ # update stats?
+ # Record the fact that this book was returned.
+ UpdateStats(
+ \%env, $branch, 'return', '0', '',
+ $iteminformation->{'itemnumber'},
+ $iteminformation->{'itemtype'},
+ $borrower->{'borrowernumber'}
+ );
+
+ &logaction(C4::Context->userenv->{'number'},"CIRCULATION","RETURN",$currentborrower,$iteminformation->{'biblionumber'})
+ if C4::Context->preference("ReturnLog");
+
+ #adding message if holdingbranch is non equal a userenv branch to return the document to homebranch
+ #we check, if we don't have reserv or transfert for this document, if not, return it to homebranch .
+
+ if ( ($iteminformation->{'holdingbranch'} ne $iteminformation->{'homebranch'}) and not $messages->{'WrongTransfer'} and ($validTransfert ne 1) and ($reserveDone ne 1) ){
+ if (C4::Context->preference("AutomaticItemReturn") == 1) {
+ dotransfer($iteminformation->{'itemnumber'}, C4::Context->userenv->{'branch'}, $iteminformation->{'homebranch'});
+ $messages->{'WasTransfered'} = 1;
+ warn "was transfered";
+ }
+ }
+
+ return ( $doreturn, $messages, $iteminformation, $borrower );
+}
+
+=head2 fixaccountforlostandreturned
+
+ &fixaccountforlostandreturned($iteminfo,$borrower);
+
+Calculates the charge for a book lost and returned (Not exported & used only once)
+
+C<$iteminfo> is a hashref to iteminfo. Only {itemnumber} is used.
+
+C<$borrower> is a hashref to borrower. Only {borrowernumber is used.
+
+=cut
+
+sub fixaccountforlostandreturned {
+ my ( $iteminfo, $borrower ) = @_;
+ my %env;
+ my $dbh = C4::Context->dbh;
+ my $itm = $iteminfo->{'itemnumber'};
+
+ # check for charge made for lost book
+ my $sth =
+ $dbh->prepare(
+"select * from accountlines where (itemnumber = ?) and (accounttype='L' or accounttype='Rep') order by date desc"
+ );
+ $sth->execute($itm);
+ if ( my $data = $sth->fetchrow_hashref ) {
+
+ # writeoff this amount
+ my $offset;
+ my $amount = $data->{'amount'};
+ my $acctno = $data->{'accountno'};
+ my $amountleft;
+ if ( $data->{'amountoutstanding'} == $amount ) {
+ $offset = $data->{'amount'};
+ $amountleft = 0;
+ }
+ else {
+ $offset = $amount - $data->{'amountoutstanding'};
+ $amountleft = $data->{'amountoutstanding'} - $amount;
+ }
+ my $usth = $dbh->prepare(
+ "update accountlines set accounttype = 'LR',amountoutstanding='0'
+ where (borrowernumber = ?)
+ and (itemnumber = ?) and (accountno = ?) "
+ );
+ $usth->execute( $data->{'borrowernumber'}, $itm, $acctno );
+ $usth->finish;
+
+ #check if any credit is left if so writeoff other accounts
+ my $nextaccntno =
+ getnextacctno( \%env, $data->{'borrowernumber'}, $dbh );
+ if ( $amountleft < 0 ) {
+ $amountleft *= -1;
+ }
+ if ( $amountleft > 0 ) {
+ my $msth = $dbh->prepare(
+ "select * from accountlines where (borrowernumber = ?)
+ and (amountoutstanding >0) order by date"
+ );
+ $msth->execute( $data->{'borrowernumber'} );
+
+ # offset transactions
+ my $newamtos;
+ my $accdata;
+ while ( ( $accdata = $msth->fetchrow_hashref )
+ and ( $amountleft > 0 ) )
+ {
+ if ( $accdata->{'amountoutstanding'} < $amountleft ) {
+ $newamtos = 0;
+ $amountleft -= $accdata->{'amountoutstanding'};
+ }
+ else {
+ $newamtos = $accdata->{'amountoutstanding'} - $amountleft;
+ $amountleft = 0;
+ }
+ my $thisacct = $accdata->{'accountno'};
+ my $usth = $dbh->prepare(
+ "update accountlines set amountoutstanding= ?
+ where (borrowernumber = ?)
+ and (accountno=?)"
+ );
+ $usth->execute( $newamtos, $data->{'borrowernumber'},
+ '$thisacct' );
+ $usth->finish;
+ $usth = $dbh->prepare(
+ "insert into accountoffsets
+ (borrowernumber, accountno, offsetaccount, offsetamount)
+ values
+ (?,?,?,?)"
+ );
+ $usth->execute(
+ $data->{'borrowernumber'},
+ $accdata->{'accountno'},
+ $nextaccntno, $newamtos
+ );
+ $usth->finish;
+ }
+ $msth->finish;
+ }
+ if ( $amountleft > 0 ) {
+ $amountleft *= -1;
+ }
+ my $desc = "Book Returned " . $iteminfo->{'barcode'};
+ $usth = $dbh->prepare(
+ "insert into accountlines
+ (borrowernumber,accountno,date,amount,description,accounttype,amountoutstanding)
+ values (?,?,now(),?,?,'CR',?)"
+ );
+ $usth->execute(
+ $data->{'borrowernumber'},
+ $nextaccntno, 0 - $amount,
+ $desc, $amountleft
+ );
+ $usth->finish;
+ $usth = $dbh->prepare(
+ "insert into accountoffsets
+ (borrowernumber, accountno, offsetaccount, offsetamount)
+ values (?,?,?,?)"
+ );
+ $usth->execute( $borrower->{'borrowernumber'},
+ $data->{'accountno'}, $nextaccntno, $offset );
+ $usth->finish;
+ $usth = $dbh->prepare("update items set paidfor='' where itemnumber=?");
+ $usth->execute($itm);
+ $usth->finish;
+ }
$sth->finish;
return;
}
-# Not exported
+=head2 fixoverdueonreturn
+
+ &fixoverdueonreturn($brn,$itm);
+
+C<$brn> borrowernumber
+
+C<$itm> itemnumber
+
+=cut
+
sub fixoverduesonreturn {
- my ($brn, $itm) = @_;
+ 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();
+
+ # check for overdue fine
+ my $sth =
+ $dbh->prepare(
+"select * from accountlines where (borrowernumber = ?) and (itemnumber = ?) and (accounttype='FU' or accounttype='O')"
+ );
+ $sth->execute( $brn, $itm );
+
+ # alter fine to show that the book has been returned
+ if ( my $data = $sth->fetchrow_hashref ) {
+ my $usth =
+ $dbh->prepare(
+"update accountlines set accounttype='F' where (borrowernumber = ?) and (itemnumber = ?) and (accountno = ?)"
+ );
+ $usth->execute( $brn, $itm, $data->{'accountno'} );
+ $usth->finish();
}
- $sth->finish;
+ $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
+=head2 patronflags
+
+ 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
+
+=cut
+
sub patronflags {
-# Original subroutine for Circ2.pm
+
+ # 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 ( $env, $patroninformation, $dbh ) = @_;
+ my $amount =
+ checkaccount( $env, $patroninformation->{'borrowernumber'}, $dbh );
+ if ( $amount > 0 ) {
+ my %flaginfo;
+ my $noissuescharge = C4::Context->preference("noissuescharge");
+ $flaginfo{'message'} = sprintf "Patron owes \$%.02f", $amount;
+ if ( $amount > $noissuescharge ) {
+ $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'}
+ && $patroninformation->{'gonenoaddress'} == 1 )
+ {
+ my %flaginfo;
+ $flaginfo{'message'} = 'Borrower has no valid address.';
+ $flaginfo{'noissues'} = 1;
+ $flags{'GNA'} = \%flaginfo;
+ }
+ if ( $patroninformation->{'lost'} && $patroninformation->{'lost'} == 1 ) {
+ my %flaginfo;
+ $flaginfo{'message'} = 'Borrower\'s card reported lost.';
+ $flaginfo{'noissues'} = 1;
+ $flags{'LOST'} = \%flaginfo;
+ }
+ if ( $patroninformation->{'debarred'}
+ && $patroninformation->{'debarred'} == 1 )
+ {
+ my %flaginfo;
+ $flaginfo{'message'} = 'Borrower is Debarred.';
+ $flaginfo{'noissues'} = 1;
+ $flags{'DBARRED'} = \%flaginfo;
+ }
+ if ( $patroninformation->{'borrowernotes'}
+ && $patroninformation->{'borrowernotes'} )
+ {
+ my %flaginfo;
+ $flaginfo{'message'} = "$patroninformation->{'borrowernotes'}";
+ $flags{'NOTES'} = \%flaginfo;
}
- my ($nowaiting, $itemswaiting)
- = CheckWaiting($patroninformation->{'borrowernumber'});
- if ($nowaiting > 0) {
- my %flaginfo;
- $flaginfo{'message'} = "Reserved items available";
- $flaginfo{'itemlist'} = $itemswaiting;
- $flags{'WAITING'} = \%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;
}
- return(\%flags);
+ my $itemswaiting =
+ C4::Reserves2::GetWaitingReserves( $patroninformation->{'borrowernumber'} );
+ my $nowaiting = scalar @$itemswaiting;
+ if ( $nowaiting > 0 ) {
+ my %flaginfo;
+ $flaginfo{'message'} = "Reserved items available";
+ $flaginfo{'itemlist'} = $itemswaiting;
+ $flags{'WAITING'} = \%flaginfo;
+ }
+ return ( \%flags );
}
+=head2 checkoverdues
+
+( $count, $overdueitems )=checkoverdues( $env, $borrowernumber, $dbh );
+
+Not exported
+
+=cut
-# 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);
+#checks whether a borrower has overdue items
+ my ( $env, $borrowernumber, $dbh ) = @_;
+ my @datearr = localtime;
+ my $today =
+ ( $datearr[5] + 1900 ) . "-" . ( $datearr[4] + 1 ) . "-" . $datearr[3];
+ my @overdueitems;
+ my $count = 0;
+ my $sth = $dbh->prepare(
+ "SELECT * FROM issues,biblio,biblioitems,items
+ WHERE items.biblioitemnumber = biblioitems.biblioitemnumber
+ AND items.biblionumber = biblio.biblionumber
+ AND issues.itemnumber = items.itemnumber
+ AND issues.borrowernumber = ?
+ AND issues.returndate is NULL
+ AND issues.date_due < ?"
+ );
+ $sth->execute( $borrowernumber, $today );
+ while ( my $data = $sth->fetchrow_hashref ) {
+ push( @overdueitems, $data );
+ $count++;
+ }
+ $sth->finish;
+ return ( $count, \@overdueitems );
}
-# Not exported
+=head2 currentborrower
+
+$borrower=currentborrower($itemnumber)
+
+Not exported
+
+=cut
+
sub currentborrower {
-# Original subroutine for Circ2.pm
+
+ # Original subroutine for Circ2.pm
my ($itemnumber) = @_;
- my $dbh = C4::Context->dbh;
+ my $dbh = C4::Context->dbh;
my $q_itemnumber = $dbh->quote($itemnumber);
- my $sth=$dbh->prepare("select borrowers.borrowernumber from
+ 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");
+ NULL"
+ );
$sth->execute;
my ($borrower) = $sth->fetchrow;
- return($borrower);
+ 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')
+=head2 checkreserve_to_delete
+
+( $resbor, $resrec ) = &checkreserve_to_delete($env,$dbh,$itemnum);
+
+=cut
+
+sub checkreserve_to_delete {
+
+ # Stolen from Main.pm
+ # Check for reserves for biblio
+ my ( $env, $dbh, $itemnum ) = @_;
+ my $resbor = "";
+ my $sth = $dbh->prepare(
+ "select * from reserves,items
+ where (items.itemnumber = ?)
and (reserves.cancellationdate is NULL)
and (items.biblionumber = reserves.biblionumber)
and ((reserves.found = 'W')
or (reserves.found is null))
- order by priority";
- 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);
+ order by priority"
+ );
+ $sth->execute($itemnum);
+ my $resrec;
+ my $data = $sth->fetchrow_hashref;
+ while ( $data && $resbor eq '' ) {
+ $resrec = $data;
+ my $const = $data->{'constrainttype'};
+ if ( $const eq "a" ) {
+ $resbor = $data->{'borrowernumber'};
+ }
+ else {
+ my $found = 0;
+ my $csth = $dbh->prepare(
+ "select * from reserveconstraints,items
+ where (borrowernumber=?)
+ and reservedate=?
+ and reserveconstraints.biblionumber=?
+ and (items.itemnumber=? and
+ items.biblioitemnumber = reserveconstraints.biblioitemnumber)"
+ );
+ $csth->execute(
+ $data->{'borrowernumber'},
+ $data->{'biblionumber'},
+ $data->{'reservedate'}, $itemnum
+ );
+ if ( my $cdata = $csth->fetchrow_hashref ) { $found = 1; }
+ if ( $const eq 'o' ) {
+ if ( $found eq 1 ) { $resbor = $data->{'borrowernumber'}; }
+ }
+ else {
+ if ( $found eq 0 ) { $resbor = $data->{'borrowernumber'}; }
+ }
+ $csth->finish();
+ }
+ $data = $sth->fetchrow_hashref;
+ }
+ $sth->finish;
+ return ( $resbor, $resrec );
}
-=item currentissues
+=head2 currentissues
- $issues = ¤tissues($env, $borrower);
+$issues = ¤tissues($env, $borrower);
Returns a list of books currently on loan to a patron.
Koha database for that particular item.
=cut
+
#'
sub currentissues {
-# New subroutine for Circ2.pm
- my ($env, $borrower) = @_;
+
+ # New subroutine for Circ2.pm
+ my ( $env, $borrower ) = @_;
my $dbh = C4::Context->dbh;
my %currentissues;
- my $counter=1;
+ my $counter = 1;
my $borrowernumber = $borrower->{'borrowernumber'};
- my $crit='';
+ my $crit = '';
# Figure out whether to get the books issued today, or earlier.
# FIXME - $env->{todaysissues} and $env->{nottodaysissues} can
# 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%') ";
+ 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++;
+ my $sth = $dbh->prepare(
+ "select * from issues,items,biblioitems,biblio where
+ 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"
+ );
+ $sth->execute($borrowernumber);
+ 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);
+ return ( \%currentissues );
}
-=item getissues
+=head2 getissues
- $issues = &getissues($borrowernumber);
+$issues = &getissues($borrowernumber);
Returns the set of books currently on loan to a patron.
of the Koha database.
=cut
+
#'
sub getissues {
-# New subroutine for Circ2.pm
- my ($borrower) = @_;
- my $dbh = C4::Context->dbh;
+
+ # 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);
+ my $select = "
+ SELECT items.*,
+ issues.timestamp AS timestamp,
+ issues.date_due AS date_due,
+ items.barcode AS barcode,
+ biblio.title AS title,
+ biblio.author AS author,
+ biblioitems.dewey AS dewey,
+ itemtypes.description AS itemtype,
+ biblioitems.subclass AS subclass,
+ biblioitems.ccode AS ccode,
+ biblioitems.isbn AS isbn,
+ biblioitems.classification AS classification
+ FROM items
+ LEFT JOIN issues ON issues.itemnumber = items.itemnumber
+ LEFT JOIN biblio ON biblio.biblionumber = items.biblionumber
+ LEFT JOIN biblioitems ON items.biblioitemnumber = biblioitems.biblioitemnumber
+ LEFT JOIN itemtypes ON itemtypes.itemtype = biblioitems.itemtype
+ WHERE issues.borrowernumber = ?
+ AND issues.returndate IS NULL
+ ORDER BY issues.date_due DESC
+ ";
+ 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.
+
+ 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);
+ 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);
-}
+=head2 GetIssuesFromBiblio
-# 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);
+$issues = GetIssuesFromBiblio($biblionumber);
+
+this function get all issues from a biblionumber.
+
+Return:
+C<$issues> is a reference to array which each value is ref-to-hash. This ref-to-hash containts all column from
+tables issues and the firstname,surname & cardnumber from borrowers.
+
+=cut
+
+sub GetIssuesFromBiblio {
+ my $biblionumber = shift;
+ return undef unless $biblionumber;
+ my $dbh = C4::Context->dbh;
+ my $query = "
+ SELECT issues.*,biblio.biblionumber,biblio.title, biblio.author,borrowers.cardnumber,borrowers.surname,borrowers.firstname
+ FROM issues
+ LEFT JOIN borrowers ON borrowers.borrowernumber = issues.borrowernumber
+ LEFT JOIN items ON issues.itemnumber = items.itemnumber
+ LEFT JOIN biblioitems ON items.itemnumber = biblioitems.biblioitemnumber
+ LEFT JOIN biblio ON biblio.biblionumber = items.biblioitemnumber
+ WHERE biblio.biblionumber = ?
+ ORDER BY issues.timestamp
+ ";
+ my $sth = $dbh->prepare($query);
+ $sth->execute($biblionumber);
+
+ my @issues;
+ while ( my $data = $sth->fetchrow_hashref ) {
+ push @issues, $data;
+ }
+ return \@issues;
}
-# FIXME - This is identical to &C4::Circulation::Renewals::renewstatus.
-# Pick one and stick with it.
+=head2 renewstatus
+
+$ok = &renewstatus($env, $dbh, $borrowernumber, $itemnumber);
+
+Find out whether a borrowed item may be renewed.
+
+C<$env> is ignored.
+
+C<$dbh> is a DBI handle to the Koha database.
+
+C<$borrowernumber> is the borrower number of the patron who currently
+has the item on loan.
+
+C<$itemnumber> is the number of the item to renew.
+
+C<$renewstatus> returns a true value iff the item may be renewed. The
+item must currently be on loan to the specified borrower; renewals
+must be allowed for the item's type; and the borrower must not have
+already renewed the loan.
+
+=cut
+
sub renewstatus {
-# 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);
+
+ # check renewal status
+ my ( $env, $borrowernumber, $itemno ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $renews = 1;
+ my $renewokay = 0;
+
+ # Look in the issues table for this item, lent to this borrower,
+ # and not yet returned.
+
+ # FIXME - I think this function could be redone to use only one SQL call.
+ my $sth1 = $dbh->prepare(
+ "select * from issues
+ where (borrowernumber = ?)
+ and (itemnumber = ?)
+ and returndate is null"
+ );
+ $sth1->execute( $borrowernumber, $itemno );
+ if ( my $data1 = $sth1->fetchrow_hashref ) {
+
+ # Found a matching item
+
+ # See if this item may be renewed. This query is convoluted
+ # because it's a bit messy: given the item number, we need to find
+ # the biblioitem, which gives us the itemtype, which tells us
+ # whether it may be renewed.
+ my $sth2 = $dbh->prepare(
+ "SELECT renewalsallowed from items,biblioitems,itemtypes
+ where (items.itemnumber = ?)
+ and (items.biblioitemnumber = biblioitems.biblioitemnumber)
+ and (biblioitems.itemtype = itemtypes.itemtype)"
+ );
+ $sth2->execute($itemno);
+ if ( my $data2 = $sth2->fetchrow_hashref ) {
+ $renews = $data2->{'renewalsallowed'};
+ }
+ if ( $renews && $renews > $data1->{'renewals'} ) {
+ $renewokay = 1;
+ }
+ $sth2->finish;
+ my ( $resfound, $resrec ) = CheckReserves($itemno);
+ if ($resfound) {
+ $renewokay = 0;
+ }
+ ( $resfound, $resrec ) = CheckReserves($itemno);
+ if ($resfound) {
+ $renewokay = 0;
+ }
+
+ }
+ $sth1->finish;
+ return ($renewokay);
}
+=head2 renewbook
+
+&renewbook($env, $borrowernumber, $itemnumber, $datedue);
+
+Renews a loan.
+
+C<$env-E<gt>{branchcode}> is the code of the branch where the
+renewal is taking place.
+
+C<$env-E<gt>{usercode}> is the value to log in C<statistics.usercode>
+in the Koha database.
+
+C<$borrowernumber> is the borrower number of the patron who currently
+has the item.
+
+C<$itemnumber> is the number of the item to renew.
+
+C<$datedue> can be used to set the due date. If C<$datedue> is the
+empty string, C<&renewbook> will calculate the due date automatically
+from the book's item type. If you wish to set the due date manually,
+C<$datedue> should be in the form YYYY-MM-DD.
+
+=cut
+
sub renewbook {
-# 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'}
+
+ # mark book as renewed
+ my ( $env, $borrowernumber, $itemno, $datedue ) = @_;
+ my $dbh = C4::Context->dbh;
+
+ # If the due date wasn't specified, calculate it by adding the
+ # book's loan length to today's date.
+ if ( $datedue eq "" ) {
+
+ #debug_msg($env, "getting date");
+ my $iteminformation = getiteminformation( $itemno, 0 );
+ my $borrower = getpatroninformation( $env, $borrowernumber, 0 );
+ my $loanlength = getLoanLength(
+ $borrower->{'categorycode'},
+ $iteminformation->{'itemtype'},
+ $borrower->{'branchcode'}
+ );
+ my ( $due_year, $due_month, $due_day ) =
+ Add_Delta_DHMS( Today_and_Now(), $loanlength, 0, 0, 0 );
+ $datedue = "$due_year-$due_month-$due_day";
+
+ #$datedue = UnixDate(DateCalc("today","$loanlength days"),"%Y-%m-%d");
}
+
+ # Find the issues record for this book
+ my $sth =
+ $dbh->prepare(
+"select * from issues where borrowernumber=? and itemnumber=? and returndate is null"
+ );
+ $sth->execute( $borrowernumber, $itemno );
+ my $issuedata = $sth->fetchrow_hashref;
$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);
+
+ # Update the issues record to have the new due date, and a new count
+ # of how many times it has been renewed.
+ my $renews = $issuedata->{'renewals'} + 1;
+ $sth = $dbh->prepare(
+ "update issues set date_due = ?, renewals = ?
+ where borrowernumber=? and itemnumber=? and returndate is null"
+ );
+ $sth->execute( $datedue, $renews, $borrowernumber, $itemno );
+ $sth->finish;
+
+ # Log the renewal
+ UpdateStats( $env, $env->{'branchcode'}, 'renew', '', '', $itemno );
+
+ # Charge a new rental fee, if applicable?
+ my ( $charge, $type ) = calc_charges( $env, $itemno, $borrowernumber );
+ if ( $charge > 0 ) {
+ my $accountno = getnextacctno( $env, $borrowernumber, $dbh );
+ my $item = getiteminformation($itemno);
+ $sth = $dbh->prepare(
+"Insert into accountlines (borrowernumber,accountno,date,amount,description,accounttype,amountoutstanding,itemnumber)
+ values (?,?,now(),?,?,?,?,?)"
+ );
+ $sth->execute( $borrowernumber, $accountno, $charge,
+ "Renewal of Rental Item $item->{'title'} $item->{'barcode'}",
+ 'Rent', $charge, $itemno );
+ $sth->finish;
+ }
+
+ # return();
}
-# 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.
+=head2 calc_charges
+
+($charge, $item_type) = &calc_charges($env, $itemnumber, $borrowernumber);
+
+Calculate how much it would cost for a given patron to borrow a given
+item, including any applicable discounts.
+
+C<$env> is ignored.
+
+C<$itemnumber> is the item number of item the patron wishes to borrow.
+
+C<$borrowernumber> is the patron's borrower number.
+
+C<&calc_charges> returns two values: C<$charge> is the rental charge,
+and C<$item_type> is the code for the item's item type (e.g., C<VID>
+if it's a video).
+
+=cut
+
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");
+
+ # calculate charges due
+ my ( $env, $itemno, $borrowernumber ) = @_;
+ my $charge = 0;
+ my $dbh = C4::Context->dbh;
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;
+
+ # Get the book's item type and rental charge (via its biblioitem).
+ my $sth1 = $dbh->prepare(
+ "select itemtypes.itemtype,rentalcharge from items,biblioitems,itemtypes
+ where (items.itemnumber =?)
+ and (biblioitems.biblioitemnumber = items.biblioitemnumber)
+ and (biblioitems.itemtype = itemtypes.itemtype)"
+ );
+ $sth1->execute($itemno);
+ if ( my $data1 = $sth1->fetchrow_hashref ) {
+ $item_type = $data1->{'itemtype'};
+ $charge = $data1->{'rentalcharge'};
+ my $q2 = "select rentaldiscount from issuingrules,borrowers
+ where (borrowers.borrowernumber = ?)
+ and (borrowers.categorycode = issuingrules.categorycode)
+ and (issuingrules.itemtype = ?)";
+ my $sth2 = $dbh->prepare($q2);
+ $sth2->execute( $borrowernumber, $item_type );
+ if ( my $data2 = $sth2->fetchrow_hashref ) {
+ my $discount = $data2->{'rentaldiscount'};
+ if ( $discount eq 'NULL' ) {
+ $discount = 0;
+ }
+ $charge = ( $charge * ( 100 - $discount ) ) / 100;
+ }
+ $sth2->finish;
}
+
$sth1->finish;
-# close FILE;
- return ($charge, $item_type);
+ return ( $charge, $item_type );
}
+=head2 createcharge
+
+&createcharge( $env, $dbh, $itemno, $borrowernumber, $charge )
+
+=cut
+
# 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;
- }
+ #Stolen from Issues.pm
+ my ( $env, $dbh, $itemno, $borrowernumber, $charge ) = @_;
+ my $nextaccntno = getnextacctno( $env, $borrowernumber, $dbh );
+ my $query ="
+ INSERT INTO accountlines
+ (borrowernumber, itemnumber, accountno,
+ date, amount, description, accounttype,
+ amountoutstanding)
+ VALUES (?, ?, ?,now(), ?, 'Rental', 'Rent',?)
+ ";
+ my $sth = $dbh->prepare($query);
+ $sth->execute( $borrowernumber, $itemno, $nextaccntno, $charge, $charge );
$sth->finish;
- return($nextaccntno);
}
-=item find_reserves
+=head2 find_reserves
- ($status, $record) = &find_reserves($itemnumber);
+($status, $record) = &find_reserves($itemnumber);
Looks up an item in the reserves.
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
+
+ # Stolen from Returns.pm
+ warn "!!!!! SHOULD NOT BE HERE : Circ2::find_reserves is deprecated !!!";
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 ($itemdata) = getiteminformation( $itemno, 0 );
+ my $bibno = $dbh->quote( $itemdata->{'biblionumber'} );
+ my $bibitm = $dbh->quote( $itemdata->{'biblioitemnumber'} );
+ my $sth =
+ $dbh->prepare(
+"select * from reserves where ((found = 'W') or (found is null)) and biblionumber = ? and cancellationdate is NULL order by priority, reservedate"
+ );
+ $sth->execute($bibno);
my $resfound = 0;
my $resrec;
my $lastrec;
-# print $query;
+
+ # 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.
- }
+ 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 $consth =
+ $dbh->prepare(
+ "SELECT * FROM reserveconstraints
+ WHERE borrowernumber = ?
+ AND reservedate = ?
+ AND biblionumber = ?
+ AND biblioitemnumber = ?"
+ );
+ $consth->execute( $brn, $rdate, $bibno, $bibitm );
+ if ( my $conrec = $consth->fetchrow_hashref ) {
+ if ( $resrec->{'constrainttype'} eq "o" ) {
+ $resfound = 1;
+ }
+ }
+ $consth->finish;
+ }
+ }
+ if ($resfound) {
+ my $updsth =
+ $dbh->prepare(
+ "UPDATE reserves
+ SET found = 'W',
+ itemnumber = ?
+ WHERE borrowernumber = ?
+ AND reservedate = ?
+ AND biblionumber = ?"
+ );
+ $updsth->execute( $itemno, $brn, $rdate, $bibno );
+ $updsth->finish;
+
+ # FIXME - "last;" here to break out of the loop early.
+ }
}
$sth->finish;
- return ($resfound,$lastrec);
+ return ( $resfound, $lastrec );
}
-1;
-__END__
+=head2 fixdate
+
+( $date, $invalidduedate ) = fixdate( $year, $month, $day );
+
+=cut
+
+sub fixdate {
+ my ( $year, $month, $day ) = @_;
+ my $invalidduedate;
+ my $date;
+ if ( $year && $month && $day ) {
+ if ( ( $year eq 0 ) && ( $month eq 0 ) && ( $year eq 0 ) ) {
+
+ # $env{'datedue'}='';
+ }
+ else {
+ if ( ( $year eq 0 ) || ( $month eq 0 ) || ( $year eq 0 ) ) {
+ $invalidduedate = 1;
+ }
+ else {
+ if (
+ ( $day > 30 )
+ && ( ( $month == 4 )
+ || ( $month == 6 )
+ || ( $month == 9 )
+ || ( $month == 11 ) )
+ )
+ {
+ $invalidduedate = 1;
+ }
+ elsif ( ( $day > 29 ) && ( $month == 2 ) ) {
+ $invalidduedate = 1;
+ }
+ elsif (
+ ( $month == 2 )
+ && ( $day > 28 )
+ && ( ( $year % 4 )
+ && ( ( !( $year % 100 ) || ( $year % 400 ) ) ) )
+ )
+ {
+ $invalidduedate = 1;
+ }
+ else {
+ $date = "$year-$month-$day";
+ }
+ }
+ }
+ }
+ return ( $date, $invalidduedate );
+}
+
+=head2 get_current_return_date_of
+
+&get_current_return_date_of(@itemnumber);
+
+=cut
+
+sub get_current_return_date_of {
+ my (@itemnumbers) = @_;
+ my $query = '
+ SELECT
+ date_due,
+ itemnumber
+ FROM issues
+ WHERE itemnumber IN (' . join( ',', @itemnumbers ) . ')
+ AND returndate IS NULL
+ ';
+ return get_infos_of( $query, 'itemnumber', 'date_due' );
+}
+
+=head2 get_transfert_infos
+
+get_transfert_infos($itemnumber);
+
+=cut
+
+sub get_transfert_infos {
+ my ($itemnumber) = @_;
+
+ my $dbh = C4::Context->dbh;
+
+ my $query = '
+ SELECT datesent,
+ frombranch,
+ tobranch
+ FROM branchtransfers
+ WHERE itemnumber = ?
+ AND datearrived IS NULL
+ ';
+ my $sth = $dbh->prepare($query);
+ $sth->execute($itemnumber);
+ my @row = $sth->fetchrow_array();
+ $sth->finish;
+ return @row;
+}
+
+=head2 DeleteTransfer
+
+&DeleteTransfer($itemnumber);
+
+=cut
+
+sub DeleteTransfer {
+ my ($itemnumber) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare(
+ "DELETE FROM branchtransfers
+ WHERE itemnumber=?
+ AND datearrived IS NULL "
+ );
+ $sth->execute($itemnumber);
+ $sth->finish;
+}
+
+=head2 GetTransfersFromBib
+
+@results = GetTransfersFromBib($frombranch,$tobranch);
+
+=cut
+
+sub GetTransfersFromBib {
+ my ( $frombranch, $tobranch ) = @_;
+ return unless ( $frombranch && $tobranch );
+ my $dbh = C4::Context->dbh;
+ my $query = "
+ SELECT itemnumber,datesent,frombranch
+ FROM branchtransfers
+ WHERE frombranch=?
+ AND tobranch=?
+ AND datearrived IS NULL
+ ";
+ my $sth = $dbh->prepare($query);
+ $sth->execute( $frombranch, $tobranch );
+ my @gettransfers;
+ my $i = 0;
+
+ while ( my $data = $sth->fetchrow_hashref ) {
+ $gettransfers[$i] = $data;
+ $i++;
+ }
+ $sth->finish;
+ return (@gettransfers);
+}
+
+=head2 GetReservesToBranch
+
+@transreserv = GetReservesToBranch( $frombranch, $default );
+
+=cut
+
+sub GetReservesToBranch {
+ my ( $frombranch, $default ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare(
+ "SELECT borrowernumber,reservedate,itemnumber,timestamp
+ FROM reserves
+ WHERE priority='0' AND cancellationdate is null
+ AND branchcode=?
+ AND branchcode!=?
+ AND found IS NULL "
+ );
+ $sth->execute( $frombranch, $default );
+ my @transreserv;
+ my $i = 0;
+ while ( my $data = $sth->fetchrow_hashref ) {
+ $transreserv[$i] = $data;
+ $i++;
+ }
+ $sth->finish;
+ return (@transreserv);
+}
+
+=head2 GetReservesForBranch
+
+@transreserv = GetReservesForBranch($frombranch);
+
+=cut
+
+sub GetReservesForBranch {
+ my ($frombranch) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare( "
+ SELECT borrowernumber,reservedate,itemnumber,waitingdate
+ FROM reserves
+ WHERE priority='0'
+ AND cancellationdate IS NULL
+ AND found='W'
+ AND branchcode=?
+ ORDER BY waitingdate" );
+ $sth->execute($frombranch);
+ my @transreserv;
+ my $i = 0;
+ while ( my $data = $sth->fetchrow_hashref ) {
+ $transreserv[$i] = $data;
+ $i++;
+ }
+ $sth->finish;
+ return (@transreserv);
+}
+
+=head2 checktransferts
+
+@tranferts = checktransferts($itemnumber);
+
+=cut
+
+sub checktransferts {
+ my ($itemnumber) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare(
+ "SELECT datesent,frombranch,tobranch FROM branchtransfers
+ WHERE itemnumber = ? AND datearrived IS NULL"
+ );
+ $sth->execute($itemnumber);
+ my @tranferts = $sth->fetchrow_array;
+ $sth->finish;
+
+ return (@tranferts);
+}
+
+=head2 CheckItemNotify
+
+Sql request to check if the document has alreday been notified
+this function is not exported, only used with GetOverduesForBranch
+
+=cut
+
+sub CheckItemNotify {
+ my ($notify_id,$notify_level,$itemnumber) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("
+ SELECT COUNT(*) FROM notifys
+ WHERE notify_id = ?
+ AND notify_level = ?
+ AND itemnumber = ? ");
+ $sth->execute($notify_id,$notify_level,$itemnumber);
+ my $notified = $sth->fetchrow;
+$sth->finish;
+return ($notified);
+}
+
+=head2 GetOverduesForBranch
+
+Sql request for display all information for branchoverdues.pl
+2 possibilities : with or without departement .
+display is filtered by branch
+
+=cut
+
+sub GetOverduesForBranch {
+ my ( $branch, $departement) = @_;
+ if ( not $departement ) {
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("
+ SELECT
+ borrowers.surname,
+ borrowers.firstname,
+ biblio.title,
+ itemtypes.description,
+ issues.date_due,
+ issues.returndate,
+ branches.branchname,
+ items.barcode,
+ borrowers.phone,
+ borrowers.email,
+ items.itemcallnumber,
+ borrowers.borrowernumber,
+ items.itemnumber,
+ biblio.biblionumber,
+ issues.branchcode,
+ accountlines.notify_id,
+ accountlines.notify_level,
+ items.location,
+ accountlines.amountoutstanding
+ FROM issues,borrowers,biblio,biblioitems,itemtypes,items,branches,accountlines
+ WHERE ( issues.returndate is null)
+ AND ( accountlines.amountoutstanding != '0.000000')
+ AND ( accountlines.accounttype = 'FU')
+ AND ( issues.borrowernumber = accountlines.borrowernumber )
+ AND ( issues.itemnumber = accountlines.itemnumber )
+ AND ( borrowers.borrowernumber = issues.borrowernumber )
+ AND ( biblio.biblionumber = biblioitems.biblionumber )
+ AND ( biblioitems.biblionumber = items.biblionumber )
+ AND ( itemtypes.itemtype = biblioitems.itemtype )
+ AND ( items.itemnumber = issues.itemnumber )
+ AND ( branches.branchcode = issues.branchcode )
+ AND (issues.branchcode = ?)
+ AND (issues.date_due <= NOW())
+ ORDER BY borrowers.surname
+ ");
+ $sth->execute($branch);
+ my @getoverdues;
+ my $i = 0;
+ while ( my $data = $sth->fetchrow_hashref ) {
+ #check if the document has already been notified
+ my $countnotify = CheckItemNotify($data->{'notify_id'},$data->{'notify_level'},$data->{'itemnumber'});
+ if ($countnotify eq '0'){
+ $getoverdues[$i] = $data;
+ $i++;
+ }
+ }
+ return (@getoverdues);
+ $sth->finish;
+ }
+ else {
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare( "
+ SELECT borrowers.surname,
+ borrowers.firstname,
+ biblio.title,
+ itemtypes.description,
+ issues.date_due,
+ issues.returndate,
+ branches.branchname,
+ items.barcode,
+ borrowers.phone,
+ borrowers.email,
+ items.itemcallnumber,
+ borrowers.borrowernumber,
+ items.itemnumber,
+ biblio.biblionumber,
+ issues.branchcode,
+ accountlines.notify_id,
+ accountlines.notify_level,
+ items.location,
+ accountlines.amountoutstanding
+ FROM issues,borrowers,biblio,biblioitems,itemtypes,items,branches,accountlines
+ WHERE ( issues.returndate is null )
+ AND ( accountlines.amountoutstanding != '0.000000')
+ AND ( accountlines.accounttype = 'FU')
+ AND ( issues.borrowernumber = accountlines.borrowernumber )
+ AND ( issues.itemnumber = accountlines.itemnumber )
+ AND ( borrowers.borrowernumber = issues.borrowernumber )
+ AND ( biblio.biblionumber = biblioitems.biblionumber )
+ AND ( biblioitems.biblionumber = items.biblionumber )
+ AND ( itemtypes.itemtype = biblioitems.itemtype )
+ AND ( items.itemnumber = issues.itemnumber )
+ AND ( branches.branchcode = issues.branchcode )
+ AND (issues.branchcode = ? AND items.location = ?)
+ AND (issues.date_due <= NOW())
+ ORDER BY borrowers.surname
+ " );
+ $sth->execute( $branch, $departement);
+ my @getoverdues;
+ my $i = 0;
+ while ( my $data = $sth->fetchrow_hashref ) {
+ #check if the document has already been notified
+ my $countnotify = CheckItemNotify($data->{'notify_id'},$data->{'notify_level'},$data->{'itemnumber'});
+ if ($countnotify eq '0'){
+ $getoverdues[$i] = $data;
+ $i++;
+ }
+ }
+ $sth->finish;
+ return (@getoverdues);
+ }
+}
+
+
+=head2 AddNotifyLine
+
+&AddNotifyLine($borrowernumber, $itemnumber, $overduelevel, $method, $notifyId)
+
+Creat a line into notify, if the method is phone, the notification_send_date is implemented to
+
+=cut
+
+sub AddNotifyLine {
+ my ( $borrowernumber, $itemnumber, $overduelevel, $method, $notifyId ) = @_;
+ if ( $method eq "phone" ) {
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare(
+ "INSERT INTO notifys (borrowernumber,itemnumber,notify_date,notify_send_date,notify_level,method,notify_id)
+ VALUES (?,?,now(),now(),?,?,?)"
+ );
+ $sth->execute( $borrowernumber, $itemnumber, $overduelevel, $method,
+ $notifyId );
+ $sth->finish;
+ }
+ else {
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare(
+ "INSERT INTO notifys (borrowernumber,itemnumber,notify_date,notify_level,method,notify_id)
+ VALUES (?,?,now(),?,?,?)"
+ );
+ $sth->execute( $borrowernumber, $itemnumber, $overduelevel, $method,
+ $notifyId );
+ $sth->finish;
+ }
+ return 1;
+}
+
+=head2 RemoveNotifyLine
+
+&RemoveNotifyLine( $borrowernumber, $itemnumber, $notify_date );
+
+Cancel a notification
+
+=cut
+
+sub RemoveNotifyLine {
+ my ( $borrowernumber, $itemnumber, $notify_date ) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare(
+ "DELETE FROM notifys
+ WHERE
+ borrowernumber=?
+ AND itemnumber=?
+ AND notify_date=?"
+ );
+ $sth->execute( $borrowernumber, $itemnumber, $notify_date );
+ $sth->finish;
+ return 1;
+}
+
+=head2 AnonymiseIssueHistory
+
+$rows = AnonymiseIssueHistory($borrowernumber,$date)
+
+This function write NULL instead of C<$borrowernumber> given on input arg into the table issues.
+if C<$borrowernumber> is not set, it will delete the issue history for all borrower older than C<$date>.
+
+return the number of affected rows.
+
+=cut
+
+sub AnonymiseIssueHistory {
+ my $date = shift;
+ my $borrowernumber = shift;
+ my $dbh = C4::Context->dbh;
+ my $query = "
+ UPDATE issues
+ SET borrowernumber = NULL
+ WHERE returndate < '".$date."'
+ AND borrowernumber IS NOT NULL
+ ";
+ $query .= " AND borrowernumber = '".$borrowernumber."'" if defined $borrowernumber;
+ my $rows_affected = $dbh->do($query);
+ return $rows_affected;
+}
+
+=head2 GetItemsLost
+
+$items = GetItemsLost($where,$orderby);
+
+This function get the items lost into C<$items>.
+
+=over 2
+
+=item input:
+C<$where> is a hashref. it containts a field of the items table as key
+and the value to match as value.
+C<$orderby> is a field of the items table.
+
+=item return:
+C<$items> is a reference to an array full of hasref which keys are items' table column.
+
+=item usage in the perl script:
+
+my %where;
+$where{barcode} = 0001548;
+my $items = GetLostItems( \%where, "homebranch" );
+$template->param(itemsloop => $items);
=back
+=cut
+
+sub GetLostItems {
+ # Getting input args.
+ my $where = shift;
+ my $orderby = shift;
+ my $dbh = C4::Context->dbh;
+
+ my $query = "
+ SELECT *
+ FROM items
+ WHERE itemlost IS NOT NULL
+ AND itemlost <> 0
+ ";
+ foreach my $key (keys %$where) {
+ $query .= " AND " . $key . " LIKE '%" . $where->{$key} . "%'";
+ }
+ $query .= " ORDER BY ".$orderby if defined $orderby;
+
+ my $sth = $dbh->prepare($query);
+ $sth->execute;
+ my @items;
+ while ( my $row = $sth->fetchrow_hashref ){
+ push @items, $row;
+ }
+ return \@items;
+}
+
+=head2 updateWrongTransfer
+
+$items = updateWrongTransfer($itemNumber,$borrowernumber,$waitingAtLibrary,$FromLibrary);
+
+This function validate the line of brachtransfer but with the wrong destination (mistake from a librarian ...), and create a new line in branchtransfer from the actual library to the original library of reservation
+
+=cut
+
+sub updateWrongTransfer {
+ my ( $itemNumber,$waitingAtLibrary,$FromLibrary ) = @_;
+ my $dbh = C4::Context->dbh;
+# first step validate the actual line of transfert .
+ my $sth =
+ $dbh->prepare(
+ "update branchtransfers set datearrived = now(),tobranch=?,comments='wrongtransfer' where itemnumber= ? AND datearrived IS NULL"
+ );
+ $sth->execute($FromLibrary,$itemNumber);
+ $sth->finish;
+
+# second step create a new line of branchtransfer to the right location .
+ dotransfer($itemNumber, $FromLibrary, $waitingAtLibrary);
+
+#third step changing holdingbranch of item
+ UpdateHoldingbranch($FromLibrary,$itemNumber);
+}
+
+=head2 UpdateHoldingbranch
+
+$items = UpdateHoldingbranch($branch,$itmenumber);
+Simple methode for updating hodlingbranch in items BDD line
+=cut
+
+sub UpdateHoldingbranch {
+ my ( $branch,$itmenumber ) = @_;
+ my $dbh = C4::Context->dbh;
+# first step validate the actual line of transfert .
+ my $sth =
+ $dbh->prepare(
+ "update items set holdingbranch = ? where itemnumber= ?"
+ );
+ $sth->execute($branch,$itmenumber);
+ $sth->finish;
+
+
+}
+
+1;
+
+__END__
+
=head1 AUTHOR
Koha Developement team <info@koha.org>
=cut
+
projects / koha.git / blobdiff