1 package C4::Circulation::Circ2;
3 # Copyright 2000-2002 Katipo Communications
5 # This file is part of Koha.
7 # Koha is free software; you can redistribute it and/or modify it under the
8 # terms of the GNU General Public License as published by the Free Software
9 # Foundation; either version 2 of the License, or (at your option) any later
12 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
13 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
14 # A PARTICULAR PURPOSE. See the GNU General Public License for more details.
16 # You should have received a copy of the GNU General Public License along with
17 # Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
18 # Suite 330, Boston, MA 02111-1307 USA
37 use POSIX qw(strftime);
38 use C4::Branch; # GetBranches
39 use C4::Log; # logaction
41 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
43 # set the version for version checking
44 $VERSION = do { my @v = '$Revision$' =~ /\d+/g; shift(@v).".".join( "_", map { sprintf "%03d", $_ } @v ); };
48 C4::Circulation::Circ2 - Koha circulation module
52 use C4::Circulation::Circ2;
56 The functions in this module deal with circulation, issues, and
57 returns, as well as general information about the library.
58 Also deals with stocktaking.
82 &get_current_return_date_of
94 &AnonymiseIssueHistory
103 Mark item as seen. Is called when an item is issued, returned or manually marked during inventory/stocktaking
104 C<$itemnum> is the item number
110 my $dbh = C4::Context->dbh;
113 "update items set itemlost=0, datelastseen = now() where items.itemnumber = ?"
115 $sth->execute($itemnum);
122 Mark item as borrowed. Is called when an item is issued.
123 C<$itemnum> is the item number
129 my $dbh = C4::Context->dbh;
132 "update items set itemlost=0, datelastborrowed = now() where items.itemnumber = ?"
134 $sth->execute($itemnum);
138 =head2 GetItemsForInventory
140 $itemlist = GetItemsForInventory($minlocation,$maxlocation,$datelastseen,$offset,$size)
142 Retrieve a list of title/authors/barcode/callnumber, for biblio inventory.
144 The sub returns a list of hashes, containing itemnumber, author, title, barcode & item callnumber.
145 It is ordered by callnumber,title.
147 The minlocation & maxlocation parameters are used to specify a range of item callnumbers
148 the datelastseen can be used to specify that you want to see items not seen since a past date only.
149 offset & size can be used to retrieve only a part of the whole listing (defaut behaviour)
153 sub GetItemsForInventory {
154 my ( $minlocation, $maxlocation, $datelastseen, $branch, $offset, $size ) = @_;
155 my $dbh = C4::Context->dbh;
159 "SELECT itemnumber,barcode,itemcallnumber,title,author,datelastseen
161 LEFT JOIN biblio ON items.biblionumber=biblio.biblionumber
162 WHERE itemcallnumber>= ?
163 AND itemcallnumber <=?
164 AND (datelastseen< ? OR datelastseen IS NULL)";
165 $query.= " AND items.homebranch=".$dbh->quote($branch) if $branch;
166 $query .= " ORDER BY itemcallnumber,title";
167 $sth = $dbh->prepare($query);
168 $sth->execute( $minlocation, $maxlocation, $datelastseen );
172 SELECT itemnumber,barcode,itemcallnumber,title,author,datelastseen
174 LEFT JOIN biblio ON items.biblionumber=biblio.biblionumber
175 WHERE itemcallnumber>= ?
176 AND itemcallnumber <=?";
177 $query.= " AND items.homebranch=".$dbh->quote($branch) if $branch;
178 $query .= " ORDER BY itemcallnumber,title";
179 $sth = $dbh->prepare($query);
180 $sth->execute( $minlocation, $maxlocation );
183 while ( my $row = $sth->fetchrow_hashref ) {
184 $offset-- if ($offset);
185 if ( ( !$offset ) && $size ) {
193 =head2 getpatroninformation
195 ($borrower, $flags) = &getpatroninformation($env, $borrowernumber, $cardnumber);
197 Looks up a patron and returns information about him or her. If
198 C<$borrowernumber> is true (nonzero), C<&getpatroninformation> looks
199 up the borrower by number; otherwise, it looks up the borrower by card
202 C<$env> is effectively ignored, but should be a reference-to-hash.
204 C<$borrower> is a reference-to-hash whose keys are the fields of the
205 borrowers table in the Koha database. In addition,
206 C<$borrower-E<gt>{flags}> is a hash giving more detailed information
207 about the patron. Its keys act as flags :
209 if $borrower->{flags}->{LOST} {
210 # Patron's card was reported lost
213 Each flag has a C<message> key, giving a human-readable explanation of
214 the flag. If the state of a flag means that the patron should not be
215 allowed to borrow any more books, then it will have a C<noissues> key
218 The possible flags are:
224 =item Shows the patron's credit or debt, if any.
232 =item (Gone, no address.) Set if the patron has left without giving a
241 =item Set if the patron's card has been reported as lost.
249 =item Set if the patron has been debarred.
257 =item Any additional notes about the patron.
265 =item Set if the patron has overdue items. This flag has several keys:
267 C<$flags-E<gt>{ODUES}{itemlist}> is a reference-to-array listing the
268 overdue items. Its elements are references-to-hash, each describing an
269 overdue item. The keys are selected fields from the issues, biblio,
270 biblioitems, and items tables of the Koha database.
272 C<$flags-E<gt>{ODUES}{itemlist}> is a string giving a text listing of
273 the overdue items, one per line.
281 =item Set if any items that the patron has reserved are available.
283 C<$flags-E<gt>{WAITING}{itemlist}> is a reference-to-array listing the
284 available items. Each element is a reference-to-hash whose keys are
285 fields from the reserves table of the Koha database.
291 sub getpatroninformation {
292 my ( $env, $borrowernumber, $cardnumber ) = @_;
293 my $dbh = C4::Context->dbh;
296 if ($borrowernumber) {
297 $sth = $dbh->prepare("select * from borrowers where borrowernumber=?");
298 $sth->execute($borrowernumber);
300 elsif ($cardnumber) {
301 $sth = $dbh->prepare("select * from borrowers where cardnumber=?");
302 $sth->execute($cardnumber);
307 my $borrower = $sth->fetchrow_hashref;
308 my $amount = checkaccount( $env, $borrowernumber, $dbh );
309 $borrower->{'amountoutstanding'} = $amount;
310 my $flags = patronflags( $env, $borrower, $dbh );
313 $sth = $dbh->prepare("select bit,flag from userflags");
315 while ( my ( $bit, $flag ) = $sth->fetchrow ) {
316 if ( $borrower->{'flags'} && $borrower->{'flags'} & 2**$bit ) {
317 $accessflagshash->{$flag} = 1;
321 $borrower->{'flags'} = $flags;
322 $borrower->{'authflags'} = $accessflagshash;
324 # find out how long the membership lasts
327 "select enrolmentperiod from categories where categorycode = ?");
328 $sth->execute( $borrower->{'categorycode'} );
329 my $enrolment = $sth->fetchrow;
330 $borrower->{'enrolmentperiod'} = $enrolment;
331 return ($borrower); #, $flags, $accessflagshash);
336 =head3 $str = &decode($chunk);
340 =item Decodes a segment of a string emitted by a CueCat barcode scanner and
347 # FIXME - At least, I'm pretty sure this is for decoding CueCat stuff.
351 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789+-';
352 my @s = map { index( $seq, $_ ); } split( //, $encoded );
353 my $l = ( $#s + 1 ) % 4;
364 my $n = ( ( $s[0] << 6 | $s[1] ) << 6 | $s[2] ) << 6 | $s[3];
366 chr( ( $n >> 16 ) ^ 67 )
367 .chr( ( $n >> 8 & 255 ) ^ 67 )
368 .chr( ( $n & 255 ) ^ 67 );
371 $r = substr( $r, 0, length($r) - $l );
375 =head2 getiteminformation
377 $item = &getiteminformation($itemnumber, $barcode);
379 Looks up information about an item, given either its item number or
380 its barcode. If C<$itemnumber> is a nonzero value, it is used;
381 otherwise, C<$barcode> is used.
383 C<$item> is a reference-to-hash whose keys are fields from the biblio,
384 items, and biblioitems tables of the Koha database. It may also
385 contain the following keys:
391 =item The due date on this item, if it has been borrowed and not returned
392 yet. The date is in YYYY-MM-DD format.
400 =item True if the item may not be borrowed.
406 sub getiteminformation {
408 # returns a hash of item information given either the itemnumber or the barcode
409 my ( $itemnumber, $barcode ) = @_;
410 my $dbh = C4::Context->dbh;
416 from biblio,items,biblioitems
417 where items.itemnumber=? and biblio.biblionumber=items.biblionumber and biblioitems.biblioitemnumber = items.biblioitemnumber"
419 $sth->execute($itemnumber);
424 "select * from biblio,items,biblioitems where items.barcode=? and biblio.biblionumber=items.biblionumber and biblioitems.biblioitemnumber = items.biblioitemnumber"
426 $sth->execute($barcode);
431 my $iteminformation = $sth->fetchrow_hashref;
433 if ($iteminformation) {
435 $dbh->prepare("select date_due from issues where itemnumber=? and isnull(returndate)");
436 $sth->execute( $iteminformation->{'itemnumber'} );
437 my ($date_due) = $sth->fetchrow;
438 $iteminformation->{'date_due'} = $date_due;
440 ( $iteminformation->{'dewey'} == 0 )
441 && ( $iteminformation->{'dewey'} = '' );
442 $sth = $dbh->prepare("select * from itemtypes where itemtype=?");
443 $sth->execute( $iteminformation->{'itemtype'} );
444 my $itemtype = $sth->fetchrow_hashref;
446 # if specific item notforloan, don't use itemtype notforloan field.
447 # otherwise, use itemtype notforloan value to see if item can be issued.
448 $iteminformation->{'notforloan'} = $itemtype->{'notforloan'}
449 unless $iteminformation->{'notforloan'};
452 return ($iteminformation);
457 ($dotransfer, $messages, $iteminformation) = &transferbook($newbranch, $barcode, $ignore_reserves);
459 Transfers an item to a new branch. If the item is currently on loan, it is automatically returned before the actual transfer.
461 C<$newbranch> is the code for the branch to which the item should be transferred.
463 C<$barcode> is the barcode of the item to be transferred.
465 If C<$ignore_reserves> is true, C<&transferbook> ignores reserves.
466 Otherwise, if an item is reserved, the transfer fails.
468 Returns three values:
472 is true if the transfer was successful.
476 is a reference-to-hash which may have any of the following keys:
482 There is no item in the catalog with the given barcode. The value is C<$barcode>.
486 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.
488 =item C<DestinationEqualsHolding>
490 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.
494 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.
498 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>.
500 =item C<WasTransferred>
502 The item was eligible to be transferred. Barring problems communicating with the database, the transfer should indeed have succeeded. The value should be ignored.
509 # FIXME - This function tries to do too much, and its API is clumsy.
510 # If it didn't also return books, it could be used to change the home
511 # branch of a book while the book is on loan.
513 # Is there any point in returning the item information? The caller can
514 # look that up elsewhere if ve cares.
516 # This leaves the ($dotransfer, $messages) tuple. This seems clumsy.
517 # If the transfer succeeds, that's all the caller should need to know.
518 # Thus, this function could simply return 1 or 0 to indicate success
519 # or failure, and set $C4::Circulation::Circ2::errmsg in case of
520 # failure. Or this function could return undef if successful, and an
521 # error message in case of failure (this would feel more like C than
524 my ( $tbr, $barcode, $ignoreRs ) = @_;
528 my $branches = GetBranches();
529 my $iteminformation = getiteminformation( 0, $barcode );
532 if ( not $iteminformation ) {
533 $messages->{'BadBarcode'} = $barcode;
537 # get branches of book...
538 my $hbr = $iteminformation->{'homebranch'};
539 my $fbr = $iteminformation->{'holdingbranch'};
542 if ( $hbr && $branches->{$hbr}->{'PE'} ) {
543 $messages->{'IsPermanent'} = $hbr;
546 # can't transfer book if is already there....
547 # FIXME - Why not? Shouldn't it trivially succeed?
548 if ( $fbr eq $tbr ) {
549 $messages->{'DestinationEqualsHolding'} = 1;
553 # check if it is still issued to someone, return it...
554 my ($currentborrower) = currentborrower( $iteminformation->{'itemnumber'} );
555 if ($currentborrower) {
556 returnbook( $barcode, $fbr );
557 $messages->{'WasReturned'} = $currentborrower;
561 # FIXME - Don't call &CheckReserves unless $ignoreRs is true.
562 # That'll save a database query.
563 my ( $resfound, $resrec ) =
564 CheckReserves( $iteminformation->{'itemnumber'} );
565 if ( $resfound and not $ignoreRs ) {
566 $resrec->{'ResFound'} = $resfound;
568 # $messages->{'ResFound'} = $resrec;
572 #actually do the transfer....
574 dotransfer( $iteminformation->{'itemnumber'}, $fbr, $tbr );
576 # don't need to update MARC anymore, we do it in batch now
577 $messages->{'WasTransfered'} = 1;
579 return ( $dotransfer, $messages, $iteminformation );
583 # FIXME - This is only used in &transferbook. Why bother making it a
586 my ( $itm, $fbr, $tbr ) = @_;
588 my $dbh = C4::Context->dbh;
589 $itm = $dbh->quote($itm);
590 $fbr = $dbh->quote($fbr);
591 $tbr = $dbh->quote($tbr);
593 #new entry in branchtransfers....
595 "INSERT INTO branchtransfers (itemnumber, frombranch, datesent, tobranch)
596 VALUES ($itm, $fbr, now(), $tbr)"
599 #update holdingbranch in items .....
601 "UPDATE items set holdingbranch = $tbr WHERE items.itemnumber = $itm");
603 &domarctransfer( $dbh, $itm );
607 ##New sub to dotransfer in marc tables as well. Not exported -TG 10/04/2006
609 my ( $dbh, $itemnumber ) = @_;
610 $itemnumber =~ s /\'//g; ##itemnumber seems to come with quotes-TG
613 "select biblionumber,holdingbranch from items where itemnumber=$itemnumber"
616 while ( my ( $biblionumber, $holdingbranch ) = $sth->fetchrow ) {
617 &MARCmoditemonefield( $biblionumber, $itemnumber,
618 'items.holdingbranch', $holdingbranch, 0 );
623 =head2 canbookbeissued
625 Check if a book can be issued.
627 my ($issuingimpossible,$needsconfirmation) = canbookbeissued($env,$borrower,$barcode,$year,$month,$day);
631 =item C<$env> Environment variable. Should be empty usually, but used by other subs. Next code cleaning could drop it.
633 =item C<$borrower> hash with borrower informations (from getpatroninformation)
635 =item C<$barcode> is the bar code of the book being issued.
637 =item C<$year> C<$month> C<$day> contains the date of the return (in case it's forced by "stickyduedate".
645 =item C<$issuingimpossible> a reference to a hash. It contains reasons why issuing is impossible.
646 Possible values are :
652 sticky due date is invalid
656 borrower gone with no address
660 borrower declared it's card lost
666 =head3 UNKNOWN_BARCODE
680 item is restricted (set by ??)
682 C<$issuingimpossible> a reference to a hash. It contains reasons why issuing is impossible.
683 Possible values are :
691 renewing, not issuing
693 =head3 ISSUED_TO_ANOTHER
695 issued to someone else.
699 reserved for someone else.
703 sticky due date is invalid
707 if the borrower borrows to much things
711 # check if a book can be issued.
712 # returns an array with errors if any
715 my $borrower = shift;
716 my $iteminformation = shift;
717 my $cat_borrower = $borrower->{'categorycode'};
718 my $branch_borrower = $borrower->{'branchcode'};
719 my $dbh = C4::Context->dbh;
722 $dbh->prepare('select itemtype from biblioitems where biblionumber = ?');
723 $sth->execute( $iteminformation->{'biblionumber'} );
724 my $type = $sth->fetchrow;
727 'select * from issuingrules where categorycode = ? and itemtype = ? and branchcode = ?'
730 # 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 ?");
733 "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"
737 'select COUNT(*) from issues where borrowernumber = ? and returndate is null'
741 # check the 3 parameters
742 $sth->execute( $cat_borrower, $type, $branch_borrower );
743 my $result = $sth->fetchrow_hashref;
745 # warn "==>".$result->{maxissueqty};
747 # Currently, using defined($result) ie on an entire hash reports whether memory
748 # for that aggregate has ever been allocated. As $result is used all over the place
749 # it would rarely return as undefined.
750 if ( defined( $result->{maxissueqty} ) ) {
751 $sth2->execute( $borrower->{'borrowernumber'}, "%$type%" );
752 my $alreadyissued = $sth2->fetchrow;
753 if ( $result->{'maxissueqty'} <= $alreadyissued ) {
754 return ( "a $alreadyissued / ".( $result->{maxissueqty} + 0 ) );
762 $sth->execute( $cat_borrower, $type, "" );
763 $result = $sth->fetchrow_hashref;
764 if ( defined( $result->{maxissueqty} ) ) {
765 $sth2->execute( $borrower->{'borrowernumber'}, "%$type%" );
766 my $alreadyissued = $sth2->fetchrow;
767 if ( $result->{'maxissueqty'} <= $alreadyissued ) {
768 return ( "b $alreadyissued / ".( $result->{maxissueqty} + 0 ) );
775 # check for itemtype=*
776 $sth->execute( $cat_borrower, "*", $branch_borrower );
777 $result = $sth->fetchrow_hashref;
778 if ( defined( $result->{maxissueqty} ) ) {
779 $sth3->execute( $borrower->{'borrowernumber'} );
780 my ($alreadyissued) = $sth3->fetchrow;
781 if ( $result->{'maxissueqty'} <= $alreadyissued ) {
783 # warn "HERE : $alreadyissued / ($result->{maxissueqty} for $borrower->{'borrowernumber'}";
784 return ( "c $alreadyissued / " . ( $result->{maxissueqty} + 0 ) );
791 # check for borrowertype=*
792 $sth->execute( "*", $type, $branch_borrower );
793 $result = $sth->fetchrow_hashref;
794 if ( defined( $result->{maxissueqty} ) ) {
795 $sth2->execute( $borrower->{'borrowernumber'}, "%$type%" );
796 my $alreadyissued = $sth2->fetchrow;
797 if ( $result->{'maxissueqty'} <= $alreadyissued ) {
798 return ( "d $alreadyissued / " . ( $result->{maxissueqty} + 0 ) );
805 $sth->execute( "*", "*", $branch_borrower );
806 $result = $sth->fetchrow_hashref;
807 if ( defined( $result->{maxissueqty} ) ) {
808 $sth3->execute( $borrower->{'borrowernumber'} );
809 my $alreadyissued = $sth3->fetchrow;
810 if ( $result->{'maxissueqty'} <= $alreadyissued ) {
811 return ( "e $alreadyissued / " . ( $result->{maxissueqty} + 0 ) );
818 $sth->execute( "*", $type, "" );
819 $result = $sth->fetchrow_hashref;
820 if ( defined( $result->{maxissueqty} ) && $result->{maxissueqty} >= 0 ) {
821 $sth2->execute( $borrower->{'borrowernumber'}, "%$type%" );
822 my $alreadyissued = $sth2->fetchrow;
823 if ( $result->{'maxissueqty'} <= $alreadyissued ) {
824 return ( "f $alreadyissued / " . ( $result->{maxissueqty} + 0 ) );
831 $sth->execute( $cat_borrower, "*", "" );
832 $result = $sth->fetchrow_hashref;
833 if ( defined( $result->{maxissueqty} ) ) {
834 $sth2->execute( $borrower->{'borrowernumber'}, "%$type%" );
835 my $alreadyissued = $sth2->fetchrow;
836 if ( $result->{'maxissueqty'} <= $alreadyissued ) {
837 return ( "g $alreadyissued / " . ( $result->{maxissueqty} + 0 ) );
844 $sth->execute( "*", "*", "" );
845 $result = $sth->fetchrow_hashref;
846 if ( defined( $result->{maxissueqty} ) ) {
847 $sth3->execute( $borrower->{'borrowernumber'} );
848 my $alreadyissued = $sth3->fetchrow;
849 if ( $result->{'maxissueqty'} <= $alreadyissued ) {
850 return ( "h $alreadyissued / " . ( $result->{maxissueqty} + 0 ) );
861 @issues = &itemissues($biblioitemnumber, $biblio);
863 Looks up information about who has borrowed the bookZ<>(s) with the
864 given biblioitemnumber.
866 C<$biblio> is ignored.
868 C<&itemissues> returns an array of references-to-hash. The keys
869 include the fields from the C<items> table in the Koha database.
870 Additional keys include:
876 If the item is currently on loan, this gives the due date.
878 If the item is not on loan, then this is either "Available" or
879 "Cancelled", if the item has been withdrawn.
883 If the item is currently on loan, this gives the card number of the
884 patron who currently has the item.
886 =item C<timestamp0>, C<timestamp1>, C<timestamp2>
888 These give the timestamp for the last three times the item was
891 =item C<card0>, C<card1>, C<card2>
893 The card number of the last three patrons who borrowed this item.
895 =item C<borrower0>, C<borrower1>, C<borrower2>
897 The borrower number of the last three patrons who borrowed this item.
905 my ( $bibitem, $biblio ) = @_;
906 my $dbh = C4::Context->dbh;
908 # FIXME - If this function die()s, the script will abort, and the
909 # user won't get anything; depending on how far the script has
910 # gotten, the user might get a blank page. It would be much better
911 # to at least print an error message. The easiest way to do this
912 # is to set $SIG{__DIE__}.
914 $dbh->prepare("Select * from items where items.biblioitemnumber = ?")
919 $sth->execute($bibitem) || die $sth->errstr;
921 while ( my $data = $sth->fetchrow_hashref ) {
923 # Find out who currently has this item.
924 # FIXME - Wouldn't it be better to do this as a left join of
925 # some sort? Currently, this code assumes that if
926 # fetchrow_hashref() fails, then the book is on the shelf.
927 # fetchrow_hashref() can fail for any number of reasons (e.g.,
928 # database server crash), not just because no items match the
930 my $sth2 = $dbh->prepare(
931 "select * from issues,borrowers
933 and returndate is NULL
934 and issues.borrowernumber = borrowers.borrowernumber"
937 $sth2->execute( $data->{'itemnumber'} );
938 if ( my $data2 = $sth2->fetchrow_hashref ) {
939 $data->{'date_due'} = $data2->{'date_due'};
940 $data->{'card'} = $data2->{'cardnumber'};
941 $data->{'borrower'} = $data2->{'borrowernumber'};
944 if ( $data->{'wthdrawn'} eq '1' ) {
945 $data->{'date_due'} = 'Cancelled';
948 $data->{'date_due'} = 'Available';
954 # Find the last 3 people who borrowed this item.
955 $sth2 = $dbh->prepare(
956 "select * from issues, borrowers
958 and issues.borrowernumber = borrowers.borrowernumber
959 and returndate is not NULL
960 order by returndate desc,timestamp desc"
963 # $sth2 = $dbh->prepare("
966 # LEFT JOIN borrowers ON issues.borrowernumber = borrowers.borrowernumber
967 # WHERE itemnumber = ?
968 # AND returndate is not NULL
969 # ORDER BY returndate DESC,timestamp DESC
972 $sth2->execute( $data->{'itemnumber'} );
973 for ( my $i2 = 0 ; $i2 < 2 ; $i2++ )
974 { # FIXME : error if there is less than 3 pple borrowing this item
975 if ( my $data2 = $sth2->fetchrow_hashref ) {
976 $data->{"timestamp$i2"} = $data2->{'timestamp'};
977 $data->{"card$i2"} = $data2->{'cardnumber'};
978 $data->{"borrower$i2"} = $data2->{'borrowernumber'};
983 $results[$i] = $data;
991 =head2 canbookbeissued
993 $issuingimpossible, $needsconfirmation =
994 canbookbeissued( $env, $borrower, $barcode, $year, $month, $day, $inprocess );
996 C<$issuingimpossible> and C<$needsconfirmation> are some hashref.
1000 sub canbookbeissued {
1001 my ( $env, $borrower, $barcode, $year, $month, $day, $inprocess ) = @_;
1002 my %needsconfirmation; # filled with problems that needs confirmations
1003 my %issuingimpossible
1004 ; # filled with problems that causes the issue to be IMPOSSIBLE
1005 my $iteminformation = getiteminformation( 0, $barcode );
1006 my $dbh = C4::Context->dbh;
1011 my ( $duedate, $invalidduedate ) = fixdate( $year, $month, $day );
1012 $issuingimpossible{INVALID_DATE} = 1 if ($invalidduedate);
1017 if ( $borrower->{flags}->{GNA} ) {
1018 $issuingimpossible{GNA} = 1;
1020 if ( $borrower->{flags}->{'LOST'} ) {
1021 $issuingimpossible{CARD_LOST} = 1;
1023 if ( $borrower->{flags}->{'DBARRED'} ) {
1024 $issuingimpossible{DEBARRED} = 1;
1026 if ( Date_to_Days(Today) >
1027 Date_to_Days( split "-", $borrower->{'dateexpiry'} ) )
1031 #if (&Date_Cmp(&ParseDate($borrower->{expiry}),&ParseDate("today"))<0) {
1032 $issuingimpossible{EXPIRED} = 1;
1041 checkaccount( $env, $borrower->{'borrowernumber'}, $dbh, $duedate );
1042 if ( C4::Context->preference("IssuingInProcess") ) {
1043 my $amountlimit = C4::Context->preference("noissuescharge");
1044 if ( $amount > $amountlimit && !$inprocess ) {
1045 $issuingimpossible{DEBT} = sprintf( "%.2f", $amount );
1047 elsif ( $amount <= $amountlimit && !$inprocess ) {
1048 $needsconfirmation{DEBT} = sprintf( "%.2f", $amount );
1052 if ( $amount > 0 ) {
1053 $needsconfirmation{DEBT} = $amount;
1058 # JB34 CHECKS IF BORROWERS DONT HAVE ISSUE TOO MANY BOOKS
1060 my $toomany = TooMany( $borrower, $iteminformation );
1061 $needsconfirmation{TOO_MANY} = $toomany if $toomany;
1066 unless ( $iteminformation->{barcode} ) {
1067 $issuingimpossible{UNKNOWN_BARCODE} = 1;
1069 if ( $iteminformation->{'notforloan'}
1070 && $iteminformation->{'notforloan'} > 0 )
1072 $issuingimpossible{NOT_FOR_LOAN} = 1;
1074 if ( $iteminformation->{'itemtype'}
1075 && $iteminformation->{'itemtype'} eq 'REF' )
1077 $issuingimpossible{NOT_FOR_LOAN} = 1;
1079 if ( $iteminformation->{'wthdrawn'} && $iteminformation->{'wthdrawn'} == 1 )
1081 $issuingimpossible{WTHDRAWN} = 1;
1083 if ( $iteminformation->{'restricted'}
1084 && $iteminformation->{'restricted'} == 1 )
1086 $issuingimpossible{RESTRICTED} = 1;
1088 if ( C4::Context->preference("IndependantBranches") ) {
1089 my $userenv = C4::Context->userenv;
1090 if ( ($userenv) && ( $userenv->{flags} != 1 ) ) {
1091 $issuingimpossible{NOTSAMEBRANCH} = 1
1092 if ( $iteminformation->{'holdingbranch'} ne $userenv->{branch} );
1097 # CHECK IF BOOK ALREADY ISSUED TO THIS BORROWER
1099 my ($currentborrower) = currentborrower( $iteminformation->{'itemnumber'} );
1100 if ( $currentborrower && $currentborrower eq $borrower->{'borrowernumber'} )
1103 # Already issued to current borrower. Ask whether the loan should
1105 my ($renewstatus) = renewstatus(
1107 $borrower->{'borrowernumber'},
1108 $iteminformation->{'itemnumber'}
1110 if ( $renewstatus == 0 ) { # no more renewals allowed
1111 $issuingimpossible{NO_MORE_RENEWALS} = 1;
1115 # $needsconfirmation{RENEW_ISSUE} = 1;
1118 elsif ($currentborrower) {
1120 # issued to someone else
1121 my $currborinfo = getpatroninformation( 0, $currentborrower );
1123 # warn "=>.$currborinfo->{'firstname'} $currborinfo->{'surname'} ($currborinfo->{'cardnumber'})";
1124 $needsconfirmation{ISSUED_TO_ANOTHER} =
1125 "$currborinfo->{'reservedate'} : $currborinfo->{'firstname'} $currborinfo->{'surname'} ($currborinfo->{'cardnumber'})";
1128 # See if the item is on reserve.
1129 my ( $restype, $res ) = CheckReserves( $iteminformation->{'itemnumber'} );
1131 my $resbor = $res->{'borrowernumber'};
1132 if ( $resbor ne $borrower->{'borrowernumber'} && $restype eq "Waiting" )
1135 # The item is on reserve and waiting, but has been
1136 # reserved by some other patron.
1137 my ( $resborrower, $flags ) =
1138 getpatroninformation( $env, $resbor, 0 );
1139 my $branches = GetBranches();
1141 $branches->{ $res->{'branchcode'} }->{'branchname'};
1142 $needsconfirmation{RESERVE_WAITING} =
1143 "$resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'}, $branchname)";
1145 # CancelReserve(0, $res->{'itemnumber'}, $res->{'borrowernumber'}); Doesn't belong in a checking subroutine.
1147 elsif ( $restype eq "Reserved" ) {
1149 # The item is on reserve for someone else.
1150 my ( $resborrower, $flags ) =
1151 getpatroninformation( $env, $resbor, 0 );
1152 my $branches = GetBranches();
1154 $branches->{ $res->{'branchcode'} }->{'branchname'};
1155 $needsconfirmation{RESERVED} =
1156 "$res->{'reservedate'} : $resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'})";
1159 if ( C4::Context->preference("LibraryName") eq "Horowhenua Library Trust" )
1161 if ( $borrower->{'categorycode'} eq 'W' ) {
1162 my %issuingimpossible;
1163 return ( \%issuingimpossible, \%needsconfirmation );
1166 return ( \%issuingimpossible, \%needsconfirmation );
1170 return ( \%issuingimpossible, \%needsconfirmation );
1176 Issue a book. Does no check, they are done in canbookbeissued. If we reach this sub, it means the user confirmed if needed.
1178 &issuebook($env,$borrower,$barcode,$date)
1182 =item C<$env> Environment variable. Should be empty usually, but used by other subs. Next code cleaning could drop it.
1184 =item C<$borrower> hash with borrower informations (from getpatroninformation)
1186 =item C<$barcode> is the bar code of the book being issued.
1188 =item C<$date> contains the max date of return. calculated if empty.
1195 my ( $env, $borrower, $barcode, $date, $cancelreserve ) = @_;
1196 my $dbh = C4::Context->dbh;
1198 # my ($borrower, $flags) = &getpatroninformation($env, $borrowernumber, 0);
1199 my $iteminformation = getiteminformation( 0, $barcode );
1202 # check if we just renew the issue.
1204 my ($currentborrower) = currentborrower( $iteminformation->{'itemnumber'} );
1205 if ( $currentborrower eq $borrower->{'borrowernumber'} ) {
1206 my ( $charge, $itemtype ) = calc_charges(
1208 $iteminformation->{'itemnumber'},
1209 $borrower->{'borrowernumber'}
1211 if ( $charge > 0 ) {
1214 $iteminformation->{'itemnumber'},
1215 $borrower->{'borrowernumber'}, $charge
1217 $iteminformation->{'charge'} = $charge;
1220 $env, $env->{'branchcode'},
1222 '', $iteminformation->{'itemnumber'},
1223 $iteminformation->{'itemtype'}, $borrower->{'borrowernumber'}
1227 $borrower->{'borrowernumber'},
1228 $iteminformation->{'itemnumber'}
1236 if ( $currentborrower ne '' ) {
1238 # This book is currently on loan, but not to the person
1239 # who wants to borrow it now. mark it returned before issuing to the new borrower
1241 $iteminformation->{'barcode'},
1242 C4::Context->userenv->{'branch'}
1246 # See if the item is on reserve.
1247 my ( $restype, $res ) =
1248 CheckReserves( $iteminformation->{'itemnumber'} );
1250 my $resbor = $res->{'borrowernumber'};
1251 if ( $resbor eq $borrower->{'borrowernumber'} ) {
1253 # The item is on reserve to the current patron
1256 elsif ( $restype eq "Waiting" ) {
1259 # The item is on reserve and waiting, but has been
1260 # reserved by some other patron.
1261 my ( $resborrower, $flags ) =
1262 getpatroninformation( $env, $resbor, 0 );
1263 my $branches = GetBranches();
1265 $branches->{ $res->{'branchcode'} }->{'branchname'};
1266 if ($cancelreserve) {
1267 CancelReserve( 0, $res->{'itemnumber'},
1268 $res->{'borrowernumber'} );
1272 # set waiting reserve to first in reserve queue as book isn't waiting now
1275 $res->{'biblionumber'},
1276 $res->{'borrowernumber'},
1277 $res->{'branchcode'}
1281 elsif ( $restype eq "Reserved" ) {
1284 # The item is on reserve for someone else.
1285 my ( $resborrower, $flags ) =
1286 getpatroninformation( $env, $resbor, 0 );
1287 my $branches = GetBranches();
1289 $branches->{ $res->{'branchcode'} }->{'branchname'};
1290 if ($cancelreserve) {
1292 # cancel reserves on this item
1293 CancelReserve( 0, $res->{'itemnumber'},
1294 $res->{'borrowernumber'} );
1296 # also cancel reserve on biblio related to this item
1297 #my $st_Fbiblio = $dbh->prepare("select biblionumber from items where itemnumber=?");
1298 #$st_Fbiblio->execute($res->{'itemnumber'});
1299 #my $biblionumber = $st_Fbiblio->fetchrow;
1300 #CancelReserve($biblionumber,0,$res->{'borrowernumber'});
1301 #warn "CancelReserve $res->{'itemnumber'}, $res->{'borrowernumber'}";
1305 # my $tobrcd = ReserveWaiting($res->{'itemnumber'}, $res->{'borrowernumber'});
1306 # transferbook($tobrcd,$barcode, 1);
1307 # warn "transferbook";
1311 # END OF THE RESTYPE WORK
1313 # Starting process for transfer job (checking transfert and validate it if we have one)
1315 my ($datesent) = get_transfert_infos($iteminformation->{'itemnumber'});
1318 # updating line of branchtranfert to finish it, and changing the to branch value, implement a comment for lisibility of this case (maybe for stats ....)
1321 "update branchtransfers set datearrived = now(),
1323 comments = 'Forced branchtransfert'
1325 itemnumber= ? AND datearrived IS NULL"
1327 $sth->execute(C4::Context->userenv->{'branch'},$iteminformation->{'itemnumber'});
1331 # Ending process for transfert check
1333 # Record in the database the fact that the book was issued.
1336 "insert into issues (borrowernumber, itemnumber,issuedate, date_due, branchcode) values (?,?,?,?,?)"
1338 my $loanlength = getLoanLength(
1339 $borrower->{'categorycode'},
1340 $iteminformation->{'itemtype'},
1341 $borrower->{'branchcode'}
1343 my $datedue = time + ($loanlength) * 86400;
1344 my @datearr = localtime($datedue);
1346 ( 1900 + $datearr[5] ) . "-"
1347 . ( $datearr[4] + 1 ) . "-"
1353 # if ReturnBeforeExpiry ON the datedue can't be after borrower expirydate
1354 if ( C4::Context->preference('ReturnBeforeExpiry')
1355 && $dateduef gt $borrower->{dateexpiry} )
1357 $dateduef = $borrower->{dateexpiry};
1360 $borrower->{'borrowernumber'},
1361 $iteminformation->{'itemnumber'},
1362 strftime( "%Y-%m-%d", localtime ),$dateduef, $env->{'branchcode'}
1365 $iteminformation->{'issues'}++;
1368 "update items set issues=?, holdingbranch=? where itemnumber=?");
1370 $iteminformation->{'issues'},
1371 C4::Context->userenv->{'branch'},
1372 $iteminformation->{'itemnumber'}
1375 &itemseen( $iteminformation->{'itemnumber'} );
1376 itemborrowed( $iteminformation->{'itemnumber'} );
1378 # If it costs to borrow this book, charge it to the patron's account.
1379 my ( $charge, $itemtype ) = calc_charges(
1381 $iteminformation->{'itemnumber'},
1382 $borrower->{'borrowernumber'}
1384 if ( $charge > 0 ) {
1387 $iteminformation->{'itemnumber'},
1388 $borrower->{'borrowernumber'}, $charge
1390 $iteminformation->{'charge'} = $charge;
1393 # Record the fact that this book was issued.
1395 $env, $env->{'branchcode'},
1397 '', $iteminformation->{'itemnumber'},
1398 $iteminformation->{'itemtype'}, $borrower->{'borrowernumber'}
1402 &logaction(C4::Context->userenv->{'number'},"CIRCULATION","ISSUE",$borrower->{'borrowernumber'},$iteminformation->{'biblionumber'})
1403 if C4::Context->preference("IssueLog");
1407 =head2 getLoanLength
1409 Get loan length for an itemtype, a borrower type and a branch
1411 my $loanlength = &getLoanLength($borrowertype,$itemtype,branchcode)
1416 my ( $borrowertype, $itemtype, $branchcode ) = @_;
1417 my $dbh = C4::Context->dbh;
1420 "select issuelength from issuingrules where categorycode=? and itemtype=? and branchcode=?"
1423 # try to find issuelength & return the 1st available.
1424 # check with borrowertype, itemtype and branchcode, then without one of those parameters
1425 $sth->execute( $borrowertype, $itemtype, $branchcode );
1426 my $loanlength = $sth->fetchrow_hashref;
1427 return $loanlength->{issuelength}
1428 if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
1430 $sth->execute( $borrowertype, $itemtype, "" );
1431 $loanlength = $sth->fetchrow_hashref;
1432 return $loanlength->{issuelength}
1433 if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
1435 $sth->execute( $borrowertype, "*", $branchcode );
1436 $loanlength = $sth->fetchrow_hashref;
1437 return $loanlength->{issuelength}
1438 if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
1440 $sth->execute( "*", $itemtype, $branchcode );
1441 $loanlength = $sth->fetchrow_hashref;
1442 return $loanlength->{issuelength}
1443 if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
1445 $sth->execute( $borrowertype, "*", "" );
1446 $loanlength = $sth->fetchrow_hashref;
1447 return $loanlength->{issuelength}
1448 if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
1450 $sth->execute( "*", "*", $branchcode );
1451 $loanlength = $sth->fetchrow_hashref;
1452 return $loanlength->{issuelength}
1453 if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
1455 $sth->execute( "*", $itemtype, "" );
1456 $loanlength = $sth->fetchrow_hashref;
1457 return $loanlength->{issuelength}
1458 if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
1460 $sth->execute( "*", "*", "" );
1461 $loanlength = $sth->fetchrow_hashref;
1462 return $loanlength->{issuelength}
1463 if defined($loanlength) && $loanlength->{issuelength} ne 'NULL';
1465 # if no rule is set => 21 days (hardcoded)
1471 ($doreturn, $messages, $iteminformation, $borrower) =
1472 &returnbook($barcode, $branch);
1476 C<$barcode> is the bar code of the book being returned. C<$branch> is
1477 the code of the branch where the book is being returned.
1479 C<&returnbook> returns a list of four items:
1481 C<$doreturn> is true iff the return succeeded.
1483 C<$messages> is a reference-to-hash giving the reason for failure:
1489 No item with this barcode exists. The value is C<$barcode>.
1493 The book is not currently on loan. The value is C<$barcode>.
1495 =item C<IsPermanent>
1497 The book's home branch is a permanent collection. If you have borrowed
1498 this book, you are not allowed to return it. The value is the code for
1499 the book's home branch.
1503 This book has been withdrawn/cancelled. The value should be ignored.
1507 The item was reserved. The value is a reference-to-hash whose keys are
1508 fields from the reserves table of the Koha database, and
1509 C<biblioitemnumber>. It also has the key C<ResFound>, whose value is
1510 either C<Waiting>, C<Reserved>, or 0.
1514 C<$borrower> is a reference-to-hash, giving information about the
1515 patron who last borrowed the book.
1519 # FIXME - This API is bogus. There's no need to return $borrower and
1520 # $iteminformation; the caller can ask about those separately, if it
1521 # cares (it'd be inefficient to make two database calls instead of
1522 # one, but &getpatroninformation and &getiteminformation can be
1523 # memoized if this is an issue).
1525 # The ($doreturn, $messages) tuple is redundant: if the return
1526 # succeeded, that's all the caller needs to know. So &returnbook can
1527 # return 1 and 0 on success and failure, and set
1528 # $C4::Circulation::Circ2::errmsg to indicate the error. Or it can
1529 # return undef for success, and an error message on error (though this
1530 # is more C-ish than Perl-ish).
1533 my ( $barcode, $branch ) = @_;
1536 my $dbh = C4::Context->dbh;
1538 my $validTransfert = 0;
1539 my $reserveDone = 0;
1541 die '$branch not defined' unless defined $branch; # just in case (bug 170)
1542 # get information on item
1543 my ($iteminformation) = getiteminformation( 0, $barcode );
1545 if ( not $iteminformation ) {
1546 $messages->{'BadBarcode'} = $barcode;
1551 my ($currentborrower) = currentborrower( $iteminformation->{'itemnumber'} );
1552 if ( ( not $currentborrower ) && $doreturn ) {
1553 $messages->{'NotIssued'} = $barcode;
1557 # check if the book is in a permanent collection....
1558 my $hbr = $iteminformation->{'homebranch'};
1559 my $branches = GetBranches();
1560 if ( $hbr && $branches->{$hbr}->{'PE'} ) {
1561 $messages->{'IsPermanent'} = $hbr;
1564 # check that the book has been cancelled
1565 if ( $iteminformation->{'wthdrawn'} ) {
1566 $messages->{'wthdrawn'} = 1;itemnumber
1570 # new op dev : if the book returned in an other branch update the holding branch
1572 # update issues, thereby returning book (should push this out into another subroutine
1573 my ($borrower) = getpatroninformation( \%env, $currentborrower, 0 );
1575 # case of a return of document (deal with issues and holdingbranch)
1580 "update issues set returndate = now() where (borrowernumber = ?) and (itemnumber = ?) and (returndate is null)"
1582 $sth->execute( $borrower->{'borrowernumber'},
1583 $iteminformation->{'itemnumber'} );
1584 $messages->{'WasReturned'} = 1; # FIXME is the "= 1" right?
1587 # continue to deal with returns cases, but not only if we have an issue
1589 # the holdingbranch is updated if the document is returned in an other location .
1590 if ( $iteminformation->{'holdingbranch'} ne C4::Context->userenv->{'branch'} )
1592 UpdateHoldingbranch(C4::Context->userenv->{'branch'},$iteminformation->{'itemnumber'});
1593 # reload iteminformation holdingbranch with the userenv value
1594 $iteminformation->{'holdingbranch'} = C4::Context->userenv->{'branch'};
1596 itemseen( $iteminformation->{'itemnumber'} );
1597 ($borrower) = getpatroninformation( \%env, $currentborrower, 0 );
1599 # fix up the accounts.....
1600 if ( $iteminformation->{'itemlost'} ) {
1601 fixaccountforlostandreturned( $iteminformation, $borrower );
1602 $messages->{'WasLost'} = 1; # FIXME is the "= 1" right?
1605 # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
1606 # check if we have a transfer for this document
1607 my ($datesent,$frombranch,$tobranch) = checktransferts( $iteminformation->{'itemnumber'} );
1609 # if we have a return, we update the line of transfers with the datearrived
1611 if ( $tobranch eq C4::Context->userenv->{'branch'} ) {
1614 "update branchtransfers set datearrived = now() where itemnumber= ? AND datearrived IS NULL"
1616 $sth->execute( $iteminformation->{'itemnumber'} );
1618 # 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'
1619 SetWaitingStatus( $iteminformation->{'itemnumber'} );
1622 $messages->{'WrongTransfer'} = $tobranch;
1623 $messages->{'WrongTransferItem'} = $iteminformation->{'itemnumber'};
1625 $validTransfert = 1;
1628 # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
1629 # fix up the overdues in accounts...
1630 fixoverduesonreturn( $borrower->{'borrowernumber'},
1631 $iteminformation->{'itemnumber'} );
1633 # find reserves.....
1634 # if we don't have a reserve with the status W, we launch the Checkreserves routine
1635 my ( $resfound, $resrec ) =
1636 CheckReserves( $iteminformation->{'itemnumber'} );
1639 # my $tobrcd = ReserveWaiting($resrec->{'itemnumber'}, $resrec->{'borrowernumber'});
1640 $resrec->{'ResFound'} = $resfound;
1641 $messages->{'ResFound'} = $resrec;
1646 # Record the fact that this book was returned.
1648 \%env, $branch, 'return', '0', '',
1649 $iteminformation->{'itemnumber'},
1650 $iteminformation->{'itemtype'},
1651 $borrower->{'borrowernumber'}
1654 &logaction(C4::Context->userenv->{'number'},"CIRCULATION","RETURN",$currentborrower,$iteminformation->{'biblionumber'})
1655 if C4::Context->preference("ReturnLog");
1657 #adding message if holdingbranch is non equal a userenv branch to return the document to homebranch
1658 #we check, if we don't have reserv or transfert for this document, if not, return it to homebranch .
1660 if ( ($iteminformation->{'holdingbranch'} ne $iteminformation->{'homebranch'}) and not $messages->{'WrongTransfer'} and ($validTransfert ne 1) and ($reserveDone ne 1) ){
1661 if (C4::Context->preference("AutomaticItemReturn") == 1) {
1662 dotransfer($iteminformation->{'itemnumber'}, C4::Context->userenv->{'branch'}, $iteminformation->{'homebranch'});
1663 $messages->{'WasTransfered'} = 1;
1664 warn "was transfered";
1668 return ( $doreturn, $messages, $iteminformation, $borrower );
1671 =head2 fixaccountforlostandreturned
1673 &fixaccountforlostandreturned($iteminfo,$borrower);
1675 Calculates the charge for a book lost and returned (Not exported & used only once)
1677 C<$iteminfo> is a hashref to iteminfo. Only {itemnumber} is used.
1679 C<$borrower> is a hashref to borrower. Only {borrowernumber is used.
1683 sub fixaccountforlostandreturned {
1684 my ( $iteminfo, $borrower ) = @_;
1686 my $dbh = C4::Context->dbh;
1687 my $itm = $iteminfo->{'itemnumber'};
1689 # check for charge made for lost book
1692 "select * from accountlines where (itemnumber = ?) and (accounttype='L' or accounttype='Rep') order by date desc"
1694 $sth->execute($itm);
1695 if ( my $data = $sth->fetchrow_hashref ) {
1697 # writeoff this amount
1699 my $amount = $data->{'amount'};
1700 my $acctno = $data->{'accountno'};
1702 if ( $data->{'amountoutstanding'} == $amount ) {
1703 $offset = $data->{'amount'};
1707 $offset = $amount - $data->{'amountoutstanding'};
1708 $amountleft = $data->{'amountoutstanding'} - $amount;
1710 my $usth = $dbh->prepare(
1711 "update accountlines set accounttype = 'LR',amountoutstanding='0'
1712 where (borrowernumber = ?)
1713 and (itemnumber = ?) and (accountno = ?) "
1715 $usth->execute( $data->{'borrowernumber'}, $itm, $acctno );
1718 #check if any credit is left if so writeoff other accounts
1720 getnextacctno( \%env, $data->{'borrowernumber'}, $dbh );
1721 if ( $amountleft < 0 ) {
1724 if ( $amountleft > 0 ) {
1725 my $msth = $dbh->prepare(
1726 "select * from accountlines where (borrowernumber = ?)
1727 and (amountoutstanding >0) order by date"
1729 $msth->execute( $data->{'borrowernumber'} );
1731 # offset transactions
1734 while ( ( $accdata = $msth->fetchrow_hashref )
1735 and ( $amountleft > 0 ) )
1737 if ( $accdata->{'amountoutstanding'} < $amountleft ) {
1739 $amountleft -= $accdata->{'amountoutstanding'};
1742 $newamtos = $accdata->{'amountoutstanding'} - $amountleft;
1745 my $thisacct = $accdata->{'accountno'};
1746 my $usth = $dbh->prepare(
1747 "update accountlines set amountoutstanding= ?
1748 where (borrowernumber = ?)
1751 $usth->execute( $newamtos, $data->{'borrowernumber'},
1754 $usth = $dbh->prepare(
1755 "insert into accountoffsets
1756 (borrowernumber, accountno, offsetaccount, offsetamount)
1761 $data->{'borrowernumber'},
1762 $accdata->{'accountno'},
1763 $nextaccntno, $newamtos
1769 if ( $amountleft > 0 ) {
1772 my $desc = "Book Returned " . $iteminfo->{'barcode'};
1773 $usth = $dbh->prepare(
1774 "insert into accountlines
1775 (borrowernumber,accountno,date,amount,description,accounttype,amountoutstanding)
1776 values (?,?,now(),?,?,'CR',?)"
1779 $data->{'borrowernumber'},
1780 $nextaccntno, 0 - $amount,
1784 $usth = $dbh->prepare(
1785 "insert into accountoffsets
1786 (borrowernumber, accountno, offsetaccount, offsetamount)
1789 $usth->execute( $borrower->{'borrowernumber'},
1790 $data->{'accountno'}, $nextaccntno, $offset );
1792 $usth = $dbh->prepare("update items set paidfor='' where itemnumber=?");
1793 $usth->execute($itm);
1800 =head2 fixoverdueonreturn
1802 &fixoverdueonreturn($brn,$itm);
1804 C<$brn> borrowernumber
1810 sub fixoverduesonreturn {
1811 my ( $brn, $itm ) = @_;
1812 my $dbh = C4::Context->dbh;
1814 # check for overdue fine
1817 "select * from accountlines where (borrowernumber = ?) and (itemnumber = ?) and (accounttype='FU' or accounttype='O')"
1819 $sth->execute( $brn, $itm );
1821 # alter fine to show that the book has been returned
1822 if ( my $data = $sth->fetchrow_hashref ) {
1825 "update accountlines set accounttype='F' where (borrowernumber = ?) and (itemnumber = ?) and (accountno = ?)"
1827 $usth->execute( $brn, $itm, $data->{'accountno'} );
1838 NOTE!: If you change this function, be sure to update the POD for
1839 &getpatroninformation.
1841 $flags = &patronflags($env, $patron, $dbh);
1844 {message} Message showing patron's credit or debt
1845 {noissues} Set if patron owes >$5.00
1846 {GNA} Set if patron gone w/o address
1847 {message} "Borrower has no valid address"
1849 {LOST} Set if patron's card reported lost
1850 {message} Message to this effect
1852 {DBARRED} Set is patron is debarred
1853 {message} Message to this effect
1855 {NOTES} Set if patron has notes
1856 {message} Notes about patron
1857 {ODUES} Set if patron has overdue books
1859 {itemlist} ref-to-array: list of overdue books
1860 {itemlisttext} Text list of overdue items
1861 {WAITING} Set if there are items available that the
1863 {message} Message to this effect
1864 {itemlist} ref-to-array: list of available items
1870 # Original subroutine for Circ2.pm
1872 my ( $env, $patroninformation, $dbh ) = @_;
1874 checkaccount( $env, $patroninformation->{'borrowernumber'}, $dbh );
1875 if ( $amount > 0 ) {
1877 my $noissuescharge = C4::Context->preference("noissuescharge");
1878 $flaginfo{'message'} = sprintf "Patron owes \$%.02f", $amount;
1879 if ( $amount > $noissuescharge ) {
1880 $flaginfo{'noissues'} = 1;
1882 $flags{'CHARGES'} = \%flaginfo;
1884 elsif ( $amount < 0 ) {
1886 $flaginfo{'message'} = sprintf "Patron has credit of \$%.02f", -$amount;
1887 $flags{'CHARGES'} = \%flaginfo;
1889 if ( $patroninformation->{'gonenoaddress'}
1890 && $patroninformation->{'gonenoaddress'} == 1 )
1893 $flaginfo{'message'} = 'Borrower has no valid address.';
1894 $flaginfo{'noissues'} = 1;
1895 $flags{'GNA'} = \%flaginfo;
1897 if ( $patroninformation->{'lost'} && $patroninformation->{'lost'} == 1 ) {
1899 $flaginfo{'message'} = 'Borrower\'s card reported lost.';
1900 $flaginfo{'noissues'} = 1;
1901 $flags{'LOST'} = \%flaginfo;
1903 if ( $patroninformation->{'debarred'}
1904 && $patroninformation->{'debarred'} == 1 )
1907 $flaginfo{'message'} = 'Borrower is Debarred.';
1908 $flaginfo{'noissues'} = 1;
1909 $flags{'DBARRED'} = \%flaginfo;
1911 if ( $patroninformation->{'borrowernotes'}
1912 && $patroninformation->{'borrowernotes'} )
1915 $flaginfo{'message'} = "$patroninformation->{'borrowernotes'}";
1916 $flags{'NOTES'} = \%flaginfo;
1918 my ( $odues, $itemsoverdue ) =
1919 checkoverdues( $env, $patroninformation->{'borrowernumber'}, $dbh );
1922 $flaginfo{'message'} = "Yes";
1923 $flaginfo{'itemlist'} = $itemsoverdue;
1924 foreach ( sort { $a->{'date_due'} cmp $b->{'date_due'} }
1927 $flaginfo{'itemlisttext'} .=
1928 "$_->{'date_due'} $_->{'barcode'} $_->{'title'} \n";
1930 $flags{'ODUES'} = \%flaginfo;
1933 C4::Reserves2::GetWaitingReserves( $patroninformation->{'borrowernumber'} );
1934 my $nowaiting = scalar @$itemswaiting;
1935 if ( $nowaiting > 0 ) {
1937 $flaginfo{'message'} = "Reserved items available";
1938 $flaginfo{'itemlist'} = $itemswaiting;
1939 $flags{'WAITING'} = \%flaginfo;
1944 =head2 checkoverdues
1946 ( $count, $overdueitems )=checkoverdues( $env, $borrowernumber, $dbh );
1954 # From Main.pm, modified to return a list of overdueitems, in addition to a count
1955 #checks whether a borrower has overdue items
1956 my ( $env, $borrowernumber, $dbh ) = @_;
1957 my @datearr = localtime;
1959 ( $datearr[5] + 1900 ) . "-" . ( $datearr[4] + 1 ) . "-" . $datearr[3];
1962 my $sth = $dbh->prepare(
1963 "SELECT * FROM issues,biblio,biblioitems,items
1964 WHERE items.biblioitemnumber = biblioitems.biblioitemnumber
1965 AND items.biblionumber = biblio.biblionumber
1966 AND issues.itemnumber = items.itemnumber
1967 AND issues.borrowernumber = ?
1968 AND issues.returndate is NULL
1969 AND issues.date_due < ?"
1971 $sth->execute( $borrowernumber, $today );
1972 while ( my $data = $sth->fetchrow_hashref ) {
1973 push( @overdueitems, $data );
1977 return ( $count, \@overdueitems );
1980 =head2 currentborrower
1982 $borrower=currentborrower($itemnumber)
1988 sub currentborrower {
1990 # Original subroutine for Circ2.pm
1991 my ($itemnumber) = @_;
1992 my $dbh = C4::Context->dbh;
1993 my $q_itemnumber = $dbh->quote($itemnumber);
1994 my $sth = $dbh->prepare(
1995 "select borrowers.borrowernumber from
1996 issues,borrowers where issues.itemnumber=$q_itemnumber and
1997 issues.borrowernumber=borrowers.borrowernumber and issues.returndate is
2001 my ($borrower) = $sth->fetchrow;
2005 =head2 checkreserve_to_delete
2007 ( $resbor, $resrec ) = &checkreserve_to_delete($env,$dbh,$itemnum);
2011 sub checkreserve_to_delete {
2013 # Stolen from Main.pm
2014 # Check for reserves for biblio
2015 my ( $env, $dbh, $itemnum ) = @_;
2017 my $sth = $dbh->prepare(
2018 "select * from reserves,items
2019 where (items.itemnumber = ?)
2020 and (reserves.cancellationdate is NULL)
2021 and (items.biblionumber = reserves.biblionumber)
2022 and ((reserves.found = 'W')
2023 or (reserves.found is null))
2026 $sth->execute($itemnum);
2028 my $data = $sth->fetchrow_hashref;
2029 while ( $data && $resbor eq '' ) {
2031 my $const = $data->{'constrainttype'};
2032 if ( $const eq "a" ) {
2033 $resbor = $data->{'borrowernumber'};
2037 my $csth = $dbh->prepare(
2038 "select * from reserveconstraints,items
2039 where (borrowernumber=?)
2041 and reserveconstraints.biblionumber=?
2042 and (items.itemnumber=? and
2043 items.biblioitemnumber = reserveconstraints.biblioitemnumber)"
2046 $data->{'borrowernumber'},
2047 $data->{'biblionumber'},
2048 $data->{'reservedate'}, $itemnum
2050 if ( my $cdata = $csth->fetchrow_hashref ) { $found = 1; }
2051 if ( $const eq 'o' ) {
2052 if ( $found eq 1 ) { $resbor = $data->{'borrowernumber'}; }
2055 if ( $found eq 0 ) { $resbor = $data->{'borrowernumber'}; }
2059 $data = $sth->fetchrow_hashref;
2062 return ( $resbor, $resrec );
2065 =head2 currentissues
2067 $issues = ¤tissues($env, $borrower);
2069 Returns a list of books currently on loan to a patron.
2071 If C<$env-E<gt>{todaysissues}> is set and true, C<¤tissues> only
2072 returns information about books issued today. If
2073 C<$env-E<gt>{nottodaysissues}> is set and true, C<¤tissues> only
2074 returns information about books issued before today. If both are
2075 specified, C<$env-E<gt>{todaysissues}> is ignored. If neither is
2076 specified, C<¤tissues> returns all of the patron's issues.
2078 C<$borrower->{borrowernumber}> is the borrower number of the patron
2079 whose issues we want to list.
2081 C<¤tissues> returns a PHP-style array: C<$issues> is a
2082 reference-to-hash whose keys are integers in the range 1...I<n>, where
2083 I<n> is the number of items on issue (either today or before today).
2084 C<$issues-E<gt>{I<n>}> is a reference-to-hash whose keys are all of
2085 the fields of the biblio, biblioitems, items, and issues fields of the
2086 Koha database for that particular item.
2093 # New subroutine for Circ2.pm
2094 my ( $env, $borrower ) = @_;
2095 my $dbh = C4::Context->dbh;
2098 my $borrowernumber = $borrower->{'borrowernumber'};
2101 # Figure out whether to get the books issued today, or earlier.
2102 # FIXME - $env->{todaysissues} and $env->{nottodaysissues} can
2103 # both be specified, but are mutually-exclusive. This is bogus.
2104 # Make this a flag. Or better yet, return everything in (reverse)
2105 # chronological order and let the caller figure out which books
2106 # were issued today.
2107 if ( $env->{'todaysissues'} ) {
2110 # $today = POSIX::strftime("%Y%m%d", localtime);
2111 # FIXME - Since $today will be used in either case, move it
2112 # out of the two if-blocks.
2113 my @datearr = localtime( time() );
2114 my $today = ( 1900 + $datearr[5] ) . sprintf "%02d",
2115 ( $datearr[4] + 1 ) . sprintf "%02d", $datearr[3];
2117 # FIXME - MySQL knows about dates. Just use
2118 # and issues.timestamp = curdate();
2119 $crit = " and issues.timestamp like '$today%' ";
2121 if ( $env->{'nottodaysissues'} ) {
2124 # $today = POSIX::strftime("%Y%m%d", localtime);
2125 # FIXME - Since $today will be used in either case, move it
2126 # out of the two if-blocks.
2127 my @datearr = localtime( time() );
2128 my $today = ( 1900 + $datearr[5] ) . sprintf "%02d",
2129 ( $datearr[4] + 1 ) . sprintf "%02d", $datearr[3];
2131 # FIXME - MySQL knows about dates. Just use
2132 # and issues.timestamp < curdate();
2133 $crit = " and !(issues.timestamp like '$today%') ";
2136 # FIXME - Does the caller really need every single field from all
2138 my $sth = $dbh->prepare(
2139 "select * from issues,items,biblioitems,biblio where
2140 borrowernumber=? and issues.itemnumber=items.itemnumber and
2141 items.biblionumber=biblio.biblionumber and
2142 items.biblioitemnumber=biblioitems.biblioitemnumber and returndate is null
2143 $crit order by issues.date_due"
2145 $sth->execute($borrowernumber);
2146 while ( my $data = $sth->fetchrow_hashref ) {
2148 # FIXME - The Dewey code is a string, not a number.
2149 $data->{'dewey'} =~ s/0*$//;
2150 ( $data->{'dewey'} == 0 ) && ( $data->{'dewey'} = '' );
2153 # $todaysdate = POSIX::strftime("%Y%m%d", localtime)
2154 # or better yet, just reuse $today which was calculated above.
2155 # This function isn't going to run until midnight, is it?
2157 # $todaysdate = POSIX::strftime("%Y-%m-%d", localtime)
2158 # if ($data->{'date_due'} lt $todaysdate)
2160 # Either way, the date should be be formatted outside of the
2162 my @datearr = localtime( time() );
2164 ( 1900 + $datearr[5] )
2165 . sprintf( "%0.2d", ( $datearr[4] + 1 ) )
2166 . sprintf( "%0.2d", $datearr[3] );
2167 my $datedue = $data->{'date_due'};
2169 if ( $datedue < $todaysdate ) {
2170 $data->{'overdue'} = 1;
2172 my $itemnumber = $data->{'itemnumber'};
2174 # FIXME - Consecutive integers as hash keys? You have GOT to
2175 # be kidding me! Use an array, fercrissakes!
2176 $currentissues{$counter} = $data;
2180 return ( \%currentissues );
2185 $issues = &getissues($borrowernumber);
2187 Returns the set of books currently on loan to a patron.
2189 C<$borrowernumber> is the patron's borrower number.
2191 C<&getissues> returns a PHP-style array: C<$issues> is a
2192 reference-to-hash whose keys are integers in the range 0..I<n>-1,
2193 where I<n> is the number of books the patron currently has on loan.
2195 The values of C<$issues> are references-to-hash whose keys are
2196 selected fields from the issues, items, biblio, and biblioitems tables
2197 of the Koha database.
2204 # New subroutine for Circ2.pm
2205 my ($borrower) = @_;
2206 my $dbh = C4::Context->dbh;
2207 my $borrowernumber = $borrower->{'borrowernumber'};
2211 issues.timestamp AS timestamp,
2212 issues.date_due AS date_due,
2213 items.barcode AS barcode,
2214 biblio.title AS title,
2215 biblio.author AS author,
2216 biblioitems.dewey AS dewey,
2217 itemtypes.description AS itemtype,
2218 biblioitems.subclass AS subclass,
2219 biblioitems.ccode AS ccode,
2220 biblioitems.isbn AS isbn,
2221 biblioitems.classification AS classification
2223 LEFT JOIN issues ON issues.itemnumber = items.itemnumber
2224 LEFT JOIN biblio ON biblio.biblionumber = items.biblionumber
2225 LEFT JOIN biblioitems ON items.biblioitemnumber = biblioitems.biblioitemnumber
2226 LEFT JOIN itemtypes ON itemtypes.itemtype = biblioitems.itemtype
2227 WHERE issues.borrowernumber = ?
2228 AND issues.returndate IS NULL
2229 ORDER BY issues.date_due DESC
2231 my $sth = $dbh->prepare($select);
2232 $sth->execute($borrowernumber);
2235 while ( my $data = $sth->fetchrow_hashref ) {
2236 $data->{'dewey'} =~ s/0*$//;
2237 ( $data->{'dewey'} == 0 ) && ( $data->{'dewey'} = '' );
2239 # FIXME - The Dewey code is a string, not a number.
2240 # FIXME - Use POSIX::strftime to get a text version of today's
2241 # date. That's what it's for.
2242 # FIXME - Move the date calculation outside of the loop.
2243 my @datearr = localtime( time() );
2245 ( 1900 + $datearr[5] )
2246 . sprintf( "%0.2d", ( $datearr[4] + 1 ) )
2247 . sprintf( "%0.2d", $datearr[3] );
2249 # FIXME - Instead of converting the due date to YYYYMMDD, just
2251 # $todaysdate = POSIX::strftime("%Y-%m-%d", localtime);
2253 # if ($date->{date_due} lt $todaysdate)
2254 my $datedue = $data->{'date_due'};
2256 if ( $datedue < $todaysdate ) {
2257 $data->{'overdue'} = 1;
2259 $currentissues{$counter} = $data;
2262 # FIXME - This is ludicrous. If you want to return an
2263 # array of values, just use an array. That's what
2264 # they're there for.
2267 return ( \%currentissues );
2270 =head2 GetIssuesFromBiblio
2272 $issues = GetIssuesFromBiblio($biblionumber);
2274 this function get all issues from a biblionumber.
2277 C<$issues> is a reference to array which each value is ref-to-hash. This ref-to-hash containts all column from
2278 tables issues and the firstname,surname & cardnumber from borrowers.
2282 sub GetIssuesFromBiblio {
2283 my $biblionumber = shift;
2284 return undef unless $biblionumber;
2285 my $dbh = C4::Context->dbh;
2287 SELECT issues.*,biblio.biblionumber,biblio.title, biblio.author,borrowers.cardnumber,borrowers.surname,borrowers.firstname
2289 LEFT JOIN borrowers ON borrowers.borrowernumber = issues.borrowernumber
2290 LEFT JOIN items ON issues.itemnumber = items.itemnumber
2291 LEFT JOIN biblioitems ON items.itemnumber = biblioitems.biblioitemnumber
2292 LEFT JOIN biblio ON biblio.biblionumber = items.biblioitemnumber
2293 WHERE biblio.biblionumber = ?
2294 ORDER BY issues.timestamp
2296 my $sth = $dbh->prepare($query);
2297 $sth->execute($biblionumber);
2300 while ( my $data = $sth->fetchrow_hashref ) {
2301 push @issues, $data;
2308 $ok = &renewstatus($env, $dbh, $borrowernumber, $itemnumber);
2310 Find out whether a borrowed item may be renewed.
2314 C<$dbh> is a DBI handle to the Koha database.
2316 C<$borrowernumber> is the borrower number of the patron who currently
2317 has the item on loan.
2319 C<$itemnumber> is the number of the item to renew.
2321 C<$renewstatus> returns a true value iff the item may be renewed. The
2322 item must currently be on loan to the specified borrower; renewals
2323 must be allowed for the item's type; and the borrower must not have
2324 already renewed the loan.
2330 # check renewal status
2331 my ( $env, $borrowernumber, $itemno ) = @_;
2332 my $dbh = C4::Context->dbh;
2336 # Look in the issues table for this item, lent to this borrower,
2337 # and not yet returned.
2339 # FIXME - I think this function could be redone to use only one SQL call.
2340 my $sth1 = $dbh->prepare(
2341 "select * from issues
2342 where (borrowernumber = ?)
2343 and (itemnumber = ?)
2344 and returndate is null"
2346 $sth1->execute( $borrowernumber, $itemno );
2347 if ( my $data1 = $sth1->fetchrow_hashref ) {
2349 # Found a matching item
2351 # See if this item may be renewed. This query is convoluted
2352 # because it's a bit messy: given the item number, we need to find
2353 # the biblioitem, which gives us the itemtype, which tells us
2354 # whether it may be renewed.
2355 my $sth2 = $dbh->prepare(
2356 "SELECT renewalsallowed from items,biblioitems,itemtypes
2357 where (items.itemnumber = ?)
2358 and (items.biblioitemnumber = biblioitems.biblioitemnumber)
2359 and (biblioitems.itemtype = itemtypes.itemtype)"
2361 $sth2->execute($itemno);
2362 if ( my $data2 = $sth2->fetchrow_hashref ) {
2363 $renews = $data2->{'renewalsallowed'};
2365 if ( $renews && $renews > $data1->{'renewals'} ) {
2369 my ( $resfound, $resrec ) = CheckReserves($itemno);
2373 ( $resfound, $resrec ) = CheckReserves($itemno);
2380 return ($renewokay);
2385 &renewbook($env, $borrowernumber, $itemnumber, $datedue);
2389 C<$env-E<gt>{branchcode}> is the code of the branch where the
2390 renewal is taking place.
2392 C<$env-E<gt>{usercode}> is the value to log in C<statistics.usercode>
2393 in the Koha database.
2395 C<$borrowernumber> is the borrower number of the patron who currently
2398 C<$itemnumber> is the number of the item to renew.
2400 C<$datedue> can be used to set the due date. If C<$datedue> is the
2401 empty string, C<&renewbook> will calculate the due date automatically
2402 from the book's item type. If you wish to set the due date manually,
2403 C<$datedue> should be in the form YYYY-MM-DD.
2409 # mark book as renewed
2410 my ( $env, $borrowernumber, $itemno, $datedue ) = @_;
2411 my $dbh = C4::Context->dbh;
2413 # If the due date wasn't specified, calculate it by adding the
2414 # book's loan length to today's date.
2415 if ( $datedue eq "" ) {
2417 #debug_msg($env, "getting date");
2418 my $iteminformation = getiteminformation( $itemno, 0 );
2419 my $borrower = getpatroninformation( $env, $borrowernumber, 0 );
2420 my $loanlength = getLoanLength(
2421 $borrower->{'categorycode'},
2422 $iteminformation->{'itemtype'},
2423 $borrower->{'branchcode'}
2425 my ( $due_year, $due_month, $due_day ) =
2426 Add_Delta_DHMS( Today_and_Now(), $loanlength, 0, 0, 0 );
2427 $datedue = "$due_year-$due_month-$due_day";
2429 #$datedue = UnixDate(DateCalc("today","$loanlength days"),"%Y-%m-%d");
2432 # Find the issues record for this book
2435 "select * from issues where borrowernumber=? and itemnumber=? and returndate is null"
2437 $sth->execute( $borrowernumber, $itemno );
2438 my $issuedata = $sth->fetchrow_hashref;
2441 # Update the issues record to have the new due date, and a new count
2442 # of how many times it has been renewed.
2443 my $renews = $issuedata->{'renewals'} + 1;
2444 $sth = $dbh->prepare(
2445 "update issues set date_due = ?, renewals = ?
2446 where borrowernumber=? and itemnumber=? and returndate is null"
2448 $sth->execute( $datedue, $renews, $borrowernumber, $itemno );
2452 UpdateStats( $env, $env->{'branchcode'}, 'renew', '', '', $itemno );
2454 # Charge a new rental fee, if applicable?
2455 my ( $charge, $type ) = calc_charges( $env, $itemno, $borrowernumber );
2456 if ( $charge > 0 ) {
2457 my $accountno = getnextacctno( $env, $borrowernumber, $dbh );
2458 my $item = getiteminformation($itemno);
2459 $sth = $dbh->prepare(
2460 "Insert into accountlines (borrowernumber,accountno,date,amount,description,accounttype,amountoutstanding,itemnumber)
2461 values (?,?,now(),?,?,?,?,?)"
2463 $sth->execute( $borrowernumber, $accountno, $charge,
2464 "Renewal of Rental Item $item->{'title'} $item->{'barcode'}",
2465 'Rent', $charge, $itemno );
2474 ($charge, $item_type) = &calc_charges($env, $itemnumber, $borrowernumber);
2476 Calculate how much it would cost for a given patron to borrow a given
2477 item, including any applicable discounts.
2481 C<$itemnumber> is the item number of item the patron wishes to borrow.
2483 C<$borrowernumber> is the patron's borrower number.
2485 C<&calc_charges> returns two values: C<$charge> is the rental charge,
2486 and C<$item_type> is the code for the item's item type (e.g., C<VID>
2493 # calculate charges due
2494 my ( $env, $itemno, $borrowernumber ) = @_;
2496 my $dbh = C4::Context->dbh;
2499 # Get the book's item type and rental charge (via its biblioitem).
2500 my $sth1 = $dbh->prepare(
2501 "select itemtypes.itemtype,rentalcharge from items,biblioitems,itemtypes
2502 where (items.itemnumber =?)
2503 and (biblioitems.biblioitemnumber = items.biblioitemnumber)
2504 and (biblioitems.itemtype = itemtypes.itemtype)"
2506 $sth1->execute($itemno);
2507 if ( my $data1 = $sth1->fetchrow_hashref ) {
2508 $item_type = $data1->{'itemtype'};
2509 $charge = $data1->{'rentalcharge'};
2510 my $q2 = "select rentaldiscount from issuingrules,borrowers
2511 where (borrowers.borrowernumber = ?)
2512 and (borrowers.categorycode = issuingrules.categorycode)
2513 and (issuingrules.itemtype = ?)";
2514 my $sth2 = $dbh->prepare($q2);
2515 $sth2->execute( $borrowernumber, $item_type );
2516 if ( my $data2 = $sth2->fetchrow_hashref ) {
2517 my $discount = $data2->{'rentaldiscount'};
2518 if ( $discount eq 'NULL' ) {
2521 $charge = ( $charge * ( 100 - $discount ) ) / 100;
2527 return ( $charge, $item_type );
2532 &createcharge( $env, $dbh, $itemno, $borrowernumber, $charge )
2536 # FIXME - A virtually identical function appears in
2537 # C4::Circulation::Issues. Pick one and stick with it.
2540 #Stolen from Issues.pm
2541 my ( $env, $dbh, $itemno, $borrowernumber, $charge ) = @_;
2542 my $nextaccntno = getnextacctno( $env, $borrowernumber, $dbh );
2544 INSERT INTO accountlines
2545 (borrowernumber, itemnumber, accountno,
2546 date, amount, description, accounttype,
2548 VALUES (?, ?, ?,now(), ?, 'Rental', 'Rent',?)
2550 my $sth = $dbh->prepare($query);
2551 $sth->execute( $borrowernumber, $itemno, $nextaccntno, $charge, $charge );
2555 =head2 find_reserves
2557 ($status, $record) = &find_reserves($itemnumber);
2559 Looks up an item in the reserves.
2561 C<$itemnumber> is the itemnumber to look up.
2563 C<$status> is true iff the search was successful.
2565 C<$record> is a reference-to-hash describing the reserve. Its keys are
2566 the fields from the reserves table of the Koha database.
2571 # FIXME - This API is bogus: just return the record, or undef if none
2573 # FIXME - There's also a &C4::Circulation::Returns::find_reserves, but
2574 # that one looks rather different.
2577 # Stolen from Returns.pm
2578 warn "!!!!! SHOULD NOT BE HERE : Circ2::find_reserves is deprecated !!!";
2581 my $dbh = C4::Context->dbh;
2582 my ($itemdata) = getiteminformation( $itemno, 0 );
2583 my $bibno = $dbh->quote( $itemdata->{'biblionumber'} );
2584 my $bibitm = $dbh->quote( $itemdata->{'biblioitemnumber'} );
2587 "select * from reserves where ((found = 'W') or (found is null)) and biblionumber = ? and cancellationdate is NULL order by priority, reservedate"
2589 $sth->execute($bibno);
2596 # FIXME - I'm not really sure what's going on here, but since we
2597 # only want one result, wouldn't it be possible (and far more
2598 # efficient) to do something clever in SQL that only returns one
2600 while ( ( $resrec = $sth->fetchrow_hashref ) && ( not $resfound ) ) {
2602 # FIXME - Unlike Pascal, Perl allows you to exit loops
2603 # early. Take out the "&& (not $resfound)" and just
2604 # use "last" at the appropriate point in the loop.
2605 # (Oh, and just in passing: if you'd used "!" instead
2606 # of "not", you wouldn't have needed the parentheses.)
2608 my $brn = $dbh->quote( $resrec->{'borrowernumber'} );
2609 my $rdate = $dbh->quote( $resrec->{'reservedate'} );
2610 my $bibno = $dbh->quote( $resrec->{'biblionumber'} );
2611 if ( $resrec->{'found'} eq "W" ) {
2612 if ( $resrec->{'itemnumber'} eq $itemno ) {
2617 # FIXME - Use 'elsif' to avoid unnecessary indentation.
2618 if ( $resrec->{'constrainttype'} eq "a" ) {
2624 "SELECT * FROM reserveconstraints
2625 WHERE borrowernumber = ?
2627 AND biblionumber = ?
2628 AND biblioitemnumber = ?"
2630 $consth->execute( $brn, $rdate, $bibno, $bibitm );
2631 if ( my $conrec = $consth->fetchrow_hashref ) {
2632 if ( $resrec->{'constrainttype'} eq "o" ) {
2645 WHERE borrowernumber = ?
2647 AND biblionumber = ?"
2649 $updsth->execute( $itemno, $brn, $rdate, $bibno );
2652 # FIXME - "last;" here to break out of the loop early.
2656 return ( $resfound, $lastrec );
2661 ( $date, $invalidduedate ) = fixdate( $year, $month, $day );
2666 my ( $year, $month, $day ) = @_;
2669 if ( $year && $month && $day ) {
2670 if ( ( $year eq 0 ) && ( $month eq 0 ) && ( $year eq 0 ) ) {
2672 # $env{'datedue'}='';
2675 if ( ( $year eq 0 ) || ( $month eq 0 ) || ( $year eq 0 ) ) {
2676 $invalidduedate = 1;
2681 && ( ( $month == 4 )
2684 || ( $month == 11 ) )
2687 $invalidduedate = 1;
2689 elsif ( ( $day > 29 ) && ( $month == 2 ) ) {
2690 $invalidduedate = 1;
2696 && ( ( !( $year % 100 ) || ( $year % 400 ) ) ) )
2699 $invalidduedate = 1;
2702 $date = "$year-$month-$day";
2707 return ( $date, $invalidduedate );
2710 =head2 get_current_return_date_of
2712 &get_current_return_date_of(@itemnumber);
2716 sub get_current_return_date_of {
2717 my (@itemnumbers) = @_;
2723 WHERE itemnumber IN (' . join( ',', @itemnumbers ) . ')
2724 AND returndate IS NULL
2726 return get_infos_of( $query, 'itemnumber', 'date_due' );
2729 =head2 get_transfert_infos
2731 get_transfert_infos($itemnumber);
2735 sub get_transfert_infos {
2736 my ($itemnumber) = @_;
2738 my $dbh = C4::Context->dbh;
2744 FROM branchtransfers
2745 WHERE itemnumber = ?
2746 AND datearrived IS NULL
2748 my $sth = $dbh->prepare($query);
2749 $sth->execute($itemnumber);
2750 my @row = $sth->fetchrow_array();
2755 =head2 DeleteTransfer
2757 &DeleteTransfer($itemnumber);
2761 sub DeleteTransfer {
2762 my ($itemnumber) = @_;
2763 my $dbh = C4::Context->dbh;
2764 my $sth = $dbh->prepare(
2765 "DELETE FROM branchtransfers
2767 AND datearrived IS NULL "
2769 $sth->execute($itemnumber);
2773 =head2 GetTransfersFromBib
2775 @results = GetTransfersFromBib($frombranch,$tobranch);
2779 sub GetTransfersFromBib {
2780 my ( $frombranch, $tobranch ) = @_;
2781 return unless ( $frombranch && $tobranch );
2782 my $dbh = C4::Context->dbh;
2784 SELECT itemnumber,datesent,frombranch
2785 FROM branchtransfers
2788 AND datearrived IS NULL
2790 my $sth = $dbh->prepare($query);
2791 $sth->execute( $frombranch, $tobranch );
2795 while ( my $data = $sth->fetchrow_hashref ) {
2796 $gettransfers[$i] = $data;
2800 return (@gettransfers);
2803 =head2 GetReservesToBranch
2805 @transreserv = GetReservesToBranch( $frombranch, $default );
2809 sub GetReservesToBranch {
2810 my ( $frombranch, $default ) = @_;
2811 my $dbh = C4::Context->dbh;
2812 my $sth = $dbh->prepare(
2813 "SELECT borrowernumber,reservedate,itemnumber,timestamp
2815 WHERE priority='0' AND cancellationdate is null
2820 $sth->execute( $frombranch, $default );
2823 while ( my $data = $sth->fetchrow_hashref ) {
2824 $transreserv[$i] = $data;
2828 return (@transreserv);
2831 =head2 GetReservesForBranch
2833 @transreserv = GetReservesForBranch($frombranch);
2837 sub GetReservesForBranch {
2838 my ($frombranch) = @_;
2839 my $dbh = C4::Context->dbh;
2840 my $sth = $dbh->prepare( "
2841 SELECT borrowernumber,reservedate,itemnumber,waitingdate
2844 AND cancellationdate IS NULL
2847 ORDER BY waitingdate" );
2848 $sth->execute($frombranch);
2851 while ( my $data = $sth->fetchrow_hashref ) {
2852 $transreserv[$i] = $data;
2856 return (@transreserv);
2859 =head2 checktransferts
2861 @tranferts = checktransferts($itemnumber);
2865 sub checktransferts {
2866 my ($itemnumber) = @_;
2867 my $dbh = C4::Context->dbh;
2868 my $sth = $dbh->prepare(
2869 "SELECT datesent,frombranch,tobranch FROM branchtransfers
2870 WHERE itemnumber = ? AND datearrived IS NULL"
2872 $sth->execute($itemnumber);
2873 my @tranferts = $sth->fetchrow_array;
2876 return (@tranferts);
2879 =head2 CheckItemNotify
2881 Sql request to check if the document has alreday been notified
2882 this function is not exported, only used with GetOverduesForBranch
2886 sub CheckItemNotify {
2887 my ($notify_id,$notify_level,$itemnumber) = @_;
2888 my $dbh = C4::Context->dbh;
2889 my $sth = $dbh->prepare("
2890 SELECT COUNT(*) FROM notifys
2892 AND notify_level = ?
2893 AND itemnumber = ? ");
2894 $sth->execute($notify_id,$notify_level,$itemnumber);
2895 my $notified = $sth->fetchrow;
2900 =head2 GetOverduesForBranch
2902 Sql request for display all information for branchoverdues.pl
2903 2 possibilities : with or without department .
2904 display is filtered by branch
2908 sub GetOverduesForBranch {
2909 my ( $branch, $department) = @_;
2910 if ( not $department ) {
2911 my $dbh = C4::Context->dbh;
2912 my $sth = $dbh->prepare("
2915 borrowers.firstname,
2917 itemtypes.description,
2920 branches.branchname,
2924 items.itemcallnumber,
2925 borrowers.borrowernumber,
2927 biblio.biblionumber,
2929 accountlines.notify_id,
2930 accountlines.notify_level,
2932 accountlines.amountoutstanding
2933 FROM issues,borrowers,biblio,biblioitems,itemtypes,items,branches,accountlines
2934 WHERE ( issues.returndate is null)
2935 AND ( accountlines.amountoutstanding != '0.000000')
2936 AND ( accountlines.accounttype = 'FU')
2937 AND ( issues.borrowernumber = accountlines.borrowernumber )
2938 AND ( issues.itemnumber = accountlines.itemnumber )
2939 AND ( borrowers.borrowernumber = issues.borrowernumber )
2940 AND ( biblio.biblionumber = biblioitems.biblionumber )
2941 AND ( biblioitems.biblionumber = items.biblionumber )
2942 AND ( itemtypes.itemtype = biblioitems.itemtype )
2943 AND ( items.itemnumber = issues.itemnumber )
2944 AND ( branches.branchcode = issues.branchcode )
2945 AND (issues.branchcode = ?)
2946 AND (issues.date_due <= NOW())
2947 ORDER BY borrowers.surname
2949 $sth->execute($branch);
2952 while ( my $data = $sth->fetchrow_hashref ) {
2953 #check if the document has already been notified
2954 my $countnotify = CheckItemNotify($data->{'notify_id'},$data->{'notify_level'},$data->{'itemnumber'});
2955 if ($countnotify eq '0'){
2956 $getoverdues[$i] = $data;
2960 return (@getoverdues);
2964 my $dbh = C4::Context->dbh;
2965 my $sth = $dbh->prepare( "
2966 SELECT borrowers.surname,
2967 borrowers.firstname,
2969 itemtypes.description,
2972 branches.branchname,
2976 items.itemcallnumber,
2977 borrowers.borrowernumber,
2979 biblio.biblionumber,
2981 accountlines.notify_id,
2982 accountlines.notify_level,
2984 accountlines.amountoutstanding
2985 FROM issues,borrowers,biblio,biblioitems,itemtypes,items,branches,accountlines
2986 WHERE ( issues.returndate is null )
2987 AND ( accountlines.amountoutstanding != '0.000000')
2988 AND ( accountlines.accounttype = 'FU')
2989 AND ( issues.borrowernumber = accountlines.borrowernumber )
2990 AND ( issues.itemnumber = accountlines.itemnumber )
2991 AND ( borrowers.borrowernumber = issues.borrowernumber )
2992 AND ( biblio.biblionumber = biblioitems.biblionumber )
2993 AND ( biblioitems.biblionumber = items.biblionumber )
2994 AND ( itemtypes.itemtype = biblioitems.itemtype )
2995 AND ( items.itemnumber = issues.itemnumber )
2996 AND ( branches.branchcode = issues.branchcode )
2997 AND (issues.branchcode = ? AND items.location = ?)
2998 AND (issues.date_due <= NOW())
2999 ORDER BY borrowers.surname
3001 $sth->execute( $branch, $department);
3004 while ( my $data = $sth->fetchrow_hashref ) {
3005 #check if the document has already been notified
3006 my $countnotify = CheckItemNotify($data->{'notify_id'},$data->{'notify_level'},$data->{'itemnumber'});
3007 if ($countnotify eq '0'){
3008 $getoverdues[$i] = $data;
3013 return (@getoverdues);
3018 =head2 AddNotifyLine
3020 &AddNotifyLine($borrowernumber, $itemnumber, $overduelevel, $method, $notifyId)
3022 Creat a line into notify, if the method is phone, the notification_send_date is implemented to
3027 my ( $borrowernumber, $itemnumber, $overduelevel, $method, $notifyId ) = @_;
3028 if ( $method eq "phone" ) {
3029 my $dbh = C4::Context->dbh;
3030 my $sth = $dbh->prepare(
3031 "INSERT INTO notifys (borrowernumber,itemnumber,notify_date,notify_send_date,notify_level,method,notify_id)
3032 VALUES (?,?,now(),now(),?,?,?)"
3034 $sth->execute( $borrowernumber, $itemnumber, $overduelevel, $method,
3039 my $dbh = C4::Context->dbh;
3040 my $sth = $dbh->prepare(
3041 "INSERT INTO notifys (borrowernumber,itemnumber,notify_date,notify_level,method,notify_id)
3042 VALUES (?,?,now(),?,?,?)"
3044 $sth->execute( $borrowernumber, $itemnumber, $overduelevel, $method,
3051 =head2 RemoveNotifyLine
3053 &RemoveNotifyLine( $borrowernumber, $itemnumber, $notify_date );
3055 Cancel a notification
3059 sub RemoveNotifyLine {
3060 my ( $borrowernumber, $itemnumber, $notify_date ) = @_;
3061 my $dbh = C4::Context->dbh;
3062 my $sth = $dbh->prepare(
3063 "DELETE FROM notifys
3069 $sth->execute( $borrowernumber, $itemnumber, $notify_date );
3074 =head2 AnonymiseIssueHistory
3076 $rows = AnonymiseIssueHistory($borrowernumber,$date)
3078 This function write NULL instead of C<$borrowernumber> given on input arg into the table issues.
3079 if C<$borrowernumber> is not set, it will delete the issue history for all borrower older than C<$date>.
3081 return the number of affected rows.
3085 sub AnonymiseIssueHistory {
3087 my $borrowernumber = shift;
3088 my $dbh = C4::Context->dbh;
3091 SET borrowernumber = NULL
3092 WHERE returndate < '".$date."'
3093 AND borrowernumber IS NOT NULL
3095 $query .= " AND borrowernumber = '".$borrowernumber."'" if defined $borrowernumber;
3096 my $rows_affected = $dbh->do($query);
3097 return $rows_affected;
3102 $items = GetItemsLost($where,$orderby);
3104 This function get the items lost into C<$items>.
3109 C<$where> is a hashref. it containts a field of the items table as key
3110 and the value to match as value.
3111 C<$orderby> is a field of the items table.
3114 C<$items> is a reference to an array full of hasref which keys are items' table column.
3116 =item usage in the perl script:
3119 $where{barcode} = 0001548;
3120 my $items = GetLostItems( \%where, "homebranch" );
3121 $template->param(itemsloop => $items);
3128 # Getting input args.
3130 my $orderby = shift;
3131 my $dbh = C4::Context->dbh;
3136 WHERE itemlost IS NOT NULL
3139 foreach my $key (keys %$where) {
3140 $query .= " AND " . $key . " LIKE '%" . $where->{$key} . "%'";
3142 $query .= " ORDER BY ".$orderby if defined $orderby;
3144 my $sth = $dbh->prepare($query);
3147 while ( my $row = $sth->fetchrow_hashref ){
3153 =head2 updateWrongTransfer
3155 $items = updateWrongTransfer($itemNumber,$borrowernumber,$waitingAtLibrary,$FromLibrary);
3157 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
3161 sub updateWrongTransfer {
3162 my ( $itemNumber,$waitingAtLibrary,$FromLibrary ) = @_;
3163 my $dbh = C4::Context->dbh;
3164 # first step validate the actual line of transfert .
3167 "update branchtransfers set datearrived = now(),tobranch=?,comments='wrongtransfer' where itemnumber= ? AND datearrived IS NULL"
3169 $sth->execute($FromLibrary,$itemNumber);
3172 # second step create a new line of branchtransfer to the right location .
3173 dotransfer($itemNumber, $FromLibrary, $waitingAtLibrary);
3175 #third step changing holdingbranch of item
3176 UpdateHoldingbranch($FromLibrary,$itemNumber);
3179 =head2 UpdateHoldingbranch
3181 $items = UpdateHoldingbranch($branch,$itmenumber);
3182 Simple methode for updating hodlingbranch in items BDD line
3185 sub UpdateHoldingbranch {
3186 my ( $branch,$itmenumber ) = @_;
3187 my $dbh = C4::Context->dbh;
3188 # first step validate the actual line of transfert .
3191 "update items set holdingbranch = ? where itemnumber= ?"
3193 $sth->execute($branch,$itmenumber);
3205 Koha Developement team <info@koha.org>