circ2.pm

来自「开源图书馆管理软件」· PM 代码 · 共 1,870 行 · 第 1/5 页

	    $rejected="Restricted item.";
	    last SWITCH;
	}
	if ($iteminformation->{'itemtype'} eq 'REF') {
	    $rejected="Reference item:  Not for loan.";
	    last SWITCH;
	}
	my ($currentborrower) = currentborrower($iteminformation->{'itemnumber'});
	if ($currentborrower eq $patroninformation->{'borrowernumber'}) {
# Already issued to current borrower. Ask whether the loan should
# be renewed.
	    my ($renewstatus) = renewstatus($env,$dbh,$patroninformation->{'borrowernumber'}, $iteminformation->{'itemnumber'});
	    if ($renewstatus == 0) {
		$rejected="No more renewals allowed for this item.";
		last SWITCH;
	    } else {
		if ($responses->{4} eq '') {
		    $questionnumber = 4;
		    $question = "Book is issued to this borrower.\nRenew?";
		    $defaultanswer = 'Y';
		    last SWITCH;
		} elsif ($responses->{4} eq 'Y') {
		    my ($charge,$itemtyp1) = calc_charges($env, $dbh, $iteminformation->{'itemnumber'}, $patroninformation->{'borrowernumber'});

		    if ($charge > 0) {
			createcharge($env, $dbh, $iteminformation->{'itemnumber'}, $patroninformation->{'borrowernumber'}, $charge);
			$iteminformation->{'charge'} = $charge;
		    }
		    &UpdateStats($env,$env->{'branchcode'},'renew',$charge,'',$iteminformation->{'itemnumber'},$iteminformation->{'itemtype'});
		    renewbook($env,$dbh, $patroninformation->{'borrowernumber'}, $iteminformation->{'itemnumber'});
		    $noissue=1;
		} else {
		    $rejected=-1;
		    last SWITCH;
		}
	    }
	} elsif ($currentborrower ne '') {
	    # This book is currently on loan, but not to the person
	    # who wants to borrow it now.
	    my ($currborrower, $cbflags) = getpatroninformation($env,$currentborrower,0);
	    if ($responses->{1} eq '') {
		$questionnumber=1;
		$question = "Issued to $currborrower->{'firstname'} $currborrower->{'surname'} ($currborrower->{'cardnumber'}).\nMark as returned?";
		$defaultanswer='Y';
		last SWITCH;
	    } elsif ($responses->{1} eq 'Y') {
		returnbook($iteminformation->{'barcode'}, $env->{'branch'});
	    } else {
		$rejected=-1;
		last SWITCH;
	    }
	}

	# See if the item is on reserve.
	my ($restype, $res) = CheckReserves($iteminformation->{'itemnumber'});
	if ($restype) {
	    my $resbor = $res->{'borrowernumber'};
	    if ($resbor eq $patroninformation->{'borrowernumber'}) {
		# The item is on reserve to the current patron
		FillReserve($res);
	    } elsif ($restype eq "Waiting") {
		# The item is on reserve and waiting, but has been
		# reserved by some other patron.
		my ($resborrower, $flags)=getpatroninformation($env, $resbor,0);
		my $branches = getbranches();
		my $branchname = $branches->{$res->{'branchcode'}}->{'branchname'};
		if ($responses->{2} eq '') {
		    $questionnumber=2;
		    # FIXME - Assumes HTML
		    $question="<font color=red>Waiting</font> for $resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'}) at $branchname \nAllow issue?";
		    $defaultanswer='N';
		    last SWITCH;
		} elsif ($responses->{2} eq 'N') {
		    $rejected=-1;
		    last SWITCH;
		} else {
		    if ($responses->{3} eq '') {
			$questionnumber=3;
			$question="Cancel reserve for $resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'})?";
			$defaultanswer='N';
			last SWITCH;
		    } elsif ($responses->{3} eq 'Y') {
			CancelReserve(0, $res->{'itemnumber'}, $res->{'borrowernumber'});
		    }
		}
	    } elsif ($restype eq "Reserved") {
		# The item is on reserve for someone else.
		my ($resborrower, $flags)=getpatroninformation($env, $resbor,0);
		my $branches = getbranches();
		my $branchname = $branches->{$res->{'branchcode'}}->{'branchname'};
		if ($responses->{5} eq '') {
		    $questionnumber=5;
		    $question="Reserved for $resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'}) since $res->{'reservedate'} \nAllow issue?";
		    $defaultanswer='N';
		    last SWITCH;
		} elsif ($responses->{5} eq 'N') {
		    if ($responses->{6} eq '') {
			$questionnumber=6;
			$question="Set reserve for $resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'}) to waiting and transfer to $branchname?";
			$defaultanswer='N';
		    } elsif ($responses->{6} eq 'Y') {
			my $tobrcd = ReserveWaiting($res->{'itemnumber'}, $res->{'borrowernumber'});
			transferbook($tobrcd, $barcode, 1);
			$message = "Item should now be waiting at $branchname";
		    }
		    $rejected=-1;
		    last SWITCH;
		} else {
		    if ($responses->{7} eq '') {
			$questionnumber=7;
			$question="Cancel reserve for $resborrower->{'firstname'} $resborrower->{'surname'} ($resborrower->{'cardnumber'})?";
			$defaultanswer='N';
			last SWITCH;
		    } elsif ($responses->{7} eq 'Y') {
			CancelReserve(0, $res->{'itemnumber'}, $res->{'borrowernumber'});
		    }
		}
	    }
	}
    }
    my $dateduef;
    unless (($question) || ($rejected) || ($noissue)) {
	# There's no reason why the item can't be issued.
	# FIXME - my $loanlength = $iteminformation->{loanlength} || 21;
	my $loanlength=21;
	if ($iteminformation->{'loanlength'}) {
	    $loanlength=$iteminformation->{'loanlength'};
	}
	my $ti=time;		# FIXME - Never used
	my $datedue=time+($loanlength)*86400;
	# FIXME - Could just use POSIX::strftime("%Y-%m-%d", localtime);
	# That's what it's for. Or, in this case:
	#	$dateduef = $env->{datedue} ||
	#		strftime("%Y-%m-%d", localtime(time +
	#				     $loanlength * 86400));
	my @datearr = localtime($datedue);
	$dateduef = (1900+$datearr[5])."-".($datearr[4]+1)."-".$datearr[3];
	if ($env->{'datedue'}) {
	    $dateduef=$env->{'datedue'};
	}
	$dateduef=~ s/2001\-4\-25/2001\-4\-26/;
		# FIXME - What's this for? Leftover from debugging?

	# Record in the database the fact that the book was issued.
	# FIXME - Use $dbh->do();
	my $sth=$dbh->prepare("insert into issues (borrowernumber, itemnumber, date_due, branchcode) values ($patroninformation->{'borrowernumber'}, $iteminformation->{'itemnumber'}, '$dateduef', '$env->{'branchcode'}')");
	$sth->execute;
	$sth->finish;
	$iteminformation->{'issues'}++;
	# FIXME - Use $dbh->do();
	$sth=$dbh->prepare("update items set issues=$iteminformation->{'issues'},datelastseen=now() where itemnumber=$iteminformation->{'itemnumber'}");
	$sth->execute;
	$sth->finish;
	# If it costs to borrow this book, charge it to the patron's account.
	my ($charge,$itemtype)=calc_charges($env, $dbh, $iteminformation->{'itemnumber'}, $patroninformation->{'borrowernumber'});
#	warn "here charge is $charge itemtype $itemtype";
	if ($charge > 0) {
	    createcharge($env, $dbh, $iteminformation->{'itemnumber'}, $patroninformation->{'borrowernumber'}, $charge);
	    $iteminformation->{'charge'}=$charge;
	}
	# Record the fact that this book was issued.
	&UpdateStats($env,$env->{'branchcode'},'issue',$charge,'',$iteminformation->{'itemnumber'},$iteminformation->{'itemtype'});
    }
    if ($iteminformation->{'charge'}) {
	$message=sprintf "Rental charge of \$%.02f applies.", $iteminformation->{'charge'};
    }
    $dbh->disconnect;
    return ($iteminformation, $dateduef, $rejected, $question, $questionnumber, $defaultanswer, $message);
}



