#!/usr/bin/perl
use Test::WWW::Mechanize::CGIApp;
use strict;
use warnings;
use DateTime;
use POSIX;
#use Test::More 'no_plan';
use Test::More tests => 114;
use Test::Builder::Tester;
=begin # tests:
1) retrieve patient & submit valid request
2) select same patient & register new unit number for same location
3) new request - duplicate labno
4) new request - invalid specimen
5) new request - missing referrer_code
6) retrieve request history for new record
7) submit new request for unknown GP
8) submit new request for unknown clinician
9) delete record
10) re-create record - test for original request.id
11) check lab-test automatically requested by sample type
12) amend record to doi & register new record without doi - check for warning
=cut
BEGIN {
require 't/test-lib.pl';
}
my $mech = get_mech();
my $dbh;
eval {
$dbh = get_dbh() or die 'no database handle recieved from get_dbh';
};
warn $@ if $@;
foreach( qw/requests request_specimen request_specimen_detail/ ) {
drop_and_recreate($_);
}
#{
# $dbh->do( q!ALTER TABLE `request_specimen`
# ADD CONSTRAINT `request_specimen_ibfk_1` FOREIGN KEY (`request_id`)
# REFERENCES `requests` (`id`) ON DELETE CASCADE! );
#}
do_login();
$mech->get_ok('/register'); # print_and_exit();
my $last_name = 'green';
$mech->submit_form(
fields => {
name => $last_name,
},
); # print_and_exit();
$mech->follow_link_ok(
# {n => 8}, "Logout $_ via eighth link on page",
{ url_regex => qr/select/i, },
'select patient using link',
); # print_and_exit();
$mech->follow_link_ok(
# {n => 8}, "Logout $_ via eighth link on page",
{ url_regex => qr/new/i, },
'select case using link',
); # print_and_exit();
$mech->submit_form(
fields => {
request_number => 1,
specimen => 'pb',
referrer_code => 'G1234567',
},
); # print_and_exit();
$mech->content_contains(
q!New request successful!,
'OK: new request entered successfully',
); # print_and_exit();
{
my $i=0;
foreach (qw/PB 1111111111 01.Feb.1940 1011 GREEN/, 'Black DE', 'The Surgery, Newtown, NT1 1NT' ) {
$i++;
$mech->content_like(
qr(<input type="text" value="$_"\s+readonly="readonly" />),
"OK: new request field [$i] detected",
);
}
}
# follow 'next' link to add new record:
$mech->follow_link_ok(
# {n => 8}, "Logout $_ via eighth link on page",
{ url_regex => qr(localhost/register)i, },
'select "next" using link',
); # print_and_exit();
$mech->content_contains(
q!Search For Patient Details!,
'OK: new reqest page loaded',
);
# select same patient as previous:
$mech->submit_form(
fields => {
name => $last_name,
},
); # print_and_exit();
$mech->follow_link_ok(
# {n => 8}, "Logout $_ via eighth link on page",
{ url_regex => qr/select/i, },
'select patient using link',
); # print_and_exit();
# register new location / unit number:
$mech->submit_form(
fields => {
unit_number => 123456,
referral_source_id => 1,
},
); # print $fh $mech->content; exit;
{
my $i=0;
foreach (qw/1111111111 01.Feb.1940 GREEN 123456/ ) {
$i++;
$mech->content_contains(
qq!<td>$_</td>!,
"OK: submitted field [$i] detected",
);
} # print_and_exit();
}
# submit duplicate labno:
$mech->submit_form(
fields => {
request_number => 1,
specimen => 'PB',
},
); # print_and_exit();
has_dfv_errors();
has_duplicate();
# correct duplicate labno, but submit invalid specimen:
$mech->submit_form(
fields => {
request_number => 2,
specimen => 'BMTA',
},
); # print_and_exit();
has_dfv_errors();
has_invalid();
has_missing();
# correct invalid specimen & missing referrer_code:
$mech->submit_form(
fields => {
request_number => 2,
specimen => 'PB',
referrer_code => 'C1234567',
external_reference => 'AB/1234',
error_code_id => 1,
_referrer => 'Brown, CC', # ajax function in form
},
); # print_and_exit();
{
my $i=0;
my @fields = ( qw/PB 1111111111 01.Feb.1940 GREEN 123456 AB\/1234/,
'Newtown General Infirmary', 'Brown, CC' );
foreach ( @fields ) {
$i++;
$mech->content_like(
qr(<input type="text" value="$_"\s+readonly="readonly" />),
"OK: new request field [$i] detected",
);
}
} # print_and_exit();
# test history:
$mech->get_ok('/search'); # print_and_exit();
$mech->submit_form(
fields => {
lab_number => 2,
},
); # print_and_exit();
$mech->content_contains(
'Record not screened',
'OK: record loaded & not screened',
);
$mech->follow_link_ok(
# {n => 8}, "Logout $_ via eighth link on page",
{ url_regex => qr(history)i, },
'select "history" link',
); # print_and_exit();
$mech->content_contains(
'Request history',
'OK: request history page loaded',
);
$mech->has_tag(
td => 'registered',
'OK: registration history action detected',
);
$mech->has_tag(
td => 'recorded error code A',
'OK: error code history action detected',
);
# access new request for case_number.id = 1 direct:
$mech->get_ok('/request/add_new/1'); # print_and_exit();
$mech->content_contains(
'» Request » New',
'OK: new request page loaded',
);
$mech->content_contains(
'The Surgery, Newtown',
'OK: expected patient_case data loaded',
);
# select unknown GP:
$mech->submit_form(
fields => {
request_number => 3,
specimen => 'PB',
referrer_code => 'G9999998',
},
); # print_and_exit();
$mech->content_contains(
q!value="Unknown"!,
'OK: value "unknown" detected',
);
# access new request for case_number.id = 3 direct:
$mech->get_ok('/request/add_new/3'); # print_and_exit();
$mech->content_contains(
'» Request » New',
'OK: new request page loaded',
);
$mech->content_contains(
'Newtown General Infirmary',
'OK: expected patient_case data loaded',
);
# select unknown clinician:
$mech->submit_form(
fields => {
request_number => 4,
specimen => 'PB',
referrer_code => 'C9999998',
},
); # print_and_exit();
# can't verify unknown clinician from request summary, so do search on request no:
$mech->get_ok('/search'); # print_and_exit();
{
$mech->submit_form(
fields => {
lab_number => 4,
},
); # print_and_exit();
my $yr = DateTime->now->strftime('%y');
$mech->has_tag(
td => 'Newtown General Infirmary',
'OK: expected content returned',
);
$mech->has_tag(
span => 'Unknown',
'OK: expected content returned',
);
$mech->content_like(
qr(\w4/$yr), # department prefix = \w
'OK: expected request number returned',
);
}
# delete record:
$mech->get_ok('/search/do_search?lab_number=3'); # print_and_exit();
{
# need to setup FK's this test:
my $dbh = get_dbh();
my $dbix = get_dbix();
my @non_cascade_tables = qw(history phone_log lab_test_history);
my @cascade_tables = qw(audit consent diagnosis_history error_code external_ref
initial_screen lab_test_results lab_test_status option report_detail
result_summaries specimen trial);
foreach(@cascade_tables) {
my $table = 'request_' . $_;
my $fk = $table . '_ibfk_1';
$dbh->do( qq!ALTER TABLE `$table` ADD CONSTRAINT `$fk` FOREIGN KEY (`request_id`)
REFERENCES `requests` (`id`) ON DELETE CASCADE! );
}
{ # add some data to tables with fk to request.id:
$dbix->insert('request_audit', { request_id => 3, audit_request_option_id => 1});
$dbix->insert('request_consent', { request_id => 3, consent_id => 1, status => 'yes'});
$dbix->insert('request_error_code', { request_id => 3, error_code_id => 1});
$dbix->insert('request_external_ref', { request_id => 3, external_reference => 'AB12'});
$dbix->insert('request_initial_screen', { request_id => 3, screen_id => 1});
$dbix->insert('request_lab_test_results', { request_id => 3, lab_test_id => 1, result => 'foo'});
$dbix->insert('request_lab_test_status', { request_id => 3, lab_test_id => 2, status_option_id => 1});
$dbix->insert('request_option', { request_id => 3, option_id => 1});
$dbix->insert('request_report_detail', { request_id => 3, comment => 'foo',
clinical_details => 'foo', diagnosis_id => 1});
$dbix->insert('request_diagnosis_history', { request_id => 3, diagnosis_id => 2, option_id => 1, user_id => 1});
$dbix->insert('request_lab_test_history', { request_id => 3, action => 'foo', user_id => 1});
$dbix->insert('request_trial', { request_id => 3, trial_id => 1});
$dbix->insert('request_phone_log', { request_id => 3, user_id => 1, contact => 'foo',
status => 'inbound', details => 'foo'});
$dbix->insert('request_result_summaries', { request_id => 3, lab_section_id => 1,
results_summary => 'foo'});
}
# check data exists:
foreach ( sort (@cascade_tables, @non_cascade_tables) ) {
my $tbl = 'request_' . $_;
is( $dbix->query(qq!select 1 from `$tbl` where `request_id` = ?!, 3)->list,
1, "OK: $tbl contains expected request data" );
}
$mech->has_tag_like(
td => qr(GREEN, Alan),
'OK: expected record found',
);
# test for absence of re-registered record patient (below):
test_out( 'not ok 1 - foo' );
test_fail( +1 );
$mech->has_tag_like( td => qr(BROWN, Stan), 'foo' );
test_test( 'OK: expected record found' );
# test for absence of re-registered record specimen type:
test_out( 'not ok 1 - foo' );
test_fail( +1 );
$mech->has_tag( td => 'LU', 'foo' );
test_test( 'OK: expected record found' );
$mech->follow_link_ok(
# {n => 8}, "Logout $_ via eighth link on page",
{ url_regex => qr(request/delete_request), },
'follow delete link',
); # print_and_exit();
my %delete = (
reason => 'inappropriate request',
confirm_delete => 1,
);
$mech->submit_form(fields => \%delete); # print_and_exit();
lacks_dfv_errors(); # print_and_exit();
$mech->has_tag(
p => 'INFO: record deleted',
'OK: delete success message detected'
);
# repeat search for lab_number:
$mech->get_ok('/search/do_search?lab_number=3'); # print_and_exit();
$mech->has_tag(
p => get_messages('search')->{no_records_found},
'OK: failed to find deleted record',
); # print_and_exit();
# check table status & remove FK's:
# data should be deleted from these (coz ON DELETE CASCADE set):
foreach my $t(sort @cascade_tables) {
my $tbl = 'request_' . $t;
my $fk = $tbl . '_ibfk_1';
isnt( $dbix->query(qq!select 1 from `$tbl` where `request_id` = ?!, 3)->list,
1, "OK: expected request data deleted from $tbl" );
$dbh->do( qq!ALTER TABLE `$tbl` DROP FOREIGN KEY `$fk`! );
}
# data should still be in these:
foreach my $t(sort @non_cascade_tables) {
my $tbl = 'request_' . $t;
is( $dbix->query(qq!select 1 from `$tbl` where `request_id` = ?!, 3)->list,
1, "OK: $tbl still contains expected request data" );
}
} # print_and_exit();
# re-register deleted record:
$mech->get_ok('/patient/select_patient/2'); # print_and_exit();
{
$mech->has_tag(
td => 'BROWN',
'OK: expected record found',
);
$mech->follow_link_ok(
# {n => 8}, "Logout $_ via eighth link on page",
{ url_regex => qr(request/add_new/2), },
'follow delete link',
); # print_and_exit();
$mech->has_tag(
td => 'BROWN',
'OK: expected record found',
);
my $yesterday = DateTime->now->subtract(days => 1);
$mech->submit_form(
fields => {
request_number => 3,
specimen => 'BMAT',
referrer_code => 'G1234567',
_referrer => 'Black, DE', # ajax function in form
# add specimen taken date:
year => $yesterday->year,
month => 13, # invalid
day => ( sprintf '%02d', $yesterday->day ),
minute => ( sprintf '%02d', $yesterday->minute ),
hour => ( sprintf '%02d', $yesterday->hour ),
},
); # print_and_exit();
$mech->content_contains(
dfv_format('invalid_date'),
'OK: invalid date detected',
);
$mech->field( month => sprintf '%02d', $yesterday->month );
$mech->submit; # print_and_exit();
# just check specimen taken date:
my $taken = $yesterday->strftime('%d.%m.%Y @ %H:%M');
$mech->content_like(
qr(<input type="text" value="$taken"\s+readonly="readonly" />),
'OK: specimen taken date found',
); # print_and_exit();
$mech->get_ok('/search/do_search?lab_number=3'); # print_and_exit();
$mech->has_tag_like(
td => qr(BROWN, Stan),
'OK: expected record found',
);
# test for absence of original name:
test_out( 'not ok 1 - foo' );
test_fail( +1 );
$mech->has_tag_like( td => qr(GREEN, Alan), 'foo' );
test_test( 'OK: expected record found' );
# test for new specimen type:
$mech->has_tag(
span => 'BMAT',
'OK: expected specimen type found',
); # print_and_exit();
# check 'AUTO' test been automatically requested by specimen code (BMAT):
$mech->content_like(
qr(<span class="test_name">AUTO:</span>\s+<span class="grey">\[pending\]</span>),
'OK: expected lab test automatically requested',
);
# test for absence of original specimen type:
test_out( 'not ok 1 - foo' );
test_fail( +1 );
$mech->has_tag_like( td => qr(PB), 'foo' ); # has_tag_like in case PB not deleted
test_test( 'OK: expected record found' );
=begin # not reusing original request_id now
# prove new request.id is same as old request.id:
my $dbix = get_dbix();
my $new_request_id
= $dbix->query('select id from requests where request_number = ?',3)->list;
is( $new_request_id, 3, 'OK: got expected new request_id' );
# get history:
$mech->get_ok('/history/=/3'); # print_and_exit();
$mech->has_tag_like(
td => qr{deleted record H3/\d{2} \(id: 3\) \[reason: inappropriate request\]},
'OK: expected history output found',
);
=cut
}
{ # amend record to doi:
$mech->get_ok('/request/edit_request/1'); # print_and_exit();
$mech->submit_form(
fields => {
error_code_id => 1,
doi => 1,
},
); # print_and_exit();
my $msg = sprintf get_messages('request_edit')->{edit_success}, 1;
$msg =~ s/([\(\)])/\\$1/g; # need to escape parens or qr fails
$mech->has_tag_like(
p => qr(INFO: $msg),
'OK: edit action succeeded',
);
$mech->get_ok('/history/=/1'); # print_and_exit();
$mech->content_contains(
q!new request option 'doi'!,
'OK: expected history entry found',
);
}
{ # register new record on previous DOI without DOI:
$mech->get_ok('/request/add_new/1'); # print_and_exit();
$mech->submit_form(
fields => {
request_number => 5,
specimen => 'pb',
referrer_code => 'G1234567',
},
); # print_and_exit();
$mech->get_ok('/search/=/6'); # print_and_exit();
$mech->content_contains(
get_messages('patient')->{biohazard},
'OK: expected history entry found',
);
}
do_logout();
