#!/usr/bin/perl
use Time::HiRes qw(gettimeofday tv_interval);
use SQL::Abstract::Plugin::InsertMulti;
use IPC::System::Simple qw(system);
use Test::WWW::Mechanize::CGIApp;
use WWW::Mechanize::TreeBuilder;
use Data::Printer;
use Test::More;
use strict;
use warnings;
use feature 'say';
use lib 't/lib'; # loads t/lib/LIMS/DB/Outreach files in place of lib/LIMS/DB/Outreach
=begin # tests:
=cut
use constant TESTS => 63;
BEGIN { # need to copy LIMS/DB/Outreach files and substitute db name:
my $t0 = [gettimeofday];
# make new directory t/lib/LIMS/DB/Outreach:
system( 'mkdir', '-p', 't/lib/LIMS/DB/Outreach' );
# copy files from lib/LIMS/DB/Outreach (needs to be all 1 command for shell + wild-card):
system( 'cp lib/LIMS/DB/Outreach/*.pm t/lib/LIMS/DB/Outreach/' );
# substitute 'outreach' -> 'outreach_test' for all files in new directory
# (x27 is hex for apostrophe, otherwise needs ugly escaping; make warnings
# fatal so that process dies before any tests can run):
system( q!perl -mwarnings=FATAL,all -pi -e \
's/(schema\s*=>\s*\x27outreach)/$1_test/' \
t/lib/LIMS/DB/Outreach/*.pm! );
# check all files in t/lib/LIMS/DB/Outreach have substitution, or die (0777
# is impossible hex char so line-sep changes to undef so whole file is read):
system(q!perl -0777 -ne '/outreach_test/ or die' t/lib/LIMS/DB/Outreach/*.pm!);
say sprintf 'copied Outreach DB: %.2f sec', tv_interval $t0, [gettimeofday];
require 't/test-lib.pl';
say sprintf 'finished: %.2f sec', tv_interval $t0, [gettimeofday];
}
my $dbix = get_dbix();
my $mech = get_mech();
WWW::Mechanize::TreeBuilder->meta->apply($mech);
# need to see if 'require_spell_check' is required:
my $spell_check_required = is_spell_check_required(); # warn $spell_check_required;
$dbix->dbh->do( qq!TRUNCATE TABLE outreach_test.$_! ) for qw(
request_followup
request_pack_dispatch
);
{ # new db entries:
# new specimen:
$dbix->insert('specimens',
{ sample_code => 'CMP', description => 'Outreach' });
# new screen category:
$dbix->insert('screen_category', { name => 'outreach', is_active => 'yes'});
my $category_id = get_last_insert_id('screen_category');
# new screen:
$dbix->insert('screens',
{ description => 'Outreach', category_id => $category_id, active => 'yes' });
# new test:
$dbix->insert('lab_tests',
{ test_name => 'outreach', field_label => 'Outreach', test_type=> 'panel',
lab_section_id => 1, has_results => 'no' });
# new screen_lab_test:
my $screen_id = get_last_insert_id('screens');
my $test_id = get_last_insert_id('lab_tests');
$dbix->insert('screen_lab_test',
{ screen_id => $screen_id, lab_test_id => $test_id });
# patient demographics:
$dbix->insert('patient_demographics', { patient_id => 2, # patient for req #3
address => '1 The Drive', post_code => 'AB1 2CD', gp_id => 2,
practice_id => 2, status => 'alive' });
# check test data exists, or create it:
my $tbl = 'outreach_test.followup_options';
unless ( $dbix->select( $tbl, 'COUNT(*)')->list ) {
my @data = (
[ 'zero_month', 'immediately', 1 ],
[ 'one_month', 'one month', 2 ],
[ 'six_week', 'six weeks', 3 ],
[ 'twenty_four_month', 'two years', 4 ],
[ 'clinic_return', 'return to clinic', 5 ],
[ 'other', 'other', 6 ],
);
my @cols = qw( `option` label position ); # option is mysql keyword
my ($stmt, @bind) = SQL::Abstract->new
->insert_multi( $tbl, \@cols, \@data ); # p $stmt; p @bind;
$dbix->query($stmt, @bind);
}
}
do_login();
my $today = DateTime->today;
# check future pack dispatches worklist (should be none:
$mech->get_ok('/local_worklist?function_name=outreach_packs_future');
$mech->has_tag(
p => 'No Outreach pack dispatches due in future',
'OK: no future pack dispatches'
); # print_and_exit();
$mech->get_ok('/request/add_new/2'); # print_and_exit();
$mech->submit_form(
fields => {
request_number => 3,
specimen => 'pb,cmp',
referrer_code => 'C1234567',
},
); # print_and_exit();
$mech->content_contains(
q!New request successful!,
'OK: new request entered successfully',
);
$mech->get_ok('/search/=/3'); # print_and_exit();
$mech->text_contains(
q!Screened as Outreach!,
'OK: screened as expected',
); # print_and_exit();
$mech->follow_link_ok(
# {n => 8}, "Logout $_ via eighth link on page",
{ url_regex => qr(outreach)i, },
'select "outreach" link',
); # print_and_exit();
$mech->text_contains(
q!Report table!,
'OK: report page loaded',
);
$mech->form_name('reportForm');
is( $mech->value('clinical_details'), 'Outreach monitoring',
'OK: request details loaded');
# minimal fields required:
my %fields = ( # changed for Deb9, needs to submit_form as (fields => \%fields)
followup_option_id => 3, # six weeks
specimen_quality => 'adequate',
diagnosis_id => 2,
authorise => 1,
);
$mech->submit_form(fields => \%fields); # print_and_exit();
$mech->form_name('reportForm');
# changed for Deb9, needs to re-submit form with args:
$mech->submit_form(fields => \%fields) if $spell_check_required;
{
my $msg = get_messages('action')->{edit_success};
$mech->has_tag_like(
p => qr($msg),
'OK: record updated successfully',
); # print_and_exit();
}
$mech->get_ok('/report/outreach/3'); # print_and_exit();
$mech->form_name('reportForm');
is( $mech->value('followup_option_id', 1), 3, 'OK: expected followup option');
{ # expected pack dispatch due date:
my $date = $today->clone->add(weeks => 6)->subtract(days => 14); # p $date;
is( $mech->look_down(id => 'pack_due')->attr('value'),
$date->strftime('%d.%b.%Y'),
'OK: expected pack dispatch due date'
); # print_and_exit();
}
# check future pack dispatches worklist (has request):
$mech->get_ok('/local_worklist?function_name=outreach_packs_future');
$mech->has_tag(
h3 => 'Outreach pack dispatches due in future',
'OK: worklist loaded'
);
$mech->has_tag(
td => 2222222222,
'OK: patient listed in future pack dispatches worklist'
); # print_and_exit();
# edit followup option (requires edit_outreach_data permission):
$mech->get_ok('/outreach/edit_followup/3'); # print_and_exit();
$mech->content_contains('Permission Denied', 'OK: expected permission denied');
{ # new user permission:
$dbix->insert('user_functions',
{ function_name => 'edit_outreach_data', active => 'yes',
function_detail => 'edit_outreach_data' });
my $user_function_id = get_last_insert_id('user_functions');
$dbix->insert('user_group_function',
{ group_id => 1, function_id => $user_function_id });
}
# logout and back in again for permission change:
do_logout();
do_login();
$mech->get_ok('/outreach/edit_followup/3'); # print_and_exit();
$mech->content_contains('Edit Outreach follow-up', 'OK: function now allowed');
$mech->form_name('followup');
$mech->field(followup_option_id => 4); # two years
$mech->submit; # print_and_exit();
{ # expected pack dispatch due date:
my $date = $today->clone->add(years => 2)->subtract(days => 14); # p $date;
is( $mech->look_down(id => 'pack_due')->attr('value'),
$date->strftime('%d.%b.%Y'),
'OK: expected new pack dispatch due date'
); # print_and_exit();
}
# history:
$mech->get_ok('/history/=/3'); # print_and_exit();
$mech->text_contains('from six weeks to two years', 'OK: history log');
# check 'clinic returns' worklist:
$mech->get_ok('/local_worklist?function_name=outreach_clinic_returns');
$mech->has_tag(
h3 => 'Outreach clinic returns without appointment dates',
'OK: worklist loaded'
);
$mech->has_tag(
p => 'None',
'OK: patient not listed in clinic returns worklist'
); # print_and_exit();
# return to clinic:
$mech->get_ok('/outreach/edit_followup/3'); # print_and_exit();
$mech->form_name('followup');
$mech->field(followup_option_id => 5); # return to clinic
$mech->submit; # print_and_exit();
is( $mech->look_down(id => 'pack_due')->attr('value'), '01.Jan.1999',
'OK: default date for no pack dispatch'
);
# history:
$mech->get_ok('/history/=/3'); # print_and_exit();
$mech->text_contains('from two years to return to clinic', 'OK: history log');
# check 'clinic returns' worklist (has request):
$mech->get_ok('/local_worklist?function_name=outreach_clinic_returns');
$mech->has_tag(
h3 => 'Outreach clinic returns without appointment dates',
'OK: worklist loaded'
);
$mech->has_tag(
td => 2222222222,
'OK: patient listed in clinic returns worklist'
); # print_and_exit();
# followup option = other:
$mech->get_ok('/outreach/edit_followup/3'); # print_and_exit();
$mech->form_name('followup');
$mech->field(followup_option_id => 6); # other
$mech->submit; # print_and_exit();
is( $mech->look_down(id => 'pack_due')->attr('value'), '01.Jan.1999',
'OK: default date for no pack dispatch'
); # print_and_exit();
# history:
$mech->get_ok('/history/=/3'); # print_and_exit();
$mech->text_contains('from return to clinic to other', 'OK: history log');
# check 'pack dispatch' worklist (request should not be listed):
$mech->get_ok('/local_worklist?function_name=outreach_pack_dispatch');
$mech->has_tag(
p => 'No Outreach pack dispatches due',
'OK: patient not listed in pack dispatches worklist'
); # print_and_exit();
# return immediately:
$mech->get_ok('/outreach/edit_followup/3'); # print_and_exit();
$mech->form_name('followup');
$mech->field(followup_option_id => 1); # immediately
$mech->submit; # print_and_exit();
{ # expected pack dispatch due date:
my $date = $today->clone->subtract(days => 14); # p $date;
is( $mech->look_down(id => 'pack_due')->attr('value'),
$date->strftime('%d.%b.%Y'),
'OK: expected new pack dispatch due date'
); # print_and_exit();
}
# history:
$mech->get_ok('/history/=/3'); # print_and_exit();
$mech->text_contains('from other to immediately', 'OK: history log');
# check 'pack dispatch' worklist (has request):
$mech->get_ok('/local_worklist?function_name=outreach_pack_dispatch');
$mech->has_tag(
h3 => 'Outreach pack dispatches',
'OK: worklist loaded'
);
$mech->has_tag(
td => 2222222222,
'OK: patient listed in pack dispatches worklist'
); # print_and_exit();
# record pack dispatch:
$mech->tick('request_id', 3);
$mech->submit_form(); # print_and_exit();
# check history:
$mech->get_ok('/history/=/3'); # print_and_exit();
$mech->text_contains('dispatched CMP pack', 'OK: history log');
# check report for pack sent & return due dates:
$mech->get_ok('/report/outreach/3'); # print_and_exit();
{ # pack sent date (today):
is( $mech->look_down(id => 'pack_sent')->attr('value'),
$today->strftime('%a %d.%b.%Y'),
'OK: expected pack dispatch date'
); # print_and_exit();
}
{ # expected return due date (40 days after dispatch):
my $date = $today->clone->add(days => 40); # p $date;
is( $mech->look_down(id => 'return_due')->attr('value'),
$date->strftime('%a %d.%b.%Y'),
'OK: expected pack return date'
); # print_and_exit();
}
# check 'pack dispatch' worklist again (request should not be listed):
$mech->get_ok('/local_worklist?function_name=outreach_pack_dispatch');
$mech->has_tag(
p => 'No Outreach pack dispatches due',
'OK: patient not listed in pack dispatches worklist'
); # print_and_exit();
done_testing(TESTS);
