3 # Copyright 2000-2002 Katipo Communications
5 # This file is part of Koha.
7 # Koha is free software; you can redistribute it and/or modify it under the
8 # terms of the GNU General Public License as published by the Free Software
9 # Foundation; either version 2 of the License, or (at your option) any later
12 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
13 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
14 # A PARTICULAR PURPOSE. See the GNU General Public License for more details.
16 # You should have received a copy of the GNU General Public License along
17 # with Koha; if not, write to the Free Software Foundation, Inc.,
18 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
21 #use warnings; FIXME - Bug 2505
23 use C4::Dates qw(format_date format_date_in_iso);
24 use C4::SQLHelper qw<:all>;
27 use vars qw($VERSION @ISA @EXPORT);
30 # set the version for version checking
31 $VERSION = 3.07.00.049;
72 &CheckBudgetParentPerm
79 # ----------------------------BUDGETS.PM-----------------------------";
82 =head1 FUNCTIONS ABOUT BUDGETS
87 my ( $authcat, @hide_cols ) = @_;
88 my $dbh = C4::Context->dbh;
90 my $sth1 = $dbh->prepare(
92 UPDATE aqbudgets_planning SET display = 0
96 foreach my $authvalue (@hide_cols) {
97 # $sth1->{TraceLevel} = 3;
98 $sth1->execute( $authcat, $authvalue );
103 my ( $authcat, $authvalue ) = @_;
105 my $dbh = C4::Context->dbh;
106 my $sth = $dbh->prepare(
108 SELECT count(display) as cnt from aqbudgets_planning
110 AND authvalue = ? and display = 0 |
113 # $sth->{TraceLevel} = 3;
114 $sth->execute( $authcat, $authvalue );
115 my $res = $sth->fetchrow_hashref;
117 return $res->{cnt} > 0 ? 0: 1
121 sub CheckBudgetParentPerm {
122 my ( $budget, $borrower_id ) = @_;
123 my $depth = $budget->{depth};
124 my $parent_id = $budget->{budget_parent_id};
126 my $parent = GetBudget($parent_id);
127 $parent_id = $parent->{budget_parent_id};
128 if ( $parent->{budget_owner_id} == $borrower_id ) {
136 sub AddBudgetPeriod {
137 my ($budgetperiod) = @_;
138 return InsertInTable("aqbudgetperiods",$budgetperiod);
140 # -------------------------------------------------------------------
141 sub GetPeriodsCount {
142 my $dbh = C4::Context->dbh;
143 my $sth = $dbh->prepare("
144 SELECT COUNT(*) AS sum FROM aqbudgetperiods ");
146 my $res = $sth->fetchrow_hashref;
147 return $res->{'sum'};
150 # -------------------------------------------------------------------
151 sub CheckBudgetParent {
152 my ( $new_parent, $budget ) = @_;
153 my $new_parent_id = $new_parent->{'budget_id'};
154 my $budget_id = $budget->{'budget_id'};
155 my $dbh = C4::Context->dbh;
156 my $parent_id_tmp = $new_parent_id;
158 # check new-parent is not a child (or a child's child ;)
159 my $sth = $dbh->prepare(qq|
160 SELECT budget_parent_id FROM
161 aqbudgets where budget_id = ? | );
163 $sth->execute($parent_id_tmp);
164 my $res = $sth->fetchrow_hashref;
165 if ( $res->{'budget_parent_id'} == $budget_id ) {
168 if ( not defined $res->{'budget_parent_id'} ) {
171 $parent_id_tmp = $res->{'budget_parent_id'};
175 # -------------------------------------------------------------------
176 sub BudgetHasChildren {
177 my ( $budget_id ) = @_;
178 my $dbh = C4::Context->dbh;
179 my $sth = $dbh->prepare(qq|
180 SELECT count(*) as sum FROM aqbudgets
181 WHERE budget_parent_id = ? | );
182 $sth->execute( $budget_id );
183 my $sum = $sth->fetchrow_hashref;
184 return $sum->{'sum'};
187 # -------------------------------------------------------------------
188 sub GetBudgetsPlanCell {
189 my ( $cell, $period, $budget ) = @_;
191 my $dbh = C4::Context->dbh;
192 if ( $cell->{'authcat'} eq 'MONTHS' ) {
193 # get the actual amount
194 $sth = $dbh->prepare( qq|
196 SELECT SUM(ecost) AS actual FROM aqorders
197 WHERE budget_id = ? AND
198 entrydate like "$cell->{'authvalue'}%" |
200 $sth->execute( $cell->{'budget_id'} );
201 } elsif ( $cell->{'authcat'} eq 'BRANCHES' ) {
202 # get the actual amount
203 $sth = $dbh->prepare( qq|
205 SELECT SUM(ecost) FROM aqorders
206 LEFT JOIN aqorders_items
207 ON (aqorders.ordernumber = aqorders_items.ordernumber)
209 ON (aqorders_items.itemnumber = items.itemnumber)
210 WHERE budget_id = ? AND homebranch = ? | );
212 $sth->execute( $cell->{'budget_id'}, $cell->{'authvalue'} );
213 } elsif ( $cell->{'authcat'} eq 'ITEMTYPES' ) {
214 # get the actual amount
215 $sth = $dbh->prepare( qq|
217 SELECT SUM( ecost * quantity) AS actual
218 FROM aqorders JOIN biblioitems
219 ON (biblioitems.biblionumber = aqorders.biblionumber )
220 WHERE aqorders.budget_id = ? and itemtype = ? |
222 $sth->execute( $cell->{'budget_id'},
223 $cell->{'authvalue'} );
225 # ELSE GENERIC ORDERS SORT1/SORT2 STAT COUNT.
227 # get the actual amount
228 $sth = $dbh->prepare( qq|
230 SELECT SUM(ecost * quantity) AS actual
232 JOIN aqbudgets ON (aqbudgets.budget_id = aqorders.budget_id )
233 WHERE aqorders.budget_id = ? AND
234 ((aqbudgets.sort1_authcat = ? AND sort1 =?) OR
235 (aqbudgets.sort2_authcat = ? AND sort2 =?)) |
237 $sth->execute( $cell->{'budget_id'},
238 $budget->{'sort1_authcat'},
239 $cell->{'authvalue'},
240 $budget->{'sort2_authcat'},
244 $actual = $sth->fetchrow_array;
246 # get the estimated amount
247 $sth = $dbh->prepare( qq|
249 SELECT estimated_amount AS estimated, display FROM aqbudgets_planning
250 WHERE budget_period_id = ? AND
255 $sth->execute( $cell->{'budget_period_id'},
256 $cell->{'budget_id'},
257 $cell->{'authvalue'},
262 my $res = $sth->fetchrow_hashref;
263 # my $display = $res->{'display'};
264 my $estimated = $res->{'estimated'};
267 return $actual, $estimated;
270 # -------------------------------------------------------------------
272 my ( $budget_plan, $budget_period_id, $authcat ) = @_;
273 my $dbh = C4::Context->dbh;
274 foreach my $buds (@$budget_plan) {
275 my $lines = $buds->{lines};
276 my $sth = $dbh->prepare( qq|
277 DELETE FROM aqbudgets_planning
278 WHERE budget_period_id = ? AND
282 #delete a aqplan line of cells, then insert new cells,
283 # these could be UPDATES rather than DEL/INSERTS...
284 $sth->execute( $budget_period_id, $lines->[0]{budget_id} , $authcat );
286 foreach my $cell (@$lines) {
287 my $sth = $dbh->prepare( qq|
289 INSERT INTO aqbudgets_planning
291 budget_period_id = ?,
293 estimated_amount = ?,
297 $cell->{'budget_id'},
298 $cell->{'budget_period_id'},
300 $cell->{'estimated_amount'},
301 $cell->{'authvalue'},
307 # -------------------------------------------------------------------
309 my ($budget_id) = @_;
310 my $dbh = C4::Context->dbh;
311 my $sth = $dbh->prepare(qq|
312 SELECT SUM( COALESCE(unitprice, ecost) * quantity ) AS sum FROM aqorders
313 WHERE budget_id = ? AND
314 quantityreceived > 0 AND
315 datecancellationprinted IS NULL
317 $sth->execute($budget_id);
318 my $sum = $sth->fetchrow_array;
320 $sth = $dbh->prepare(qq|
321 SELECT SUM(shipmentcost) AS sum
323 WHERE shipmentcost_budgetid = ?
324 AND closedate IS NOT NULL
326 $sth->execute($budget_id);
327 my ($shipmentcost_sum) = $sth->fetchrow_array;
328 $sum += $shipmentcost_sum;
333 # -------------------------------------------------------------------
334 sub GetBudgetOrdered {
335 my ($budget_id) = @_;
336 my $dbh = C4::Context->dbh;
337 my $sth = $dbh->prepare(qq|
338 SELECT SUM(ecost * quantity) AS sum FROM aqorders
339 WHERE budget_id = ? AND
340 quantityreceived = 0 AND
341 datecancellationprinted IS NULL
343 $sth->execute($budget_id);
344 my $sum = $sth->fetchrow_array;
346 $sth = $dbh->prepare(qq|
347 SELECT SUM(shipmentcost) AS sum
349 WHERE shipmentcost_budgetid = ?
350 AND closedate IS NULL
352 $sth->execute($budget_id);
353 my ($shipmentcost_sum) = $sth->fetchrow_array;
354 $sum += $shipmentcost_sum;
359 # -------------------------------------------------------------------
360 sub GetBudgetAuthCats {
361 my ($budget_period_id) = shift;
362 # now, populate the auth_cats_loop used in the budget planning button
363 # we must retrieve all auth values used by at least one budget
364 my $dbh = C4::Context->dbh;
365 my $sth=$dbh->prepare("SELECT sort1_authcat,sort2_authcat FROM aqbudgets WHERE budget_period_id=?");
366 $sth->execute($budget_period_id);
368 while (my ($sort1_authcat,$sort2_authcat) = $sth->fetchrow) {
369 $authcats{$sort1_authcat}=1;
370 $authcats{$sort2_authcat}=1;
373 foreach (sort keys %authcats) {
374 push @auth_cats_loop,{ authcat => $_ };
376 return \@auth_cats_loop;
379 # -------------------------------------------------------------------
380 sub GetAuthvalueDropbox {
381 my ( $authcat, $default ) = @_;
382 my $dbh = C4::Context->dbh;
383 my $sth = $dbh->prepare(
384 'SELECT authorised_value,lib FROM authorised_values
385 WHERE category = ? ORDER BY lib'
387 $sth->execute( $authcat );
388 my $option_list = [];
389 my @authorised_values = ( q{} );
390 while (my ($value, $lib) = $sth->fetchrow_array) {
391 push @{$option_list}, {
394 default => ($default eq $value),
398 if ( @{$option_list} ) {
404 # -------------------------------------------------------------------
405 sub GetBudgetPeriods {
406 my ($filters,$orderby) = @_;
407 return SearchInTable("aqbudgetperiods",$filters, $orderby, undef,undef, undef, "wide");
409 # -------------------------------------------------------------------
410 sub GetBudgetPeriod {
411 my ($budget_period_id) = @_;
412 my $dbh = C4::Context->dbh;
413 ## $total = number of records linked to the record that must be deleted
415 ## get information about the record that will be deleted
417 if ($budget_period_id) {
418 $sth = $dbh->prepare( qq|
421 WHERE budget_period_id=? |
423 $sth->execute($budget_period_id);
424 } else { # ACTIVE BUDGET
425 $sth = $dbh->prepare(qq|
428 WHERE budget_period_active=1 |
432 my $data = $sth->fetchrow_hashref;
436 # -------------------------------------------------------------------
438 my ($budget_period_id) = @_;
439 my $dbh = C4::Context->dbh;
440 ; ## $total = number of records linked to the record that must be deleted
443 ## get information about the record that will be deleted
444 my $sth = $dbh->prepare(qq|
447 WHERE budget_period_id=? |
449 return $sth->execute($budget_period_id);
452 # -------------------------------------------------------------------
453 sub ModBudgetPeriod {
454 my ($budget_period_information) = @_;
455 return UpdateInTable("aqbudgetperiods",$budget_period_information);
458 # -------------------------------------------------------------------
459 sub GetBudgetHierarchy {
460 my ( $budget_period_id, $branchcode, $owner ) = @_;
462 my $dbh = C4::Context->dbh;
464 SELECT aqbudgets.*, aqbudgetperiods.budget_period_active
466 JOIN aqbudgetperiods USING (budget_period_id)|;
469 # show only period X if requested
470 if ($budget_period_id) {
471 push @where_strings," aqbudgets.budget_period_id = ?";
472 push @bind_params, $budget_period_id;
474 # show only budgets owned by me, my branch or everyone
478 qq{ (budget_owner_id = ? OR budget_branchcode = ? OR ((budget_branchcode IS NULL or budget_branchcode="") AND (budget_owner_id IS NULL OR budget_owner_id="")))};
479 push @bind_params, ( $owner, $branchcode );
481 push @where_strings, ' (budget_owner_id = ? OR budget_owner_id IS NULL or budget_owner_id ="") ';
482 push @bind_params, $owner;
486 push @where_strings," (budget_branchcode =? or budget_branchcode is NULL)";
487 push @bind_params, $branchcode;
490 $query.=" WHERE ".join(' AND ', @where_strings) if @where_strings;
491 $debug && warn $query,join(",",@bind_params);
492 my $sth = $dbh->prepare($query);
493 $sth->execute(@bind_params);
494 my $results = $sth->fetchall_arrayref({});
499 foreach my $r (@res) {
502 $r->{depth} = '0' if !defined $r->{budget_parent_id};
503 foreach my $r2 (@res) {
504 if (defined $r2->{budget_parent_id}
505 && $r2->{budget_parent_id} == $r->{budget_id}) {
506 push @child, $r2->{budget_id};
507 $r2->{depth} = ($r->{depth} + 1) if defined $r->{depth};
510 $r->{child} = \@child if scalar @child > 0; # add the child
511 $depth_cnt++ if !defined $r->{'depth'};
513 last if ($depth_cnt == 0 || $i == 100);
517 # look for top parents 1st
518 my (@sort, $depth_count);
519 ($i, $depth_count) = 0;
522 foreach my $r (@res) {
523 if ($r->{depth} == $depth_count) {
524 $children++ if (ref $r->{child} eq 'ARRAY');
526 # find the parent id element_id and insert it after
529 if ($depth_count > 0) {
532 my $depth = $r->{depth} * 2;
533 $r->{budget_code_indent} = $r->{budget_code};
534 $r->{budget_name_indent} = $r->{budget_name};
535 foreach my $r3 (@sort) {
536 if ($r3->{budget_id} == $r->{budget_parent_id}) {
543 $r->{budget_code_indent} = $r->{budget_code};
544 $r->{budget_name_indent} = $r->{budget_name};
547 if (defined $parent) {
548 splice @sort, ($parent + 1), 0, $r;
555 } # --------------foreach
557 last if $children == 0;
560 # add budget-percent and allocation, and flags for html-template
561 foreach my $r (@sort) {
562 my $subs_href = $r->{'child'};
564 if ( defined $subs_href ) {
565 @subs_arr = @{$subs_href};
568 my $moo = $r->{'budget_code_indent'};
569 $moo =~ s/\ /\ \;/g;
570 $r->{'budget_code_indent'} = $moo;
572 $moo = $r->{'budget_name_indent'};
573 $moo =~ s/\ /\ \;/g;
574 $r->{'budget_name_indent'} = $moo;
576 $r->{'budget_spent'} = GetBudgetSpent( $r->{'budget_id'} );
578 $r->{'budget_amount_total'} = $r->{'budget_amount'};
583 foreach my $sub (@subs_arr) {
584 my $sub_budget = GetBudget($sub);
586 $r->{budget_spent_sublevel} += GetBudgetSpent( $sub_budget->{'budget_id'} );
587 $unalloc_count += $sub_budget->{'budget_amount'};
593 # -------------------------------------------------------------------
597 return InsertInTable("aqbudgets",$budget);
600 # -------------------------------------------------------------------
603 return UpdateInTable("aqbudgets",$budget);
606 # -------------------------------------------------------------------
608 my ($budget_id) = @_;
609 my $dbh = C4::Context->dbh;
610 my $sth = $dbh->prepare("delete from aqbudgets where budget_id=?");
611 my $rc = $sth->execute($budget_id);
618 &GetBudget($budget_id);
620 get a specific budget
624 # -------------------------------------------------------------------
626 my ( $budget_id ) = @_;
627 my $dbh = C4::Context->dbh;
633 my $sth = $dbh->prepare($query);
634 $sth->execute( $budget_id );
635 my $result = $sth->fetchrow_hashref;
639 =head2 GetChildBudgetsSpent
641 &GetChildBudgetsSpent($budget-id);
643 gets the total spent of the level and sublevels of $budget_id
647 # -------------------------------------------------------------------
648 sub GetChildBudgetsSpent {
649 my ( $budget_id ) = @_;
650 my $dbh = C4::Context->dbh;
654 WHERE budget_parent_id=?
656 my $sth = $dbh->prepare($query);
657 $sth->execute( $budget_id );
658 my $result = $sth->fetchall_arrayref({});
659 my $total_spent = GetBudgetSpent($budget_id);
661 $total_spent += GetChildBudgetsSpent($_->{"budget_id"}) foreach @$result;
668 &GetBudgets($filter, $order_by);
674 # -------------------------------------------------------------------
676 my ($filters,$orderby) = @_;
677 return SearchInTable("aqbudgets",$filters, $orderby, undef,undef, undef, "wide");
680 =head2 GetBudgetUsers
682 my @borrowernumbers = &GetBudgetUsers($budget_id);
684 Return the list of borrowernumbers linked to a budget
689 my ($budget_id) = @_;
691 my $dbh = C4::Context->dbh;
693 SELECT borrowernumber
694 FROM aqbudgetborrowers
697 my $sth = $dbh->prepare($query);
698 $sth->execute($budget_id);
701 while (my ($borrowernumber) = $sth->fetchrow_array) {
702 push @borrowernumbers, $borrowernumber
705 return @borrowernumbers;
708 =head2 ModBudgetUsers
710 &ModBudgetUsers($budget_id, @borrowernumbers);
712 Modify the list of borrowernumbers linked to a budget
717 my ($budget_id, @budget_users_id) = @_;
719 return unless $budget_id;
721 my $dbh = C4::Context->dbh;
722 my $query = "DELETE FROM aqbudgetborrowers WHERE budget_id = ?";
723 my $sth = $dbh->prepare($query);
724 $sth->execute($budget_id);
727 INSERT INTO aqbudgetborrowers (budget_id, borrowernumber)
730 $sth = $dbh->prepare($query);
731 foreach my $borrowernumber (@budget_users_id) {
732 next unless $borrowernumber;
733 $sth->execute($budget_id, $borrowernumber);
737 sub CanUserUseBudget {
738 my ($borrower, $budget, $userflags) = @_;
740 if (not ref $borrower) {
741 $borrower = C4::Members::GetMember(borrowernumber => $borrower);
743 if (not ref $budget) {
744 $budget = GetBudget($budget);
747 return 0 unless ($borrower and $budget);
749 if (not defined $userflags) {
750 $userflags = C4::Auth::getuserflags($borrower->{flags},
751 $borrower->{userid});
754 unless ($userflags->{superlibrarian}
755 || (ref $userflags->{acquisition}
756 && $userflags->{acquisition}->{budget_manage_all})
757 || (!ref $userflags->{acquisition} && $userflags->{acquisition}))
759 if (not exists $userflags->{acquisition}) {
763 if (!ref $userflags->{acquisition} && !$userflags->{acquisition}) {
767 # Budget restricted to owner
768 if ($budget->{budget_permission} == 1
769 && $budget->{budget_owner_id}
770 && $budget->{budget_owner_id} != $borrower->{borrowernumber}) {
774 my @budget_users = GetBudgetUsers($budget->{budget_id});
776 # Budget restricted to owner, users and library
777 if ($budget->{budget_permission} == 2
778 && $budget->{budget_owner_id}
779 && $budget->{budget_owner_id} != $borrower->{borrowernumber}
780 && (0 == grep {$borrower->{borrowernumber} == $_} @budget_users)
781 && defined $budget->{budget_branchcode}
782 && $budget->{budget_branchcode} ne C4::Context->userenv->{branch}) {
786 # Budget restricted to owner and users
787 if ($budget->{budget_permission} == 3
788 && $budget->{budget_owner_id}
789 && $budget->{budget_owner_id} != $borrower->{borrowernumber}
790 && (0 == grep {$borrower->{borrowernumber} == $_} @budget_users)) {
798 sub CanUserModifyBudget {
799 my ($borrower, $budget, $userflags) = @_;
801 if (not ref $borrower) {
802 $borrower = C4::Members::GetMember(borrowernumber => $borrower);
804 if (not ref $budget) {
805 $budget = GetBudget($budget);
808 return 0 unless ($borrower and $budget);
810 if (not defined $userflags) {
811 $userflags = C4::Auth::getuserflags($borrower->{flags},
812 $borrower->{userid});
815 unless ($userflags->{superlibrarian}
816 || (ref $userflags->{acquisition}
817 && $userflags->{acquisition}->{budget_manage_all})
818 || (!ref $userflags->{acquisition} && $userflags->{acquisition}))
820 if (!CanUserUseBudget($borrower, $budget, $userflags)) {
824 if (ref $userflags->{acquisition}
825 && !$userflags->{acquisition}->{budget_modify}) {
833 # -------------------------------------------------------------------
837 @currencies = &GetCurrencies;
839 Returns the list of all known currencies.
841 C<$currencies> is a array; its elements are references-to-hash, whose
842 keys are the fields from the currency table in the Koha database.
847 my $dbh = C4::Context->dbh;
852 my $sth = $dbh->prepare($query);
855 while ( my $data = $sth->fetchrow_hashref ) {
856 push( @results, $data );
861 # -------------------------------------------------------------------
864 my $dbh = C4::Context->dbh;
866 SELECT * FROM currency where active = '1' ";
867 my $sth = $dbh->prepare($query);
869 my $r = $sth->fetchrow_hashref;
875 &ModCurrencies($currency, $newrate);
877 Sets the exchange rate for C<$currency> to be C<$newrate>.
882 my ( $currency, $rate ) = @_;
883 my $dbh = C4::Context->dbh;
888 my $sth = $dbh->prepare($query);
889 $sth->execute( $rate, $currency );
892 # -------------------------------------------------------------------
894 =head2 ConvertCurrency
896 $foreignprice = &ConvertCurrency($currency, $localprice);
898 Converts the price C<$localprice> to foreign currency C<$currency> by
899 dividing by the exchange rate, and returns the result.
901 If no exchange rate is found, e is one to one.
905 sub ConvertCurrency {
906 my ( $currency, $price ) = @_;
907 my $dbh = C4::Context->dbh;
913 my $sth = $dbh->prepare($query);
914 $sth->execute($currency);
915 my $cur = ( $sth->fetchrow_array() )[0];
919 return ( $price / $cur );
924 returns an array containing fieldname followed by PRI as value if PRIMARY Key
929 my $tablename=shift||"aqbudgets";
930 return @{C4::Context->dbh->selectcol_arrayref("SHOW columns from $tablename",{Columns=>[1,4]})};
938 my %columns= _columns($tablename);
939 #Filter Primary Keys of table
940 my $elements=join "|",grep {$columns{$_} ne "PRI"} keys %columns;
941 foreach my $field (grep {/\b($elements)\b/} keys %$budget){
942 $$budget{$field}=format_date_in_iso($$budget{$field}) if ($field=~/date/ && $$budget{$field} !~C4::Dates->regexp("iso"));
943 my $strkeys= " $field = ? ";
944 if ($field=~/branch/){
945 $strkeys="( $strkeys OR $field='' OR $field IS NULL) ";
947 push @values, $$budget{$field};
948 push @keys, $strkeys;
950 return (\@keys,\@values);
953 END { } # module clean-up code here (global destructor)
960 Koha Development Team <http://koha-community.org/>