Koha/Patron/Debarments.pm

   1 package Koha::Patron::Debarments;
   2
   3 # This file is part of Koha.
   4 #
   5 # Copyright 2013 ByWater Solutions
   6 #
   7 # Koha is free software; you can redistribute it and/or modify it
   8 # under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation; either version 3 of the License, or
  10 # (at your option) any later version.
  11 #
  12 # Koha is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15 # GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  19
  20 use Modern::Perl;
  21
  22 use C4::Context;
  23
  24 use parent qw( Exporter );
  25
  26 our @EXPORT = qw(
  27   GetDebarments
  28
  29   AddDebarment
  30   DelDebarment
  31   ModDebarment
  32
  33   AddUniqueDebarment
  34   DelUniqueDebarment
  35
  36   IsDebarred
  37 );
  38
  39 =head1 Koha::Patron::Debarments
  40
  41 Koha::Patron::Debarments - Module for managing patron debarments
  42
  43 =cut
  44
  45 =head2 GetDebarments
  46
  47 my $arrayref = GetDebarments({ borrowernumber => $borrowernumber [, key => $value ] );
  48
  49 =cut
  50
  51 sub GetDebarments {
  52     my ($params) = @_;
  53
  54     return unless ( $params->{'borrowernumber'} );
  55
  56     my @keys   = keys %$params;
  57     my @values = values %$params;
  58
  59     my $where = join( ' AND ', map { "$_ = ?" } @keys );
  60     my $sql   = "SELECT * FROM borrower_debarments WHERE $where";
  61     my $sth   = C4::Context->dbh->prepare($sql);
  62     $sth->execute(@values);
  63
  64     return $sth->fetchall_arrayref( {} );
  65 }
  66
  67 =head2 AddDebarment
  68
  69 my $success = AddDebarment({
  70     borrowernumber => $borrowernumber,
  71     expiration     => $expiration,
  72     type           => $type, ## enum('FINES','OVERDUES','MANUAL')
  73     comment        => $comment,
  74 });
  75
  76 Creates a new debarment.
  77
  78 Required keys: borrowernumber, type
  79
  80 =cut
  81
  82 sub AddDebarment {
  83     my ($params) = @_;
  84
  85     my $borrowernumber = $params->{'borrowernumber'};
  86     my $expiration     = $params->{'expiration'} || undef;
  87     my $type           = $params->{'type'} || 'MANUAL';
  88     my $comment        = $params->{'comment'} || undef;
  89
  90     return unless ( $borrowernumber && $type );
  91
  92     my $manager_id;
  93     $manager_id = C4::Context->userenv->{'number'} if C4::Context->userenv;
  94
  95     my $sql = "
  96         INSERT INTO borrower_debarments ( borrowernumber, expiration, type, comment, manager_id, created )
  97         VALUES ( ?, ?, ?, ?, ?, NOW() )
  98     ";
  99
 100     my $r = C4::Context->dbh->do( $sql, {}, ( $borrowernumber, $expiration, $type, $comment, $manager_id ) );
 101
 102     _UpdateBorrowerDebarmentFlags($borrowernumber);
 103
 104     return $r;
 105 }
 106
 107 =head2 DelDebarment
 108
 109 my $success = DelDebarment( $borrower_debarment_id );
 110
 111 Deletes a debarment.
 112
 113 =cut
 114
 115 sub DelDebarment {
 116     my ($id) = @_;
 117
 118     my $borrowernumber = _GetBorrowernumberByDebarmentId($id);
 119
 120     my $sql = "DELETE FROM borrower_debarments WHERE borrower_debarment_id = ?";
 121
 122     my $r = C4::Context->dbh->do( $sql, {}, ($id) );
 123
 124     _UpdateBorrowerDebarmentFlags($borrowernumber);
 125
 126     return $r;
 127 }
 128
 129 =head2 ModDebarment
 130
 131 my $success = ModDebarment({
 132     borrower_debarment_id => $borrower_debarment_id,
 133     expiration            => $expiration,
 134     type                  => $type, ## enum('FINES','OVERDUES','MANUAL','DISCHARGE')
 135     comment               => $comment,
 136 });
 137
 138 Updates an existing debarment.
 139
 140 Required keys: borrower_debarment_id
 141
 142 =cut
 143
 144 sub ModDebarment {
 145     my ($params) = @_;
 146
 147     my $borrower_debarment_id = $params->{'borrower_debarment_id'};
 148
 149     return unless ($borrower_debarment_id);
 150
 151     delete( $params->{'borrower_debarment_id'} );
 152
 153     delete( $params->{'created'} );
 154     delete( $params->{'updated'} );
 155
 156     $params->{'manager_id'} = C4::Context->userenv->{'number'} if C4::Context->userenv;
 157
 158     my @keys   = keys %$params;
 159     my @values = values %$params;
 160
 161     my $sql = join( ',', map { "$_ = ?" } @keys );
 162
 163     $sql = "UPDATE borrower_debarments SET $sql, updated = NOW() WHERE borrower_debarment_id = ?";
 164
 165     my $r = C4::Context->dbh->do( $sql, {}, ( @values, $borrower_debarment_id ) );
 166
 167     _UpdateBorrowerDebarmentFlags( _GetBorrowernumberByDebarmentId($borrower_debarment_id) );
 168
 169     return $r;
 170 }
 171
 172 =head2 IsDebarred
 173
 174 my $debarment_expiration = IsDebarred( $borrowernumber );
 175
 176 Returns the date a borrowers debarment will expire, or
 177 undef if the patron is not debarred
 178
 179 =cut
 180
 181 sub IsDebarred {
 182     my ($borrowernumber) = @_;
 183
 184     return unless ($borrowernumber);
 185
 186     my $sql = "SELECT debarred FROM borrowers WHERE borrowernumber = ? AND debarred > CURRENT_DATE()";
 187     my $sth = C4::Context->dbh->prepare($sql);
 188     $sth->execute($borrowernumber);
 189     my ($debarred) = $sth->fetchrow_array();
 190
 191     return $debarred;
 192 }
 193
 194 =head2 AddUniqueDebarment
 195
 196 my $success = AddUniqueDebarment({
 197     borrowernumber => $borrowernumber,
 198     type           => $type,
 199     expiration     => $expiration,
 200     comment        => $comment,
 201 });
 202
 203 Creates a new debarment of the type defined by the key type.
 204 If a unique debarment already exists of the given type, it is updated instead.
 205 The current unique debarment types are OVERDUES, and SUSPENSION
 206
 207 Required keys: borrowernumber, type
 208
 209 =cut
 210
 211 sub AddUniqueDebarment {
 212     my ($params) = @_;
 213
 214     my $borrowernumber = $params->{'borrowernumber'};
 215     my $type           = $params->{'type'};
 216
 217     return unless ( $borrowernumber && $type );
 218
 219     my $debarment = @{ GetDebarments( { borrowernumber => $borrowernumber, type => $type } ) }[0];
 220
 221     my $r;
 222     if ($debarment) {
 223
 224         # We don't want to shorten a unique debarment's period, so if this 'update' would do so, just keep the current expiration date instead
 225         $params->{'expiration'} = $debarment->{'expiration'}
 226           if ( $debarment->{'expiration'}
 227             && $debarment->{'expiration'} gt $params->{'expiration'} );
 228
 229         $params->{'borrower_debarment_id'} =
 230           $debarment->{'borrower_debarment_id'};
 231         $r = ModDebarment($params);
 232     } else {
 233
 234         $r = AddDebarment($params);
 235     }
 236
 237     _UpdateBorrowerDebarmentFlags($borrowernumber);
 238
 239     return $r;
 240 }
 241
 242 =head2 DelUniqueDebarment
 243
 244 my $success = _DelUniqueDebarment({
 245     borrowernumber => $borrowernumber,
 246     type           => $type,
 247 });
 248
 249 Deletes a unique debarment of the type defined by the key type.
 250 The current unique debarment types are OVERDUES, and SUSPENSION
 251
 252 Required keys: borrowernumber, type
 253
 254 =cut
 255
 256 sub DelUniqueDebarment {
 257     my ($params) = @_;
 258
 259     my $borrowernumber = $params->{'borrowernumber'};
 260     my $type           = $params->{'type'};
 261
 262     return unless ( $borrowernumber && $type );
 263
 264     my $debarment = @{ GetDebarments( { borrowernumber => $borrowernumber, type => $type } ) }[0];
 265
 266     return unless ( $debarment );
 267
 268     return DelDebarment( $debarment->{'borrower_debarment_id'} );
 269 }
 270
 271 =head2 _UpdateBorrowerDebarmentFlags
 272
 273 my $success = _UpdateBorrowerDebarmentFlags( $borrowernumber );
 274
 275 So as not to create additional latency, the fields borrowers.debarred
 276 and borrowers.debarredcomment remain in the borrowers table. Whenever
 277 the a borrowers debarrments are modified, this subroutine is run to
 278 decide if the borrower is currently debarred and update the 'quick flags'
 279 in the borrowers table accordingly.
 280
 281 =cut
 282
 283 sub _UpdateBorrowerDebarmentFlags {
 284     my ($borrowernumber) = @_;
 285
 286     return unless ($borrowernumber);
 287
 288     my $dbh = C4::Context->dbh;
 289
 290     my $sql = q{
 291         SELECT COUNT(*), COUNT(*) - COUNT(expiration), MAX(expiration), GROUP_CONCAT(comment SEPARATOR '\n') FROM borrower_debarments
 292         WHERE ( expiration > CURRENT_DATE() OR expiration IS NULL ) AND borrowernumber = ?
 293     };
 294     my $sth = $dbh->prepare($sql);
 295     $sth->execute($borrowernumber);
 296     my ( $count, $indefinite_expiration, $expiration, $comment ) = $sth->fetchrow_array();
 297
 298     if ($count) {
 299         $expiration = "9999-12-31" if ($indefinite_expiration);
 300     } else {
 301         $expiration = undef;
 302         $comment    = undef;
 303     }
 304
 305     return $dbh->do( "UPDATE borrowers SET debarred = ?, debarredcomment = ? WHERE borrowernumber = ?", {}, ( $expiration, $comment, $borrowernumber ) );
 306 }
 307
 308 =head2 _GetBorrowernumberByDebarmentId
 309
 310 my $borrowernumber = _GetBorrowernumberByDebarmentId( $borrower_debarment_id );
 311
 312 =cut
 313
 314 sub _GetBorrowernumberByDebarmentId {
 315     my ($borrower_debarment_id) = @_;
 316
 317     return unless ($borrower_debarment_id);
 318
 319     my $sql = "SELECT borrowernumber FROM borrower_debarments WHERE borrower_debarment_id = ?";
 320     my $sth = C4::Context->dbh->prepare($sql);
 321     $sth->execute($borrower_debarment_id);
 322     my ($borrowernumber) = $sth->fetchrow_array();
 323
 324     return $borrowernumber;
 325 }
 326
 327 1;
 328
 329 =head2 AUTHOR
 330
 331 Kyle M Hall <kyle@bywatersoltuions.com>
 332
 333 =cut