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} if $suggestion->{branchcode} eq '';
 253
 254     my $suggestion_object = Koha::Suggestion->new( $suggestion )->store;
 255     my $suggestion_id = $suggestion_object->suggestionid;
 256
 257     my $emailpurchasesuggestions = C4::Context->preference("EmailPurchaseSuggestions");
 258     if ($emailpurchasesuggestions) {
 259         my $full_suggestion = GetSuggestion( $suggestion_id); # We should not need to refetch it!
 260         if (
 261             my $letter = C4::Letters::GetPreparedLetter(
 262                 module      => 'suggestions',
 263                 letter_code => 'NEW_SUGGESTION',
 264                 tables      => {
 265                     'branches'    => $full_suggestion->{branchcode},
 266                     'borrowers'   => $full_suggestion->{suggestedby},
 267                     'suggestions' => $full_suggestion,
 268                 },
 269             )
 270         ){
 271
 272             my $toaddress;
 273             if ( $emailpurchasesuggestions eq "BranchEmailAddress" ) {
 274                 my $library =
 275                   Koha::Libraries->find( $full_suggestion->{branchcode} );
 276                 $toaddress = $library->inbound_email_address;
 277             }
 278             elsif ( $emailpurchasesuggestions eq "KohaAdminEmailAddress" ) {
 279                 $toaddress = C4::Context->preference('ReplytoDefault')
 280                   || C4::Context->preference('KohaAdminEmailAddress');
 281             }
 282             else {
 283                 $toaddress =
 284                      C4::Context->preference($emailpurchasesuggestions)
 285                   || C4::Context->preference('ReplytoDefault')
 286                   || C4::Context->preference('KohaAdminEmailAddress');
 287             }
 288
 289             C4::Letters::EnqueueLetter(
 290                 {
 291                     letter         => $letter,
 292                     borrowernumber => $full_suggestion->{suggestedby},
 293                     suggestionid   => $full_suggestion->{suggestionid},
 294                     to_address     => $toaddress,
 295                     message_transport_type => 'email',
 296                 }
 297             ) or warn "can't enqueue letter $letter";
 298         }
 299     }
 300
 301     return $suggestion_id;
 302 }
 303
 304 =head2 ModSuggestion
 305
 306 &ModSuggestion($suggestion)
 307
 308 Modify the suggestion according to the hash passed by ref.
 309 The hash HAS to contain suggestionid
 310 Data not defined is not updated unless it is a note or sort1
 311 Send a mail to notify the user that did the suggestion.
 312
 313 Note that there is no function to modify a suggestion.
 314
 315 =cut
 316
 317 sub ModSuggestion {
 318     my ($suggestion) = @_;
 319     return unless( $suggestion and defined($suggestion->{suggestionid}) );
 320
 321     my $suggestion_object = Koha::Suggestions->find( $suggestion->{suggestionid} );
 322     eval { # FIXME Must raise an exception instead
 323         $suggestion_object->set($suggestion)->store;
 324     };
 325     return 0 if $@;
 326
 327     if ( $suggestion->{STATUS} && $suggestion_object->suggestedby ) {
 328
 329         # fetch the entire updated suggestion so that we can populate the letter
 330         my $full_suggestion = GetSuggestion( $suggestion->{suggestionid} );
 331
 332         my $patron = Koha::Patrons->find( $full_suggestion->{suggestedby} );
 333
 334         my $transport = (C4::Context->preference("FallbackToSMSIfNoEmail")) && ($patron->smsalertnumber) && (!$patron->email) ? 'sms' : 'email';
 335
 336         if (
 337             my $letter = C4::Letters::GetPreparedLetter(
 338                 module      => 'suggestions',
 339                 letter_code => $full_suggestion->{STATUS},
 340                 branchcode  => $full_suggestion->{branchcode},
 341                 lang        => $patron->lang,
 342                 tables      => {
 343                     'branches'    => $full_suggestion->{branchcode},
 344                     'borrowers'   => $full_suggestion->{suggestedby},
 345                     'suggestions' => $full_suggestion,
 346                     'biblio'      => $full_suggestion->{biblionumber},
 347                 },
 348             )
 349           )
 350         {
 351             C4::Letters::EnqueueLetter(
 352                 {
 353                     letter         => $letter,
 354                     borrowernumber => $full_suggestion->{suggestedby},
 355                     suggestionid   => $full_suggestion->{suggestionid},
 356                     LibraryName    => C4::Context->preference("LibraryName"),
 357                     message_transport_type => $transport,
 358                 }
 359             ) or warn "can't enqueue letter $letter";
 360         }
 361     }
 362     return 1; # No useful if the exception is raised earlier
 363 }
 364
 365 =head2 ConnectSuggestionAndBiblio
 366
 367 &ConnectSuggestionAndBiblio($ordernumber,$biblionumber)
 368
 369 connect a suggestion to an existing biblio
 370
 371 =cut
 372
 373 sub ConnectSuggestionAndBiblio {
 374     my ( $suggestionid, $biblionumber ) = @_;
 375     my $dbh   = C4::Context->dbh;
 376     my $query = q{
 377         UPDATE suggestions
 378         SET    biblionumber=?
 379         WHERE  suggestionid=?
 380     };
 381     my $sth = $dbh->prepare($query);
 382     $sth->execute( $biblionumber, $suggestionid );
 383 }
 384
 385 =head2 DelSuggestion
 386
 387 &DelSuggestion($borrowernumber,$ordernumber)
 388
 389 Delete a suggestion. A borrower can delete a suggestion only if they are its owner.
 390
 391 =cut
 392
 393 sub DelSuggestion {
 394     my ( $borrowernumber, $suggestionid, $type ) = @_;
 395     my $dbh = C4::Context->dbh;
 396
 397     # check that the suggestion comes from the suggestor
 398     my $query = q{
 399         SELECT suggestedby
 400         FROM   suggestions
 401         WHERE  suggestionid=?
 402     };
 403     my $sth = $dbh->prepare($query);
 404     $sth->execute($suggestionid);
 405     my ($suggestedby) = $sth->fetchrow;
 406     if ( $type eq 'intranet' || $suggestedby eq $borrowernumber ) {
 407         my $queryDelete = q{
 408             DELETE FROM suggestions
 409             WHERE suggestionid=?
 410         };
 411         $sth = $dbh->prepare($queryDelete);
 412         my $suggestiondeleted = $sth->execute($suggestionid);
 413         return $suggestiondeleted;
 414     }
 415 }
 416
 417 =head2 DelSuggestionsOlderThan
 418     &DelSuggestionsOlderThan($days)
 419
 420     Delete all suggestions older than TODAY-$days , that have be accepted or rejected.
 421     We do now allow a negative number. If you want to delete all suggestions, just use Koha::Suggestions->delete or so.
 422
 423 =cut
 424
 425 sub DelSuggestionsOlderThan {
 426     my ($days) = @_;
 427     return unless $days && $days > 0;
 428     my $dbh = C4::Context->dbh;
 429     my $sth = $dbh->prepare(
 430         q{
 431         DELETE FROM suggestions
 432         WHERE STATUS<>'ASKED'
 433             AND manageddate < ADDDATE(NOW(), ?)
 434     }
 435     );
 436     $sth->execute("-$days");
 437 }
 438
 439 sub GetUnprocessedSuggestions {
 440     my ( $number_of_days_since_the_last_modification ) = @_;
 441
 442     $number_of_days_since_the_last_modification ||= 0;
 443
 444     my $dbh = C4::Context->dbh;
 445
 446     my $s = $dbh->selectall_arrayref(q|
 447         SELECT *
 448         FROM suggestions
 449         WHERE STATUS = 'ASKED'
 450             AND budgetid IS NOT NULL
 451             AND CAST(NOW() AS DATE) - INTERVAL ? DAY = CAST(suggesteddate AS DATE)
 452     |, { Slice => {} }, $number_of_days_since_the_last_modification );
 453     return $s;
 454 }
 455
 456 =head2 MarcRecordFromNewSuggestion
 457
 458     $record = MarcRecordFromNewSuggestion ( $suggestion )
 459
 460 This function build a marc record object from a suggestion
 461
 462 =cut
 463
 464 sub MarcRecordFromNewSuggestion {
 465     my ($suggestion) = @_;
 466     my $record = MARC::Record->new();
 467
 468     if (my $isbn = $suggestion->{isbn}) {
 469         for my $field (qw(biblioitems.isbn biblioitems.issn)) {
 470             my ($tag, $subfield) = GetMarcFromKohaField($field);
 471             $record->append_fields(
 472                 MARC::Field->new($tag, ' ', ' ', $subfield => $isbn)
 473             );
 474         }
 475     }
 476     else {
 477         my ($title_tag, $title_subfield) = GetMarcFromKohaField('biblio.title');
 478         $record->append_fields(
 479             MARC::Field->new($title_tag, ' ', ' ', $title_subfield => $suggestion->{title})
 480         );
 481
 482         my ($author_tag, $author_subfield) = GetMarcFromKohaField('biblio.author');
 483         if ($record->field( $author_tag )) {
 484             $record->field( $author_tag )->add_subfields( $author_subfield => $suggestion->{author} );
 485         }
 486         else {
 487             $record->append_fields(
 488                 MARC::Field->new($author_tag, ' ', ' ', $author_subfield => $suggestion->{author})
 489             );
 490         }
 491     }
 492
 493     my ($it_tag, $it_subfield) = GetMarcFromKohaField('biblioitems.itemtype');
 494     if ($record->field( $it_tag )) {
 495         $record->field( $it_tag )->add_subfields( $it_subfield => $suggestion->{itemtype} );
 496     }
 497     else {
 498         $record->append_fields(
 499             MARC::Field->new($it_tag, ' ', ' ', $it_subfield => $suggestion->{itemtype})
 500         );
 501     }
 502
 503     return $record;
 504 }
 505
 506 1;
 507 __END__
 508
 509
 510 =head1 AUTHOR
 511
 512 Koha Development Team <http://koha-community.org/>
 513
 514 =cut
 515