#!/usr/bin/perl
# Notes:
# Needs an up-to-date hmrn database. The setup/hmrn.sql file is outdated
# though Needs bootstrapping with a dump of a live db or theres nothing to
# test
use Test::WWW::Mechanize::CGIApp;
use strict;
use warnings;
use Test::More;
use constant TESTS => 264;
use Data::Printer alias => 'ddp';
=begin: tests:
=cut
BEGIN {
require 't/test-lib.pl';
}
print_msg('Setting up');
my $mech = get_mech();
my $dbh;
eval {
$dbh = get_dbh() or die 'no database handle received from get_dbh';
};
warn $@ if $@;
my $dbix = get_dbix();
my $validation_profiles = get_validation_profiles(); # ddp $validation_profiles;
{ # create new HMRN parent:
my %h = (
parent_code => 'RR8',
description => 'LTH',
referral_type_id => 3,
);
$dbix->insert('parent_organisations', \%h) or die $dbix->error;
}
{ # create new HMRN source of new parent:
$dbix->select('parent_organisations', 'id',
{ parent_code => 'RR8' })->into(my $id);
my %h = (
parent_organisation_id => $id,
organisation_code => 'RR813',
referral_type_id => 3,
display_name => 'SJUH',
);
$dbix->insert('referral_sources', \%h) or die $dbix->error;
}
{ # create hmrn permission:
my %h = (
function_name => 'edit_clinical_data',
function_detail =>'view & edit HMRN data',
);
$dbix->insert('user_functions', \%h);
}
{ # update user access permissions:
$dbix->select('user_functions', 'id',
{ function_name => 'edit_clinical_data' })->into(my $id);
$dbix->insert('user_group_function', { group_id => 1, function_id => $id });
}
do_hmrn_data();
print_msg('Log in');
do_login();
print_msg('Registering new patient');
# register new patient_case + request:
$mech->get_ok('/patient/select_patient/2');
{
$mech->submit_form(
fields => {
unit_number => 2233,
referral_source_id => 5,
},
); # print_and_exit();
$mech->submit_form(
fields => {
request_number => 3,
referrer_code => 'C9999998',
specimen => 'PB',
},
); # print_and_exit();
$mech->has_tag(
h3 => 'New request successful',
);
}
# screen it:
print_msg('Screening');
$mech->get_ok('/screen/do_initial_screen/3?screen_id=1;option_id=1');# print_and_exit();
# report it:
print_msg('Reporting');
$mech->get_ok('/report/=/3'); # print_and_exit();
{
# test missing:
my %report = (
status => 'default',
confirm_outstanding_tests => 1,
clinical_details => 'some details here',
gross_description => 'gross description here',
specimen_quality => 'adequate',
diagnosis_id => 1,
);
$mech->form_name('reportForm');
$mech->submit_form(fields => \%report); # print_and_exit();
$mech->submit_form(form_name =>'reportForm') if is_spell_check_required();
lacks_dfv_errors(); # print_and_exit();
}
# authorise it:
print_msg('Authorising');
{
# manually change reporter's id:
$dbix->update( 'request_history',
{ user_id => 2 }, { action => 'reported', request_id => 3 },
);
$mech->get_ok('/report/=/3?pre-authorisation-check=1'); # print_and_exit();
$mech->form_name('reportForm');
$mech->field( confirm_outstanding_tests => 1 );
$mech->field( authorise => 1 );
$mech->submit_form(); # print_and_exit();
$mech->submit_form(form_name =>'reportForm') if is_spell_check_required();
lacks_dfv_errors(); # print_and_exit();
}
# =========================== MAIN TESTS ========================================
# add some HMRN data:
my %precursor_values = (
#Unique data: -----
#..no unique data
#Shared data: -----
ecog => 1,
wbc => 6.0,
hb => 20.0,
plts => 300,
lymphs => 5.0,
pcv => 65,
neutrophils => 2.0,
monocytes => 1.0,
);
my $precursor_required = $validation_profiles->hmrn_precursor->{required};
my %myeloid_values = ( # *** excluding fields shared with precursor **** :
#Unique data: -----
pcv => 60.0,
epo => 'low',
splenomegaly => 'Y',
hepatomegaly => 'N',
detection_spleen => 'both',
detection_liver => 'both',
karyotype => 'good',
cd34 => 12.0,
transfusion => 'N',
cytopenias => 1,
#Shared data: -----
ecog => 1,
wbc => 6.0,
hb => 20.0,
pcv => 65.0,
lymphs => 5.0,
neutrophils => 2.0,
monocytes => 1.0,
plts => 300,
);
my $myeloid_required = $validation_profiles->hmrn_myeloid->{required};
my %lymphoid_values = (
#Unique data: -----
bm => 'N',
sweats => 'N',
fever => 'N',
wt_loss => 'N',
ct => 'N',
scans => 'CT and PET',
binet => 'A',
stage => 'I',
ldh => 'low',
#Shared data: -----
ecog => 1,
pcv => 65.0,
monocytes => 1.0,
wbc => 6.0,
hb => 20.0,
lymphs => 5.0,
plts => 300,
neutrophils => 2.0,
paraprotein => 'IgA',
albumin => '60',
b2m => '45.0',
pp_level => 60.0,
igs => 'normal',
);
my $lymphoid_required = $validation_profiles->hmrn_lymphoid->{required};
my %plasmacell_values = (
#Unique data: -----
bence_jones => 'both',
serum_flc => 'both',
bone_disease => 'equivocal',
bone_lesions => 'multiple',
mri => 'N',
skeletal_survey => 'N',
serum_kappa => 40.0,
serum_lambda => 45.0,
kappa_lambda_ratio => 50.0,
creatinine => 55,
calcium => 65.0,
#Shared data: -----
paraprotein => 'IgA',
igs => 'normal',
ecog => 1,
plts => 300,
neutrophils => 2.0,
monocytes => 1.0,
pp_level => 60,
b2m => '45',
hb => 20.0,
albumin => '60',
wbc => 6.0,
pcv => 65.0,
lymphs => 5.0,
);
my $plasmacell_required = $validation_profiles->hmrn_plasmacell->{required};
{ # tests to add full data to each category, one at a time,
# after adding the data category, test deleting it
clear_params_for_request(3); # clear all existing parameters
$mech->get_ok('/hmrn_data/=/3'); # open the data entry page
my %category_parm_values = (
precursor => \%precursor_values,
myeloid => \%myeloid_values,
lymphoid => \%lymphoid_values,
plasmacell => \%plasmacell_values,
);
while (my ($category_name, $params_vals_ref) = each(%category_parm_values)) {
print_msg("TEST - Adding full data to $category_name");
$mech->form_name( $category_name );
$mech->submit_form( fields => $params_vals_ref );
test_edited_msg( $category_name );
print_msg("TEST - Params all exist for $category_name");
my @params = get_params_for_category( $category_name );
test_form_has_param_values( $category_name, \@params);
# test delete category
print_msg("TEST - Deleting params from $category_name");
test_delete_category_simple($category_name);
test_form_ismissing_param_values($category_name, \@params);
}
}
{ # testing deleting precursor category, warning against deleting unique data from
# the myloid category that shares data with it.
print_msg("Prepare to test deleteing shared data - clear data now");
clear_params_for_request(3); # clear all existing parameters
{ # populate myloid category, which also populates precursor category
# due to shared data
print_msg("TEST - Submit full myeloid data");
$mech->form_name('myeloid');
$mech->submit_form(fields => \%myeloid_values);
test_edited_msg('myeloid');
}
print_msg("TEST - Try to delete precursor section with shared data in myeloid");
$mech->get_ok('/hmrn_data/delete_section_data/3/precursor'); # print_and_exit;
{ # warn $mech->text;
$mech->text_contains(
'deleting data items from the PRECURSOR section will also remove them from other sections',
'OK: warning 1 located',
);
$mech->text_contains(
'sections highlighted in red also contain additional (non-shared) data ',
'OK: warning 2 located',
);
}
# provide confirmation:
{
print_msg("Provide delete confirmation");
$mech->tick(confirm_delete => 1);
$mech->submit(); # print_and_exit();
print_msg("TEST - Delete confirmed");
test_deleted_msg('precursor');
}
{ # check all precursor data gone and non-shared still exists:
# precursor fields:
print_msg("TEST - Ensure all precursor data has gone");
$mech->form_name('precursor');
my @precursor_params = get_params_for_category('precursor'); # p \@precursor_params;
for my $param(@precursor_params) { # p [ $param, $mech->value($param) ];
my $result = $mech->value($param) ? 1 : 0; # just need existance
is($result, 0, "OK: precursors.$param value deleted");
}
# myeloid fields:
print_msg("TEST - Ensure all myloid data shared with precursor data has gone");
$mech->form_name('myeloid');
for my $param(@precursor_params) { # p [ $param, $mech->value($param) ];
my $result = $mech->value($param) ? 1 : 0; # just need existance
is($result, 0, "OK: shared myeloid.$param value deleted");
}
print_msg("TEST - Ensure all myloid's unique data has been retained");
my @myeloid_params = get_params_for_category('myeloid'); # p \@myeloid_params; # didn't add all
for my $param(@myeloid_params) {
next if (grep {$_ eq $param} @precursor_params); # skip precursor parametets
my $result = $mech->value($param) ? 1 : 0; # just need existance
is($result, 1, "OK: unique myeloid.$param value retained");
}
}
}
{ # test required values
print_msg("TEST - Test submitting with each required field missing");
test_form_required_values('precursor', \%precursor_values, $precursor_required);
test_form_required_values('myeloid', \%myeloid_values, $myeloid_required);
test_form_required_values('lymphoid', \%lymphoid_values, $lymphoid_required);
test_form_required_values('plasmacell', \%plasmacell_values, $plasmacell_required);
}
#####################################################
## IN PROGRESS #
#####################################################
#{ # test ranges and defaults
#
# print_msg("TEST (IN PROGRESS) - Test myeloid ranges...");
#
# my $category = 'myeloid';
# my %modified_values = %myeloid_values;
#
# my $sql = "SELECT p.param_name, dr.min_value, dr.max_value,
# dr.not_stated, dr.not_done
# FROM category_parameter cp
# JOIN categories c ON cp.category_id=c.id
# JOIN defaults_and_ranges dr ON cp.parameter_id=dr.param_id
# JOIN parameters p ON cp.parameter_id=p.id
# WHERE c.category=?;";
#
# clear_params_for_request(3); # clear all existing parameters
# $mech->get_ok('/hmrn_data/=/3'); # open the data entry page
#
#
# for my $range_hashref ( $dbix->query($sql, $category)->hashes ) {
#
#p $range_hashref;
#
# my $param_has_range = $range_hashref->{param_name}; # parameter in this category that has a range
# my $original_value = $modified_values{$param_has_range}; # keep orignal value for this param to reset it later
# my $range_string = "[" . $range_hashref->{min_value} . " to " . $range_hashref->{max_value} . "]";
#
# # Modify value to be 0.1 under the minimum acceptable value and submit
# $modified_values{$param_has_range} = $range_hashref->{min_value} - 0.1;
#
# $mech->form_name($category);
# $mech->submit_form(fields => \%modified_values);
# $mech->content_contains('FORM FAILED VALIDATION',
# "OK: $modified_values{$param_has_range} out of range "
# . "$range_string for $category.$param_has_range"); #may need to edit this to check for something different
#### test_edited_msg($category);
#
# # reset to original value after finished testing this param
# $modified_values{$param_has_range} = $original_value;
#
# }
#
#}
#####################################################
## END OF 'IN PROGRESS' #
#####################################################
done_testing(TESTS);
print_msg("END");
sub test_form_required_values {
# Checkes each required field in a form to make sure we get a validation error if it's not there.
my($category_name, $values_href, $req_params_aref) = @_ ;
clear_params_for_request(3); # clear all existing parameters
$mech->get_ok('/hmrn_data/=/3'); # open the data entry page
my %modified_values = %$values_href;
for my $req_param (@$req_params_aref) {
$modified_values{$req_param} = undef;
$mech->form_name($category_name);
$mech->submit_form(fields => \%modified_values);
$mech->content_contains('FORM FAILED VALIDATION',
"OK: form validation failed for missing $category_name.$req_param",);
# reset modified value
$modified_values{$req_param} = $values_href->{$req_param};
}
}
sub test_delete_category_simple {
#deletes a category using the delete URL, doesn't check for confirmation messages
my $category = shift;
$mech->get_ok("/hmrn_data/delete_section_data/3/$category"); # print_and_exit;
$mech->tick(confirm_delete => 1);
$mech->submit();
test_deleted_msg($category);
}
sub test_deleted_msg {
my $deleted_category = shift;
my $msg = get_messages('action')->{delete_success};
$mech->has_tag_like(
p => qr(INFO: $msg),
"OK: delete $deleted_category action succeeded",
);
}
sub test_edited_msg {
my $edited_category = shift;
my $msg = get_messages('action')->{edit_success};
$mech->has_tag_like(
p => qr(INFO: $msg),
"OK: edit $edited_category action succeeded",
);
}
sub test_form_has_param_values {
# Tests if a given array of params have values in the given form
my($form_name, $param_aref) = @_ ;
#report caller in test output
local $Test::Builder::Level = $Test::Builder::Level + 1;
$mech->form_name($form_name);
for my $param(@$param_aref) {
my $result = $mech->value($param) ? 1 : 0; # just need existance
is($result, 1, "OK: $form_name.$param value loaded");
}
}
sub test_form_ismissing_param_values {
# Tests if a given array of params have values in the given form
my($form_name, $param_aref) = @_ ;
$mech->form_name($form_name);
for my $param(@$param_aref) {
my $result = $mech->value($param) ? 1 : 0; # just need existance
is($result, 0, "OK: $form_name.$param has no value");
}
}
sub clear_params_for_request { # JD - Clears the parameters for a given request
my $request_id = shift;
my $sql = q!select patient_id from patient_case pc join requests r on
r.patient_case_id = pc.id where r.id = ?!;
$dbix->query($sql, $request_id)->into(my $patient_id);
$dbix->delete('hmrn_test.patient_params', { patient_id => $patient_id });
}
sub get_params_for_category {
my $category = shift;
my $sql = q!select param_name from hmrn_test.parameters p join
hmrn_test.category_parameter cp on cp.parameter_id = p.id join
hmrn_test.categories c on cp.category_id = c.id where c.category = ?!;
my @params = $dbix->query($sql, $category)->flat; # \p @params;
return wantarray ? @params : \@params;
}
# Prints out a message
sub print_msg {
my $msg = shift;
print "\n" . '-' x 10 . ' ' . $msg . "\n";
}
