#!/usr/bin/perl
use Test::WWW::Mechanize::CGIApp;
use Test::Builder::Tester;
use strict;
use warnings;
use DateTime;
use POSIX;
use Test::More tests => 40;
# use Test::More 'no_plan';
=begin # tests:
=cut
BEGIN {
require 't/test-lib.pl';
}
my $mech = get_mech();
my $dbh;
eval {
$dbh = get_dbh() or die 'no database handle received from get_dbh';
};
warn $@ if $@;
foreach( qw// ) {
drop_and_recreate($_);
}
my $DATE = DateTime->now;
my $dbix = get_dbix();
# switch on section sign-out for all lab sections:
$dbix->update('lab_sections', { has_test_sign_out => 'yes'} );
# remove BMAT from request #1 to allow auto-auth:
$dbix->delete('request_specimen', { request_id => 1, specimen_id => 4 });
# add PB to request #2 to allow flow lab tests:
$dbix->insert('request_specimen', { request_id => 2, specimen_id => 1 });
# add request_external_ref to sample 2:
$dbix->insert('request_external_ref', { request_id => 2,
external_reference => 'block reference here' });
# delete NHS number to force warning:
$dbix->update('patients', { nhs_number => undef }, { id => 1 });
# create guest user:
create_guest_user({ lname => 'guest', fname => 'a' });
do_login();
# screen request #1 as PNH - can auto-authorise:
$mech->get_ok('/screen/do_initial_screen/1?screen_id=2;option_id=1'); # print_and_exit();
# result request #1:
$mech->get_ok('/result/=/1'); # print_and_exit();
{
$mech->form_name('flow_results');
$mech->field( results_summary => 'flow results summary goes here' );
$mech->tick('complete_all_tests', 1, 1);
$mech->submit;
$mech->has_tag(
p => 'INFO: results data update successful',
'OK: results update success message',
);
} # print_and_exit();
# report request #1:
$mech->get_ok('/report/=/1'); # print_and_exit();
{
my %report = (
status => 'default',
authorise => 1,
diagnosis_id => 1,
specimen_quality => 'adequate',
comment => 'comment goes here',
morphology => 'morphology description goes here',
gross_description => 'gross description goes here',
secondary_diagnosis_id => 2,
);
$mech->form_name('reportForm');
$mech->submit_form(fields => \%report);
$mech->submit_form(form_name => 'reportForm'); # print_and_exit();
}
# screen request #2 as AML:
$mech->get_ok('/screen/do_initial_screen/2?screen_id=1;option_id=1'); # print_and_exit();
# result request #1:
$mech->get_ok('/result/=/2'); # print_and_exit();
for ( qw/flow molecular/ ) {
$mech->form_name($_.'_results');
$mech->field( results_summary => $_.' results summary goes here' );
$mech->tick('complete_all_tests', 1, 1);
$mech->submit;
$mech->has_tag(
p => 'INFO: results data update successful',
"OK: $_ results update success message",
);
} # print_and_exit();
# report request #1:
$mech->get_ok('/report/=/2'); # print_and_exit();
{
my %report = (
status => 'new',
diagnosis_id => 2,
comment => 'comment goes here',
biopsy_site => 'lymph node',
specimen_quality => 'adequate',
gross_description => 'gross description goes here',
);
$mech->form_name('reportForm');
$mech->submit_form(fields => \%report);
$mech->submit_form(form_name => 'reportForm'); # print_and_exit();
}
# change user id (to guest, but ok for this purpose) so it can be authorised:
$dbix->update('request_history', { user_id => 2 },
{ request_id => 2, action => 'reported' });
# authorise - by-pass pre-auth check:
$mech->get_ok('/report/=/2?pre-authorisation-check=1'); # print_and_exit();
{
$mech->form_name('reportForm');
$mech->submit_form(fields => { authorise => 1 });
$mech->submit_form(form_name => 'reportForm'); # print_and_exit();
}
do_logout();
# login as guest user:
$mech->submit_form(
fields => { authen_username => 'a.guest', authen_password => 'guessed' },
); # print_and_exit();
# search for reported record #1:
$mech->get_ok('/search/=/1'); # print_and_exit();
{ # warn $mech->text; exit;
my $date_format = $DATE->strftime('%a %d.%b.%Y');
$mech->text_contains(
'reported on a peripheral blood specimen',
'OK: expected specimen details found',
); # print_and_exit();
{
my $date_format # clone this or it changes original
= $DATE->clone->subtract(days => 1)->strftime('%a %d.%b.%Y');
$mech->text_contains(
'taken ' . $date_format,
'OK: expected specimen taken details found',
); # print_and_exit();
}
{
my $date_format = $DATE->strftime('%a %d.%b.%Y');
$mech->text_contains(
'received ' . $date_format,
'OK: expected registration details found',
); # print_and_exit();
}
$mech->text_contains(
'1. RAEB [9983/3]',
'OK: primary diagnosis found',
);
$mech->text_contains(
'2. CLL [9823/3]',
'OK: secondary diagnosis found',
);
$mech->content_lacks(
'comment goes here',
'OK: comment suppressed by diagnosis',
);
$mech->has_tag(
pre => 'morphology description goes here',
'OK: morphology description found',
);
$mech->has_tag(
pre => 'flow results summary goes here',
'OK: flow summary found',
);
# don't want to follow this as it will hit HMRN web-site, just see if it exists:
{ # warn $_->url for $mech->followable_links();
my $i = grep { $_->url =~ '/hmrn/info' } $mech->followable_links(); # warn $i;
is ($i, 2, 'OK: 2 HMRN links found'); # both diagnoses are ICDO3
}
$mech->has_tag(
span => 'PLEASE USE THE NHS NUMBER',
'OK: please use NHS number warning found',
);
} # print_and_exit();
# search for reported record #2:
$mech->get_ok('/search/=/2'); # print_and_exit();
{ # warn $mech->text; exit;
$mech->text_contains(
'reported on a lymph node specimen',
'OK: expected biopsy details found',
); # print_and_exit();
$mech->text_contains(
'block reference here',
'OK: expected block reference details found',
); # print_and_exit();
$mech->text_contains(
'of adequate quality',
'OK: expected specimen quality details found',
); # print_and_exit();
{
my $date_format # clone this or it changes original
= $DATE->clone->subtract(days => 1)->strftime('%a %d.%b.%Y');
$mech->text_contains(
'taken ' . $date_format,
'OK: expected specimen taken details found',
); # print_and_exit();
}
{
my $date_format = $DATE->strftime('%a %d.%b.%Y');
$mech->text_contains(
'received ' . $date_format,
'OK: expected registration details found',
); # print_and_exit();
}
$mech->has_tag(
span => 'CLL',
'OK: primary diagnosis found',
);
$mech->has_tag(
p => 'comment goes here',
'OK: comment found',
);
$mech->content_lacks( # didn't supply it
'morphology description',
'OK: no morphology description',
);
$mech->content_contains(
'this is a NEW diagnosis',
'OK: new diagnosis text found',
);
$mech->has_tag(
pre => 'molecular results summary goes here',
'OK: molecular summary found',
);
$mech->has_tag(
pre => 'flow results summary goes here',
'OK: flow summary found',
);
} # print_and_exit();
{ # check links (skip HMRN) - logout link causes logout so so last:
my @links = $mech->find_all_links( url_regex => qr{localhost}); # not a name or css
# warn Dumper $_->url for @links;
# warn Dumper grep $_->url !~ 'hmrn', @links;
# print_record link will throw wkhtmltodpf QPixmap error if no x-server running:
$mech->links_ok( [ grep $_->url !~ 'hmrn|print', @links ], 'OK: nav links checked' );
}
=begin # uncomment to generate long phrases for result summary & comment:
do_login(); # login as lab user:
{ # cosmetic views - word-wrapping on long passages:
$mech->get_ok('/result/=/2'); # print_and_exit();
# flow result:
my $str = q!Lymphoid cells identified with strong CD45 expression and low !
. q!side scatter properties were gated and account for approx. 22% of marrow !
. q!events. The lymphoid comprise 34% T cells (CD2+,CD3+), 5% NK cells !
. q!(CD2+,CD3-,CD56+) and 58% B cells (CD19+,CD20+,CD22+,CD79B+). The B cells !
. q!express CD38 and are Kappa light chain restricted. CD5, CD10, and CD23 !
. qq!antigens are negative.\n\nIn addition, approx. 1-2% of marrow events are !
. q!plasma cells(strong CD38, weak CD45) which lack CD19.!;
$mech->form_name('flow_results');
$mech->submit_form(fields => { results_summary => $str }); # print_and_exit();
}
{
$mech->get_ok('/report/=/2'); # print_and_exit();
# morphology:
my $str = q!Excellent bone marrow aspirate which is mildly hypercellular and !
. qq!shows trilineage haematopoiesis with 22% atypical lymphocytes.\n!
. q!Findings suggest bone marrow infiltration with a low grade NHL best in !
. q!keeping with lymphoplasmacytic. Note cohesive islands of cells with !
. q!blastic appearence and blue nucleoli very suggestive of metastatic !
. qq!carcinoma (note history of metastaic prostate carcinoma).!;
$mech->form_name('reportForm');
$mech->submit_form(fields => { morphology => $str });
$mech->submit_form(form_name => 'reportForm'); # print_and_exit();
}
# login as guest user:
do_logout();
$mech->submit_form(
fields => { authen_username => 'a.guest', authen_password => 'guessed' },
); # print_and_exit();
{
$mech->get_ok('/search/=/2'); print_and_exit();
}
=cut
