Bug 36068: Add maint script acq_cancel_obsolete_orders.pl

Introducing $orders->filter_by_obsolete and $orders->cancel.

Test plan:
Run t/db_dependent/Koha/Acquisition/Orders.t
Create basket with few orders. Remove some biblio records.
Run acq_cancel_obsolete_orders.pl -c

Signed-off-by: Marcel de Rooy <m.de.rooy@rijksmuseum.nl>
Signed-off-by: David Nind <david@davidnind.com>
Signed-off-by: Martin Renvoize <martin.renvoize@ptfs-europe.com>
Signed-off-by: Katrin Fischer <katrin.fischer@bsz-bw.de>

Koha/Acquisition/Orders.pm

@@ -231,6 +231,83 @@ sub filter_by_id_including_transfers {
     );
 }
 
+=head3 filter_by_obsolete
+
+    $orders->filter_by_obsolete( $age );
+
+    What are obsolete orders here?
+    [1] Order lines that have no biblio anymore but are still considered open
+        (received < ordered, not cancelled).
+    [2] Order lines with status 'cancelled' but no cancellation date.
+    [3] Order lines with cancellation date and no status 'cancelled'.
+
+    An optional parameter age may limit the selection by entrydate older than $age days.
+
+=cut
+
+sub filter_by_obsolete {
+    my ( $self, $params ) = @_;
+    my $rs = $self->search(
+        {
+            -or => [
+                { datecancellationprinted => undef,           orderstatus => 'cancelled' },
+                { datecancellationprinted => { '!=', undef }, orderstatus => { '!=', 'cancelled' } },
+                -and => [
+                    orderstatus             => [ 'ordered', 'partial', 'new' ],
+                    biblionumber            => undef,
+                    datecancellationprinted => undef,
+                    -or                     => [
+                        { quantity         => [ undef, 0 ] },
+                        { quantityreceived => { '<', \['quantity'] } },
+                    ],
+                ],
+            ],
+        }
+    );
+    if ( $params->{age} ) {
+        my $dtf = Koha::Database->new->schema->storage->datetime_parser;
+        my $dt  = Koha::DateUtils::dt_from_string->subtract( days => $params->{age} )->truncate( to => 'day' );
+        $rs = $rs->search( { entrydate => { '<', $dtf->format_datetime($dt) } } );
+    }
+    return $rs;
+}
+
+
+=head3 cancel
+
+    $orders_rs->cancel( { delete_biblio => 0|1 } );
+
+    Returns a count and diagnostic object messages.
+
+=cut
+
+sub cancel {
+    my ( $self, $params ) = @_;
+    my $delete_biblio = $params->{delete_biblio} || 0;    # keep by default :)
+    my $count         = 0;
+    my @messages;
+    while ( my $order = $self->next ) {
+        _correct_quantity($order);                        # historical ballast
+        $order->cancel( { delete_biblio => $delete_biblio } );
+        if ( @{ $order->object_messages } ) {
+            push @messages, @{ $order->object_messages };
+        } else {
+            $count++;
+        }
+    }
+    return ( $count, [@messages] );
+}
+
+sub _correct_quantity {
+    my ($order) = @_;
+    if ( !$order->quantity ) {
+
+        # This may be the case in old data .. But ->store needs a quantity even when cancelling
+        # Note also that the quantity column def still has NULL -- 2024-02-14
+        $order->quantity(1);
+    }
+}
+
 =head2 Internal methods
 
 =head3 _type

misc/maintenance/acq_cancel_obsolete_orders.pl

