View | Details | Raw Unified | Return to bug 36068
Collapse All | Expand All

(-)a/Koha/Acquisition/Orders.pm (+77 lines)
Lines 231-236 sub filter_by_id_including_transfers { Link Here
231
    );
231
    );
232
}
232
}
233
233
234
=head3 filter_by_obsolete
235
236
    $orders->filter_by_obsolete( $age );
237
238
    What are obsolete orders here?
239
    [1] Order lines that have no biblio anymore but are still considered open
240
        (received < ordered, not cancelled).
241
    [2] Order lines with status 'cancelled' but no cancellation date.
242
    [3] Order lines with cancellation date and no status 'cancelled'.
243
244
    An optional parameter age may limit the selection by entrydate older than $age days.
245
246
=cut
247
248
sub filter_by_obsolete {
249
    my ( $self, $params ) = @_;
250
    my $rs = $self->search(
251
        {
252
            -or => [
253
                { datecancellationprinted => undef,           orderstatus => 'cancelled' },
254
                { datecancellationprinted => { '!=', undef }, orderstatus => { '!=', 'cancelled' } },
255
                -and => [
256
                    orderstatus             => [ 'ordered', 'partial', 'new' ],
257
                    biblionumber            => undef,
258
                    datecancellationprinted => undef,
259
                    -or                     => [
260
                        { quantity         => [ undef, 0 ] },
261
                        { quantityreceived => { '<', \['quantity'] } },
262
                    ],
263
                ],
264
            ],
265
        }
266
    );
267
    if ( $params->{age} ) {
268
        my $dtf = Koha::Database->new->schema->storage->datetime_parser;
269
        my $dt  = Koha::DateUtils::dt_from_string->subtract( days => $params->{age} )->truncate( to => 'day' );
270
        $rs = $rs->search( { entrydate => { '<', $dtf->format_datetime($dt) } } );
271
    }
272
    return $rs;
273
}
274
275
276
=head3 cancel
277
278
    $orders_rs->cancel( { delete_biblio => 0|1 } );
279
280
    Returns a count and diagnostic object messages.
281
282
=cut
283
284
sub cancel {
285
    my ( $self, $params ) = @_;
286
    my $delete_biblio = $params->{delete_biblio} || 0;    # keep by default :)
287
    my $count         = 0;
288
    my @messages;
289
    while ( my $order = $self->next ) {
290
        _correct_quantity($order);                        # historical ballast
291
        $order->cancel( { delete_biblio => $delete_biblio } );
292
        if ( @{ $order->object_messages } ) {
293
            push @messages, @{ $order->object_messages };
294
        } else {
295
            $count++;
296
        }
297
    }
298
    return ( $count, [@messages] );
299
}
300
301
sub _correct_quantity {
302
    my ($order) = @_;
303
    if ( !$order->quantity ) {
304
305
        # This may be the case in old data .. But ->store needs a quantity even when cancelling
306
        # Note also that the quantity column def still has NULL -- 2024-02-14
307
        $order->quantity(1);
308
    }
309
}
310
234
=head2 Internal methods
311
=head2 Internal methods
235
312
236
=head3 _type
313
=head3 _type
(-)a/misc/maintenance/acq_cancel_obsolete_orders.pl (+74 lines)
Line 0 Link Here
1
#!/usr/bin/perl
2
3
=head1 NAME
4
5
acq_cancel_obsolete_orders.pl - Script for cancelling obsolete orders
6
7
=head1 SYNOPSIS
8
9
    # Help
10
    misc/maintenance/acq_cancel_obsolete_orders.pl --help
11
12
    # Count obsolete orders (with/without age)
13
    misc/maintenance/acq_cancel_obsolete_orders.pl
14
    misc/maintenance/acq_cancel_obsolete_orders.pl --age 365
15
16
    # Cancel obsolete orders (with/without age)
17
    misc/maintenance/acq_cancel_obsolete_orders.pl -c
18
    misc/maintenance/acq_cancel_obsolete_orders.pl -c --age 365
19
20
=head1 DESCRIPTION
21
22
    Obsolete order lines (in table aqorders) are defined here as:
23
24
    [1] Biblionumber is null but received < ordered and not cancelled.
25
    [2] Status 'cancelled' but no cancellation date.
26
    [3] Filled cancellation date, but status is not 'cancelled'.
27
28
    This script may count those orders or cancel them.
29
30
    Optionally, you may pass an age in DAYS to limit the
31
    selected set to records with an older entrydate.
