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;