1 package C4::Circulation::Circ2;
5 #package to deal with Returns
6 #written 3/11/99 by olwen@katipo.co.nz
10 # Copyright 2000-2002 Katipo Communications
12 # This file is part of Koha.
14 # Koha is free software; you can redistribute it and/or modify it under the
15 # terms of the GNU General Public License as published by the Free Software
16 # Foundation; either version 2 of the License, or (at your option) any later
19 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
20 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
21 # A PARTICULAR PURPOSE. See the GNU General Public License for more details.
23 # You should have received a copy of the GNU General Public License along with
24 # Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
25 # Suite 330, Boston, MA 02111-1307 USA
33 #use C4::InterfaceCDK;
34 #use C4::Circulation::Main;
35 #use C4::Circulation::Renewals;
42 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
44 # set the version for version checking
49 C4::Circulation::Circ2 - Koha circulation module
53 use C4::Circulation::Circ2;
57 The functions in this module deal with circulation, issues, and
58 returns, as well as general information about the library.
67 @EXPORT = qw(&getbranches &getprinters &getpatroninformation
68 ¤tissues &getissues &getiteminformation &findborrower
69 &issuebook &returnbook &find_reserves &transferbook &decode
74 $branches = &getbranches();
75 @branch_codes = keys %$branches;
76 %main_branch_info = %{$branches->{"MAIN"}};
78 Returns information about existing library branches.
80 C<$branches> is a reference-to-hash. Its keys are the branch codes for
81 all of the existing library branches, and its values are
82 references-to-hash describing that particular branch.
84 In each branch description (C<%main_branch_info>, above), there is a
85 key for each field in the branches table of the Koha database. In
86 addition, there is a key for each branch category code to which the
87 branch belongs (the category codes are taken from the branchrelations
92 # FIXME - This function doesn't feel as if it belongs here. It should
93 # go in some generic or administrative module, not in circulation.
95 # returns a reference to a hash of references to branches...
97 my $dbh = C4::Context->dbh;
98 my $sth=$dbh->prepare("select * from branches");
100 while (my $branch=$sth->fetchrow_hashref) {
101 my $tmp = $branch->{'branchcode'}; my $brc = $dbh->quote($tmp);
102 # FIXME - my $brc = $dbh->quote($branch->{"branchcode"});
103 my $query = "select categorycode from branchrelations where branchcode = $brc";
104 my $nsth = $dbh->prepare($query);
106 while (my ($cat) = $nsth->fetchrow_array) {
107 # FIXME - This seems wrong. It ought to be
108 # $branch->{categorycodes}{$cat} = 1;
109 # otherwise, there's a namespace collision if there's a
110 # category with the same name as a field in the 'branches'
111 # table (i.e., don't create a category called "issuing").
112 # In addition, the current structure doesn't really allow
113 # you to list the categories that a branch belongs to:
114 # you'd have to list keys %$branch, and remove those keys
115 # that aren't fields in the "branches" table.
119 $branches{$branch->{'branchcode'}}=$branch;
126 $printers = &getprinters($env);
127 @queues = keys %$printers;
129 Returns information about existing printer queues.
133 C<$printers> is a reference-to-hash whose keys are the print queues
134 defined in the printers table of the Koha database. The values are
135 references-to-hash, whose keys are the fields in the printers table.
139 # FIXME - Perhaps this really belongs in C4::Print?
143 my $dbh = C4::Context->dbh;
144 my $sth=$dbh->prepare("select * from printers");
146 while (my $printer=$sth->fetchrow_hashref) {
147 $printers{$printer->{'printqueue'}}=$printer;
152 =item getpatroninformation
154 ($borrower, $flags) = &getpatroninformation($env, $borrowernumber,
157 Looks up a patron and returns information about him or her. If
158 C<$borrowernumber> is true (nonzero), C<&getpatroninformation> looks
159 up the borrower by number; otherwise, it looks up the borrower by card
162 C<$env> is effectively ignored, but should be a reference-to-hash.
164 C<$borrower> is a reference-to-hash whose keys are the fields of the
165 borrowers table in the Koha database. In addition,
166 C<$borrower-E<gt>{flags}> is the same as C<$flags>.
168 C<$flags> is a reference-to-hash giving more detailed information
169 about the patron. Its keys act as flags: if they are set, then the key
170 is a reference-to-hash that gives further details:
172 if (exists($flags->{LOST}))
174 # Patron's card was reported lost
175 print $flags->{LOST}{message}, "\n";
178 Each flag has a C<message> key, giving a human-readable explanation of
179 the flag. If the state of a flag means that the patron should not be
180 allowed to borrow any more books, then it will have a C<noissues> key
183 The possible flags are:
189 Shows the patron's credit or debt, if any.
193 (Gone, no address.) Set if the patron has left without giving a
198 Set if the patron's card has been reported as lost.
202 Set if the patron has been debarred.
206 Any additional notes about the patron.
210 Set if the patron has overdue items. This flag has several keys:
212 C<$flags-E<gt>{ODUES}{itemlist}> is a reference-to-array listing the
213 overdue items. Its elements are references-to-hash, each describing an
214 overdue item. The keys are selected fields from the issues, biblio,
215 biblioitems, and items tables of the Koha database.
217 C<$flags-E<gt>{ODUES}{itemlist}> is a string giving a text listing of
218 the overdue items, one per line.
222 Set if any items that the patron has reserved are available.
224 C<$flags-E<gt>{WAITING}{itemlist}> is a reference-to-array listing the
225 available items. Each element is a reference-to-hash whose keys are
226 fields from the reserves table of the Koha database.
232 sub getpatroninformation {
234 my ($env, $borrowernumber,$cardnumber) = @_;
235 my $dbh = C4::Context->dbh;
238 if ($borrowernumber) {
239 $query = "select * from borrowers where borrowernumber=$borrowernumber";
240 } elsif ($cardnumber) {
241 $query = "select * from borrowers where cardnumber=$cardnumber";
243 $env->{'apierror'} = "invalid borrower information passed to getpatroninformation subroutine";
246 $env->{'mess'} = $query;
247 $sth = $dbh->prepare($query);
249 my $borrower = $sth->fetchrow_hashref;
250 my $flags = patronflags($env, $borrower, $dbh);
252 $borrower->{'flags'}=$flags;
253 return($borrower, $flags);
258 $str = &decode($chunk);
260 Decodes a segment of a string emitted by a CueCat barcode scanner and
265 # FIXME - At least, I'm pretty sure this is for decoding CueCat stuff.
268 my $seq = 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789+-';
269 my @s = map { index($seq,$_); } split(//,$encoded);
284 my $n = (($s[0] << 6 | $s[1]) << 6 | $s[2]) << 6 | $s[3];
285 $r .=chr(($n >> 16) ^ 67) .
286 chr(($n >> 8 & 255) ^ 67) .
287 chr(($n & 255) ^ 67);
290 $r = substr($r,0,length($r)-$l);
294 =item getiteminformation
296 $item = &getiteminformation($env, $itemnumber, $barcode);
298 Looks up information about an item, given either its item number or
299 its barcode. If C<$itemnumber> is a nonzero value, it is used;
300 otherwise, C<$barcode> is used.
302 C<$env> is effectively ignored, but should be a reference-to-hash.
304 C<$item> is a reference-to-hash whose keys are fields from the biblio,
305 items, and biblioitems tables of the Koha database. It may also
306 contain the following keys:
312 The due date on this item, if it has been borrowed and not returned
313 yet. The date is in YYYY-MM-DD format.
317 The length of time for which the item can be borrowed, in days.
321 True if the item may not be borrowed.
327 sub getiteminformation {
328 # returns a hash of item information given either the itemnumber or the barcode
329 my ($env, $itemnumber, $barcode) = @_;
330 my $dbh = C4::Context->dbh;
333 $sth=$dbh->prepare("select * from biblio,items,biblioitems where items.itemnumber=$itemnumber and biblio.biblionumber=items.biblionumber and biblioitems.biblioitemnumber = items.biblioitemnumber");
335 my $q_barcode=$dbh->quote($barcode);
336 $sth=$dbh->prepare("select * from biblio,items,biblioitems where items.barcode=$q_barcode and biblio.biblionumber=items.biblionumber and biblioitems.biblioitemnumber = items.biblioitemnumber");
338 $env->{'apierror'}="getiteminformation() subroutine must be called with either an itemnumber or a barcode";
343 my $iteminformation=$sth->fetchrow_hashref;
345 # FIXME - Style: instead of putting the entire rest of the
346 # function in a block, just say
347 # return undef unless $iteminformation;
348 # That way, the rest of the function needn't be indented as much.
349 if ($iteminformation) {
350 $sth=$dbh->prepare("select date_due from issues where itemnumber=$iteminformation->{'itemnumber'} and isnull(returndate)");
352 my ($date_due) = $sth->fetchrow;
353 $iteminformation->{'date_due'}=$date_due;
355 # FIXME - The Dewey code is a string, not a number. Besides,
356 # "000" is a perfectly valid Dewey code.
357 #$iteminformation->{'dewey'}=~s/0*$//;
358 ($iteminformation->{'dewey'} == 0) && ($iteminformation->{'dewey'}='');
359 # FIXME - fetchrow_hashref is documented as being inefficient.
360 # Perhaps this should be rewritten as
361 # $sth = $dbh->prepare("select loanlength, notforloan ...");
363 # ($iteminformation->{loanlength},
364 # $iteminformation->{notforloan}) = fetchrow_array;
365 $sth=$dbh->prepare("select * from itemtypes where itemtype='$iteminformation->{'itemtype'}'");
367 my $itemtype=$sth->fetchrow_hashref;
368 $iteminformation->{'loanlength'}=$itemtype->{'loanlength'};
369 $iteminformation->{'notforloan'}=$itemtype->{'notforloan'};
372 return($iteminformation);
377 $borrowers = &findborrower($env, $key);
378 print $borrowers->[0]{surname};
380 Looks up patrons and returns information about them.
384 C<$key> is either a card number or a string. C<&findborrower> tries to
385 look it up as a card number first. If that fails, C<&findborrower>
386 looks up all patrons whose surname begins with C<$key>.
388 C<$borrowers> is a reference-to-array. Each element is a
389 reference-to-hash whose keys are the fields of the borrowers table in
394 # If you really want to throw a monkey wrench into the works, change
395 # your last name to "V10000008" :-)
397 # FIXME - This is different from &C4::Borrower::findborrower, but I
398 # think that one's obsolete.
400 # returns an array of borrower hash references, given a cardnumber or a partial
402 my ($env, $key) = @_;
403 my $dbh = C4::Context->dbh;
405 my $q_key=$dbh->quote($key);
406 my $sth=$dbh->prepare("select * from borrowers where cardnumber=$q_key");
409 my ($borrower)=$sth->fetchrow_hashref;
410 push (@borrowers, $borrower);
412 $q_key=$dbh->quote("$key%");
414 $sth=$dbh->prepare("select * from borrowers where surname like $q_key");
416 while (my $borrower = $sth->fetchrow_hashref) {
417 push (@borrowers, $borrower);
427 ($dotransfer, $messages, $iteminformation) =
428 &transferbook($newbranch, $barcode, $ignore_reserves);
430 Transfers an item to a new branch. If the item is currently on loan,
431 it is automatically returned before the actual transfer.
433 C<$newbranch> is the code for the branch to which the item should be
436 C<$barcode> is the barcode of the item to be transferred.
438 If C<$ignore_reserves> is true, C<&transferbook> ignores reserves.
439 Otherwise, if an item is reserved, the transfer fails.
441 Returns three values:
443 C<$dotransfer> is true iff the transfer was successful.
445 C<$messages> is a reference-to-hash which may have any of the
452 There is no item in the catalog with the given barcode. The value is
457 The item's home branch is permanent. This doesn't prevent the item
458 from being transferred, though. The value is the code of the item's
461 =item C<DestinationEqualsHolding>
463 The item is already at the branch to which it is being transferred.
464 The transfer is nonetheless considered to have failed. The value
469 The item was on loan, and C<&transferbook> automatically returned it
470 before transferring it. The value is the borrower number of the patron
475 The item was reserved. The value is a reference-to-hash whose keys are
476 fields from the reserves table of the Koha database, and
477 C<biblioitemnumber>. It also has the key C<ResFound>, whose value is
478 either C<Waiting> or C<Reserved>.
480 =item C<WasTransferred>
482 The item was eligible to be transferred. Barring problems
483 communicating with the database, the transfer should indeed have
484 succeeded. The value should be ignored.
490 # FIXME - This function tries to do too much, and its API is clumsy.
491 # If it didn't also return books, it could be used to change the home
492 # branch of a book while the book is on loan.
494 # Is there any point in returning the item information? The caller can
495 # look that up elsewhere if ve cares.
497 # This leaves the ($dotransfer, $messages) tuple. This seems clumsy.
498 # If the transfer succeeds, that's all the caller should need to know.
499 # Thus, this function could simply return 1 or 0 to indicate success
500 # or failure, and set $C4::Circulation::Circ2::errmsg in case of
501 # failure. Or this function could return undef if successful, and an
502 # error message in case of failure (this would feel more like C than
505 # transfer book code....
506 my ($tbr, $barcode, $ignoreRs) = @_;
510 my $branches = getbranches();
511 my $iteminformation = getiteminformation(\%env, 0, $barcode);
513 if (not $iteminformation) {
514 $messages->{'BadBarcode'} = $barcode;
517 # get branches of book...
518 my $hbr = $iteminformation->{'homebranch'};
519 my $fbr = $iteminformation->{'holdingbranch'};
521 if ($branches->{$hbr}->{'PE'}) {
522 $messages->{'IsPermanent'} = $hbr;
524 # can't transfer book if is already there....
525 # FIXME - Why not? Shouldn't it trivially succeed?
527 $messages->{'DestinationEqualsHolding'} = 1;
530 # check if it is still issued to someone, return it...
531 my ($currentborrower) = currentborrower($iteminformation->{'itemnumber'});
532 if ($currentborrower) {
533 returnbook($barcode, $fbr);
534 $messages->{'WasReturned'} = $currentborrower;
537 # FIXME - Don't call &CheckReserves unless $ignoreRs is true.
538 # That'll save a database query.
539 my ($resfound, $resrec) = CheckReserves($iteminformation->{'itemnumber'});
540 if ($resfound and not $ignoreRs) {
541 $resrec->{'ResFound'} = $resfound;
542 $messages->{'ResFound'} = $resrec;
545 #actually do the transfer....
547 dotransfer($iteminformation->{'itemnumber'}, $fbr, $tbr);
548 $messages->{'WasTransfered'} = 1;
550 return ($dotransfer, $messages, $iteminformation);
554 # FIXME - This is only used in &transferbook. Why bother making it a
557 my ($itm, $fbr, $tbr) = @_;
558 my $dbh = C4::Context->dbh;
559 $itm = $dbh->quote($itm);
560 $fbr = $dbh->quote($fbr);
561 $tbr = $dbh->quote($tbr);
562 #new entry in branchtransfers....
564 INSERT INTO branchtransfers
565 (itemnumber, frombranch, datearrived, tobranch)
566 VALUES ($itm, $fbr, now(), $tbr)
569 #update holdingbranch in items .....
572 SET datelastseen = now(),
574 WHERE items.itemnumber = $itm
581 ($iteminformation, $datedue, $rejected, $question, $questionnumber,
582 $defaultanswer, $message) =
583 &issuebook($env, $patroninformation, $barcode, $responses, $date);
585 Issue a book to a patron.
587 C<$env-E<gt>{usercode}> will be used in the usercode field of the
588 statistics table of the Koha database when this transaction is
591 C<$env-E<gt>{datedue}>, if given, specifies the date on which the book
592 is due back. This should be a string of the form "YYYY-MM-DD".
594 C<$env-E<gt>{branchcode}> is the code of the branch where this
595 transaction is taking place.
597 C<$patroninformation> is a reference-to-hash giving information about
598 the person borrowing the book. This is the first value returned by
599 C<&getpatroninformation>.
601 C<$barcode> is the bar code of the book being issued.
603 C<$responses> is a reference-to-hash. It represents the answers to the
604 questions asked by the C<$question>, C<$questionnumber>, and
605 C<$defaultanswer> return values (see below). The keys are numbers, and
606 the values can be "Y" or "N".
608 C<$date> is an optional date in the form "YYYY-MM-DD". If specified,
609 then only fines and charges up to that date will be considered when
610 checking to see whether the patron owes too much money to be lent a
613 C<&issuebook> returns an array of seven values:
615 C<$iteminformation> is a reference-to-hash describing the item just
616 issued. This in a form similar to that returned by
617 C<&getiteminformation>.
619 C<$datedue> is a string giving the date when the book is due, in the
622 C<$rejected> is either a string, or -1. If it is defined and is a
623 string, then the book may not be issued, and C<$rejected> gives the
624 reason for this. If C<$rejected> is -1, then the book may not be
625 issued, but no reason is given.
627 If there is a problem or question (e.g., the book is reserved for
628 another patron), then C<$question>, C<$questionnumber>, and
629 C<$defaultanswer> will be set. C<$questionnumber> indicates the
630 problem. C<$question> is a text string asking how to resolve the
631 problem, as a yes-or-no question, and C<$defaultanswer> is either "Y"
632 or "N", giving the default answer. The questions, their numbers, and
637 =item 1: "Issued to <name>. Mark as returned?" (Y)
639 =item 2: "Waiting for <patron> at <branch>. Allow issue?" (N)
641 =item 3: "Cancel reserve for <patron>?" (N)
643 =item 4: "Book is issued to this borrower. Renew?" (Y)
645 =item 5: "Reserved for <patron> at <branch> since <date>. Allow issue?" (N)
647 =item 6: "Set reserve for <patron> to waiting and transfer to <branch>?" (Y)
649 This is asked if the answer to question 5 was "N".
651 =item 7: "Cancel reserve for <patron>?" (N)
655 C<$message>, if defined, is an additional information message, e.g., a
660 # FIXME - The business with $responses is absurd. For one thing, these
661 # questions should have names, not numbers. For another, it'd be
662 # better to have the last argument be %extras. Then scripts can call
666 # -mark_returned => 0,
667 # -cancel_reserve => 1,
670 # and the script can use
671 # if (defined($extras{"-mark_returned"}) && $extras{"-mark_returned"})
672 # Heck, the $date argument should go in there as well.
674 # Also, there might be several reasons why a book can't be issued, but
675 # this API only supports asking one question at a time. Perhaps it'd
676 # be better to return a ref-to-list of problem IDs. Then the calling
677 # script can display a list of all of the problems at once.
679 # Is it this function's place to decide the default answer to the
680 # various questions? Why not document the various problems and allow
681 # the caller to decide?
683 my ($env, $patroninformation, $barcode, $responses, $date) = @_;
684 my $dbh = C4::Context->dbh;
685 my $iteminformation = getiteminformation($env, 0, $barcode);
687 my ($rejected,$question,$defaultanswer,$questionnumber, $noissue);
690 # See if there's any reason this book shouldn't be issued to this
692 SWITCH: { # FIXME - Yes, we know it's a switch. Tell us what it's for.
693 if ($patroninformation->{'gonenoaddress'}) {
694 $rejected="Patron is gone, with no known address.";
697 if ($patroninformation->{'lost'}) {
698 $rejected="Patron's card has been reported lost.";
701 if ($patroninformation->{'debarred'}) {
702 $rejected="Patron is Debarred";
705 my $amount = checkaccount($env,$patroninformation->{'borrowernumber'}, $dbh,$date);
706 # FIXME - "5" shouldn't be hardcoded. An Italian library might
707 # be generous enough to lend a book to a patron even if he
708 # does still owe them 5 lire.
709 if ($amount > 5 && $patroninformation->{'categorycode'} ne 'L' &&
710 $patroninformation->{'categorycode'} ne 'W' &&
711 $patroninformation->{'categorycode'} ne 'I' &&
712 $patroninformation->{'categorycode'} ne 'B' &&
713 $patroninformation->{'categorycode'} ne 'P') {
714 # FIXME - What do these category codes mean?
715 $rejected = sprintf "Patron owes \$%.02f.", $amount;
718 # FIXME - This sort of error-checking should be placed closer
719 # to the test; in this case, this error-checking should be
720 # done immediately after the call to &getiteminformation.
721 unless ($iteminformation) {
722 $rejected = "$barcode is not a valid barcode.";
725 if ($iteminformation->{'notforloan'} == 1) {
726 $rejected="Reference item: not for loan.";
729 if ($iteminformation->{'wthdrawn'} == 1) {
730 $rejected="Item withdrawn.";
733 if ($iteminformation->{'restricted'} == 1) {
734 $rejected="Restricted item.";
738 # See who, if anyone, currently has this book.
739 my ($currentborrower) = currentborrower($iteminformation->{'itemnumber'});
740 if ($currentborrower eq $patroninformation->{'borrowernumber'}) {
741 # Already issued to current borrower. Ask whether the loan should
743 my ($renewstatus) = renewstatus($env,$dbh,$patroninformation->{'borrowernumber'}, $iteminformation->{'itemnumber'});
744 if ($renewstatus == 0) {
745 $rejected="No more renewals allowed for this item.";
748 if ($responses->{4} eq '') {
750 $question = "Book is issued to this borrower.\nRenew?";
751 $defaultanswer = 'Y';
753 } elsif ($responses->{4} eq 'Y') {
754 my $charge = calc_charges($env, $dbh, $iteminformation->{'itemnumber'}, $patroninformation->{'borrowernumber'});
756 createcharge($env, $dbh, $iteminformation->{'itemnumber'}, $patroninformation->{'borrowernumber'}, $charge);
757 $iteminformation->{'charge'} = $charge;
759 &UpdateStats($env,$env->{'branchcode'},'renew',$charge,'',$iteminformation->{'itemnumber'},$iteminformation->{'itemtype'});
760 renewbook($env,$dbh, $patroninformation->{'borrowernumber'}, $iteminformation->{'itemnumber'});
767 } elsif ($currentborrower ne '') {
768 # This book is currently on loan, but not to the person
769 # who wants to borrow it now.
770 my ($currborrower, $cbflags) = getpatroninformation($env,$currentborrower,0);
771 if ($responses->{1} eq '') {
773 $question = "Issued to $currborrower->{'firstname'} $currborrower->{'surname'} ($currborrower->{'cardnumber'}).\nMark as returned?";
776 } elsif ($responses->{1} eq 'Y') {
777 returnbook($iteminformation->{'barcode'}, $env->{'branch'});
784 # See if the item is on reserve.
785 my ($restype, $res) = CheckReserves($iteminformation->{'itemnumber'});
787 my $resbor = $res->{'borrowernumber'};
788 if ($resbor eq $patroninformation->{'borrowernumber'}) {
789 # The item is on reserve to the current patron
791 } elsif ($restype eq "Waiting") {
792 # The item is on reserve and waiting, but has been
793 # reserved by some other patron.
794 my ($resborrower, $flags)=getpatroninformation($env, $resbor,0);
795 my $branches = getbranches();
796 my $branchname = $branches->{$res->{'branchcode'}}->{'branchname'};
797 if ($responses->{2} eq '') {
799 # FIXME - Assumes HTML
800 $question="<font color=red>Waiting</font> for $resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'}) at $branchname \nAllow issue?";
803 } elsif ($responses->{2} eq 'N') {
807 if ($responses->{3} eq '') {
809 $question="Cancel reserve for $resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'})?";
812 } elsif ($responses->{3} eq 'Y') {
813 CancelReserve(0, $res->{'itemnumber'}, $res->{'borrowernumber'});
816 } elsif ($restype eq "Reserved") {
817 # The item is on reserve for someone else.
818 my ($resborrower, $flags)=getpatroninformation($env, $resbor,0);
819 my $branches = getbranches();
820 my $branchname = $branches->{$res->{'branchcode'}}->{'branchname'};
821 if ($responses->{5} eq '') {
823 $question="Reserved for $resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'}) since $res->{'reservedate'} \nAllow issue?";
826 } elsif ($responses->{5} eq 'N') {
827 if ($responses->{6} eq '') {
829 $question="Set reserve for $resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'}) to waiting and transfer to $branchname?";
831 } elsif ($responses->{6} eq 'Y') {
832 my $tobrcd = ReserveWaiting($res->{'itemnumber'}, $res->{'borrowernumber'});
833 transferbook($tobrcd, $barcode, 1);
834 $message = "Item should now be waiting at $branchname";
839 if ($responses->{7} eq '') {
841 $question="Cancel reserve for $resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'})?";
844 } elsif ($responses->{7} eq 'Y') {
845 CancelReserve(0, $res->{'itemnumber'}, $res->{'borrowernumber'});
852 unless (($question) || ($rejected) || ($noissue)) {
853 # There's no reason why the item can't be issued.
854 # FIXME - my $loanlength = $iteminformation->{loanlength} || 21;
856 if ($iteminformation->{'loanlength'}) {
857 $loanlength=$iteminformation->{'loanlength'};
859 my $ti=time; # FIXME - Never used
860 my $datedue=time+($loanlength)*86400;
861 # FIXME - Could just use POSIX::strftime("%Y-%m-%d", localtime);
862 # That's what it's for. Or, in this case:
863 # $dateduef = $env->{datedue} ||
864 # strftime("%Y-%m-%d", localtime(time +
865 # $loanlength * 86400));
866 my @datearr = localtime($datedue);
867 $dateduef = (1900+$datearr[5])."-".($datearr[4]+1)."-".$datearr[3];
868 if ($env->{'datedue'}) {
869 $dateduef=$env->{'datedue'};
871 $dateduef=~ s/2001\-4\-25/2001\-4\-26/;
872 # FIXME - What's this for? Leftover from debugging?
874 # Record in the database the fact that the book was issued.
875 # FIXME - Use $dbh->do();
876 my $sth=$dbh->prepare("insert into issues (borrowernumber, itemnumber, date_due, branchcode) values ($patroninformation->{'borrowernumber'}, $iteminformation->{'itemnumber'}, '$dateduef', '$env->{'branchcode'}')");
879 $iteminformation->{'issues'}++;
880 # FIXME - Use $dbh->do();
881 $sth=$dbh->prepare("update items set issues=$iteminformation->{'issues'},datelastseen=now() where itemnumber=$iteminformation->{'itemnumber'}");
884 # If it costs to borrow this book, charge it to the patron's account.
885 my $charge=calc_charges($env, $dbh, $iteminformation->{'itemnumber'}, $patroninformation->{'borrowernumber'});
887 createcharge($env, $dbh, $iteminformation->{'itemnumber'}, $patroninformation->{'borrowernumber'}, $charge);
888 $iteminformation->{'charge'}=$charge;
890 # Record the fact that this book was issued.
891 &UpdateStats($env,$env->{'branchcode'},'issue',$charge,'',$iteminformation->{'itemnumber'},$iteminformation->{'itemtype'});
893 if ($iteminformation->{'charge'}) {
894 $message=sprintf "Rental charge of \$%.02f applies.", $iteminformation->{'charge'};
896 return ($iteminformation, $dateduef, $rejected, $question, $questionnumber, $defaultanswer, $message);
903 ($doreturn, $messages, $iteminformation, $borrower) =
904 &returnbook($barcode, $branch);
908 C<$barcode> is the bar code of the book being returned. C<$branch> is
909 the code of the branch where the book is being returned.
911 C<&returnbook> returns a list of four items:
913 C<$doreturn> is true iff the return succeeded.
915 C<$messages> is a reference-to-hash giving the reason for failure:
921 No item with this barcode exists. The value is C<$barcode>.
925 The book is not currently on loan. The value is C<$barcode>.
929 The book's home branch is a permanent collection. If you have borrowed
930 this book, you are not allowed to return it. The value is the code for
931 the book's home branch.
935 This book has been withdrawn/cancelled. The value should be ignored.
939 The item was reserved. The value is a reference-to-hash whose keys are
940 fields from the reserves table of the Koha database, and
941 C<biblioitemnumber>. It also has the key C<ResFound>, whose value is
942 either C<Waiting>, C<Reserved>, or 0.
946 C<$borrower> is a reference-to-hash, giving information about the
947 patron who last borrowed the book.
951 # FIXME - This API is bogus. There's no need to return $borrower and
952 # $iteminformation; the caller can ask about those separately, if it
953 # cares (it'd be inefficient to make two database calls instead of
954 # one, but &getpatroninformation and &getiteminformation can be
955 # memoized if this is an issue).
957 # The ($doreturn, $messages) tuple is redundant: if the return
958 # succeeded, that's all the caller needs to know. So &returnbook can
959 # return 1 and 0 on success and failure, and set
960 # $C4::Circulation::Circ2::errmsg to indicate the error. Or it can
961 # return undef for success, and an error message on error (though this
962 # is more C-ish than Perl-ish).
964 my ($barcode, $branch) = @_;
968 # get information on item
969 my ($iteminformation) = getiteminformation(\%env, 0, $barcode);
970 if (not $iteminformation) {
971 $messages->{'BadBarcode'} = $barcode;
975 my ($currentborrower) = currentborrower($iteminformation->{'itemnumber'});
976 if ((not $currentborrower) && $doreturn) {
977 $messages->{'NotIssued'} = $barcode;
980 # check if the book is in a permanent collection....
981 my $hbr = $iteminformation->{'homebranch'};
982 my $branches = getbranches();
983 if ($branches->{$hbr}->{'PE'}) {
984 $messages->{'IsPermanent'} = $hbr;
986 # check that the book has been cancelled
987 if ($iteminformation->{'wthdrawn'}) {
988 $messages->{'wthdrawn'} = 1;
991 # update issues, thereby returning book (should push this out into another subroutine
992 my ($borrower) = getpatroninformation(\%env, $currentborrower, 0);
994 doreturn($borrower->{'borrowernumber'}, $iteminformation->{'itemnumber'});
995 $messages->{'WasReturned'}; # FIXME - This does nothing
997 ($borrower) = getpatroninformation(\%env, $currentborrower, 0);
998 # transfer book to the current branch
999 my ($transfered, $mess, $item) = transferbook($branch, $barcode, 1);
1000 if ($transfered) { # FIXME - perl -wc complains about this line.
1001 $messages->{'WasTransfered'}; # FIXME - This does nothing
1003 # fix up the accounts.....
1004 if ($iteminformation->{'itemlost'}) {
1005 # Mark the item as not being lost.
1006 updateitemlost($iteminformation->{'itemnumber'});
1007 fixaccountforlostandreturned($iteminformation, $borrower);
1008 $messages->{'WasLost'}; # FIXME - This does nothing
1010 # fix up the overdues in accounts...
1011 fixoverduesonreturn($borrower->{'borrowernumber'}, $iteminformation->{'itemnumber'});
1012 # find reserves.....
1013 my ($resfound, $resrec) = CheckReserves($iteminformation->{'itemnumber'});
1015 $resrec->{'ResFound'} = $resfound;
1016 $messages->{'ResFound'} = $resrec;
1019 # Record the fact that this book was returned.
1020 UpdateStats(\%env, $branch ,'return','0','',$iteminformation->{'itemnumber'});
1021 return ($doreturn, $messages, $iteminformation, $borrower);
1025 # Takes a borrowernumber and an itemnuber.
1026 # Updates the 'issues' table to mark the item as returned (assuming
1027 # that it's currently on loan to the given borrower. Otherwise, the
1028 # item remains on loan.
1029 # Updates items.datelastseen for the item.
1031 # FIXME - This is only used in &returnbook. Why make it into a
1032 # separate function?
1034 my ($brn, $itm) = @_;
1035 my $dbh = C4::Context->dbh;
1036 $brn = $dbh->quote($brn);
1037 $itm = $dbh->quote($itm);
1038 my $query = "update issues set returndate = now() where (borrowernumber = $brn)
1039 and (itemnumber = $itm) and (returndate is null)";
1040 my $sth = $dbh->prepare($query);
1043 $query="update items set datelastseen=now() where itemnumber=$itm";
1044 $sth=$dbh->prepare($query);
1051 # Marks an item as not being lost.
1055 my $dbh = C4::Context->dbh;
1060 WHERE itemnumber = $itemno
1065 sub fixaccountforlostandreturned {
1066 my ($iteminfo, $borrower) = @_;
1068 my $dbh = C4::Context->dbh;
1069 my $itm = $dbh->quote($iteminfo->{'itemnumber'});
1070 # check for charge made for lost book
1071 my $query = "select * from accountlines where (itemnumber = $itm)
1072 and (accounttype='L' or accounttype='Rep') order by date desc";
1073 my $sth = $dbh->prepare($query);
1075 if (my $data = $sth->fetchrow_hashref) {
1076 # writeoff this amount
1078 my $amount = $data->{'amount'};
1079 my $acctno = $data->{'accountno'};
1081 if ($data->{'amountoutstanding'} == $amount) {
1082 $offset = $data->{'amount'};
1085 $offset = $amount - $data->{'amountoutstanding'};
1086 $amountleft = $data->{'amountoutstanding'} - $amount;
1088 my $uquery = "update accountlines set accounttype = 'LR',amountoutstanding='0'
1089 where (borrowernumber = '$data->{'borrowernumber'}')
1090 and (itemnumber = $itm) and (accountno = '$acctno') ";
1091 my $usth = $dbh->prepare($uquery);
1094 #check if any credit is left if so writeoff other accounts
1095 my $nextaccntno = getnextacctno(\%env,$data->{'borrowernumber'},$dbh);
1096 if ($amountleft < 0){
1099 if ($amountleft > 0){
1100 my $query = "select * from accountlines where (borrowernumber = '$data->{'borrowernumber'}')
1101 and (amountoutstanding >0) order by date";
1102 my $msth = $dbh->prepare($query);
1104 # offset transactions
1107 while (($accdata=$msth->fetchrow_hashref) and ($amountleft>0)){
1108 if ($accdata->{'amountoutstanding'} < $amountleft) {
1110 $amountleft -= $accdata->{'amountoutstanding'};
1112 $newamtos = $accdata->{'amountoutstanding'} - $amountleft;
1115 my $thisacct = $accdata->{'accountno'};
1116 my $updquery = "update accountlines set amountoutstanding= '$newamtos'
1117 where (borrowernumber = '$data->{'borrowernumber'}')
1118 and (accountno='$thisacct')";
1119 my $usth = $dbh->prepare($updquery);
1122 $updquery = "insert into accountoffsets
1123 (borrowernumber, accountno, offsetaccount, offsetamount)
1125 ('$data->{'borrowernumber'}','$accdata->{'accountno'}','$nextaccntno','$newamtos')";
1126 $usth = $dbh->prepare($updquery);
1132 if ($amountleft > 0){
1135 my $desc="Book Returned ".$iteminfo->{'barcode'};
1136 $uquery = "insert into accountlines
1137 (borrowernumber,accountno,date,amount,description,accounttype,amountoutstanding)
1138 values ('$data->{'borrowernumber'}','$nextaccntno',now(),0-$amount,'$desc',
1140 $usth = $dbh->prepare($uquery);
1143 $uquery = "insert into accountoffsets
1144 (borrowernumber, accountno, offsetaccount, offsetamount)
1145 values ($borrower->{'borrowernumber'},$data->{'accountno'},$nextaccntno,$offset)";
1146 $usth = $dbh->prepare($uquery);
1149 $uquery = "update items set paidfor='' where itemnumber=$itm";
1150 $usth = $dbh->prepare($uquery);
1159 sub fixoverduesonreturn {
1160 my ($brn, $itm) = @_;
1161 my $dbh = C4::Context->dbh;
1162 $itm = $dbh->quote($itm);
1163 $brn = $dbh->quote($brn);
1164 # check for overdue fine
1165 my $query = "select * from accountlines where (borrowernumber=$brn)
1166 and (itemnumber = $itm) and (accounttype='FU' or accounttype='O')";
1167 my $sth = $dbh->prepare($query);
1169 # alter fine to show that the book has been returned
1170 if (my $data = $sth->fetchrow_hashref) {
1171 my $query = "update accountlines set accounttype='F' where (borrowernumber = $brn)
1172 and (itemnumber = $itm) and (acccountno='$data->{'accountno'}')";
1173 my $usth=$dbh->prepare($query);
1183 # NOTE!: If you change this function, be sure to update the POD for
1184 # &getpatroninformation.
1186 # $flags = &patronflags($env, $patron, $dbh);
1189 # {message} Message showing patron's credit or debt
1190 # {noissues} Set if patron owes >$5.00
1191 # {GNA} Set if patron gone w/o address
1192 # {message} "Borrower has no valid address"
1194 # {LOST} Set if patron's card reported lost
1195 # {message} Message to this effect
1197 # {DBARRED} Set is patron is debarred
1198 # {message} Message to this effect
1200 # {NOTES} Set if patron has notes
1201 # {message} Notes about patron
1202 # {ODUES} Set if patron has overdue books
1204 # {itemlist} ref-to-array: list of overdue books
1205 # {itemlisttext} Text list of overdue items
1206 # {WAITING} Set if there are items available that the
1208 # {message} Message to this effect
1209 # {itemlist} ref-to-array: list of available items
1211 # Original subroutine for Circ2.pm
1213 my ($env, $patroninformation, $dbh) = @_;
1214 my $amount = checkaccount($env, $patroninformation->{'borrowernumber'}, $dbh);
1217 $flaginfo{'message'}= sprintf "Patron owes \$%.02f", $amount;
1219 $flaginfo{'noissues'} = 1;
1221 $flags{'CHARGES'} = \%flaginfo;
1222 } elsif ($amount < 0){
1224 $flaginfo{'message'} = sprintf "Patron has credit of \$%.02f", -$amount;
1225 $flags{'CHARGES'} = \%flaginfo;
1227 if ($patroninformation->{'gonenoaddress'} == 1) {
1229 $flaginfo{'message'} = 'Borrower has no valid address.';
1230 $flaginfo{'noissues'} = 1;
1231 $flags{'GNA'} = \%flaginfo;
1233 if ($patroninformation->{'lost'} == 1) {
1235 $flaginfo{'message'} = 'Borrower\'s card reported lost.';
1236 $flaginfo{'noissues'} = 1;
1237 $flags{'LOST'} = \%flaginfo;
1239 if ($patroninformation->{'debarred'} == 1) {
1241 $flaginfo{'message'} = 'Borrower is Debarred.';
1242 $flaginfo{'noissues'} = 1;
1243 $flags{'DBARRED'} = \%flaginfo;
1245 if ($patroninformation->{'borrowernotes'}) {
1247 $flaginfo{'message'} = "$patroninformation->{'borrowernotes'}";
1248 $flags{'NOTES'} = \%flaginfo;
1250 my ($odues, $itemsoverdue)
1251 = checkoverdues($env, $patroninformation->{'borrowernumber'}, $dbh);
1254 $flaginfo{'message'} = "Yes";
1255 $flaginfo{'itemlist'} = $itemsoverdue;
1256 foreach (sort {$a->{'date_due'} cmp $b->{'date_due'}} @$itemsoverdue) {
1257 $flaginfo{'itemlisttext'}.="$_->{'date_due'} $_->{'barcode'} $_->{'title'} \n";
1259 $flags{'ODUES'} = \%flaginfo;
1261 my ($nowaiting, $itemswaiting)
1262 = CheckWaiting($patroninformation->{'borrowernumber'});
1263 if ($nowaiting > 0) {
1265 $flaginfo{'message'} = "Reserved items available";
1266 $flaginfo{'itemlist'} = $itemswaiting;
1267 $flags{'WAITING'} = \%flaginfo;
1275 # From Main.pm, modified to return a list of overdueitems, in addition to a count
1276 #checks whether a borrower has overdue items
1277 my ($env, $bornum, $dbh)=@_;
1278 my @datearr = localtime;
1279 my $today = ($datearr[5] + 1900)."-".($datearr[4]+1)."-".$datearr[3];
1282 my $query = "SELECT * FROM issues,biblio,biblioitems,items
1283 WHERE items.biblioitemnumber = biblioitems.biblioitemnumber
1284 AND items.biblionumber = biblio.biblionumber
1285 AND issues.itemnumber = items.itemnumber
1286 AND issues.borrowernumber = $bornum
1287 AND issues.returndate is NULL
1288 AND issues.date_due < '$today'";
1289 my $sth = $dbh->prepare($query);
1291 while (my $data = $sth->fetchrow_hashref) {
1292 push (@overdueitems, $data);
1296 return ($count, \@overdueitems);
1300 sub currentborrower {
1301 # Original subroutine for Circ2.pm
1302 my ($itemnumber) = @_;
1303 my $dbh = C4::Context->dbh;
1304 my $q_itemnumber = $dbh->quote($itemnumber);
1305 my $sth=$dbh->prepare("select borrowers.borrowernumber from
1306 issues,borrowers where issues.itemnumber=$q_itemnumber and
1307 issues.borrowernumber=borrowers.borrowernumber and issues.returndate is
1310 my ($borrower) = $sth->fetchrow;
1314 # FIXME - Not exported, but used in 'updateitem.pl' anyway.
1316 # Stolen from Main.pm
1317 # Check for reserves for biblio
1318 my ($env,$dbh,$itemnum)=@_;
1320 my $query = "select * from reserves,items
1321 where (items.itemnumber = '$itemnum')
1322 and (reserves.cancellationdate is NULL)
1323 and (items.biblionumber = reserves.biblionumber)
1324 and ((reserves.found = 'W')
1325 or (reserves.found is null))
1327 my $sth = $dbh->prepare($query);
1330 my $data=$sth->fetchrow_hashref;
1331 while ($data && $resbor eq '') {
1333 my $const = $data->{'constrainttype'};
1334 if ($const eq "a") {
1335 $resbor = $data->{'borrowernumber'};
1338 my $cquery = "select * from reserveconstraints,items
1339 where (borrowernumber='$data->{'borrowernumber'}')
1340 and reservedate='$data->{'reservedate'}'
1341 and reserveconstraints.biblionumber='$data->{'biblionumber'}'
1342 and (items.itemnumber=$itemnum and
1343 items.biblioitemnumber = reserveconstraints.biblioitemnumber)";
1344 my $csth = $dbh->prepare($cquery);
1346 if (my $cdata=$csth->fetchrow_hashref) {$found = 1;}
1347 if ($const eq 'o') {
1348 if ($found eq 1) {$resbor = $data->{'borrowernumber'};}
1350 if ($found eq 0) {$resbor = $data->{'borrowernumber'};}
1354 $data=$sth->fetchrow_hashref;
1357 return ($resbor,$resrec);
1362 $issues = ¤tissues($env, $borrower);
1364 Returns a list of books currently on loan to a patron.
1366 If C<$env-E<gt>{todaysissues}> is set and true, C<¤tissues> only
1367 returns information about books issued today. If
1368 C<$env-E<gt>{nottodaysissues}> is set and true, C<¤tissues> only
1369 returns information about books issued before today. If both are
1370 specified, C<$env-E<gt>{todaysissues}> is ignored. If neither is
1371 specified, C<¤tissues> returns all of the patron's issues.
1373 C<$borrower->{borrowernumber}> is the borrower number of the patron
1374 whose issues we want to list.
1376 C<¤tissues> returns a PHP-style array: C<$issues> is a
1377 reference-to-hash whose keys are integers in the range 1...I<n>, where
1378 I<n> is the number of items on issue (either today or before today).
1379 C<$issues-E<gt>{I<n>}> is a reference-to-hash whose keys are all of
1380 the fields of the biblio, biblioitems, items, and issues fields of the
1381 Koha database for that particular item.
1386 # New subroutine for Circ2.pm
1387 my ($env, $borrower) = @_;
1388 my $dbh = C4::Context->dbh;
1391 my $borrowernumber = $borrower->{'borrowernumber'};
1394 # Figure out whether to get the books issued today, or earlier.
1395 # FIXME - $env->{todaysissues} and $env->{nottodaysissues} can
1396 # both be specified, but are mutually-exclusive. This is bogus.
1397 # Make this a flag. Or better yet, return everything in (reverse)
1398 # chronological order and let the caller figure out which books
1399 # were issued today.
1400 if ($env->{'todaysissues'}) {
1402 # $today = POSIX::strftime("%Y%m%d", localtime);
1403 # FIXME - Since $today will be used in either case, move it
1404 # out of the two if-blocks.
1405 my @datearr = localtime(time());
1406 my $today = (1900+$datearr[5]).sprintf "%02d", ($datearr[4]+1).sprintf "%02d", $datearr[3];
1407 # FIXME - MySQL knows about dates. Just use
1408 # and issues.timestamp = curdate();
1409 $crit=" and issues.timestamp like '$today%' ";
1411 if ($env->{'nottodaysissues'}) {
1413 # $today = POSIX::strftime("%Y%m%d", localtime);
1414 # FIXME - Since $today will be used in either case, move it
1415 # out of the two if-blocks.
1416 my @datearr = localtime(time());
1417 my $today = (1900+$datearr[5]).sprintf "%02d", ($datearr[4]+1).sprintf "%02d", $datearr[3];
1418 # FIXME - MySQL knows about dates. Just use
1419 # and issues.timestamp < curdate();
1420 $crit=" and !(issues.timestamp like '$today%') ";
1423 # FIXME - Does the caller really need every single field from all
1425 my $select="select * from issues,items,biblioitems,biblio where
1426 borrowernumber='$borrowernumber' and issues.itemnumber=items.itemnumber and
1427 items.biblionumber=biblio.biblionumber and
1428 items.biblioitemnumber=biblioitems.biblioitemnumber and returndate is null
1429 $crit order by issues.date_due";
1431 my $sth=$dbh->prepare($select);
1433 while (my $data = $sth->fetchrow_hashref) {
1434 # FIXME - The Dewey code is a string, not a number.
1435 $data->{'dewey'}=~s/0*$//;
1436 ($data->{'dewey'} == 0) && ($data->{'dewey'}='');
1438 # $todaysdate = POSIX::strftime("%Y%m%d", localtime)
1439 # or better yet, just reuse $today which was calculated above.
1440 # This function isn't going to run until midnight, is it?
1442 # $todaysdate = POSIX::strftime("%Y-%m-%d", localtime)
1443 # if ($data->{'date_due'} lt $todaysdate)
1445 # Either way, the date should be be formatted outside of the
1447 my @datearr = localtime(time());
1448 my $todaysdate = (1900+$datearr[5]).sprintf ("%0.2d", ($datearr[4]
1449 +1)).sprintf ("%0.2d", $datearr[3]);
1450 my $datedue=$data->{'date_due'};
1452 if ($datedue < $todaysdate) {
1453 $data->{'overdue'}=1;
1455 my $itemnumber=$data->{'itemnumber'};
1456 # FIXME - Consecutive integers as hash keys? You have GOT to
1457 # be kidding me! Use an array, fercrissakes!
1458 $currentissues{$counter}=$data;
1462 return(\%currentissues);
1467 $issues = &getissues($borrowernumber);
1469 Returns the set of books currently on loan to a patron.
1471 C<$borrowernumber> is the patron's borrower number.
1473 C<&getissues> returns a PHP-style array: C<$issues> is a
1474 reference-to-hash whose keys are integers in the range 0..I<n>-1,
1475 where I<n> is the number of books the patron currently has on loan.
1477 The values of C<$issues> are references-to-hash whose keys are
1478 selected fields from the issues, items, biblio, and biblioitems tables
1479 of the Koha database.
1484 # New subroutine for Circ2.pm
1485 my ($borrower) = @_;
1486 my $dbh = C4::Context->dbh;
1487 my $borrowernumber = $borrower->{'borrowernumber'};
1488 my $brn =$dbh->quote($borrowernumber);
1490 my $select = "select issues.timestamp, issues.date_due, items.biblionumber,
1491 items.barcode, biblio.title, biblio.author, biblioitems.dewey,
1492 biblioitems.subclass
1493 from issues,items,biblioitems,biblio
1494 where issues.borrowernumber = $brn
1495 and issues.itemnumber = items.itemnumber
1496 and items.biblionumber = biblio.biblionumber
1497 and items.biblioitemnumber = biblioitems.biblioitemnumber
1498 and issues.returndate is null
1499 order by issues.date_due";
1501 my $sth=$dbh->prepare($select);
1504 while (my $data = $sth->fetchrow_hashref) {
1505 $data->{'dewey'} =~ s/0*$//;
1506 ($data->{'dewey'} == 0) && ($data->{'dewey'} = '');
1507 # FIXME - The Dewey code is a string, not a number.
1508 # FIXME - Use POSIX::strftime to get a text version of today's
1509 # date. That's what it's for.
1510 # FIXME - Move the date calculation outside of the loop.
1511 my @datearr = localtime(time());
1512 my $todaysdate = (1900+$datearr[5]).sprintf ("%0.2d", ($datearr[4]+1)).sprintf ("%0.2d", $datearr[3]);
1514 # FIXME - Instead of converting the due date to YYYYMMDD, just
1516 # $todaysdate = POSIX::strftime("%Y-%m-%d", localtime);
1518 # if ($date->{date_due} lt $todaysdate)
1519 my $datedue = $data->{'date_due'};
1521 if ($datedue < $todaysdate) {
1522 $data->{'overdue'} = 1;
1524 $currentissues{$counter} = $data;
1526 # FIXME - This is ludicrous. If you want to return an
1527 # array of values, just use an array. That's what
1528 # they're there for.
1531 return(\%currentissues);
1536 #Stolen from Main.pm
1537 # check for reserves waiting
1538 my ($env,$dbh,$bornum)=@_;
1540 my $query = "select * from reserves
1541 where (borrowernumber = '$bornum')
1542 and (reserves.found='W') and cancellationdate is NULL";
1543 my $sth = $dbh->prepare($query);
1546 if (my $data=$sth->fetchrow_hashref) {
1547 $itemswaiting[$cnt] =$data;
1551 return ($cnt,\@itemswaiting);
1555 # FIXME - This is nearly-identical to &C4::Accounts::checkaccount
1557 # Stolen from Accounts.pm
1558 #take borrower number
1559 #check accounts and list amounts owing
1560 my ($env,$bornumber,$dbh,$date)=@_;
1561 my $select="Select sum(amountoutstanding) from accountlines where
1562 borrowernumber=$bornumber and amountoutstanding<>0";
1564 $select.=" and date < '$date'";
1567 my $sth=$dbh->prepare($select);
1570 while (my $data=$sth->fetchrow_hashref){
1571 $total += $data->{'sum(amountoutstanding)'};
1574 # output(1,2,"borrower owes $total");
1576 # # output(1,2,"borrower owes $total");
1578 # reconcileaccount($env,$dbh,$bornumber,$total);
1585 # FIXME - This is identical to &C4::Circulation::Renewals::renewstatus.
1586 # Pick one and stick with it.
1588 # Stolen from Renewals.pm
1589 # check renewal status
1590 my ($env,$dbh,$bornum,$itemno)=@_;
1593 my $q1 = "select * from issues
1594 where (borrowernumber = '$bornum')
1595 and (itemnumber = '$itemno')
1596 and returndate is null";
1597 my $sth1 = $dbh->prepare($q1);
1599 if (my $data1 = $sth1->fetchrow_hashref) {
1600 my $q2 = "select renewalsallowed from items,biblioitems,itemtypes
1601 where (items.itemnumber = '$itemno')
1602 and (items.biblioitemnumber = biblioitems.biblioitemnumber)
1603 and (biblioitems.itemtype = itemtypes.itemtype)";
1604 my $sth2 = $dbh->prepare($q2);
1606 if (my $data2=$sth2->fetchrow_hashref) {
1607 $renews = $data2->{'renewalsallowed'};
1609 if ($renews > $data1->{'renewals'}) {
1619 # Stolen from Renewals.pm
1620 # mark book as renewed
1621 my ($env,$dbh,$bornum,$itemno,$datedue)=@_;
1622 $datedue=$env->{'datedue'};
1623 if ($datedue eq "" ) {
1625 my $query= "Select * from biblioitems,items,itemtypes
1626 where (items.itemnumber = '$itemno')
1627 and (biblioitems.biblioitemnumber = items.biblioitemnumber)
1628 and (biblioitems.itemtype = itemtypes.itemtype)";
1629 my $sth=$dbh->prepare($query);
1631 if (my $data=$sth->fetchrow_hashref) {
1632 $loanlength = $data->{'loanlength'}
1636 my $datedu = time + ($loanlength * 86400);
1637 my @datearr = localtime($datedu);
1638 $datedue = (1900+$datearr[5])."-".($datearr[4]+1)."-".$datearr[3];
1640 my @date = split("-",$datedue);
1641 my $odatedue = ($date[2]+0)."-".($date[1]+0)."-".$date[0];
1642 my $issquery = "select * from issues where borrowernumber='$bornum' and
1643 itemnumber='$itemno' and returndate is null";
1644 my $sth=$dbh->prepare($issquery);
1646 my $issuedata=$sth->fetchrow_hashref;
1648 my $renews = $issuedata->{'renewals'} +1;
1649 my $updquery = "update issues
1650 set date_due = '$datedue', renewals = '$renews'
1651 where borrowernumber='$bornum' and
1652 itemnumber='$itemno' and returndate is null";
1653 $sth=$dbh->prepare($updquery);
1660 # FIXME - This is almost, but not quite, identical to
1661 # &C4::Circulation::Issues::calc_charges and
1662 # &C4::Circulation::Renewals2::calc_charges.
1663 # Pick one and stick with it.
1665 # Stolen from Issues.pm
1666 # calculate charges due
1667 my ($env, $dbh, $itemno, $bornum)=@_;
1672 # open (FILE,">>/tmp/charges");
1674 my $q1 = "select itemtypes.itemtype,rentalcharge from items,biblioitems,itemtypes
1675 where (items.itemnumber ='$itemno')
1676 and (biblioitems.biblioitemnumber = items.biblioitemnumber)
1677 and (biblioitems.itemtype = itemtypes.itemtype)";
1678 my $sth1= $dbh->prepare($q1);
1679 # print FILE "$q1\n";
1681 if (my $data1=$sth1->fetchrow_hashref) {
1682 $item_type = $data1->{'itemtype'};
1683 $charge = $data1->{'rentalcharge'};
1684 # print FILE "charge is $charge\n";
1685 my $q2 = "select rentaldiscount from borrowers,categoryitem
1686 where (borrowers.borrowernumber = '$bornum')
1687 and (borrowers.categorycode = categoryitem.categorycode)
1688 and (categoryitem.itemtype = '$item_type')";
1689 my $sth2=$dbh->prepare($q2);
1692 if (my $data2=$sth2->fetchrow_hashref) {
1693 my $discount = $data2->{'rentaldiscount'};
1694 # print FILE "discount is $discount";
1695 if ($discount eq 'NULL') {
1698 $charge = ($charge *(100 - $discount)) / 100;
1707 # FIXME - A virtually identical function appears in
1708 # C4::Circulation::Issues. Pick one and stick with it.
1710 #Stolen from Issues.pm
1711 my ($env,$dbh,$itemno,$bornum,$charge) = @_;
1712 my $nextaccntno = getnextacctno($env,$bornum,$dbh);
1713 my $sth = $dbh->prepare(<<EOT);
1714 INSERT INTO accountlines
1715 (borrowernumber, itemnumber, accountno,
1716 date, amount, description, accounttype,
1719 now(), ?, 'Rental', 'Rent',
1722 $sth->execute($bornum, $itemno, $nextaccntno, $charge, $charge);
1728 # Stolen from Accounts.pm
1729 my ($env,$bornumber,$dbh)=@_;
1730 my $nextaccntno = 1;
1731 my $query = "select * from accountlines where (borrowernumber = '$bornumber') order by accountno desc";
1732 my $sth = $dbh->prepare($query);
1734 if (my $accdata=$sth->fetchrow_hashref){
1735 $nextaccntno = $accdata->{'accountno'} + 1;
1738 return($nextaccntno);
1743 ($status, $record) = &find_reserves($itemnumber);
1745 Looks up an item in the reserves.
1747 C<$itemnumber> is the itemnumber to look up.
1749 C<$status> is true iff the search was successful.
1751 C<$record> is a reference-to-hash describing the reserve. Its keys are
1752 the fields from the reserves table of the Koha database.
1756 # FIXME - This API is bogus: just return the record, or undef if none
1758 # FIXME - There's also a &C4::Circulation::Returns::find_reserves, but
1759 # that one looks rather different.
1761 # Stolen from Returns.pm
1764 my $dbh = C4::Context->dbh;
1765 my ($itemdata) = getiteminformation(\%env, $itemno,0);
1766 my $bibno = $dbh->quote($itemdata->{'biblionumber'});
1767 my $bibitm = $dbh->quote($itemdata->{'biblioitemnumber'});
1768 my $query = "select * from reserves where ((found = 'W') or (found is null))
1769 and biblionumber = $bibno and cancellationdate is NULL
1770 order by priority, reservedate ";
1771 my $sth = $dbh->prepare($query);
1778 # FIXME - I'm not really sure what's going on here, but since we
1779 # only want one result, wouldn't it be possible (and far more
1780 # efficient) to do something clever in SQL that only returns one
1782 while (($resrec = $sth->fetchrow_hashref) && (not $resfound)) {
1783 # FIXME - Unlike Pascal, Perl allows you to exit loops
1784 # early. Take out the "&& (not $resfound)" and just
1785 # use "last" at the appropriate point in the loop.
1786 # (Oh, and just in passing: if you'd used "!" instead
1787 # of "not", you wouldn't have needed the parentheses.)
1789 my $brn = $dbh->quote($resrec->{'borrowernumber'});
1790 my $rdate = $dbh->quote($resrec->{'reservedate'});
1791 my $bibno = $dbh->quote($resrec->{'biblionumber'});
1792 if ($resrec->{'found'} eq "W") {
1793 if ($resrec->{'itemnumber'} eq $itemno) {
1797 # FIXME - Use 'elsif' to avoid unnecessary indentation.
1798 if ($resrec->{'constrainttype'} eq "a") {
1801 my $conquery = "select * from reserveconstraints where borrowernumber = $brn
1802 and reservedate = $rdate and biblionumber = $bibno and biblioitemnumber = $bibitm";
1803 my $consth = $dbh->prepare($conquery);
1805 if (my $conrec = $consth->fetchrow_hashref) {
1806 if ($resrec->{'constrainttype'} eq "o") {
1814 my $updquery = "update reserves set found = 'W', itemnumber = '$itemno'
1815 where borrowernumber = $brn and reservedate = $rdate and biblionumber = $bibno";
1816 my $updsth = $dbh->prepare($updquery);
1819 # FIXME - "last;" here to break out of the loop early.
1823 return ($resfound,$lastrec);
1833 Koha Developement team <info@koha.org>