32
33
=cut
34
35
# Copyright 2024 Rijksmuseum
36
#
37
# This file is part of Koha.
38
#
39
# Koha is free software; you can redistribute it and/or modify it
40
# under the terms of the GNU General Public License as published by
41
# the Free Software Foundation; either version 3 of the License, or
42
# (at your option) any later version.
43
#
44
# Koha is distributed in the hope that it will be useful, but
45
# WITHOUT ANY WARRANTY; without even the implied warranty of
46
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
47
# GNU General Public License for more details.
48
#
49
# You should have received a copy of the GNU General Public License
50
# along with Koha; if not, see <http://www.gnu.org/licenses>.
51
52
use Modern::Perl;
53
use Getopt::Long qw( GetOptions );
54
use Pod::Usage   qw( pod2usage );
55
56
use Koha::Acquisition::Orders;
57
use Koha::Script;
58
59
my ($params);
60
GetOptions(
61
    'confirm' => \$params->{confirm}, 'help' => \$params->{help}, 'age:i' => \$params->{age},
62
);
63
if ( $params->{help} ) {
64
    pod2usage( -verbose => 2 );
65
    exit;
66
}
67
68
my $rs = Koha::Acquisition::Orders->filter_by_obsolete( { age => $params->{age} } );
69
print sprintf( "Found %d obsolete orders\n", $rs->count );
70
if ( $params->{confirm} ) {
71
    my @results = $rs->cancel;
72
    print sprintf( "Cancelled %d obsolete orders\n", $results[0] );
73
    print sprintf( "Got %d warnings\n",              @{ $results[1] } ) if @{ $results[1] };
74
}
(-)a/t/db_dependent/Koha/Acquisition/Orders.t (-2 / +47 lines)
Lines 19-25 Link Here
19
19
20
use Modern::Perl;
20
use Modern::Perl;
21
21
22
use Test::More tests => 2;
22
use Test::More tests => 3;
23
use Test::Exception;
23
use Test::Exception;
24
24
25
use t::lib::TestBuilder;
25
use t::lib::TestBuilder;
Lines 158-160 subtest 'filter_by_id_including_transfers() tests' => sub { Link Here
158
158
159
    $schema->storage->txn_rollback;
159
    $schema->storage->txn_rollback;
160
};
160
};
161
- 
161
162
subtest 'filter_by_obsolete and cancel' => sub {
163
    plan tests => 11;
164
    $schema->storage->txn_begin;
165
166
    my $order_1 = $builder->build_object( { class => 'Koha::Acquisition::Orders' } );
167
    my $order_2 = $builder->build_object( { class => 'Koha::Acquisition::Orders' } );
168
    my $order_3 = $builder->build_object( { class => 'Koha::Acquisition::Orders' } );
169
170
    # First make order 1 obsolete by removing biblio, and order 3 by status problem.
171
    my $date = Koha::DateUtils::dt_from_string->subtract( days => 7 );
172
    $order_1->orderstatus('ordered')->quantity(2)->quantityreceived(0)->datecancellationprinted(undef)
173
        ->entrydate($date)->store;
174
    Koha::Biblios->find( $order_1->biblionumber )->delete;
175
    $order_1->discard_changes;
176
    $order_2->orderstatus('ordered')->quantity(3)->quantityreceived(0)->datecancellationprinted(undef)->store;
177
    $order_3->orderstatus('cancelled')->datecancellationprinted(undef)->store;
178
179
    my $limit = { ordernumber => { '>=', $order_1->ordernumber } };
180
    my $rs    = Koha::Acquisition::Orders->filter_by_obsolete->search($limit);
181
    is( $rs->count, 2, 'Two obsolete' );
182
    is( $rs->search( { ordernumber => $order_1->ordernumber } )->count, 1, 'Including order_1' );
183
    is( $rs->search( { ordernumber => $order_2->ordernumber } )->count, 0, 'Excluding order_2' );
184
185
    # Test param age
186
    $rs = Koha::Acquisition::Orders->filter_by_obsolete( { age => 6 } )->search($limit);
187
    is( $rs->count, 1, 'Age 6: Including order_1' );
188
    $rs = Koha::Acquisition::Orders->filter_by_obsolete( { age => 7 } )->search($limit);
189
    is( $rs->count, 0, 'Age 7: Excluding order_1' );
190
191
    # Make order 2 obsolete too
192
    Koha::Biblios->find( $order_2->biblionumber )->delete;
193
    $order_2->discard_changes;
194
195
    # Use the plural cancel method
196
    $rs = Koha::Acquisition::Orders->filter_by_obsolete->search($limit);
197
    is( $rs->count, 3, 'Three obsolete' );
198
    my @results = $rs->cancel;
199
    is( $results[0],                            3,           'All should be cancelled' );
200
    is( @{ $results[1] },                       0,           'No messages' );
201
    is( $order_1->discard_changes->orderstatus, 'cancelled', 'Check orderstatus of order_1' );
202
    isnt( $order_2->discard_changes->datecancellationprinted, undef, 'Cancellation date of order_2 filled' );
203
    isnt( $order_3->discard_changes->datecancellationprinted, undef, 'Cancellation date of order_3 filled' );
204
205
    $schema->storage->txn_rollback;
206
};

Return to bug 36068