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
25 use vars qw($VERSION @ISA @EXPORT);
28 # set the version for version checking
29 $VERSION = 3.07.00.049;
35 &GetBudgetByOrderNumber
46 GetBudgetHierarchySpent
47 GetBudgetHierarchyOrdered
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 unless($budgetperiod->{budget_period_startdate} && $budgetperiod->{budget_period_enddate});
140 my $resultset = Koha::Database->new()->schema->resultset('Aqbudgetperiod');
141 return $resultset->create($budgetperiod)->id;
143 # -------------------------------------------------------------------
144 sub GetPeriodsCount {
145 my $dbh = C4::Context->dbh;
146 my $sth = $dbh->prepare("
147 SELECT COUNT(*) AS sum FROM aqbudgetperiods ");
149 my $res = $sth->fetchrow_hashref;
150 return $res->{'sum'};
153 # -------------------------------------------------------------------
154 sub CheckBudgetParent {
155 my ( $new_parent, $budget ) = @_;
156 my $new_parent_id = $new_parent->{'budget_id'};
157 my $budget_id = $budget->{'budget_id'};
158 my $dbh = C4::Context->dbh;
159 my $parent_id_tmp = $new_parent_id;
161 # check new-parent is not a child (or a child's child ;)
162 my $sth = $dbh->prepare(qq|
163 SELECT budget_parent_id FROM
164 aqbudgets where budget_id = ? | );
166 $sth->execute($parent_id_tmp);
167 my $res = $sth->fetchrow_hashref;
168 if ( $res->{'budget_parent_id'} == $budget_id ) {
171 if ( not defined $res->{'budget_parent_id'} ) {
174 $parent_id_tmp = $res->{'budget_parent_id'};
178 # -------------------------------------------------------------------
179 sub BudgetHasChildren {
180 my ( $budget_id ) = @_;
181 my $dbh = C4::Context->dbh;
182 my $sth = $dbh->prepare(qq|
183 SELECT count(*) as sum FROM aqbudgets
184 WHERE budget_parent_id = ? | );
185 $sth->execute( $budget_id );
186 my $sum = $sth->fetchrow_hashref;
187 return $sum->{'sum'};
190 sub GetBudgetChildren {
191 my ( $budget_id ) = @_;
192 my $dbh = C4::Context->dbh;
193 return $dbh->selectall_arrayref(q|
194 SELECT * FROM aqbudgets
195 WHERE budget_parent_id = ?
196 |, { Slice => {} }, $budget_id );
199 sub SetOwnerToFundHierarchy {
200 my ( $budget_id, $borrowernumber ) = @_;
202 my $budget = GetBudget( $budget_id );
203 $budget->{budget_owner_id} = $borrowernumber;
204 ModBudget( $budget );
205 my $children = GetBudgetChildren( $budget_id );
206 for my $child ( @$children ) {
207 SetOwnerToFundHierarchy( $child->{budget_id}, $borrowernumber );
211 # -------------------------------------------------------------------
212 sub GetBudgetsPlanCell {
213 my ( $cell, $period, $budget ) = @_;
215 my $dbh = C4::Context->dbh;
216 if ( $cell->{'authcat'} eq 'MONTHS' ) {
217 # get the actual amount
218 $sth = $dbh->prepare( qq|
220 SELECT SUM(ecost) AS actual FROM aqorders
221 WHERE budget_id = ? AND
222 entrydate like "$cell->{'authvalue'}%" |
224 $sth->execute( $cell->{'budget_id'} );
225 } elsif ( $cell->{'authcat'} eq 'BRANCHES' ) {
226 # get the actual amount
227 $sth = $dbh->prepare( qq|
229 SELECT SUM(ecost) FROM aqorders
230 LEFT JOIN aqorders_items
231 ON (aqorders.ordernumber = aqorders_items.ordernumber)
233 ON (aqorders_items.itemnumber = items.itemnumber)
234 WHERE budget_id = ? AND homebranch = ? | );
236 $sth->execute( $cell->{'budget_id'}, $cell->{'authvalue'} );
237 } elsif ( $cell->{'authcat'} eq 'ITEMTYPES' ) {
238 # get the actual amount
239 $sth = $dbh->prepare( qq|
241 SELECT SUM( ecost * quantity) AS actual
242 FROM aqorders JOIN biblioitems
243 ON (biblioitems.biblionumber = aqorders.biblionumber )
244 WHERE aqorders.budget_id = ? and itemtype = ? |
246 $sth->execute( $cell->{'budget_id'},
247 $cell->{'authvalue'} );
249 # ELSE GENERIC ORDERS SORT1/SORT2 STAT COUNT.
251 # get the actual amount
252 $sth = $dbh->prepare( qq|
254 SELECT SUM(ecost * quantity) AS actual
256 JOIN aqbudgets ON (aqbudgets.budget_id = aqorders.budget_id )
257 WHERE aqorders.budget_id = ? AND
258 ((aqbudgets.sort1_authcat = ? AND sort1 =?) OR
259 (aqbudgets.sort2_authcat = ? AND sort2 =?)) |
261 $sth->execute( $cell->{'budget_id'},
262 $budget->{'sort1_authcat'},
263 $cell->{'authvalue'},
264 $budget->{'sort2_authcat'},
268 $actual = $sth->fetchrow_array;
270 # get the estimated amount
271 $sth = $dbh->prepare( qq|
273 SELECT estimated_amount AS estimated, display FROM aqbudgets_planning
274 WHERE budget_period_id = ? AND
279 $sth->execute( $cell->{'budget_period_id'},
280 $cell->{'budget_id'},
281 $cell->{'authvalue'},
286 my $res = $sth->fetchrow_hashref;
287 # my $display = $res->{'display'};
288 my $estimated = $res->{'estimated'};
291 return $actual, $estimated;
294 # -------------------------------------------------------------------
296 my ( $budget_plan, $budget_period_id, $authcat ) = @_;
297 my $dbh = C4::Context->dbh;
298 foreach my $buds (@$budget_plan) {
299 my $lines = $buds->{lines};
300 my $sth = $dbh->prepare( qq|
301 DELETE FROM aqbudgets_planning
302 WHERE budget_period_id = ? AND
306 #delete a aqplan line of cells, then insert new cells,
307 # these could be UPDATES rather than DEL/INSERTS...
308 $sth->execute( $budget_period_id, $lines->[0]{budget_id} , $authcat );
310 foreach my $cell (@$lines) {
311 my $sth = $dbh->prepare( qq|
313 INSERT INTO aqbudgets_planning
315 budget_period_id = ?,
317 estimated_amount = ?,
321 $cell->{'budget_id'},
322 $cell->{'budget_period_id'},
324 $cell->{'estimated_amount'},
325 $cell->{'authvalue'},
331 # -------------------------------------------------------------------
333 my ($budget_id) = @_;
334 my $dbh = C4::Context->dbh;
335 my $sth = $dbh->prepare(qq|
336 SELECT SUM( COALESCE(unitprice, ecost) * quantity ) AS sum FROM aqorders
337 WHERE budget_id = ? AND
338 quantityreceived > 0 AND
339 datecancellationprinted IS NULL
341 $sth->execute($budget_id);
342 my $sum = $sth->fetchrow_array;
344 $sth = $dbh->prepare(qq|
345 SELECT SUM(shipmentcost) AS sum
347 WHERE shipmentcost_budgetid = ?
348 AND closedate IS NOT NULL
350 $sth->execute($budget_id);
351 my ($shipmentcost_sum) = $sth->fetchrow_array;
352 $sum += $shipmentcost_sum;
357 # -------------------------------------------------------------------
358 sub GetBudgetOrdered {
359 my ($budget_id) = @_;
360 my $dbh = C4::Context->dbh;
361 my $sth = $dbh->prepare(qq|
362 SELECT SUM(ecost * quantity) AS sum FROM aqorders
363 WHERE budget_id = ? AND
364 quantityreceived = 0 AND
365 datecancellationprinted IS NULL
367 $sth->execute($budget_id);
368 my $sum = $sth->fetchrow_array;
370 $sth = $dbh->prepare(qq|
371 SELECT SUM(shipmentcost) AS sum
373 WHERE shipmentcost_budgetid = ?
374 AND closedate IS NULL
376 $sth->execute($budget_id);
377 my ($shipmentcost_sum) = $sth->fetchrow_array;
378 $sum += $shipmentcost_sum;
385 my $budget_name = &GetBudgetName($budget_id);
387 get the budget_name for a given budget_id
392 my ( $budget_id ) = @_;
393 my $dbh = C4::Context->dbh;
394 my $sth = $dbh->prepare(
401 $sth->execute($budget_id);
402 return $sth->fetchrow_array;
405 # -------------------------------------------------------------------
406 sub GetBudgetAuthCats {
407 my ($budget_period_id) = shift;
408 # now, populate the auth_cats_loop used in the budget planning button
409 # we must retrieve all auth values used by at least one budget
410 my $dbh = C4::Context->dbh;
411 my $sth=$dbh->prepare("SELECT sort1_authcat,sort2_authcat FROM aqbudgets WHERE budget_period_id=?");
412 $sth->execute($budget_period_id);
414 while (my ($sort1_authcat,$sort2_authcat) = $sth->fetchrow) {
415 $authcats{$sort1_authcat}=1;
416 $authcats{$sort2_authcat}=1;
419 foreach (sort keys %authcats) {
420 push @auth_cats_loop,{ authcat => $_ };
422 return \@auth_cats_loop;
425 # -------------------------------------------------------------------
426 sub GetBudgetPeriods {
427 my ($filters,$orderby) = @_;
429 my $rs = Koha::Database->new()->schema->resultset('Aqbudgetperiod');
430 $rs = $rs->search( $filters, { order_by => $orderby } );
431 $rs->result_class('DBIx::Class::ResultClass::HashRefInflator');
434 # -------------------------------------------------------------------
435 sub GetBudgetPeriod {
436 my ($budget_period_id) = @_;
437 my $dbh = C4::Context->dbh;
438 ## $total = number of records linked to the record that must be deleted
440 ## get information about the record that will be deleted
442 if ($budget_period_id) {
443 $sth = $dbh->prepare( qq|
446 WHERE budget_period_id=? |
448 $sth->execute($budget_period_id);
449 } else { # ACTIVE BUDGET
450 $sth = $dbh->prepare(qq|
453 WHERE budget_period_active=1 |
457 my $data = $sth->fetchrow_hashref;
461 # -------------------------------------------------------------------
463 my ($budget_period_id) = @_;
464 my $dbh = C4::Context->dbh;
465 ; ## $total = number of records linked to the record that must be deleted
468 ## get information about the record that will be deleted
469 my $sth = $dbh->prepare(qq|
472 WHERE budget_period_id=? |
474 return $sth->execute($budget_period_id);
477 # -------------------------------------------------------------------
478 sub ModBudgetPeriod {
479 my ($budget_period) = @_;
480 my $result = Koha::Database->new()->schema->resultset('Aqbudgetperiod')->find($budget_period);
481 return unless($result);
483 $result = $result->update($budget_period);
484 return $result->in_storage;
487 # -------------------------------------------------------------------
488 sub GetBudgetHierarchy {
489 my ( $budget_period_id, $branchcode, $owner ) = @_;
491 my $dbh = C4::Context->dbh;
493 SELECT aqbudgets.*, aqbudgetperiods.budget_period_active, aqbudgetperiods.budget_period_description
495 JOIN aqbudgetperiods USING (budget_period_id)|;
498 # show only period X if requested
499 if ($budget_period_id) {
500 push @where_strings," aqbudgets.budget_period_id = ?";
501 push @bind_params, $budget_period_id;
503 # show only budgets owned by me, my branch or everyone
507 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="")))};
508 push @bind_params, ( $owner, $branchcode );
510 push @where_strings, ' (budget_owner_id = ? OR budget_owner_id IS NULL or budget_owner_id ="") ';
511 push @bind_params, $owner;
515 push @where_strings," (budget_branchcode =? or budget_branchcode is NULL)";
516 push @bind_params, $branchcode;
519 $query.=" WHERE ".join(' AND ', @where_strings) if @where_strings;
520 $debug && warn $query,join(",",@bind_params);
521 my $sth = $dbh->prepare($query);
522 $sth->execute(@bind_params);
523 my $results = $sth->fetchall_arrayref({});
528 foreach my $r (@res) {
531 $r->{depth} = '0' if !defined $r->{budget_parent_id};
532 foreach my $r2 (@res) {
533 if (defined $r2->{budget_parent_id}
534 && $r2->{budget_parent_id} == $r->{budget_id}) {
535 push @child, $r2->{budget_id};
536 $r2->{depth} = ($r->{depth} + 1) if defined $r->{depth};
539 $r->{child} = \@child if scalar @child > 0; # add the child
540 $depth_cnt++ if !defined $r->{'depth'};
542 last if ($depth_cnt == 0 || $i == 100);
546 # look for top parents 1st
547 my (@sort, $depth_count);
548 ($i, $depth_count) = 0;
551 foreach my $r (@res) {
552 if ($r->{depth} == $depth_count) {
553 $children++ if (ref $r->{child} eq 'ARRAY');
555 # find the parent id element_id and insert it after
558 if ($depth_count > 0) {
561 my $depth = $r->{depth} * 2;
562 $r->{budget_code_indent} = $r->{budget_code};
563 $r->{budget_name_indent} = $r->{budget_name};
564 foreach my $r3 (@sort) {
565 if ($r3->{budget_id} == $r->{budget_parent_id}) {
572 $r->{budget_code_indent} = $r->{budget_code};
573 $r->{budget_name_indent} = $r->{budget_name};
576 if (defined $parent) {
577 splice @sort, ($parent + 1), 0, $r;
584 } # --------------foreach
586 last if $children == 0;
590 foreach my $budget (@sort) {
591 $budget->{budget_spent} = GetBudgetSpent( $budget->{budget_id} );
592 $budget->{budget_ordered} = GetBudgetOrdered( $budget->{budget_id} );
593 $budget->{total_spent} = GetBudgetHierarchySpent( $budget->{budget_id} );
594 $budget->{total_ordered} = GetBudgetHierarchyOrdered( $budget->{budget_id} );
599 # -------------------------------------------------------------------
603 return unless ($budget);
605 my $resultset = Koha::Database->new()->schema->resultset('Aqbudget');
606 return $resultset->create($budget)->id;
609 # -------------------------------------------------------------------
612 my $result = Koha::Database->new()->schema->resultset('Aqbudget')->find($budget);
613 return unless($result);
615 $result = $result->update($budget);
616 return $result->in_storage;
619 # -------------------------------------------------------------------
621 my ($budget_id) = @_;
622 my $dbh = C4::Context->dbh;
623 my $sth = $dbh->prepare("delete from aqbudgets where budget_id=?");
624 my $rc = $sth->execute($budget_id);
631 &GetBudget($budget_id);
633 get a specific budget
637 # -------------------------------------------------------------------
639 my ( $budget_id ) = @_;
640 my $dbh = C4::Context->dbh;
646 my $sth = $dbh->prepare($query);
647 $sth->execute( $budget_id );
648 my $result = $sth->fetchrow_hashref;
652 =head2 GetBudgetByOrderNumber
654 &GetBudgetByOrderNumber($ordernumber);
656 get a specific budget by order number
660 # -------------------------------------------------------------------
661 sub GetBudgetByOrderNumber {
662 my ( $ordernumber ) = @_;
663 my $dbh = C4::Context->dbh;
666 FROM aqbudgets, aqorders
668 AND aqorders.budget_id = aqbudgets.budget_id
670 my $sth = $dbh->prepare($query);
671 $sth->execute( $ordernumber );
672 my $result = $sth->fetchrow_hashref;
676 =head2 GetBudgetByCode
678 my $budget = &GetBudgetByCode($budget_code);
680 Retrieve all aqbudgets fields as a hashref for the budget that has
685 sub GetBudgetByCode {
686 my ( $budget_code ) = @_;
688 my $dbh = C4::Context->dbh;
692 WHERE budget_code = ?
693 ORDER BY budget_id DESC
696 my $sth = $dbh->prepare( $query );
697 $sth->execute( $budget_code );
698 return $sth->fetchrow_hashref;
701 =head2 GetBudgetHierarchySpent
703 my $spent = GetBudgetHierarchySpent( $budget_id );
705 Gets the total spent of the level and sublevels of $budget_id
709 sub GetBudgetHierarchySpent {
710 my ( $budget_id ) = @_;
711 my $dbh = C4::Context->dbh;
712 my $children_ids = $dbh->selectcol_arrayref(q|
715 WHERE budget_parent_id = ?
718 my $total_spent = GetBudgetSpent( $budget_id );
719 for my $child_id ( @$children_ids ) {
720 $total_spent += GetBudgetHierarchySpent( $child_id );
725 =head2 GetBudgetHierarchyOrdered
727 my $ordered = GetBudgetHierarchyOrdered( $budget_id );
729 Gets the total ordered of the level and sublevels of $budget_id
733 sub GetBudgetHierarchyOrdered {
734 my ( $budget_id ) = @_;
735 my $dbh = C4::Context->dbh;
736 my $children_ids = $dbh->selectcol_arrayref(q|
739 WHERE budget_parent_id = ?
742 my $total_ordered = GetBudgetOrdered( $budget_id );
743 for my $child_id ( @$children_ids ) {
744 $total_ordered += GetBudgetHierarchyOrdered( $child_id );
746 return $total_ordered;
751 &GetBudgets($filter, $order_by);
757 # -------------------------------------------------------------------
759 my ($filters, $orderby) = @_;
760 $orderby = 'budget_name' unless($orderby);
762 my $rs = Koha::Database->new()->schema->resultset('Aqbudget');
763 $rs = $rs->search( $filters, { order_by => $orderby } );
764 $rs->result_class('DBIx::Class::ResultClass::HashRefInflator');
768 =head2 GetBudgetUsers
770 my @borrowernumbers = &GetBudgetUsers($budget_id);
772 Return the list of borrowernumbers linked to a budget
777 my ($budget_id) = @_;
779 my $dbh = C4::Context->dbh;
781 SELECT borrowernumber
782 FROM aqbudgetborrowers
785 my $sth = $dbh->prepare($query);
786 $sth->execute($budget_id);
789 while (my ($borrowernumber) = $sth->fetchrow_array) {
790 push @borrowernumbers, $borrowernumber
793 return @borrowernumbers;
796 =head2 ModBudgetUsers
798 &ModBudgetUsers($budget_id, @borrowernumbers);
800 Modify the list of borrowernumbers linked to a budget
805 my ($budget_id, @budget_users_id) = @_;
807 return unless $budget_id;
809 my $dbh = C4::Context->dbh;
810 my $query = "DELETE FROM aqbudgetborrowers WHERE budget_id = ?";
811 my $sth = $dbh->prepare($query);
812 $sth->execute($budget_id);
815 INSERT INTO aqbudgetborrowers (budget_id, borrowernumber)
818 $sth = $dbh->prepare($query);
819 foreach my $borrowernumber (@budget_users_id) {
820 next unless $borrowernumber;
821 $sth->execute($budget_id, $borrowernumber);
825 sub CanUserUseBudget {
826 my ($borrower, $budget, $userflags) = @_;
828 if (not ref $borrower) {
829 $borrower = C4::Members::GetMember(borrowernumber => $borrower);
831 if (not ref $budget) {
832 $budget = GetBudget($budget);
835 return 0 unless ($borrower and $budget);
837 if (not defined $userflags) {
838 $userflags = C4::Auth::getuserflags($borrower->{flags},
839 $borrower->{userid});
842 unless ($userflags->{superlibrarian}
843 || (ref $userflags->{acquisition}
844 && $userflags->{acquisition}->{budget_manage_all})
845 || (!ref $userflags->{acquisition} && $userflags->{acquisition}))
847 if (not exists $userflags->{acquisition}) {
851 if (!ref $userflags->{acquisition} && !$userflags->{acquisition}) {
855 # Budget restricted to owner
856 if ( $budget->{budget_permission} == 1 ) {
857 if ( $budget->{budget_owner_id}
858 and $budget->{budget_owner_id} != $borrower->{borrowernumber} )
864 # Budget restricted to owner, users and library
865 elsif ( $budget->{budget_permission} == 2 ) {
866 my @budget_users = GetBudgetUsers( $budget->{budget_id} );
870 $budget->{budget_owner_id}
871 and $budget->{budget_owner_id} !=
872 $borrower->{borrowernumber}
873 or not $budget->{budget_owner_id}
875 and ( 0 == grep { $borrower->{borrowernumber} == $_ }
877 and defined $budget->{budget_branchcode}
878 and $budget->{budget_branchcode} ne
879 C4::Context->userenv->{branch}
886 # Budget restricted to owner and users
887 elsif ( $budget->{budget_permission} == 3 ) {
888 my @budget_users = GetBudgetUsers( $budget->{budget_id} );
891 $budget->{budget_owner_id}
892 and $budget->{budget_owner_id} !=
893 $borrower->{borrowernumber}
894 or not $budget->{budget_owner_id}
896 and ( 0 == grep { $borrower->{borrowernumber} == $_ }
908 sub CanUserModifyBudget {
909 my ($borrower, $budget, $userflags) = @_;
911 if (not ref $borrower) {
912 $borrower = C4::Members::GetMember(borrowernumber => $borrower);
914 if (not ref $budget) {
915 $budget = GetBudget($budget);
918 return 0 unless ($borrower and $budget);
920 if (not defined $userflags) {
921 $userflags = C4::Auth::getuserflags($borrower->{flags},
922 $borrower->{userid});
925 unless ($userflags->{superlibrarian}
926 || (ref $userflags->{acquisition}
927 && $userflags->{acquisition}->{budget_manage_all})
928 || (!ref $userflags->{acquisition} && $userflags->{acquisition}))
930 if (!CanUserUseBudget($borrower, $budget, $userflags)) {
934 if (ref $userflags->{acquisition}
935 && !$userflags->{acquisition}->{budget_modify}) {
943 # -------------------------------------------------------------------
947 @currencies = &GetCurrencies;
949 Returns the list of all known currencies.
951 C<$currencies> is a array; its elements are references-to-hash, whose
952 keys are the fields from the currency table in the Koha database.
957 my $dbh = C4::Context->dbh;
962 my $sth = $dbh->prepare($query);
965 while ( my $data = $sth->fetchrow_hashref ) {
966 push( @results, $data );
971 # -------------------------------------------------------------------
974 my $dbh = C4::Context->dbh;
976 SELECT * FROM currency where active = '1' ";
977 my $sth = $dbh->prepare($query);
979 my $r = $sth->fetchrow_hashref;
985 &ModCurrencies($currency, $newrate);
987 Sets the exchange rate for C<$currency> to be C<$newrate>.
992 my ( $currency, $rate ) = @_;
993 my $dbh = C4::Context->dbh;
998 my $sth = $dbh->prepare($query);
999 $sth->execute( $rate, $currency );
1002 # -------------------------------------------------------------------
1004 =head2 ConvertCurrency
1006 $foreignprice = &ConvertCurrency($currency, $localprice);
1008 Converts the price C<$localprice> to foreign currency C<$currency> by
1009 dividing by the exchange rate, and returns the result.
1011 If no exchange rate is found, e is one to one.
1015 sub ConvertCurrency {
1016 my ( $currency, $price ) = @_;
1017 my $dbh = C4::Context->dbh;
1023 my $sth = $dbh->prepare($query);
1024 $sth->execute($currency);
1025 my $cur = ( $sth->fetchrow_array() )[0];
1029 return ( $price / $cur );
1033 =head2 CloneBudgetPeriod
1035 my $new_budget_period_id = CloneBudgetPeriod({
1036 budget_period_id => $budget_period_id,
1037 budget_period_startdate => $budget_period_startdate,
1038 budget_period_enddate => $budget_period_enddate,
1039 mark_original_budget_as_inactive => 1n
1040 reset_all_budgets => 1,
1043 Clone a budget period with all budgets.
1044 If the mark_origin_budget_as_inactive is set (0 by default),
1045 the original budget will be marked as inactive.
1047 If the reset_all_budgets is set (0 by default), all budget (fund)
1048 amounts will be reset.
1052 sub CloneBudgetPeriod {
1054 my $budget_period_id = $params->{budget_period_id};
1055 my $budget_period_startdate = $params->{budget_period_startdate};
1056 my $budget_period_enddate = $params->{budget_period_enddate};
1057 my $budget_period_description = $params->{budget_period_description};
1058 my $mark_original_budget_as_inactive =
1059 $params->{mark_original_budget_as_inactive} || 0;
1060 my $reset_all_budgets = $params->{reset_all_budgets} || 0;
1062 my $budget_period = GetBudgetPeriod($budget_period_id);
1064 $budget_period->{budget_period_startdate} = $budget_period_startdate;
1065 $budget_period->{budget_period_enddate} = $budget_period_enddate;
1066 $budget_period->{budget_period_description} = $budget_period_description;
1067 # The new budget (budget_period) should be active by default
1068 $budget_period->{budget_period_active} = 1;
1069 my $original_budget_period_id = $budget_period->{budget_period_id};
1070 delete $budget_period->{budget_period_id};
1071 my $new_budget_period_id = AddBudgetPeriod( $budget_period );
1073 my $budgets = GetBudgetHierarchy($budget_period_id);
1074 CloneBudgetHierarchy(
1076 budgets => $budgets,
1077 new_budget_period_id => $new_budget_period_id
1081 if ($mark_original_budget_as_inactive) {
1084 budget_period_id => $budget_period_id,
1085 budget_period_active => 0,
1090 if ( $reset_all_budgets ) {
1091 my $budgets = GetBudgets({ budget_period_id => $new_budget_period_id });
1092 for my $budget ( @$budgets ) {
1093 $budget->{budget_amount} = 0;
1094 ModBudget( $budget );
1098 return $new_budget_period_id;
1101 =head2 CloneBudgetHierarchy
1103 CloneBudgetHierarchy({
1104 budgets => $budgets,
1105 new_budget_period_id => $new_budget_period_id;
1108 Clone a budget hierarchy.
1112 sub CloneBudgetHierarchy {
1114 my $budgets = $params->{budgets};
1115 my $new_budget_period_id = $params->{new_budget_period_id};
1116 next unless @$budgets or $new_budget_period_id;
1118 my $children_of = $params->{children_of};
1119 my $new_parent_id = $params->{new_parent_id};
1121 my @first_level_budgets =
1122 ( not defined $children_of )
1123 ? map { ( not $_->{budget_parent_id} ) ? $_ : () } @$budgets
1124 : map { ( $_->{budget_parent_id} == $children_of ) ? $_ : () } @$budgets;
1126 # get only the columns of aqbudgets
1127 my @columns = Koha::Database->new()->schema->source('Aqbudget')->columns;
1129 for my $budget ( sort { $a->{budget_id} <=> $b->{budget_id} }
1130 @first_level_budgets )
1134 { map { join( ' ', @columns ) =~ /$_/ ? ( $_ => $budget->{$_} ) : () }
1136 my $new_budget_id = AddBudget(
1140 budget_parent_id => $new_parent_id,
1141 budget_period_id => $new_budget_period_id
1144 CloneBudgetHierarchy(
1146 budgets => $budgets,
1147 new_budget_period_id => $new_budget_period_id,
1148 children_of => $budget->{budget_id},
1149 new_parent_id => $new_budget_id
1157 my $report = MoveOrders({
1158 from_budget_period_id => $from_budget_period_id,
1159 to_budget_period_id => $to_budget_period_id,
1162 Move orders from one budget period to another.
1168 my $from_budget_period_id = $params->{from_budget_period_id};
1169 my $to_budget_period_id = $params->{to_budget_period_id};
1170 my $move_remaining_unspent = $params->{move_remaining_unspent};
1172 if not $from_budget_period_id
1173 or not $to_budget_period_id
1174 or $from_budget_period_id == $to_budget_period_id;
1176 # Can't move orders to an inactive budget (budgetperiod)
1177 my $budget_period = GetBudgetPeriod($to_budget_period_id);
1178 return unless $budget_period->{budget_period_active};
1181 my $dbh = C4::Context->dbh;
1182 my $sth_update_aqorders = $dbh->prepare(
1186 WHERE ordernumber = ?
1189 my $sth_update_budget_amount = $dbh->prepare(
1192 SET budget_amount = ?
1196 my $from_budgets = GetBudgetHierarchy($from_budget_period_id);
1197 for my $from_budget (@$from_budgets) {
1198 my $new_budget_id = $dbh->selectcol_arrayref(
1202 WHERE budget_period_id = ?
1204 |, {}, $to_budget_period_id, $from_budget->{budget_code}
1206 $new_budget_id = $new_budget_id->[0];
1207 my $new_budget = GetBudget( $new_budget_id );
1208 unless ( $new_budget ) {
1212 budget => $from_budget,
1213 error => 'budget_code_not_exists',
1217 my $orders_to_move = C4::Acquisition::SearchOrders(
1219 budget_id => $from_budget->{budget_id},
1225 for my $order (@$orders_to_move) {
1226 $sth_update_aqorders->execute( $new_budget->{budget_id}, $order->{ordernumber} );
1227 push @orders_moved, $order;
1230 my $unspent_moved = 0;
1231 if ($move_remaining_unspent) {
1232 my $spent = GetBudgetHierarchySpent( $from_budget->{budget_id} );
1233 my $unspent = $from_budget->{budget_amount} - $spent;
1234 my $new_budget_amount = $new_budget->{budget_amount};
1235 if ( $unspent > 0 ) {
1236 $new_budget_amount += $unspent;
1237 $unspent_moved = $unspent;
1239 $new_budget->{budget_amount} = $new_budget_amount;
1240 $sth_update_budget_amount->execute( $new_budget_amount,
1241 $new_budget->{budget_id} );
1246 budget => $new_budget,
1247 orders_moved => \@orders_moved,
1249 unspent_moved => $unspent_moved,
1255 END { } # module clean-up code here (global destructor)
1262 Koha Development Team <http://koha-community.org/>