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