1 package C4
::Suggestions
;
3 # Copyright 2000-2002 Katipo Communications
4 # Parts Copyright Biblibre 2011
6 # This file is part of Koha.
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.
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.
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>.
28 use C4
::Biblio
qw( GetMarcFromKohaField );
30 use Koha
::Suggestions
;
32 use List
::MoreUtils
qw(any);
33 use base
qw(Exporter);
36 ConnectSuggestionAndBiblio
40 GetSuggestionFromBiblionumber
41 GetSuggestionInfoFromBiblionumber
47 DelSuggestionsOlderThan
48 GetUnprocessedSuggestions
49 MarcRecordFromNewSuggestion
54 C4::Suggestions - Some useful functions for dealings with aqorders.
62 The functions in this module deal with the aqorders in OPAC and in librarian interface
64 A suggestion is done in the OPAC. It has the status "ASKED"
66 When a librarian manages the suggestion, they can set the status to "REJECTED" or "ACCEPTED".
68 When the book is ordered, the suggestion status becomes "ORDERED"
70 When a book is ordered and arrived in the library, the status becomes "AVAILABLE"
72 All aqorders of a borrower can be seen by the borrower itself.
73 Suggestions done by other borrowers can be seen when not "AVAILABLE"
77 =head2 SearchSuggestion
79 (\@array) = &SearchSuggestion($suggestionhashref_to_search)
81 searches for a suggestion
84 C<\@array> : the aqorders found. Array of hash.
85 Note the status is stored twice :
87 * as parameter ( for example ASKED => 1, or REJECTED => 1) . This is for template & translation purposes.
91 sub SearchSuggestion
{
92 my ($suggestion) = @_;
93 my $dbh = C4
::Context
->dbh;
98 U1.branchcode AS branchcodesuggestedby,
99 B1.branchname AS branchnamesuggestedby,
100 U1.surname AS surnamesuggestedby,
101 U1.firstname AS firstnamesuggestedby,
102 U1.cardnumber AS cardnumbersuggestedby,
103 U1.email AS emailsuggestedby,
104 U1.borrowernumber AS borrnumsuggestedby,
105 U1.categorycode AS categorycodesuggestedby,
106 C1.description AS categorydescriptionsuggestedby,
107 U2.surname AS surnamemanagedby,
108 U2.firstname AS firstnamemanagedby,
109 B2.branchname AS branchnamesuggestedby,
110 U2.email AS emailmanagedby,
111 U2.branchcode AS branchcodemanagedby,
112 U2.borrowernumber AS borrnummanagedby,
113 U3.surname AS surnamelastmodificationby,
114 U3.firstname AS firstnamelastmodificationby,
115 BU.budget_name AS budget_name
117 LEFT JOIN borrowers AS U1 ON suggestedby=U1.borrowernumber
118 LEFT JOIN branches AS B1 ON B1.branchcode=U1.branchcode
119 LEFT JOIN categories AS C1 ON C1.categorycode=U1.categorycode
120 LEFT JOIN borrowers AS U2 ON managedby=U2.borrowernumber
121 LEFT JOIN branches AS B2 ON B2.branchcode=U2.branchcode
122 LEFT JOIN categories AS C2 ON C2.categorycode=U2.categorycode
123 LEFT JOIN borrowers AS U3 ON lastmodificationby=U3.borrowernumber
124 LEFT JOIN aqbudgets AS BU ON budgetid=BU.budget_id
129 # filter on biblio informations
131 qw( title author isbn publishercode copyrightdate collectiontitle ))
133 if ( $suggestion->{$field} ) {
134 push @sql_params, '%' . $suggestion->{$field} . '%';
135 push @query, qq{ AND suggestions
.$field LIKE ?
};
139 # filter on user branch
140 if ( C4
::Context
->preference('IndependentBranches')
141 && !C4
::Context
->IsSuperLibrarian() )
143 # If IndependentBranches is set and the logged in user is not superlibrarian
144 # Then we want to filter by the user's library (i.e. cannot see suggestions from other libraries)
145 my $userenv = C4
::Context
->userenv;
148 push @sql_params, $$userenv{branch
};
150 AND (suggestions.branchcode=? OR suggestions.branchcode='')
155 elsif (defined $suggestion->{branchcode
}
156 && $suggestion->{branchcode
}
157 && $suggestion->{branchcode
} ne '__ANY__' )
159 # If IndependentBranches is not set OR the logged in user is not superlibrarian
160 # AND the branchcode filter is passed and not '__ANY__'
161 # Then we want to filter using this parameter
162 push @sql_params, $suggestion->{branchcode
};
163 push @query, qq{ AND suggestions
.branchcode
=?
};
166 # filter on nillable fields
168 qw( STATUS itemtype suggestedby managedby acceptedby budgetid biblionumber )
171 if ( exists $suggestion->{$field}
172 and defined $suggestion->{$field}
173 and $suggestion->{$field} ne '__ANY__'
175 $suggestion->{$field} ne q
||
176 or $field eq 'STATUS'
179 if ( $suggestion->{$field} eq '__NONE__' ) {
180 push @query, qq{ AND
(suggestions
.$field = '' OR suggestions
.$field IS NULL
) };
183 push @sql_params, $suggestion->{$field};
184 push @query, qq{ AND suggestions
.$field = ?
};
189 # filter on date fields
190 foreach my $field (qw( suggesteddate manageddate accepteddate )) {
191 my $from = $field . "_from";
192 my $to = $field . "_to";
194 $from_dt = eval { dt_from_string
( $suggestion->{$from} ) } if ( $suggestion->{$from} );
195 my $from_sql = '0000-00-00';
196 $from_sql = output_pref
({ dt
=> $from_dt, dateformat
=> 'iso', dateonly
=> 1 })
198 $debug && warn "SQL for start date ($field): $from_sql";
199 if ( $suggestion->{$from} || $suggestion->{$to} ) {
200 push @query, qq{ AND suggestions
.$field BETWEEN ? AND ?
};
201 push @sql_params, $from_sql;
203 output_pref
({ dt
=> dt_from_string
( $suggestion->{$to} ), dateformat
=> 'iso', dateonly
=> 1 }) || output_pref
({ dt
=> dt_from_string
, dateformat
=> 'iso', dateonly
=> 1 });
207 # By default do not search for archived suggestions
208 unless ( exists $suggestion->{archived
} && $suggestion->{archived
} ) {
209 push @query, q{ AND suggestions.archived = 0 };
212 $debug && warn "@query";
213 my $sth = $dbh->prepare("@query");
214 $sth->execute(@sql_params);
217 # add status as field
218 while ( my $data = $sth->fetchrow_hashref ) {
219 $data->{ $data->{STATUS
} } = 1;
220 push( @results, $data );
223 return ( \
@results );
228 \%sth = &GetSuggestion($suggestionid)
230 this function get the detail of the suggestion $suggestionid (input arg)
233 the result of the SQL query as a hash : $sth->fetchrow_hashref.
238 my ($suggestionid) = @_;
239 my $dbh = C4
::Context
->dbh;
245 my $sth = $dbh->prepare($query);
246 $sth->execute($suggestionid);
247 return ( $sth->fetchrow_hashref );
250 =head2 GetSuggestionFromBiblionumber
252 $ordernumber = &GetSuggestionFromBiblionumber($biblionumber)
254 Get a suggestion from it's biblionumber.
257 the id of the suggestion which is related to the biblionumber given on input args.
261 sub GetSuggestionFromBiblionumber
{
262 my ($biblionumber) = @_;
266 WHERE biblionumber=? LIMIT 1
268 my $dbh = C4
::Context
->dbh;
269 my $sth = $dbh->prepare($query);
270 $sth->execute($biblionumber);
271 my ($suggestionid) = $sth->fetchrow;
272 return $suggestionid;
275 =head2 GetSuggestionInfoFromBiblionumber
277 Get a suggestion and borrower's informations from it's biblionumber.
280 all informations (suggestion and borrower) of the suggestion which is related to the biblionumber given.
284 sub GetSuggestionInfoFromBiblionumber
{
285 my ($biblionumber) = @_;
287 SELECT suggestions.*,
288 U1.surname AS surnamesuggestedby,
289 U1.firstname AS firstnamesuggestedby,
290 U1.borrowernumber AS borrnumsuggestedby
292 LEFT JOIN borrowers AS U1 ON suggestedby=U1.borrowernumber
296 my $dbh = C4
::Context
->dbh;
297 my $sth = $dbh->prepare($query);
298 $sth->execute($biblionumber);
299 return $sth->fetchrow_hashref;
302 =head2 GetSuggestionInfo
304 Get a suggestion and borrower's informations from it's suggestionid
307 all informations (suggestion and borrower) of the suggestion which is related to the suggestionid given.
311 sub GetSuggestionInfo
{
312 my ($suggestionid) = @_;
314 SELECT suggestions.*,
315 U1.surname AS surnamesuggestedby,
316 U1.firstname AS firstnamesuggestedby,
317 U1.borrowernumber AS borrnumsuggestedby
319 LEFT JOIN borrowers AS U1 ON suggestedby=U1.borrowernumber
323 my $dbh = C4
::Context
->dbh;
324 my $sth = $dbh->prepare($query);
325 $sth->execute($suggestionid);
326 return $sth->fetchrow_hashref;
329 =head2 GetSuggestionByStatus
331 $aqorders = &GetSuggestionByStatus($status,[$branchcode])
333 Get a suggestion from it's status
336 all the suggestion with C<$status>
340 sub GetSuggestionByStatus
{
342 my $branchcode = shift;
343 my $dbh = C4
::Context
->dbh;
344 my @sql_params = ($status);
346 SELECT suggestions.*,
347 U1.surname AS surnamesuggestedby,
348 U1.firstname AS firstnamesuggestedby,
349 U1.branchcode AS branchcodesuggestedby,
350 B1.branchname AS branchnamesuggestedby,
351 U1.borrowernumber AS borrnumsuggestedby,
352 U1.categorycode AS categorycodesuggestedby,
353 C1.description AS categorydescriptionsuggestedby,
354 U2.surname AS surnamemanagedby,
355 U2.firstname AS firstnamemanagedby,
356 U2.borrowernumber AS borrnummanagedby
358 LEFT JOIN borrowers AS U1 ON suggestedby=U1.borrowernumber
359 LEFT JOIN borrowers AS U2 ON managedby=U2.borrowernumber
360 LEFT JOIN categories AS C1 ON C1.categorycode=U1.categorycode
361 LEFT JOIN branches AS B1 on B1.branchcode=U1.branchcode
363 ORDER BY suggestionid
367 if ( C4
::Context
->preference("IndependentBranches") || $branchcode ) {
368 my $userenv = C4
::Context
->userenv;
370 unless ( C4
::Context
->IsSuperLibrarian() ) {
371 push @sql_params, $userenv->{branch
};
372 $query .= q{ AND (U1.branchcode = ? OR U1.branchcode ='') };
376 push @sql_params, $branchcode;
377 $query .= q{ AND (U1.branchcode = ? OR U1.branchcode ='') };
381 my $sth = $dbh->prepare($query);
382 $sth->execute(@sql_params);
384 $results = $sth->fetchall_arrayref( {} );
391 &NewSuggestion($suggestion);
393 Insert a new suggestion on database with value given on input arg.
398 my ($suggestion) = @_;
400 $suggestion->{STATUS
} = "ASKED" unless $suggestion->{STATUS
};
402 $suggestion->{suggesteddate
} = dt_from_string
unless $suggestion->{suggesteddate
};
404 delete $suggestion->{branchcode
} if $suggestion->{branchcode
} eq '';
406 my $suggestion_object = Koha
::Suggestion
->new( $suggestion )->store;
407 my $suggestion_id = $suggestion_object->suggestionid;
409 my $emailpurchasesuggestions = C4
::Context
->preference("EmailPurchaseSuggestions");
410 if ($emailpurchasesuggestions) {
411 my $full_suggestion = GetSuggestion
( $suggestion_id); # We should not need to refetch it!
413 my $letter = C4
::Letters
::GetPreparedLetter
(
414 module
=> 'suggestions',
415 letter_code
=> 'NEW_SUGGESTION',
417 'branches' => $full_suggestion->{branchcode
},
418 'borrowers' => $full_suggestion->{suggestedby
},
419 'suggestions' => $full_suggestion,
425 if ( $emailpurchasesuggestions eq "BranchEmailAddress" ) {
427 Koha
::Libraries
->find( $full_suggestion->{branchcode
} );
428 $toaddress = $library->inbound_email_address;
430 elsif ( $emailpurchasesuggestions eq "KohaAdminEmailAddress" ) {
431 $toaddress = C4
::Context
->preference('ReplytoDefault')
432 || C4
::Context
->preference('KohaAdminEmailAddress');
436 C4
::Context
->preference($emailpurchasesuggestions)
437 || C4
::Context
->preference('ReplytoDefault')
438 || C4
::Context
->preference('KohaAdminEmailAddress');
441 C4
::Letters
::EnqueueLetter
(
444 borrowernumber
=> $full_suggestion->{suggestedby
},
445 suggestionid
=> $full_suggestion->{suggestionid
},
446 to_address
=> $toaddress,
447 message_transport_type
=> 'email',
449 ) or warn "can't enqueue letter $letter";
453 return $suggestion_id;
458 &ModSuggestion($suggestion)
460 Modify the suggestion according to the hash passed by ref.
461 The hash HAS to contain suggestionid
462 Data not defined is not updated unless it is a note or sort1
463 Send a mail to notify the user that did the suggestion.
465 Note that there is no function to modify a suggestion.
470 my ($suggestion) = @_;
471 return unless( $suggestion and defined($suggestion->{suggestionid
}) );
473 my $suggestion_object = Koha
::Suggestions
->find( $suggestion->{suggestionid
} );
474 eval { # FIXME Must raise an exception instead
475 $suggestion_object->set($suggestion)->store;
479 if ( $suggestion->{STATUS
} && $suggestion_object->suggestedby ) {
481 # fetch the entire updated suggestion so that we can populate the letter
482 my $full_suggestion = GetSuggestion
( $suggestion->{suggestionid
} );
484 my $patron = Koha
::Patrons
->find( $full_suggestion->{suggestedby
} );
486 my $transport = (C4
::Context
->preference("FallbackToSMSIfNoEmail")) && ($patron->smsalertnumber) && (!$patron->email) ?
'sms' : 'email';
489 my $letter = C4
::Letters
::GetPreparedLetter
(
490 module
=> 'suggestions',
491 letter_code
=> $full_suggestion->{STATUS
},
492 branchcode
=> $full_suggestion->{branchcode
},
493 lang
=> $patron->lang,
495 'branches' => $full_suggestion->{branchcode
},
496 'borrowers' => $full_suggestion->{suggestedby
},
497 'suggestions' => $full_suggestion,
498 'biblio' => $full_suggestion->{biblionumber
},
503 C4
::Letters
::EnqueueLetter
(
506 borrowernumber
=> $full_suggestion->{suggestedby
},
507 suggestionid
=> $full_suggestion->{suggestionid
},
508 LibraryName
=> C4
::Context
->preference("LibraryName"),
509 message_transport_type
=> $transport,
511 ) or warn "can't enqueue letter $letter";
514 return 1; # No useful if the exception is raised earlier
517 =head2 ConnectSuggestionAndBiblio
519 &ConnectSuggestionAndBiblio($ordernumber,$biblionumber)
521 connect a suggestion to an existing biblio
525 sub ConnectSuggestionAndBiblio
{
526 my ( $suggestionid, $biblionumber ) = @_;
527 my $dbh = C4
::Context
->dbh;
533 my $sth = $dbh->prepare($query);
534 $sth->execute( $biblionumber, $suggestionid );
539 &DelSuggestion($borrowernumber,$ordernumber)
541 Delete a suggestion. A borrower can delete a suggestion only if they are its owner.
546 my ( $borrowernumber, $suggestionid, $type ) = @_;
547 my $dbh = C4
::Context
->dbh;
549 # check that the suggestion comes from the suggestor
555 my $sth = $dbh->prepare($query);
556 $sth->execute($suggestionid);
557 my ($suggestedby) = $sth->fetchrow;
558 if ( $type eq 'intranet' || $suggestedby eq $borrowernumber ) {
560 DELETE FROM suggestions
563 $sth = $dbh->prepare($queryDelete);
564 my $suggestiondeleted = $sth->execute($suggestionid);
565 return $suggestiondeleted;
569 =head2 DelSuggestionsOlderThan
570 &DelSuggestionsOlderThan($days)
572 Delete all suggestions older than TODAY-$days , that have be accepted or rejected.
573 We do now allow a negative number. If you want to delete all suggestions, just use Koha::Suggestions->delete or so.
577 sub DelSuggestionsOlderThan
{
579 return unless $days && $days > 0;
580 my $dbh = C4
::Context
->dbh;
581 my $sth = $dbh->prepare(
583 DELETE FROM suggestions
584 WHERE STATUS<>'ASKED'
585 AND date < ADDDATE(NOW(), ?)
588 $sth->execute("-$days");
591 sub GetUnprocessedSuggestions
{
592 my ( $number_of_days_since_the_last_modification ) = @_;
594 $number_of_days_since_the_last_modification ||= 0;
596 my $dbh = C4
::Context
->dbh;
598 my $s = $dbh->selectall_arrayref(q
|
601 WHERE STATUS
= 'ASKED'
602 AND budgetid IS NOT NULL
603 AND CAST
(NOW
() AS DATE
) - INTERVAL ? DAY
= CAST
(suggesteddate AS DATE
)
604 |, { Slice
=> {} }, $number_of_days_since_the_last_modification );
608 =head2 MarcRecordFromNewSuggestion
610 $record = MarcRecordFromNewSuggestion ( $suggestion )
612 This function build a marc record object from a suggestion
616 sub MarcRecordFromNewSuggestion
{
617 my ($suggestion) = @_;
618 my $record = MARC
::Record
->new();
620 my ($title_tag, $title_subfield) = GetMarcFromKohaField
('biblio.title', '');
621 $record->append_fields(
622 MARC
::Field
->new($title_tag, ' ', ' ', $title_subfield => $suggestion->{title
})
625 my ($author_tag, $author_subfield) = GetMarcFromKohaField
('biblio.author', '');
626 if ($record->field( $author_tag )) {
627 $record->field( $author_tag )->add_subfields( $author_subfield => $suggestion->{author
} );
630 $record->append_fields(
631 MARC
::Field
->new($author_tag, ' ', ' ', $author_subfield => $suggestion->{author
})
635 my ($it_tag, $it_subfield) = GetMarcFromKohaField
('biblioitems.itemtype', '');
636 if ($record->field( $it_tag )) {
637 $record->field( $it_tag )->add_subfields( $it_subfield => $suggestion->{itemtype
} );
640 $record->append_fields(
641 MARC
::Field
->new($it_tag, ' ', ' ', $it_subfield => $suggestion->{itemtype
})
654 Koha Development Team <http://koha-community.org/>