package LIMS::Model::HMRN::PrognosticIndicator;
use Moose::Role;
requires 'patient_id';
use Data::Dumper;
# all previous & current diagnostic categories on this patient:
has diagnostic_categories_map => (is => 'ro', isa => 'HashRef', lazy_build => 1);
# number of nodal & extranodal sites - set in prognostic_indicators():
has involved_sites => (is => 'rw', isa => 'HashRef', default => sub { {} });
# supplied by calling model class & set in prognostic_indicators()
has staging_data => (is => 'rw', isa => 'HashRef', default => sub { {} });
has patient_age => (is => 'rw', isa => 'Int'); # calculated in prognostic_indicators()
has ann_arbor => (is => 'rw', isa => 'Str'); # calculated in ann_arbor()
sub prognostic_indicators {
my $self = shift;
my $args = shift; # warn Dumper $args;
my $dbix = $self->lims_dbix;
# set some internal params for calculations:
my %h = (
params => $args->{params_data},
imaging => $args->{initial_scan},
option_maps => $args->{option_maps},
); # warn Dumper \%h;
$self->staging_data(\%h);
my $patient_id = $self->patient_id;
# set some internal params for calculations:
{ # number of extranodal sites + nodal sites from above & below diaphragm:
my %involved_sites = ( # initialise all 3 regions:
upper_nodal => 0,
lower_nodal => 0,
extranodal => 0,
);
my $sql = $self->sql_lib->retr('hmrn_imaging_options'); # for prognostic_indicator.t
my $sites_map = $dbix->query($sql)->map;
while ( my ($id, $opt_type) = each %$sites_map ) { # warn Dumper [$id, $opt_type];
$involved_sites{$opt_type}++ if $h{imaging}{site_opts}{$id};
} # warn Dumper \%involved_sites;
$self->involved_sites(\%involved_sites);
}
{ # need to calculate age again, as patient object not handed to model:
my $sql = $self->sql_lib->retr('hmrn_calculate_patient_age');
my $ref = $dbix->query($sql, $patient_id)->hash; # warn Dumper $ref;
my @dates = qw(dob diagnosis);
$self->inflate_mysql_dates_to_datetime($ref, \@dates);
my $age = LIMS::Local::Utils::calculate_age(@{$ref}{@dates});
$self->patient_age($age); # warn "AGE: $age";
}
my %indices = ();
# do this 1st as some other calculated indices depend on it:
if ( my $ann_arbor = $self->_calculate_ann_arbor ) {
$indices{ann_arbor} = $ann_arbor;
}
if ( my $binet = $self->_calculate_binet ) {
$indices{binet} = $binet;
}
if ( my $flipi = $self->_calculate_flipi ) {
$indices{flipi} = $flipi;
}
if ( my $hipi = $self->_calculate_hipi ) {
$indices{hipi} = $hipi;
}
if ( my $ipi = $self->_calculate_ipi ) {
$indices{ipi} = $ipi;
}
return \%indices;
}
# calculate Ann-Arbor if HL, FL, DLBCL, EMZL or T-cell (ie not CLL, SMZL, MCL or HCL):
sub _calculate_ann_arbor {
my $self = shift;
my $data = $self->staging_data; # warn Dumper $data;
my $lymphoid_data = $data->{params}->{lymphoid}; # warn Dumper $lymphoid_data;
# all previous & current diagnostic categories:
my $categories_map = $self->diagnostic_categories_map; # warn Dumper $categories_map;
# get hash of involved site names:
my $site_names = $self->_get_involved_sites(); # warn Dumper $site_names;
my $ct = $lymphoid_data->{ct} || 'N'; # avoid uninitialized error
my @categories = qw( Hodgkin FL DLBCL MZL T-lymphoproliferative );
# Ann Arbor calc needs to be one of above, plus had a CT scan:
return unless ( grep $categories_map->{$_}, @categories ) && $ct eq 'Y';
my $i = $self->involved_sites; # numerical representation of site distribution
my $AA;
# marrow involvement, extensive disease or > 1 extranodal site:
if ( $i->{extranodal} > 1 || grep $site_names->{$_}, qw(marrow extensive) ) {
$AA = 'IV'; # number of nodal sites not relevant
}
# both upper & lower diaphragm involved:
elsif ( $i->{upper_nodal} && $i->{lower_nodal} ) { $AA = 'III' }
# either upper or lower diaphragm involved with > 1 group:
elsif ( $i->{upper_nodal} > 1 || $i->{lower_nodal} > 1 ) {
$AA = sprintf 'II[%s]', $i->{upper_nodal} || $i->{lower_nodal};
}
# one group only, or no nodal involvement:
elsif ( ($i->{upper_nodal} + $i->{lower_nodal}) <= 1 ) { $AA = 'I' }
else { $AA = '[Unclassifiable - check data]' } # presumably cocked-up the algorithm!!
$AA .= 'S' if $site_names->{spleen};
$AA .= 'X' if $site_names->{bulky};
# ? needs modifying to contiguous/proximal to nodal site:
$AA .= 'E' if ($i->{extranodal} && $AA !~ /^IV/); # any extranodal & not already IV
$AA .= 'B' if grep $lymphoid_data->{$_} eq 'Y', qw(sweats wt_loss fever);
# some other calculated indices depend on this value:
$self->ann_arbor($AA); # warn Dumper $AA;
return $AA;
}
# calculate IPI if DLBCL or MCL + Ann-Arbor + age:
sub _calculate_ipi {
my $self = shift;
# all previous & current diagnostic categories:
my $categories_map = $self->diagnostic_categories_map;
return unless grep $categories_map->{$_}, qw(DLBCL MCL);
my $data = $self->staging_data;
my $age = $self->patient_age; # warn $age;
my $AA = $self->ann_arbor; # warn $AA;
my $i = $self->involved_sites; # numerical representation of site distribution
my $lymphoid_data = $data->{params}->{lymphoid}; # warn Dumper $lymphoid_data;
my $ecog = $lymphoid_data->{ecog}; # warn $ecog;
my $ldh = $lymphoid_data->{ldh}; # warn $ldh;
my $ipi;
if ( $ldh && (defined $ecog) && $age && $AA ) { # ECOG can be '0'
my $score = 0 # add 1 for each (range 0 to 4):
+ ( $AA =~ /^(III|IV)/ )
+ ( $ecog > 1 )
+ ( $ldh eq 'raised' )
+ ( $age > 60 && $i->{extranodal} > 1 ); # only relevant > 60yr
# works for both IPI & age-adjusted IPI, if age > 60 score cannot be 0,
# so don't need to consider age
my @risk = qw(low low-intermediate high-intermediate high high);
$ipi = sprintf "%s [%s]", $risk[$score], $score; # warn Dumper $ipi;
}
return $ipi;
}
# calculate HIPI if HL:
sub _calculate_hipi {
my $self = shift;
# all previous & current diagnostic categories:
my $categories_map = $self->diagnostic_categories_map;
return unless $categories_map->{Hodgkin};
my $dbix = $self->lims_dbix;
my $sql = 'select gender FROM patients WHERE id = ?';
my $gender = $dbix->query($sql, $self->patient_id)->list || 'U';
my $data = $self->staging_data;
my $age = $self->patient_age;
my $AA = $self->ann_arbor;
my $lymph_data = $data->{params}->{lymphoid};
my $albumin = $lymph_data->{albumin};
my $lymphs = $lymph_data->{lymphs};
my $wbc = $lymph_data->{wbc};
my $hb = $lymph_data->{hb};
my $hipi;
if ( $age && $AA && $gender # plus all 4 params defined:
&& !grep { !defined $lymph_data->{$_} } qw/hb albumin wbc lymphs/ ) {
my $score = 0 # add 1 for each (range 0 to 7):
+ ( $gender eq 'M')
+ ( $age >= 45 )
+ ( $AA =~ /^IV/ )
+ ( $wbc > 15 )
+ ( $hb < 10.5 )
+ ( $lymphs < 0.6 )
+ ( $albumin < 40 ); # = 4g/dL
my $risk = $score <= 2 ? 'low-risk' : 'mod/high risk';
$hipi = sprintf "%s [%s]", $risk, $score;
}
return $hipi;
}
# calculate FLIPI if FL or diffuse FL:
sub _calculate_flipi {
my $self = shift;
# all previous & current diagnostic categories:
my $categories_map = $self->diagnostic_categories_map; # warn Dumper $categories_map;
return unless $categories_map->{FL};
my $data = $self->staging_data; # warn Dumper $data;
my $age = $self->patient_age; # warn $age;
my $AA = $self->ann_arbor; # warn $AA;
my $i = $self->involved_sites; # numerical representation of site distribution
my $lymph_data = $data->{params}->{lymphoid};
my $ldh = $lymph_data->{ldh}; # warn Dumper $ldh;
my $hb = $lymph_data->{hb}; # warn Dumper $hb;
my $ct = $lymph_data->{ct} || 'N'; # avoid uninitialized error
my $flipi;
if ( $age && $AA && $hb && $ldh && $ct eq 'Y' ) {
my @risk = qw(good good intermediate poor poor poor); # for scores 0 - 5
my $score = 0 # add 1 for each (range 0 to 5):
+ ( $age > 60 )
+ ( $hb < 12 )
+ ( $ldh eq 'raised' )
+ ( $AA =~ /^(III|IV)/ )
+ ( $i->{upper_nodal} + $i->{lower_nodal} > 4 );
$flipi = sprintf "%s [%s]", $risk[$score], $score; # warn Dumper $flipi;
}
return $flipi;
}
# BINET for CLL:
sub _calculate_binet {
my $self = shift;
# all previous & current diagnostic categories:
my $categories_map = $self->diagnostic_categories_map;
return unless $categories_map->{CLL};
my $data = $self->staging_data; # warn Dumper $data;
# get hash of involved site names:
my $sites_names = $self->_get_involved_sites();
my $i = $self->involved_sites; # numerical representation of site distribution
my $lymph_data = $data->{params}->{lymphoid};
my $plts = $lymph_data->{plts};
my $hb = $lymph_data->{hb};
my $binet;
if ( $hb && $plts ) {
if ($hb < 10 || $plts < 100) { $binet = 'C' }
else { # 1 for each of neck, axillae, groin, spleen and liver (assumes CLL does not get CT scan)
no warnings 'uninitialized'; # adding undef vals causes error
my $sites = 0 # add numeric data:
+ $i->{upper_nodal}
+ $i->{lower_nodal}
+ $sites_names->{liver};
$binet = $sites >= 3 ? 'B' : 'A';
}
}
return $binet;
}
sub _get_involved_sites {
my $self = shift;
my $data = $self->staging_data; # warn Dumper $data;
# hashref of involved nodal & extranodal opt. ids:
my $site_opts = $data->{imaging}->{site_opts}; # warn Dumper $site_opts;
# map of imaging_options ( id => { description & option_type } ):
my $option_map = $data->{option_maps}->{imaging_options}->{map}; # warn Dumper $option_map;
# get hash of involved site names:
my %sites = map +($option_map->{$_}->{description} => 1), keys %$site_opts; # warn Dumper \%sites;
return \%sites;
}
# get all previous & current diagnostic categories on this patient:
sub _build_diagnostic_categories_map {
my $self = shift; # warn $self->patient_id;
my $dbix = $self->lims_dbix;
my $sql = $self->sql_lib->retr('hmrn_patient_diagnostic_categories');
my $categories = $dbix->query($sql, $self->patient_id)->flat; # warn Dumper $categories;
my %map = map { $_ => 1 } @$categories; # warn Dumper \%map;
return \%map;
}
1;
