use strict;
# requires case to be reported, with diagnoses in lymphoid category
# also requires sql.lib file with 3 sql queries required by PrognosticIndicator
#------------------------------------------------------------------
package PrognosticIndicator;
# provides necessary env for M::HMRN::PrognosticIndicator
use lib 'lib';
use LIMS::Local::QueryLibrary; # loads 'private' sql src file so can't use M::Roles::Query
use Moose;
with (
'LIMS::Model::Roles::DBIxSimple', # provides lims_dbix() for M::HMRN::PrognosticIndicator
'LIMS::Model::HMRN::PrognosticIndicator',
);
has _patient_id => ( is => 'rw', isa => 'Int');
has sql_lib => ( is => 'ro', isa => 'LIMS::Local::QueryLibrary', lazy_build => 1 );
has lims_cfg => ( is => 'ro', isa => 'HashRef', lazy_build => 1 );
sub patient_id { return shift->_patient_id }
sub _build_lims_cfg { LIMS::Local::Config->instance; }
sub _build_sql_lib {
my $sql_lib = new LIMS::Local::QueryLibrary( { lib => 't/local.sql' } );
return $sql_lib;
}
1;
#------------------------------------------------------------------
package main;
use Test::Builder::Tester;
use Data::Dumper;
use strict;
use warnings;
use Test::More tests => 39;
# use Test::More 'no_plan';
BEGIN {
require 't/test-lib.pl';
}
our ($result);
my $dbix = get_dbix();
my $o = PrognosticIndicator->new(); # warn Dumper $o;
# rebuild tables:
my $sql = $o->sql_lib->retr('hmrn_rebuild_tables'); # warn Dumper $sql;
$sql =~ s/\n//g; # remove new-lines
my @tbls = split ';', $sql;
$dbix->dbh->do($_) for @tbls; # warn Dumper $_ for (split ";\n", $sql);
my @site_opts = (
[ 'mesenteric', 'lower_nodal' ], # 1
[ 'spleen', 'lower_nodal' ], # 2
[ 'mediastinal','upper_nodal' ], # 3
[ 'waldeyer', 'upper_nodal' ], # 4
[ 'thymus', 'upper_nodal' ], # 5
[ 'cns', 'extranodal' ], # 6
[ 'git', 'extranodal' ], # 7
[ 'marrow', 'extranodal' ], # 8
[ 'bulky', 'flag' ], # 9
);
# populate tables:
_populate_tables();
# some default data; tested params =
# ldh, ecog, ct(scan), sweats, wt_loss, fever, extramedullary (sites hashref)
# albumin, lymphs, wbc, hb, plts
my %data = (
lymphoid => {
wbc => 10.2,
ecog => 1,
plts => 317,
wt_loss => 'N',
fever => 'N',
sweats => 'Y',
ct => 'Y', # required by almost all
albumin => 41,
hb => 12.7,
ldh => 'normal',
lymphs => 5.0,
},
site_opts => { 6 => 1 }, # just cns
imaging_opts => { $dbix->select('imaging_options',
[ qw(id description option_type) ])->map_hashes('id') },
); # warn Dumper \%data;
{ # Ann Arbour:
_change_diagnosis('FCL'); # change request #1 diagnosis
# default data
$result = _get_prognostic_indicators(\%data);
is($result->{ann_arbor}, 'IEB'); # warn Dumper $result;
# remove B-symptoms:
local $data{lymphoid}{sweats} = 'N';
$result = _get_prognostic_indicators(\%data);
is($result->{ann_arbor}, 'IE'); # warn Dumper $result;
# remove all extramedullary involvement:
local $data{site_opts} = {};
$result = _get_prognostic_indicators(\%data);
is($result->{ann_arbor}, 'I'); # warn Dumper $result;
# add 2 upper-nodal groups:
local $data{site_opts}{5} = 1; # thymus
local $data{site_opts}{4} = 1; # waldeyer
$result = _get_prognostic_indicators(\%data); # warn Dumper \%data;
is($result->{ann_arbor}, 'II[2]'); # warn Dumper $result;
# add lower-nodal group:
local $data{site_opts}{1} = 1; # mesenteric
$result = _get_prognostic_indicators(\%data); # warn Dumper \%data;
is($result->{ann_arbor}, 'III'); # warn Dumper $result;
# add marrow involvment:
local $data{site_opts}{8} = 1; # marrow
$result = _get_prognostic_indicators(\%data);
is($result->{ann_arbor}, 'IV'); # warn Dumper $result;
# add spleen:
local $data{site_opts}{2} = 1; # spleen
$result = _get_prognostic_indicators(\%data);
is($result->{ann_arbor}, 'IVS'); # warn Dumper $result;
# add bulky disease:
local $data{site_opts}{9} = 1; # bulky
$result = _get_prognostic_indicators(\%data);
is($result->{ann_arbor}, 'IVSX'); # warn Dumper $result;
# no ann_arbor:
local $data{lymphoid}{ct} = 'N';
$result = _get_prognostic_indicators(\%data);
is($result->{ann_arbor}, undef); # warn Dumper $result;
}
{ # FLIPI:
# default data (because age > 60):
$result = _get_prognostic_indicators(\%data);
is($result->{flipi}, 'good [1]'); # warn Dumper $result;
{ # local change to diagnosed date to take age < 60:
# _manipulate_diagnosis_date_by_years(15); # changes with time
_manipulate_patient_dob(58); # more robust for future dates
$result = _get_prognostic_indicators(\%data);
is($result->{flipi}, 'good [0]'); # warn Dumper $result;
# _manipulate_diagnosis_date_by_years(0); # '0' to revert
_manipulate_patient_dob(75); # restore to original; more robust for future dates
}
# reduce Hb below 12:
local $data{lymphoid}{hb} = 11;
$result = _get_prognostic_indicators(\%data);
is($result->{flipi}, 'intermediate [2]'); # warn Dumper $result;
# increased ldh:
local $data{lymphoid}{ldh} = 'raised';
$result = _get_prognostic_indicators(\%data);
is($result->{flipi}, 'poor [3]'); # warn Dumper $result;
# force Ann Arbour to stage IV:
local $data{site_opts}{8} = 1; # marrow
$result = _get_prognostic_indicators(\%data);
is($result->{flipi}, 'poor [4]'); # warn Dumper $result;
# make upper_nodal + lower_nodal groups > 4:
local $data{site_opts}{1} = 1; # mesenteric
local $data{site_opts}{2} = 1; # spleen
local $data{site_opts}{3} = 1; # mediastinal
local $data{site_opts}{4} = 1; # waldeyer
local $data{site_opts}{5} = 1; # thymus
$result = _get_prognostic_indicators(\%data);
is($result->{flipi}, 'poor [5]'); # warn Dumper $result;
# no flipi:
local $data{lymphoid}{ct} = 'N';
$result = _get_prognostic_indicators(\%data);
is($result->{flipi}, undef); # warn Dumper $result;
}
{ # IPI:
_change_diagnosis('DLBCL'); # change request #1 diagnosis
local $data{site_opts} = {}; # clear nodal/extranodal involvement
# default data
$result = _get_prognostic_indicators(\%data);
is($result->{ipi}, 'low [0]'); # warn Dumper $result;
# increase ECOG score:
local $data{lymphoid}{ecog} = 2;
$result = _get_prognostic_indicators(\%data);
is($result->{ipi}, 'low-intermediate [1]'); # warn Dumper $result;
# increased ldh:
local $data{lymphoid}{ldh} = 'raised';
$result = _get_prognostic_indicators(\%data);
is($result->{ipi}, 'high-intermediate [2]'); # warn Dumper $result;
# force Ann Arbour to stage IV:
local $data{site_opts}{8} = 1; # marrow
$result = _get_prognostic_indicators(\%data); # warn Dumper \%data;
is($result->{ipi}, 'high [3]');
# $age > 60 && extranodal sites > 1:
local $data{site_opts}{7} = 1; # git; 2nd extranodal site
$result = _get_prognostic_indicators(\%data);
is($result->{ipi}, 'high [4]'); # warn Dumper $result;
# decrease ECOG score to 0:
local $data{lymphoid}{ecog} = 0;
$result = _get_prognostic_indicators(\%data);
is($result->{ipi}, 'high [3]'); # warn Dumper $result;
{ # local change to diagnosed date to take age < 60:
# _manipulate_diagnosis_date_by_years(15); # changes with time
_manipulate_patient_dob(58); # more robust for future dates
$result = _get_prognostic_indicators(\%data);
is($result->{ipi}, 'high-intermediate [2]'); # warn Dumper $result;
# _manipulate_diagnosis_date_by_years(0); # '0' to revert
_manipulate_patient_dob(75); # restore to original; more robust for future dates
}
# no ipi:
local $data{lymphoid}{ecog} = undef;
$result = _get_prognostic_indicators(\%data);
is($result->{ipi}, undef); # warn Dumper $result;
}
{ # HIPI:
_change_diagnosis('Hodgkin'); # change request #1 diagnosis
# default data ($age >= 45 & Gender = M):
$result = _get_prognostic_indicators(\%data);
is($result->{hipi}, 'low-risk [2]'); # warn Dumper $result; exit;
{ # local change to diagnosed date to take age < 45:
# _manipulate_diagnosis_date_by_years(30); # changes with time
_manipulate_patient_dob(43); # more robust for future dates
$result = _get_prognostic_indicators(\%data); # warn Dumper \%data;
is($result->{hipi}, 'low-risk [1]'); # warn Dumper $result;
# _manipulate_diagnosis_date_by_years(0); # '0' to revert
_manipulate_patient_dob(75); # restore to original; more robust for future dates
}
# reduce Hb below 10.5:
local $data{lymphoid}{hb} = 10;
$result = _get_prognostic_indicators(\%data);
is($result->{hipi}, 'mod/high risk [3]'); # warn Dumper $result;
# increase wbc above 15:
local $data{lymphoid}{wbc} = 16;
$result = _get_prognostic_indicators(\%data);
is($result->{hipi}, 'mod/high risk [4]'); # warn Dumper $result;
# reduce albumin below 40:
local $data{lymphoid}{albumin} = 30;
$result = _get_prognostic_indicators(\%data);
is($result->{hipi}, 'mod/high risk [5]'); # warn Dumper $result;
# reduce lymphs below 0.6:
local $data{lymphoid}{lymphs} = 0.5;
$result = _get_prognostic_indicators(\%data);
is($result->{hipi}, 'mod/high risk [6]'); # warn Dumper $result;
# force Ann Arbour to stage IV:
local $data{site_opts}{8} = 1; # marrow
$result = _get_prognostic_indicators(\%data);
is($result->{hipi}, 'mod/high risk [7]'); # warn Dumper $result;
# no hipi:
local $data{lymphoid}{albumin} = undef; # warn Dumper \%data;
$result = _get_prognostic_indicators(\%data);
is($result->{hipi}, undef); # warn Dumper $result;
}
{ # Binet:
_change_diagnosis('B-LPD'); # change request #1 diagnosis
# default data
$result = _get_prognostic_indicators(\%data);
is($result->{binet}, 'A'); # warn Dumper $result;
# add upper nodal (stays at 'A'):
local $data{site_opts}{5} = 1; # thymus
$result = _get_prognostic_indicators(\%data);
is($result->{binet}, 'A'); # warn Dumper $result;
# add lower nodal:
local $data{site_opts}{1} = 1; # mesenteric
$result = _get_prognostic_indicators(\%data);
is($result->{binet}, 'A'); # warn Dumper $result;
# add another upper nodal:
local $data{site_opts}{4} = 1; # waldeyer
$result = _get_prognostic_indicators(\%data);
is($result->{binet}, 'B'); # warn Dumper $result;
# reduce Hb < 10: || $plts < 100) { $binet = 'C' }
local $data{lymphoid}{hb} = 9;
$result = _get_prognostic_indicators(\%data);
is($result->{binet}, 'C'); # warn Dumper $result;
# restore Hb & reduce $plts < 100:
local $data{lymphoid}{hb} = 11;
local $data{lymphoid}{plts} = 80;
$result = _get_prognostic_indicators(\%data);
is($result->{binet}, 'C'); # warn Dumper $result;
# no Binet:
local $data{lymphoid}{plts} = undef;
$result = _get_prognostic_indicators(\%data);
is($result->{binet}, undef); # warn Dumper $result;
}
sub _get_prognostic_indicators {
my $data = shift; # warn Dumper $data;
# create new PrognosticIndicator object to force diagnostic_categories_map change:
my $o = PrognosticIndicator->new(
lims_dbix => $dbix,
_patient_id => 1,
); # warn Dumper $o;
# LIMS::Model::HMRN::PrognosticIndicator requires:
# params_data - HoH containing 'lymphoid' accessor
# initial_scan - HoH containing 'site_opts' accessor
# option_maps - {imaging_options}->{map}
my %params = ( lymphoid => $data->{lymphoid} );
my %i_scan = ( site_opts => $data->{site_opts} );
my %o_maps = ( imaging_options => { map => $data->{imaging_opts} } );
my %h = (
params_data => \%params,
initial_scan => \%i_scan,
option_maps => \%o_maps,
); # warn Dumper \%h;
my $result = $o->prognostic_indicators(\%h);
return $result;
}
=begin - repalced with dob manipulation - future-proof
sub _manipulate_diagnosis_date_by_years {
my $years = shift;
$dbix->update('patient_event',
{ date => DateTime->today->subtract( years => $years )->ymd },
{ patient_id => 1, event_id => 1 }
);
}
=cut
sub _manipulate_patient_dob {
my $years = shift;
$dbix->update('lims_test.patients',
{ dob => DateTime->today->subtract( years => $years )->ymd },
{ id => 1 }
);
}
sub _populate_tables {
my $dbh = $dbix->dbh;
{ # imaging site options (just need a selection):
for (@site_opts) {
$dbh->do(
q!INSERT INTO imaging_options (description,option_type) VALUES (?,?)!,
undef, @$_
);
}
for (1 .. scalar @site_opts) {
$dbh->do( q!INSERT INTO patient_imaging_option VALUES (?,?)!, undef, 1, $_ );
}
}
{ # events
$dbh->do(
qq!INSERT INTO events (id, description) VALUES (?,?)!,
undef, 1, 'diagnosis' );
}
{ # diagnostic categories:
my $categories = _get_diagnostic_categories();
for (@$categories) {
$dbh->do(
qq!INSERT INTO diagnostic_categories (description,category_type)
VALUES (?,?)!, undef, $_, 'sub'
);
}
}
{ # diagnoses:
my $diagnoses = _get_diagnoses();
my $sql = 'select id from diagnostic_categories where description = ?';
while ( my($name,$icdo3) = each %$diagnoses ) { # warn Dumper [$name,$icdo3];
# get diagnostic_category_id:
my $category = $name; # except:
$category =~ s/B-LPD/CLL/;
$category =~ s/FCL/FL/;
$dbix->query($sql, $category)->into(my $id);
$dbix->insert('diagnoses', {
name => $name, icdo3 => $icdo3, diagnostic_category_id => $id,
});
}
}
{ # icdo3_category (simplified version of hilis4):
$dbix->dbh->do(
q!insert into icdo_category(diagnostic_category_id,icdo3)
select diagnostic_category_id,icdo3 from diagnoses!
);
}
{ # patient imaging event:
my %h = (
patient_id => 1, dataset => 1, scan_type => 'ct',
stage => 'initial', date => DateTime->today->ymd,
);
$dbix->insert('patient_imaging_event', \%h);
}
{ # patient event:
$dbix->insert('patient_event',
{ patient_id => 1, event_id => 1, date => DateTime->today->ymd }
);
}
}
sub _change_diagnosis {
my $diagnosis = shift;
$dbix->query('select id from diagnoses where name = ?', $diagnosis)->into(my $id);
$dbix->delete('request_report_detail', { request_id => 1 });
$dbix->insert('request_report_detail', { request_id => 1, diagnosis_id => $id });
}
sub _get_diagnoses {
return {
'B-LPD' => '9823/3', # already have CLL as Lymphoproliferative
FCL => '9690/3',
MZL => '9689/3', # SMZL
Hodgkin => '9652/3',
DLBCL => '9680/3',
MCL => '9673/3',
}
}
sub _get_diagnostic_categories {
return [ qw(CLL FL MZL Hodgkin DLBCL MCL) ];
}
# perlfaq 4 - How do I find the first array element for which a condition is true?
sub _get_array_position_for {
my ($term, $array) = @_; # warn Dumper [$term, $array];
my $index = -1;
for ( my $i = 0; $i < @$array; $i++ ) {
if ( $array->[$i] eq $term ) { # want exact match in this case
$index = $i; # warn $index;
last;
}
}
return $index;
}