@@ -0,0 +1,74 @@
+#!/usr/bin/perl
+
+=head1 NAME
+
+acq_cancel_obsolete_orders.pl - Script for cancelling obsolete orders
+
+=head1 SYNOPSIS
+
+    # Help
+    misc/maintenance/acq_cancel_obsolete_orders.pl --help
+
+    # Count obsolete orders (with/without age)
+    misc/maintenance/acq_cancel_obsolete_orders.pl
+    misc/maintenance/acq_cancel_obsolete_orders.pl --age 365
+
+    # Cancel obsolete orders (with/without age)
+    misc/maintenance/acq_cancel_obsolete_orders.pl -c
+    misc/maintenance/acq_cancel_obsolete_orders.pl -c --age 365
+
+=head1 DESCRIPTION
+
+    Obsolete order lines (in table aqorders) are defined here as:
+
+    [1] Biblionumber is null but received < ordered and not cancelled.
+    [2] Status 'cancelled' but no cancellation date.
+    [3] Filled cancellation date, but status is not 'cancelled'.
+
+    This script may count those orders or cancel them.
+
+    Optionally, you may pass an age in DAYS to limit the
+    selected set to records with an older entrydate.
+
+=cut
+
+# Copyright 2024 Rijksmuseum
+#
+# This file is part of Koha.
+#
+# Koha is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+#
+# Koha is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with Koha; if not, see <http://www.gnu.org/licenses>.
+
+use Modern::Perl;
+use Getopt::Long qw( GetOptions );
+use Pod::Usage   qw( pod2usage );
+
+use Koha::Acquisition::Orders;
+use Koha::Script;
+
+my ($params);
+GetOptions(
+    'confirm' => \$params->{confirm}, 'help' => \$params->{help}, 'age:i' => \$params->{age},
+);
+if ( $params->{help} ) {
+    pod2usage( -verbose => 2 );
+    exit;
+}
+
+my $rs = Koha::Acquisition::Orders->filter_by_obsolete( { age => $params->{age} } );
+print sprintf( "Found %d obsolete orders\n", $rs->count );
+if ( $params->{confirm} ) {
+    my @results = $rs->cancel;
+    print sprintf( "Cancelled %d obsolete orders\n", $results[0] );
+    print sprintf( "Got %d warnings\n",              @{ $results[1] } ) if @{ $results[1] };
+}

t/db_dependent/Koha/Acquisition/Orders.t

@@ -19,7 +19,7 @@
 
 use Modern::Perl;
 
-use Test::More tests => 2;
+use Test::More tests => 3;
 use Test::Exception;
 
 use t::lib::TestBuilder;
@@ -158,3 +158,49 @@ subtest 'filter_by_id_including_transfers() tests' => sub {
 
     $schema->storage->txn_rollback;
 };
+
+subtest 'filter_by_obsolete and cancel' => sub {
+    plan tests => 11;
+    $schema->storage->txn_begin;
+
+    my $order_1 = $builder->build_object( { class => 'Koha::Acquisition::Orders' } );
+    my $order_2 = $builder->build_object( { class => 'Koha::Acquisition::Orders' } );
+    my $order_3 = $builder->build_object( { class => 'Koha::Acquisition::Orders' } );
+
+    # First make order 1 obsolete by removing biblio, and order 3 by status problem.
+    my $date = Koha::DateUtils::dt_from_string->subtract( days => 7 );
+    $order_1->orderstatus('ordered')->quantity(2)->quantityreceived(0)->datecancellationprinted(undef)
+        ->entrydate($date)->store;
+    Koha::Biblios->find( $order_1->biblionumber )->delete;
+    $order_1->discard_changes;
+    $order_2->orderstatus('ordered')->quantity(3)->quantityreceived(0)->datecancellationprinted(undef)->store;
+    $order_3->orderstatus('cancelled')->datecancellationprinted(undef)->store;
+
+    my $limit = { ordernumber => { '>=', $order_1->ordernumber } };
+    my $rs    = Koha::Acquisition::Orders->filter_by_obsolete->search($limit);
+    is( $rs->count, 2, 'Two obsolete' );
+    is( $rs->search( { ordernumber => $order_1->ordernumber } )->count, 1, 'Including order_1' );
+    is( $rs->search( { ordernumber => $order_2->ordernumber } )->count, 0, 'Excluding order_2' );
+
+    # Test param age
+    $rs = Koha::Acquisition::Orders->filter_by_obsolete( { age => 6 } )->search($limit);
+    is( $rs->count, 1, 'Age 6: Including order_1' );
+    $rs = Koha::Acquisition::Orders->filter_by_obsolete( { age => 7 } )->search($limit);
+    is( $rs->count, 0, 'Age 7: Excluding order_1' );
+
+    # Make order 2 obsolete too
+    Koha::Biblios->find( $order_2->biblionumber )->delete;
+    $order_2->discard_changes;
+
+    # Use the plural cancel method
+    $rs = Koha::Acquisition::Orders->filter_by_obsolete->search($limit);
+    is( $rs->count, 3, 'Three obsolete' );
+    my @results = $rs->cancel;
+    is( $results[0],                            3,           'All should be cancelled' );
+    is( @{ $results[1] },                       0,           'No messages' );
+    is( $order_1->discard_changes->orderstatus, 'cancelled', 'Check orderstatus of order_1' );
+    isnt( $order_2->discard_changes->datecancellationprinted, undef, 'Cancellation date of order_2 filled' );
+    isnt( $order_3->discard_changes->datecancellationprinted, undef, 'Cancellation date of order_3 filled' );
+
+    $schema->storage->txn_rollback;
+};