C4/Suggestions.pm

   1 package C4::Suggestions;
   2
   3 # Copyright 2000-2002 Katipo Communications
   4 # Parts Copyright Biblibre 2011
   5 #
   6 # This file is part of Koha.
   7 #
   8 # Koha is free software; you can redistribute it and/or modify it
   9 # under the terms of the GNU General Public License as published by
  10 # the Free Software Foundation; either version 3 of the License, or
  11 # (at your option) any later version.
  12 #
  13 # Koha is distributed in the hope that it will be useful, but
  14 # WITHOUT ANY WARRANTY; without even the implied warranty of
  15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  16 # GNU General Public License for more details.
  17 #
  18 # You should have received a copy of the GNU General Public License
  19 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  20
  21 use Modern::Perl;
  22 use CGI qw ( -utf8 );
  23
  24 use C4::Context;
  25 use C4::Output;
  26 use C4::Letters;
  27 use C4::Biblio qw( GetMarcFromKohaField );
  28 use Koha::DateUtils qw( dt_from_string );
  29 use Koha::Suggestions;
  30
  31 use base qw(Exporter);
  32
  33 our @EXPORT  = qw(
  34   ConnectSuggestionAndBiblio
  35   DelSuggestion
  36   GetSuggestion
  37   GetSuggestionByStatus
  38   GetSuggestionFromBiblionumber
  39   GetSuggestionInfoFromBiblionumber
  40   GetSuggestionInfo
  41   ModStatus
  42   ModSuggestion
  43   NewSuggestion
  44   DelSuggestionsOlderThan
  45   GetUnprocessedSuggestions
  46   MarcRecordFromNewSuggestion
  47 );
  48
  49 =head1 NAME
  50
  51 C4::Suggestions - Some useful functions for dealings with aqorders.
  52
  53 =head1 SYNOPSIS
  54
  55 use C4::Suggestions;
  56
  57 =head1 DESCRIPTION
  58
  59 The functions in this module deal with the aqorders in OPAC and in librarian interface
  60
  61 A suggestion is done in the OPAC. It has the status "ASKED"
  62
  63 When a librarian manages the suggestion, they can set the status to "REJECTED" or "ACCEPTED".
  64
  65 When the book is ordered, the suggestion status becomes "ORDERED"
  66
  67 When a book is ordered and arrived in the library, the status becomes "AVAILABLE"
  68
  69 All aqorders of a borrower can be seen by the borrower itself.
  70 Suggestions done by other borrowers can be seen when not "AVAILABLE"
  71
  72 =head1 FUNCTIONS
  73
  74 =head2 GetSuggestion
  75
  76 \%sth = &GetSuggestion($suggestionid)
  77
  78 this function get the detail of the suggestion $suggestionid (input arg)
  79
  80 return :
  81     the result of the SQL query as a hash : $sth->fetchrow_hashref.
  82
  83 =cut
  84
  85 sub GetSuggestion {
  86     my ($suggestionid) = @_;
  87     my $dbh           = C4::Context->dbh;
  88     my $query         = q{
  89         SELECT *
  90         FROM   suggestions
  91         WHERE  suggestionid=?
  92     };
  93     my $sth = $dbh->prepare($query);
  94     $sth->execute($suggestionid);
  95     return ( $sth->fetchrow_hashref );
  96 }
  97
  98 =head2 GetSuggestionFromBiblionumber
  99
 100 $ordernumber = &GetSuggestionFromBiblionumber($biblionumber)
 101
 102 Get a suggestion from it's biblionumber.
 103
 104 return :
 105 the id of the suggestion which is related to the biblionumber given on input args.
 106
 107 =cut
 108
 109 sub GetSuggestionFromBiblionumber {
 110     my ($biblionumber) = @_;
 111     my $query = q{
 112         SELECT suggestionid
 113         FROM   suggestions
 114         WHERE  biblionumber=? LIMIT 1
 115     };
 116     my $dbh = C4::Context->dbh;
 117     my $sth = $dbh->prepare($query);
 118     $sth->execute($biblionumber);
 119     my ($suggestionid) = $sth->fetchrow;
 120     return $suggestionid;
 121 }
 122
 123 =head2 GetSuggestionInfoFromBiblionumber
 124
 125 Get a suggestion and borrower's informations from it's biblionumber.
 126
 127 return :
 128 all informations (suggestion and borrower) of the suggestion which is related to the biblionumber given.
 129
 130 =cut
 131
 132 sub GetSuggestionInfoFromBiblionumber {
 133     my ($biblionumber) = @_;
 134     my $query = q{
 135         SELECT suggestions.*,
 136             U1.surname          AS surnamesuggestedby,
 137             U1.firstname        AS firstnamesuggestedby,
 138             U1.borrowernumber   AS borrnumsuggestedby
 139         FROM suggestions
 140             LEFT JOIN borrowers AS U1 ON suggestedby=U1.borrowernumber
 141         WHERE biblionumber=?
 142         LIMIT 1
 143     };
 144     my $dbh = C4::Context->dbh;
 145     my $sth = $dbh->prepare($query);
 146     $sth->execute($biblionumber);
 147     return $sth->fetchrow_hashref;
 148 }
 149
 150 =head2 GetSuggestionInfo
 151
 152 Get a suggestion and borrower's informations from it's suggestionid
 153
 154 return :
 155 all informations (suggestion and borrower) of the suggestion which is related to the suggestionid given.
 156
 157 =cut
 158
 159 sub GetSuggestionInfo {
 160     my ($suggestionid) = @_;
 161     my $query = q{
 162         SELECT suggestions.*,
 163             U1.surname          AS surnamesuggestedby,
 164             U1.firstname        AS firstnamesuggestedby,
 165             U1.borrowernumber   AS borrnumsuggestedby
 166         FROM suggestions
 167             LEFT JOIN borrowers AS U1 ON suggestedby=U1.borrowernumber
 168         WHERE suggestionid=?
 169         LIMIT 1
 170     };
 171     my $dbh = C4::Context->dbh;
 172     my $sth = $dbh->prepare($query);
 173     $sth->execute($suggestionid);
 174     return $sth->fetchrow_hashref;
 175 }
 176
 177 =head2 GetSuggestionByStatus
 178
 179 $aqorders = &GetSuggestionByStatus($status,[$branchcode])
 180
 181 Get a suggestion from it's status
 182
 183 return :
 184 all the suggestion with C<$status>
 185
 186 =cut
 187
 188 sub GetSuggestionByStatus {
 189     my $status     = shift;
 190     my $branchcode = shift;
 191     my $dbh        = C4::Context->dbh;
 192     my @sql_params = ($status);
 193     my $query      = q{
 194         SELECT suggestions.*,
 195             U1.surname          AS surnamesuggestedby,
 196             U1.firstname        AS firstnamesuggestedby,
 197             U1.branchcode       AS branchcodesuggestedby,
 198             B1.branchname       AS branchnamesuggestedby,
 199             U1.borrowernumber   AS borrnumsuggestedby,
 200             U1.categorycode     AS categorycodesuggestedby,
 201             C1.description      AS categorydescriptionsuggestedby,
 202             U2.surname          AS surnamemanagedby,
 203             U2.firstname        AS firstnamemanagedby,
 204             U2.borrowernumber   AS borrnummanagedby
 205         FROM suggestions
 206             LEFT JOIN borrowers     AS U1 ON suggestedby=U1.borrowernumber
 207             LEFT JOIN borrowers     AS U2 ON managedby=U2.borrowernumber
 208             LEFT JOIN categories    AS C1 ON C1.categorycode=U1.categorycode
 209             LEFT JOIN branches      AS B1 on B1.branchcode=U1.branchcode
 210         WHERE status = ?
 211         ORDER BY suggestionid
 212     };
 213
 214     # filter on branch
 215     if ( C4::Context->preference("IndependentBranches") || $branchcode ) {
 216         my $userenv = C4::Context->userenv;
 217         if ($userenv) {
 218             unless ( C4::Context->IsSuperLibrarian() ) {
 219                 push @sql_params, $userenv->{branch};
 220                 $query .= q{ AND (U1.branchcode = ? OR U1.branchcode ='') };
 221             }
 222         }
 223         if ($branchcode) {
 224             push @sql_params, $branchcode;
 225             $query .= q{ AND (U1.branchcode = ? OR U1.branchcode ='') };
 226         }
 227     }
 228
 229     my $sth = $dbh->prepare($query);
 230     $sth->execute(@sql_params);
 231     my $results;
 232     $results = $sth->fetchall_arrayref( {} );
 233     return $results;
 234 }
 235
 236 =head2 NewSuggestion
 237
 238
 239 &NewSuggestion($suggestion);
 240
 241 Insert a new suggestion on database with value given on input arg.
 242
 243 =cut
 244
 245 sub NewSuggestion {
 246     my ($suggestion) = @_;
 247
 248     $suggestion->{STATUS} = "ASKED" unless $suggestion->{STATUS};
 249
 250     $suggestion->{suggesteddate} = dt_from_string unless $suggestion->{suggesteddate};
 251
 252     delete $suggestion->{branchcode}
 253       if defined $suggestion->{branchcode} and $suggestion->{branchcode} eq '';
 254
 255     my $suggestion_object = Koha::Suggestion->new( $suggestion )->store;
 256     my $suggestion_id = $suggestion_object->suggestionid;
 257
 258     my $emailpurchasesuggestions = C4::Context->preference("EmailPurchaseSuggestions");
 259     if ($emailpurchasesuggestions) {
 260         my $full_suggestion = GetSuggestion( $suggestion_id); # We should not need to refetch it!
 261         if (
 262             my $letter = C4::Letters::GetPreparedLetter(
 263                 module      => 'suggestions',
 264                 letter_code => 'NEW_SUGGESTION',
 265                 tables      => {
 266                     'branches'    => $full_suggestion->{branchcode},
 267                     'borrowers'   => $full_suggestion->{suggestedby},
 268                     'suggestions' => $full_suggestion,
 269                 },
 270             )
 271         ){
 272
 273             my $toaddress;
 274             if ( $emailpurchasesuggestions eq "BranchEmailAddress" ) {
 275                 my $library =
 276                   Koha::Libraries->find( $full_suggestion->{branchcode} );
 277                 $toaddress = $library->inbound_email_address;
 278             }
 279             elsif ( $emailpurchasesuggestions eq "KohaAdminEmailAddress" ) {
 280                 $toaddress = C4::Context->preference('ReplytoDefault')
 281                   || C4::Context->preference('KohaAdminEmailAddress');
 282             }
 283             else {
 284                 $toaddress =
 285                      C4::Context->preference($emailpurchasesuggestions)
 286                   || C4::Context->preference('ReplytoDefault')
 287                   || C4::Context->preference('KohaAdminEmailAddress');
 288             }
 289
 290             C4::Letters::EnqueueLetter(
 291                 {
 292                     letter         => $letter,
 293                     borrowernumber => $full_suggestion->{suggestedby},
 294                     suggestionid   => $full_suggestion->{suggestionid},
 295                     to_address     => $toaddress,
 296                     message_transport_type => 'email',
 297                 }
 298             ) or warn "can't enqueue letter $letter";
 299         }
 300     }
 301
 302     return $suggestion_id;
 303 }
 304
 305 =head2 ModSuggestion
 306
 307 &ModSuggestion($suggestion)
 308
 309 Modify the suggestion according to the hash passed by ref.
 310 The hash HAS to contain suggestionid
 311 Data not defined is not updated unless it is a note or sort1
 312 Send a mail to notify the user that did the suggestion.
 313
 314 Note that there is no function to modify a suggestion.
 315
 316 =cut
 317
 318 sub ModSuggestion {
 319     my ($suggestion) = @_;
 320     return unless( $suggestion and defined($suggestion->{suggestionid}) );
 321
 322     my $suggestion_object = Koha::Suggestions->find( $suggestion->{suggestionid} );
 323     eval { # FIXME Must raise an exception instead
 324         $suggestion_object->set($suggestion)->store;
 325     };
 326     return 0 if $@;
 327
 328     if ( $suggestion->{STATUS} && $suggestion_object->suggestedby ) {
 329
 330         # fetch the entire updated suggestion so that we can populate the letter
 331         my $full_suggestion = GetSuggestion( $suggestion->{suggestionid} );
 332
 333         my $patron = Koha::Patrons->find( $full_suggestion->{suggestedby} );
 334
 335         my $transport = (C4::Context->preference("FallbackToSMSIfNoEmail")) && ($patron->smsalertnumber) && (!$patron->email) ? 'sms' : 'email';
 336
 337         if (
 338             my $letter = C4::Letters::GetPreparedLetter(
 339                 module      => 'suggestions',
 340                 letter_code => $full_suggestion->{STATUS},
 341                 branchcode  => $full_suggestion->{branchcode},
 342                 lang        => $patron->lang,
 343                 tables      => {
 344                     'branches'    => $full_suggestion->{branchcode},
 345                     'borrowers'   => $full_suggestion->{suggestedby},
 346                     'suggestions' => $full_suggestion,
 347                     'biblio'      => $full_suggestion->{biblionumber},
 348                 },
 349             )
 350           )
 351         {
 352             C4::Letters::EnqueueLetter(
 353                 {
 354                     letter         => $letter,
 355                     borrowernumber => $full_suggestion->{suggestedby},
 356                     suggestionid   => $full_suggestion->{suggestionid},
 357                     LibraryName    => C4::Context->preference("LibraryName"),
 358                     message_transport_type => $transport,
 359                 }
 360             ) or warn "can't enqueue letter $letter";
 361         }
 362     }
 363     return 1; # No useful if the exception is raised earlier
 364 }
 365
 366 =head2 ConnectSuggestionAndBiblio
 367
 368 &ConnectSuggestionAndBiblio($ordernumber,$biblionumber)
 369
 370 connect a suggestion to an existing biblio
 371
 372 =cut
 373
 374 sub ConnectSuggestionAndBiblio {
 375     my ( $suggestionid, $biblionumber ) = @_;
 376     my $dbh   = C4::Context->dbh;
 377     my $query = q{
 378         UPDATE suggestions
 379         SET    biblionumber=?
 380         WHERE  suggestionid=?
 381     };
 382     my $sth = $dbh->prepare($query);
 383     $sth->execute( $biblionumber, $suggestionid );
 384 }
 385
 386 =head2 DelSuggestion
 387
 388 &DelSuggestion($borrowernumber,$ordernumber)
 389
 390 Delete a suggestion. A borrower can delete a suggestion only if they are its owner.
 391
 392 =cut
 393
 394 sub DelSuggestion {
 395     my ( $borrowernumber, $suggestionid, $type ) = @_;
 396     my $dbh = C4::Context->dbh;
 397
 398     # check that the suggestion comes from the suggestor
 399     my $query = q{
 400         SELECT suggestedby
 401         FROM   suggestions
 402         WHERE  suggestionid=?
 403     };
 404     my $sth = $dbh->prepare($query);
 405     $sth->execute($suggestionid);
 406     my ($suggestedby) = $sth->fetchrow;
 407     $suggestedby //= '';
 408     $borrowernumber //= '';
 409     if ( defined $type && $type eq 'intranet' || $suggestedby eq $borrowernumber ) {
 410         my $queryDelete = q{
 411             DELETE FROM suggestions
 412             WHERE suggestionid=?
 413         };
 414         $sth = $dbh->prepare($queryDelete);
 415         my $suggestiondeleted = $sth->execute($suggestionid);
 416         return $suggestiondeleted;
 417     }
 418 }
 419
 420 =head2 DelSuggestionsOlderThan
 421     &DelSuggestionsOlderThan($days)
 422
 423     Delete all suggestions older than TODAY-$days , that have be accepted or rejected.
 424     We do now allow a negative number. If you want to delete all suggestions, just use Koha::Suggestions->delete or so.
 425
 426 =cut
 427
 428 sub DelSuggestionsOlderThan {
 429     my ($days) = @_;
 430     return unless $days && $days > 0;
 431     my $dbh = C4::Context->dbh;
 432     my $sth = $dbh->prepare(
 433         q{
 434         DELETE FROM suggestions
 435         WHERE STATUS<>'ASKED'
 436             AND manageddate < ADDDATE(NOW(), ?)
 437     }
 438     );
 439     $sth->execute("-$days");
 440 }
 441
 442 sub GetUnprocessedSuggestions {
 443     my ( $number_of_days_since_the_last_modification ) = @_;
 444
 445     $number_of_days_since_the_last_modification ||= 0;
 446
 447     my $dbh = C4::Context->dbh;
 448
 449     my $s = $dbh->selectall_arrayref(q|
 450         SELECT *
 451         FROM suggestions
 452         WHERE STATUS = 'ASKED'
 453             AND budgetid IS NOT NULL
 454             AND CAST(NOW() AS DATE) - INTERVAL ? DAY = CAST(suggesteddate AS DATE)
 455     |, { Slice => {} }, $number_of_days_since_the_last_modification );
 456     return $s;
 457 }
 458
 459 =head2 MarcRecordFromNewSuggestion
 460
 461     $record = MarcRecordFromNewSuggestion ( $suggestion )
 462
 463 This function build a marc record object from a suggestion
 464
 465 =cut
 466
 467 sub MarcRecordFromNewSuggestion {
 468     my ($suggestion) = @_;
 469     my $record = MARC::Record->new();
 470
 471     if (my $isbn = $suggestion->{isbn}) {
 472         for my $field (qw(biblioitems.isbn biblioitems.issn)) {
 473             my ($tag, $subfield) = GetMarcFromKohaField($field);
 474             $record->append_fields(
 475                 MARC::Field->new($tag, ' ', ' ', $subfield => $isbn)
 476             );
 477         }
 478     }
 479     else {
 480         my ($title_tag, $title_subfield) = GetMarcFromKohaField('biblio.title');
 481         $record->append_fields(
 482             MARC::Field->new($title_tag, ' ', ' ', $title_subfield => $suggestion->{title})
 483         );
 484
 485         my ($author_tag, $author_subfield) = GetMarcFromKohaField('biblio.author');
 486         if ($record->field( $author_tag )) {
 487             $record->field( $author_tag )->add_subfields( $author_subfield => $suggestion->{author} );
 488         }
 489         else {
 490             $record->append_fields(
 491                 MARC::Field->new($author_tag, ' ', ' ', $author_subfield => $suggestion->{author})
 492             );
 493         }
 494     }
 495
 496     my ($it_tag, $it_subfield) = GetMarcFromKohaField('biblioitems.itemtype');
 497     if ($record->field( $it_tag )) {
 498         $record->field( $it_tag )->add_subfields( $it_subfield => $suggestion->{itemtype} );
 499     }
 500     else {
 501         $record->append_fields(
 502             MARC::Field->new($it_tag, ' ', ' ', $it_subfield => $suggestion->{itemtype})
 503         );
 504     }
 505
 506     return $record;
 507 }
 508
 509 1;
 510 __END__
 511
 512
 513 =head1 AUTHOR
 514
 515 Koha Development Team <http://koha-community.org/>
 516
 517 =cut
 518