=item returnbook

  ($doreturn, $messages, $iteminformation, $borrower) =
	  &returnbook($barcode, $branch);

Returns a book.

C<$barcode> is the bar code of the book being returned. C<$branch> is
the code of the branch where the book is being returned.

C<&returnbook> returns a list of four items:

C<$doreturn> is true iff the return succeeded.

C<$messages> is a reference-to-hash giving the reason for failure:

=over 4

=item C<BadBarcode>

No item with this barcode exists. The value is C<$barcode>.

=item C<NotIssued>

The book is not currently on loan. The value is C<$barcode>.

=item C<IsPermanent>

The book's home branch is a permanent collection. If you have borrowed
this book, you are not allowed to return it. The value is the code for
the book's home branch.

=item C<wthdrawn>

This book has been withdrawn/cancelled. The value should be ignored.

=item C<ResFound>

The item was reserved. The value is a reference-to-hash whose keys are
fields from the reserves table of the Koha database, and
C<biblioitemnumber>. It also has the key C<ResFound>, whose value is
either C<Waiting>, C<Reserved>, or 0.

=back

C<$borrower> is a reference-to-hash, giving information about the
patron who last borrowed the book.

=cut
#'
# FIXME - This API is bogus. There's no need to return $borrower and
# $iteminformation; the caller can ask about those separately, if it
# cares (it'd be inefficient to make two database calls instead of
# one, but &getpatroninformation and &getiteminformation can be
# memoized if this is an issue).
#
# The ($doreturn, $messages) tuple is redundant: if the return
# succeeded, that's all the caller needs to know. So &returnbook can
# return 1 and 0 on success and failure, and set
# $C4::Circulation::Circ2::errmsg to indicate the error. Or it can
# return undef for success, and an error message on error (though this
# is more C-ish than Perl-ish).
sub returnbook {
    my ($barcode, $branch) = @_;
    my %env;
    my $messages;
    my $doreturn = 1;
# get information on item
    my ($iteminformation) = getiteminformation(\%env, 0, $barcode);
    if (not $iteminformation) {
	$messages->{'BadBarcode'} = $barcode;
	$doreturn = 0;
    }
# find the borrower
    my ($currentborrower) = currentborrower($iteminformation->{'itemnumber'});
    if ((not $currentborrower) && $doreturn) {
	$messages->{'NotIssued'} = $barcode;
	$doreturn = 0;
    }
# check if the book is in a permanent collection....
    my $hbr = $iteminformation->{'homebranch'};
    my $branches = getbranches();
    if ($branches->{$hbr}->{'PE'}) {
	$messages->{'IsPermanent'} = $hbr;
    }
# check that the book has been cancelled
    if ($iteminformation->{'wthdrawn'}) {
	$messages->{'wthdrawn'} = 1;
	$doreturn = 0;
    }
# update issues, thereby returning book (should push this out into another subroutine
    my ($borrower) = getpatroninformation(\%env, $currentborrower, 0);
    if ($doreturn) {
	doreturn($borrower->{'borrowernumber'}, $iteminformation->{'itemnumber'});
	$messages->{'WasReturned'};	# FIXME - This does nothing
    }
    ($borrower) = getpatroninformation(\%env, $currentborrower, 0);
# transfer book to the current branch
    my ($transfered, $mess, $item) = transferbook($branch, $barcode, 1);
    if ($transfered) {	# FIXME - perl -wc complains about this line.
	$messages->{'WasTransfered'};	# FIXME - This does nothing
    }
# fix up the accounts.....
    if ($iteminformation->{'itemlost'}) {
	# Mark the item as not being lost.
	updateitemlost($iteminformation->{'itemnumber'});
	fixaccountforlostandreturned($iteminformation, $borrower);
	$messages->{'WasLost'};		# FIXME - This does nothing
    }
# fix up the overdues in accounts...
    fixoverduesonreturn($borrower->{'borrowernumber'}, $iteminformation->{'itemnumber'});
# find reserves.....
    my ($resfound, $resrec) = CheckReserves($iteminformation->{'itemnumber'});
    if ($resfound) {
	#my $tobrcd = ReserveWaiting($resrec->{'itemnumber'}, $resrec->{'borrowernumber'});
	$resrec->{'ResFound'} = $resfound;
	$messages->{'ResFound'} = $resrec;
    }
# update stats?
# Record the fact that this book was returned.
    UpdateStats(\%env, $branch ,'return','0','',$iteminformation->{'itemnumber'});
    return ($doreturn, $messages, $iteminformation, $borrower);
}

