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;
  29 use Koha::Suggestions;
  30
  31 use List::MoreUtils qw(any);
  32 use base qw(Exporter);
  33
  34 our @EXPORT  = qw(
  35   ConnectSuggestionAndBiblio
  36   DelSuggestion
  37   GetSuggestion
  38   GetSuggestionByStatus
  39   GetSuggestionFromBiblionumber
  40   GetSuggestionInfoFromBiblionumber
  41   GetSuggestionInfo
  42   ModStatus
  43   ModSuggestion
  44   NewSuggestion
  45   SearchSuggestion
  46   DelSuggestionsOlderThan
  47   GetUnprocessedSuggestions
  48   MarcRecordFromNewSuggestion
  49 );
  50
  51 =head1 NAME
  52
  53 C4::Suggestions - Some useful functions for dealings with aqorders.
  54
  55 =head1 SYNOPSIS
  56
  57 use C4::Suggestions;
  58
  59 =head1 DESCRIPTION
  60
  61 The functions in this module deal with the aqorders in OPAC and in librarian interface
  62
  63 A suggestion is done in the OPAC. It has the status "ASKED"
  64
  65 When a librarian manages the suggestion, they can set the status to "REJECTED" or "ACCEPTED".
  66
  67 When the book is ordered, the suggestion status becomes "ORDERED"
  68
  69 When a book is ordered and arrived in the library, the status becomes "AVAILABLE"
  70
  71 All aqorders of a borrower can be seen by the borrower itself.
  72 Suggestions done by other borrowers can be seen when not "AVAILABLE"
  73
  74 =head1 FUNCTIONS
  75
  76 =head2 SearchSuggestion
  77
  78 (\@array) = &SearchSuggestion($suggestionhashref_to_search)
  79
  80 searches for a suggestion
  81
  82 return :
  83 C<\@array> : the aqorders found. Array of hash.
  84 Note the status is stored twice :
  85 * in the status field
  86 * as parameter ( for example ASKED => 1, or REJECTED => 1) . This is for template & translation purposes.
  87
  88 =cut
  89
  90 sub SearchSuggestion {
  91     my ($suggestion) = @_;
  92     my $dbh = C4::Context->dbh;
  93     my @sql_params;
  94     my @query = (
  95         q{
  96         SELECT suggestions.*,
  97             U1.branchcode       AS branchcodesuggestedby,
  98             B1.branchname       AS branchnamesuggestedby,
  99             U1.surname          AS surnamesuggestedby,
 100             U1.firstname        AS firstnamesuggestedby,
 101             U1.cardnumber       AS cardnumbersuggestedby,
 102             U1.email            AS emailsuggestedby,
 103             U1.borrowernumber   AS borrnumsuggestedby,
 104             U1.categorycode     AS categorycodesuggestedby,
 105             C1.description      AS categorydescriptionsuggestedby,
 106             U2.surname          AS surnamemanagedby,
 107             U2.firstname        AS firstnamemanagedby,
 108             B2.branchname       AS branchnamesuggestedby,
 109             U2.email            AS emailmanagedby,
 110             U2.branchcode       AS branchcodemanagedby,
 111             U2.borrowernumber   AS borrnummanagedby,
 112             U3.surname          AS surnamelastmodificationby,
 113             U3.firstname        AS firstnamelastmodificationby,
 114             BU.budget_name      AS budget_name
 115         FROM suggestions
 116             LEFT JOIN borrowers     AS U1 ON suggestedby=U1.borrowernumber
 117             LEFT JOIN branches      AS B1 ON B1.branchcode=U1.branchcode
 118             LEFT JOIN categories    AS C1 ON C1.categorycode=U1.categorycode
 119             LEFT JOIN borrowers     AS U2 ON managedby=U2.borrowernumber
 120             LEFT JOIN branches      AS B2 ON B2.branchcode=U2.branchcode
 121             LEFT JOIN categories    AS C2 ON C2.categorycode=U2.categorycode
 122             LEFT JOIN borrowers     AS U3 ON lastmodificationby=U3.borrowernumber
 123             LEFT JOIN aqbudgets     AS BU ON budgetid=BU.budget_id
 124         WHERE 1=1
 125     }
 126     );
 127
 128     # filter on biblio informations
 129     foreach my $field (
 130         qw( title author isbn publishercode copyrightdate collectiontitle ))
 131     {
 132         if ( $suggestion->{$field} ) {
 133             push @sql_params, '%' . $suggestion->{$field} . '%';
 134             push @query,      qq{ AND suggestions.$field LIKE ? };
 135         }
 136     }
 137
 138     # filter on user branch
 139     if (   C4::Context->preference('IndependentBranches')
 140         && !C4::Context->IsSuperLibrarian() )
 141     {
 142         # If IndependentBranches is set and the logged in user is not superlibrarian
 143         # Then we want to filter by the user's library (i.e. cannot see suggestions from other libraries)
 144         my $userenv = C4::Context->userenv;
 145         if ($userenv) {
 146             {
 147                 push @sql_params, $$userenv{branch};
 148                 push @query,      q{
 149                     AND (suggestions.branchcode=? OR suggestions.branchcode='')
 150                 };
 151             }
 152         }
 153     }
 154     elsif (defined $suggestion->{branchcode}
 155         && $suggestion->{branchcode}
 156         && $suggestion->{branchcode} ne '__ANY__' )
 157     {
 158         # If IndependentBranches is not set OR the logged in user is not superlibrarian
 159         # AND the branchcode filter is passed and not '__ANY__'
 160         # Then we want to filter using this parameter
 161         push @sql_params, $suggestion->{branchcode};
 162         push @query,      qq{ AND suggestions.branchcode=? };
 163     }
 164
 165     # filter on nillable fields
 166     foreach my $field (
 167         qw( STATUS itemtype suggestedby managedby acceptedby budgetid biblionumber )
 168       )
 169     {
 170         if ( exists $suggestion->{$field}
 171                 and defined $suggestion->{$field}
 172                 and $suggestion->{$field} ne '__ANY__'
 173                 and (
 174                     $suggestion->{$field} ne q||
 175                         or $field eq 'STATUS'
 176                 )
 177         ) {
 178             if ( $suggestion->{$field} eq '__NONE__' ) {
 179                 push @query, qq{ AND (suggestions.$field = '' OR suggestions.$field IS NULL) };
 180             }
 181             else {
 182                 push @sql_params, $suggestion->{$field};
 183                 push @query, qq{ AND suggestions.$field = ? };
 184             }
 185         }
 186     }
 187
 188     # filter on date fields
 189     my $dtf = Koha::Database->new->schema->storage->datetime_parser;
 190     foreach my $field (qw( suggesteddate manageddate accepteddate )) {
 191         my $from = $field . "_from";
 192         my $to   = $field . "_to";
 193         my $from_dt;
 194         $from_dt = eval { dt_from_string( $suggestion->{$from} ) } if ( $suggestion->{$from} );
 195         my $to_dt;
 196         $to_dt = eval { dt_from_string( $suggestion->{$to} ) } if ( $suggestion->{$to} );
 197         if ( $from_dt ) {
 198             push @query, qq{ AND suggestions.$field >= ?};
 199             push @sql_params, $dtf->format_date($from_dt);
 200         }
 201         if ( $to_dt ) {
 202             push @query, qq{ AND suggestions.$field <= ?};
 203             push @sql_params, $dtf->format_date($to_dt);
 204         }
 205     }
 206
 207     # By default do not search for archived suggestions
 208     unless ( exists $suggestion->{archived} && $suggestion->{archived} ) {
 209         push @query, q{ AND suggestions.archived = 0 };
 210     }
 211
 212     my $sth = $dbh->prepare("@query");
 213     $sth->execute(@sql_params);
 214     my @results;
 215
 216     # add status as field
 217     while ( my $data = $sth->fetchrow_hashref ) {
 218         $data->{ $data->{STATUS} } = 1;
 219         push( @results, $data );
 220     }
 221
 222     return ( \@results );
 223 }
 224
 225 =head2 GetSuggestion
 226
 227 \%sth = &GetSuggestion($suggestionid)
 228
 229 this function get the detail of the suggestion $suggestionid (input arg)
 230
 231 return :
 232     the result of the SQL query as a hash : $sth->fetchrow_hashref.
 233
 234 =cut
 235
 236 sub GetSuggestion {
 237     my ($suggestionid) = @_;
 238     my $dbh           = C4::Context->dbh;
 239     my $query         = q{
 240         SELECT *
 241         FROM   suggestions
 242         WHERE  suggestionid=?
 243     };
 244     my $sth = $dbh->prepare($query);
 245     $sth->execute($suggestionid);
 246     return ( $sth->fetchrow_hashref );
 247 }
 248
 249 =head2 GetSuggestionFromBiblionumber
 250
 251 $ordernumber = &GetSuggestionFromBiblionumber($biblionumber)
 252
 253 Get a suggestion from it's biblionumber.
 254
 255 return :
 256 the id of the suggestion which is related to the biblionumber given on input args.
 257
 258 =cut
 259
 260 sub GetSuggestionFromBiblionumber {
 261     my ($biblionumber) = @_;
 262     my $query = q{
 263         SELECT suggestionid
 264         FROM   suggestions
 265         WHERE  biblionumber=? LIMIT 1
 266     };
 267     my $dbh = C4::Context->dbh;
 268     my $sth = $dbh->prepare($query);
 269     $sth->execute($biblionumber);
 270     my ($suggestionid) = $sth->fetchrow;
 271     return $suggestionid;
 272 }
 273
 274 =head2 GetSuggestionInfoFromBiblionumber
 275
 276 Get a suggestion and borrower's informations from it's biblionumber.
 277
 278 return :
 279 all informations (suggestion and borrower) of the suggestion which is related to the biblionumber given.
 280
 281 =cut
 282
 283 sub GetSuggestionInfoFromBiblionumber {
 284     my ($biblionumber) = @_;
 285     my $query = q{
 286         SELECT suggestions.*,
 287             U1.surname          AS surnamesuggestedby,
 288             U1.firstname        AS firstnamesuggestedby,
 289             U1.borrowernumber   AS borrnumsuggestedby
 290         FROM suggestions
 291             LEFT JOIN borrowers AS U1 ON suggestedby=U1.borrowernumber
 292         WHERE biblionumber=?
 293         LIMIT 1
 294     };
 295     my $dbh = C4::Context->dbh;
 296     my $sth = $dbh->prepare($query);
 297     $sth->execute($biblionumber);
 298     return $sth->fetchrow_hashref;
 299 }
 300
 301 =head2 GetSuggestionInfo
 302
 303 Get a suggestion and borrower's informations from it's suggestionid
 304
 305 return :
 306 all informations (suggestion and borrower) of the suggestion which is related to the suggestionid given.
 307
 308 =cut
 309
 310 sub GetSuggestionInfo {
 311     my ($suggestionid) = @_;
 312     my $query = q{
 313         SELECT suggestions.*,
 314             U1.surname          AS surnamesuggestedby,
 315             U1.firstname        AS firstnamesuggestedby,
 316             U1.borrowernumber   AS borrnumsuggestedby
 317         FROM suggestions
 318             LEFT JOIN borrowers AS U1 ON suggestedby=U1.borrowernumber
 319         WHERE suggestionid=?
 320         LIMIT 1
 321     };
 322     my $dbh = C4::Context->dbh;
 323     my $sth = $dbh->prepare($query);
 324     $sth->execute($suggestionid);
 325     return $sth->fetchrow_hashref;
 326 }
 327
 328 =head2 GetSuggestionByStatus
 329
 330 $aqorders = &GetSuggestionByStatus($status,[$branchcode])
 331
 332 Get a suggestion from it's status
 333
 334 return :
 335 all the suggestion with C<$status>
 336
 337 =cut
 338
 339 sub GetSuggestionByStatus {
 340     my $status     = shift;
 341     my $branchcode = shift;
 342     my $dbh        = C4::Context->dbh;
 343     my @sql_params = ($status);
 344     my $query      = q{
 345         SELECT suggestions.*,
 346             U1.surname          AS surnamesuggestedby,
 347             U1.firstname        AS firstnamesuggestedby,
 348             U1.branchcode       AS branchcodesuggestedby,
 349             B1.branchname       AS branchnamesuggestedby,
 350             U1.borrowernumber   AS borrnumsuggestedby,
 351             U1.categorycode     AS categorycodesuggestedby,
 352             C1.description      AS categorydescriptionsuggestedby,
 353             U2.surname          AS surnamemanagedby,
 354             U2.firstname        AS firstnamemanagedby,
 355             U2.borrowernumber   AS borrnummanagedby
 356         FROM suggestions
 357             LEFT JOIN borrowers     AS U1 ON suggestedby=U1.borrowernumber
 358             LEFT JOIN borrowers     AS U2 ON managedby=U2.borrowernumber
 359             LEFT JOIN categories    AS C1 ON C1.categorycode=U1.categorycode
 360             LEFT JOIN branches      AS B1 on B1.branchcode=U1.branchcode
 361         WHERE status = ?
 362         ORDER BY suggestionid
 363     };
 364
 365     # filter on branch
 366     if ( C4::Context->preference("IndependentBranches") || $branchcode ) {
 367         my $userenv = C4::Context->userenv;
 368         if ($userenv) {
 369             unless ( C4::Context->IsSuperLibrarian() ) {
 370                 push @sql_params, $userenv->{branch};
 371                 $query .= q{ AND (U1.branchcode = ? OR U1.branchcode ='') };
 372             }
 373         }
 374         if ($branchcode) {
 375             push @sql_params, $branchcode;
 376             $query .= q{ AND (U1.branchcode = ? OR U1.branchcode ='') };
 377         }
 378     }
 379
 380     my $sth = $dbh->prepare($query);
 381     $sth->execute(@sql_params);
 382     my $results;
 383     $results = $sth->fetchall_arrayref( {} );
 384     return $results;
 385 }
 386
 387 =head2 NewSuggestion
 388
 389
 390 &NewSuggestion($suggestion);
 391
 392 Insert a new suggestion on database with value given on input arg.
 393
 394 =cut
 395
 396 sub NewSuggestion {
 397     my ($suggestion) = @_;
 398
 399     $suggestion->{STATUS} = "ASKED" unless $suggestion->{STATUS};
 400
 401     $suggestion->{suggesteddate} = dt_from_string unless $suggestion->{suggesteddate};
 402
 403     delete $suggestion->{branchcode} if $suggestion->{branchcode} eq '';
 404
 405     my $suggestion_object = Koha::Suggestion->new( $suggestion )->store;
 406     my $suggestion_id = $suggestion_object->suggestionid;
 407
 408     my $emailpurchasesuggestions = C4::Context->preference("EmailPurchaseSuggestions");
 409     if ($emailpurchasesuggestions) {
 410         my $full_suggestion = GetSuggestion( $suggestion_id); # We should not need to refetch it!
 411         if (
 412             my $letter = C4::Letters::GetPreparedLetter(
 413                 module      => 'suggestions',
 414                 letter_code => 'NEW_SUGGESTION',
 415                 tables      => {
 416                     'branches'    => $full_suggestion->{branchcode},
 417                     'borrowers'   => $full_suggestion->{suggestedby},
 418                     'suggestions' => $full_suggestion,
 419                 },
 420             )
 421         ){
 422
 423             my $toaddress;
 424             if ( $emailpurchasesuggestions eq "BranchEmailAddress" ) {
 425                 my $library =
 426                   Koha::Libraries->find( $full_suggestion->{branchcode} );
 427                 $toaddress = $library->inbound_email_address;
 428             }
 429             elsif ( $emailpurchasesuggestions eq "KohaAdminEmailAddress" ) {
 430                 $toaddress = C4::Context->preference('ReplytoDefault')
 431                   || C4::Context->preference('KohaAdminEmailAddress');
 432             }
 433             else {
 434                 $toaddress =
 435                      C4::Context->preference($emailpurchasesuggestions)
 436                   || C4::Context->preference('ReplytoDefault')
 437                   || C4::Context->preference('KohaAdminEmailAddress');
 438             }
 439
 440             C4::Letters::EnqueueLetter(
 441                 {
 442                     letter         => $letter,
 443                     borrowernumber => $full_suggestion->{suggestedby},
 444                     suggestionid   => $full_suggestion->{suggestionid},
 445                     to_address     => $toaddress,
 446                     message_transport_type => 'email',
 447                 }
 448             ) or warn "can't enqueue letter $letter";
 449         }
 450     }
 451
 452     return $suggestion_id;
 453 }
 454
 455 =head2 ModSuggestion
 456
 457 &ModSuggestion($suggestion)
 458
 459 Modify the suggestion according to the hash passed by ref.
 460 The hash HAS to contain suggestionid
 461 Data not defined is not updated unless it is a note or sort1
 462 Send a mail to notify the user that did the suggestion.
 463
 464 Note that there is no function to modify a suggestion.
 465
 466 =cut
 467
 468 sub ModSuggestion {
 469     my ($suggestion) = @_;
 470     return unless( $suggestion and defined($suggestion->{suggestionid}) );
 471
 472     my $suggestion_object = Koha::Suggestions->find( $suggestion->{suggestionid} );
 473     eval { # FIXME Must raise an exception instead
 474         $suggestion_object->set($suggestion)->store;
 475     };
 476     return 0 if $@;
 477
 478     if ( $suggestion->{STATUS} && $suggestion_object->suggestedby ) {
 479
 480         # fetch the entire updated suggestion so that we can populate the letter
 481         my $full_suggestion = GetSuggestion( $suggestion->{suggestionid} );
 482
 483         my $patron = Koha::Patrons->find( $full_suggestion->{suggestedby} );
 484
 485         my $transport = (C4::Context->preference("FallbackToSMSIfNoEmail")) && ($patron->smsalertnumber) && (!$patron->email) ? 'sms' : 'email';
 486
 487         if (
 488             my $letter = C4::Letters::GetPreparedLetter(
 489                 module      => 'suggestions',
 490                 letter_code => $full_suggestion->{STATUS},
 491                 branchcode  => $full_suggestion->{branchcode},
 492                 lang        => $patron->lang,
 493                 tables      => {
 494                     'branches'    => $full_suggestion->{branchcode},
 495                     'borrowers'   => $full_suggestion->{suggestedby},
 496                     'suggestions' => $full_suggestion,
 497                     'biblio'      => $full_suggestion->{biblionumber},
 498                 },
 499             )
 500           )
 501         {
 502             C4::Letters::EnqueueLetter(
 503                 {
 504                     letter         => $letter,
 505                     borrowernumber => $full_suggestion->{suggestedby},
 506                     suggestionid   => $full_suggestion->{suggestionid},
 507                     LibraryName    => C4::Context->preference("LibraryName"),
 508                     message_transport_type => $transport,
 509                 }
 510             ) or warn "can't enqueue letter $letter";
 511         }
 512     }
 513     return 1; # No useful if the exception is raised earlier
 514 }
 515
 516 =head2 ConnectSuggestionAndBiblio
 517
 518 &ConnectSuggestionAndBiblio($ordernumber,$biblionumber)
 519
 520 connect a suggestion to an existing biblio
 521
 522 =cut
 523
 524 sub ConnectSuggestionAndBiblio {
 525     my ( $suggestionid, $biblionumber ) = @_;
 526     my $dbh   = C4::Context->dbh;
 527     my $query = q{
 528         UPDATE suggestions
 529         SET    biblionumber=?
 530         WHERE  suggestionid=?
 531     };
 532     my $sth = $dbh->prepare($query);
 533     $sth->execute( $biblionumber, $suggestionid );
 534 }
 535
 536 =head2 DelSuggestion
 537
 538 &DelSuggestion($borrowernumber,$ordernumber)
 539
 540 Delete a suggestion. A borrower can delete a suggestion only if they are its owner.
 541
 542 =cut
 543
 544 sub DelSuggestion {
 545     my ( $borrowernumber, $suggestionid, $type ) = @_;
 546     my $dbh = C4::Context->dbh;
 547
 548     # check that the suggestion comes from the suggestor
 549     my $query = q{
 550         SELECT suggestedby
 551         FROM   suggestions
 552         WHERE  suggestionid=?
 553     };
 554     my $sth = $dbh->prepare($query);
 555     $sth->execute($suggestionid);
 556     my ($suggestedby) = $sth->fetchrow;
 557     if ( $type eq 'intranet' || $suggestedby eq $borrowernumber ) {
 558         my $queryDelete = q{
 559             DELETE FROM suggestions
 560             WHERE suggestionid=?
 561         };
 562         $sth = $dbh->prepare($queryDelete);
 563         my $suggestiondeleted = $sth->execute($suggestionid);
 564         return $suggestiondeleted;
 565     }
 566 }
 567
 568 =head2 DelSuggestionsOlderThan
 569     &DelSuggestionsOlderThan($days)
 570
 571     Delete all suggestions older than TODAY-$days , that have be accepted or rejected.
 572     We do now allow a negative number. If you want to delete all suggestions, just use Koha::Suggestions->delete or so.
 573
 574 =cut
 575
 576 sub DelSuggestionsOlderThan {
 577     my ($days) = @_;
 578     return unless $days && $days > 0;
 579     my $dbh = C4::Context->dbh;
 580     my $sth = $dbh->prepare(
 581         q{
 582         DELETE FROM suggestions
 583         WHERE STATUS<>'ASKED'
 584             AND date < ADDDATE(NOW(), ?)
 585     }
 586     );
 587     $sth->execute("-$days");
 588 }
 589
 590 sub GetUnprocessedSuggestions {
 591     my ( $number_of_days_since_the_last_modification ) = @_;
 592
 593     $number_of_days_since_the_last_modification ||= 0;
 594
 595     my $dbh = C4::Context->dbh;
 596
 597     my $s = $dbh->selectall_arrayref(q|
 598         SELECT *
 599         FROM suggestions
 600         WHERE STATUS = 'ASKED'
 601             AND budgetid IS NOT NULL
 602             AND CAST(NOW() AS DATE) - INTERVAL ? DAY = CAST(suggesteddate AS DATE)
 603     |, { Slice => {} }, $number_of_days_since_the_last_modification );
 604     return $s;
 605 }
 606
 607 =head2 MarcRecordFromNewSuggestion
 608
 609     $record = MarcRecordFromNewSuggestion ( $suggestion )
 610
 611 This function build a marc record object from a suggestion
 612
 613 =cut
 614
 615 sub MarcRecordFromNewSuggestion {
 616     my ($suggestion) = @_;
 617     my $record = MARC::Record->new();
 618
 619     my ($title_tag, $title_subfield) = GetMarcFromKohaField('biblio.title', '');
 620     $record->append_fields(
 621         MARC::Field->new($title_tag, ' ', ' ', $title_subfield => $suggestion->{title})
 622     );
 623
 624     my ($author_tag, $author_subfield) = GetMarcFromKohaField('biblio.author', '');
 625     if ($record->field( $author_tag )) {
 626         $record->field( $author_tag )->add_subfields( $author_subfield => $suggestion->{author} );
 627     }
 628     else {
 629         $record->append_fields(
 630             MARC::Field->new($author_tag, ' ', ' ', $author_subfield => $suggestion->{author})
 631         );
 632     }
 633
 634     my ($it_tag, $it_subfield) = GetMarcFromKohaField('biblioitems.itemtype', '');
 635     if ($record->field( $it_tag )) {
 636         $record->field( $it_tag )->add_subfields( $it_subfield => $suggestion->{itemtype} );
 637     }
 638     else {
 639         $record->append_fields(
 640             MARC::Field->new($it_tag, ' ', ' ', $it_subfield => $suggestion->{itemtype})
 641         );
 642     }
 643
 644     return $record;
 645 }
 646
 647 1;
 648 __END__
 649
 650
 651 =head1 AUTHOR
 652
 653 Koha Development Team <http://koha-community.org/>
 654
 655 =cut
 656