• Files
• Commits
• Log
• Graph
• Stats

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 SQL::Library;
use Moose;
with (
	'LIMS::Model::Roles::DBIxSimple',
	'LIMS::Model::HMRN::PrognosticIndicator',
);
has _patient_id => ( is => 'rw', isa => 'Int'); 
has lims_dbix   => ( is => 'ro', isa => 'DBIx::Simple' ); # not always required
has sql_lib     => ( is => 'ro', isa => 'SQL::Library', lazy_build => 1 );

sub patient_id { return shift->_patient_id }

sub _build_sql_lib {
    my $sql_lib = new SQL::Library( { 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;
$dbix->dbh->do($_) for (split ";\n" ,$sql); # warn Dumper $_ for (split ";\n", $sql);

# 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,
    },
    staging => {
        cns         => 1,
        git         => 0,
        waldeyer    => 0,
        spleen      => 0,
        thymus      => 0,
        mesenteric  => 0,
        mediastinal => 0,
    },
);

{ # 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{staging} = {};
    $result = _get_prognostic_indicators(\%data);    
    is($result->{ann_arbor}, 'I'); # warn Dumper $result;
    
    # add 2 upper-nodal groups:
    local $data{staging}{thymus} = 1; # can't 'map' these !!
    local $data{staging}{waldeyer} = 1;
    $result = _get_prognostic_indicators(\%data);    
    is($result->{ann_arbor}, 'II[2]'); # warn Dumper $result;
    
    # add lower-nodal group:
    local $data{staging}{mesenteric} = 1; # warn Dumper \%data;
    $result = _get_prognostic_indicators(\%data);    
    is($result->{ann_arbor}, 'III'); # warn Dumper $result;
    
    # add marrow involvment:
    local $data{staging}{marrow} = 1; # warn Dumper \%data;
    $result = _get_prognostic_indicators(\%data);    
    is($result->{ann_arbor}, 'IV'); # warn Dumper $result;
    
    # add spleen:
    local $data{staging}{spleen} = 1; # warn Dumper \%data;
    $result = _get_prognostic_indicators(\%data);    
    is($result->{ann_arbor}, 'IVS'); # warn Dumper $result;

    # add bulky disease:
    local $data{staging}{bulky} = 1; # warn Dumper \%data;
    $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);
        $result = _get_prognostic_indicators(\%data);    
        is($result->{flipi}, 'good [0]'); # warn Dumper $result;
        _manipulate_diagnosis_date_by_years(0); # '0' to revert
    }

    # 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{staging}{marrow} = 1; # warn Dumper \%data;
    $result = _get_prognostic_indicators(\%data);        
    is($result->{flipi}, 'poor [4]'); # warn Dumper $result;
    
    # make upper_nodal + lower_nodal groups > 4:
    local $data{staging}{mediastinal} = 1; # can't 'map' these !!
    local $data{staging}{mesenteric}  = 1;
    local $data{staging}{waldeyer}    = 1;
    local $data{staging}{thymus}      = 1; 
    local $data{staging}{spleen}      = 1; 
    $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
 
    # 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{staging}{marrow} = 1; # warn Dumper \%data;
    $result = _get_prognostic_indicators(\%data);        
    is($result->{ipi}, 'high [3]'); # warn Dumper $result;

    # $age > 60 && extranodal sites > 1:
    local $data{staging}{git} = 1; # 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);
        $result = _get_prognostic_indicators(\%data);    
        is($result->{ipi}, 'high-intermediate [2]'); # warn Dumper $result;
        _manipulate_diagnosis_date_by_years(0); # '0' to revert
    }

    # 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);
        $result = _get_prognostic_indicators(\%data);    
        is($result->{hipi}, 'low-risk [1]'); # warn Dumper $result;
        _manipulate_diagnosis_date_by_years(0); # '0' to revert
    }
    
    # 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{staging}{marrow} = 1; # warn Dumper \%data;
    $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{staging}{thymus} = 1;
    $result = _get_prognostic_indicators(\%data);    
    is($result->{binet}, 'A'); # warn Dumper $result;
    
    # add lower nodal:
    local $data{staging}{mesenteric} = 1;
    $result = _get_prognostic_indicators(\%data);    
    is($result->{binet}, 'A'); # warn Dumper $result;

    # add another upper nodal:
    local $data{staging}{waldeyer} = 1;
    $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;
    
    # create new PrognosticIndicator object to force diagnostic_categories_map change:
    my $o = PrognosticIndicator->new(
        lims_dbix => $dbix,
        _patient_id => 1,
    ); # warn Dumper $o;
    my $result = $o->prognostic_indicators({params_data => $data});
    return $result;
}

sub _manipulate_diagnosis_date_by_years {
    my $years = shift;
    
    $dbix->update('patient_chronologies', 
        { diagnosed => DateTime->today->subtract( years => $years )->ymd },
        { patient_id => 1 }
    );
}

sub _populate_tables {
    my $dbh = $dbix->dbh;
    
    { # staging locations (just need a selection):
        my @sites = (
        [ 'mesenteric', 'lower_nodal' ],
        [ 'spleen',     'lower_nodal' ],
        [ 'mediastinal','upper_nodal' ],
        [ 'waldeyer',   'upper_nodal' ],
        [ 'thymus',     'upper_nodal' ],
        [ 'cns',        'extranodal'  ],
        [ 'git',        'extranodal'  ],
    );
        for (@sites) {
            $dbh->do(
                qq!INSERT INTO staging_sites (description,location) VALUES (?,?)!,
                undef, @$_
            );
        }
    }
    { # 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 chronology (for age):
        $dbix->insert('patient_chronologies',
            { patient_id => 1, diagnosed => 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', { request_id => 1 });
    $dbix->insert('request_report', { 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;
}