# doreturn
# Takes a borrowernumber and an itemnuber.
# Updates the 'issues' table to mark the item as returned (assuming
# that it's currently on loan to the given borrower. Otherwise, the
# item remains on loan.
# Updates items.datelastseen for the item.
# Not exported
# FIXME - This is only used in &returnbook. Why make it into a
# separate function?
sub doreturn {
    my ($brn, $itm) = @_;
    my $dbh=&C4Connect;
    $brn = $dbh->quote($brn);
    $itm = $dbh->quote($itm);
    my $query = "update issues set returndate = now() where (borrowernumber = $brn)
        and (itemnumber = $itm) and (returndate is null)";
    my $sth = $dbh->prepare($query);
    $sth->execute;
    $sth->finish;
    $query="update items set datelastseen=now() where itemnumber=$itm";
    $sth=$dbh->prepare($query);
    $sth->execute;
    $sth->finish;
    $dbh->disconnect;
    return;
}

# updateitemlost
# Marks an item as not being lost.
# Not exported
sub updateitemlost{
  my ($itemno)=@_;
  my $dbh=&C4Connect;
  my $query="update items set itemlost=0 where itemnumber=$itemno";
  my $sth=$dbh->prepare($query);
  $sth->execute;
  $sth->finish;
}

# Not exported
sub fixaccountforlostandreturned {
    my ($iteminfo, $borrower) = @_;
    my %env;
    my $dbh=&C4Connect;
    my $itm = $dbh->quote($iteminfo->{'itemnumber'});
# check for charge made for lost book
    my $query = "select * from accountlines where (itemnumber = $itm)
                          and (accounttype='L' or accounttype='Rep') order by date desc";
    my $sth = $dbh->prepare($query);
    $sth->execute;
    if (my $data = $sth->fetchrow_hashref) {
# writeoff this amount
	my $offset;
	my $amount = $data->{'amount'};
	my $acctno = $data->{'accountno'};
	my $amountleft;
	if ($data->{'amountoutstanding'} == $amount) {
	    $offset = $data->{'amount'};
	    $amountleft = 0;
	} else {
	    $offset = $amount - $data->{'amountoutstanding'};
	    $amountleft = $data->{'amountoutstanding'} - $amount;
	}
	my $uquery = "update accountlines set accounttype = 'LR',amountoutstanding='0'
		  where (borrowernumber = '$data->{'borrowernumber'}')
		  and (itemnumber = $itm) and (accountno = '$acctno') ";
	my $usth = $dbh->prepare($uquery);
	$usth->execute;
	$usth->finish;
#check if any credit is left if so writeoff other accounts
	my $nextaccntno = getnextacctno(\%env,$data->{'borrowernumber'},$dbh);
	if ($amountleft < 0){
	    $amountleft*=-1;
	}
	if ($amountleft > 0){
	    my $query = "select * from accountlines where (borrowernumber = '$data->{'borrowernumber'}')
                                                      and (amountoutstanding >0) order by date";
	    my $msth = $dbh->prepare($query);