• Files
• Commits
• Log
• Graph
• Stats

package LIMS::Model::HMRN;

use Moose;
with 'LIMS::Model::Roles::DBIxSimple';
extends 'LIMS::Model::Base';
use MooseX::AttributeHelpers;
use namespace::clean -except => 'meta';

has actions => (
    is         => 'ro',
    isa        => 'ArrayRef[Str]',
    default    => sub { [] },
    lazy    => 1,
	traits  => ['Array'],
	handles => {
		add_to_actions => 'push',
		all_actions    => 'elements',
	},
);

__PACKAGE__->meta->make_immutable;

use LIMS::Local::Utils;
use Data::Dumper;

# ------------------------------------------------------------------------------
sub has_data {
    my ($self, $patient_id) = @_; # warn $patient_id;
    
	my $dbix = $self->lims_dbix;
    
    # minimum data set for hmrn is mdt or chronology:
    for ( qw/chronologies mdt_dates/ ) {
        my $tbl = 'hmrn.patient_' . $_;        
        return 1 if $dbix->query( "SELECT 1 FROM $tbl WHERE patient_id = ?",
            $patient_id )->list;
    }
    return 0;
}

# ------------------------------------------------------------------------------
sub get_all_hmrn_data {
    my ($self, $patient_id) = @_; # warn $patient_id;
    
	my $dbix = $self->lims_dbix;
    
    # switch db:
    # $dbix->dbh->do('use hmrn'); # needs reversing or get fatal error downstream
    
    my $hmrn_data = {};
    
    { # chronologies:
        my $sql = q!select * from hmrn.patient_chronologies where patient_id = ?!;
        my $data = $dbix->query($sql, $patient_id)->hash; # warn Dumper $dates;
        
		my $meta = $self->get_meta('hmrn.patient_chronologies'); # warn Dumper $meta;
		my @date_cols = grep { $meta->{$_}->{type} eq 'date' } keys %$meta; # warn Dumper \@date_cols;
		
        # convert MySQL dates to dt objects:
		$self->inflate_mysql_dates_to_datetime($data, \@date_cols);

        # provide an age calculation callback:
        $data->{calculate_age} = sub {
            LIMS::Local::Utils::calculate_age(@_);
        };
        
        $hmrn_data->{chronology} = $data; 
    }
    { # add mdt data to chronologies:
        my $sql = q!select id, date from hmrn.patient_mdt_dates where 
            patient_id = ? order by date!;
        my $dates = $dbix->query($sql, $patient_id);
        while ( my $vals = $dates->hash ) {	# inflate 'date' val to DT object:
			$self->inflate_mysql_dates_to_datetime($vals, ['date']);
            push @{ $hmrn_data->{chronology}->{mdt_dates} }, $vals;
        }
    }
	{ # antecendent event data:
		my $sql = q!select event_id from hmrn.patient_antecedent where patient_id = ?!;
		my $event_id = $dbix->query($sql, $patient_id)->list;
		$hmrn_data->{antecedent}{event_id} = $event_id;
	}
	{	# get previous therapies:
		my $sql = q!select therapy from hmrn.patient_prior_therapies where patient_id = ?!;
		my $tx = $dbix->query($sql, $patient_id)->flat; # warn Dumper $tx;
		my %data = map { $_ => 1 } @$tx; # warn Dumper \%data;
		$hmrn_data->{antecedent}{prior_tx} = \%data; # part of antecedent/prior tx set
	}
	{ # treatment details:
		my $sql  = $self->sql_lib->retr('hmrn_patient_treatment_data');
		my $tx = $dbix->query($sql, $patient_id);
		while ( my $vals = $tx->hash ) { # warn Dumper $vals; # dates to datetime:
			$self->inflate_mysql_dates_to_datetime($vals, [ qw(start_date end_date) ]);
			push @{ $hmrn_data->{treatments} }, $vals; # add to treaments array
		}
	}
    { # get select option maps:
		my $select_option_data = $self->_get_select_option_data();
		$hmrn_data->{maps} = $select_option_data;
	}
	
	return $hmrn_data;
}

#-------------------------------------------------------------------------------
sub get_mdt_data {
	my ($self, $id) = @_;
	
	my $dbix = $self->lims_dbix;
	
	my $data
		= $dbix->query('select * from hmrn.patient_mdt_dates where id = ?', $id)->hash;

	# inflate 'date' val to DT object:
	$self->inflate_mysql_dates_to_datetime($data, ['date']);

	return $data;
}

#-------------------------------------------------------------------------------
sub get_treatment_data {
	my ($self, $id) = @_;
	
	my $dbix = $self->lims_dbix;
	
	my $data
		= $dbix->query('select * from hmrn.patient_treatment where id = ?', $id)->hash;

	# inflate dates:
	$self->inflate_mysql_dates_to_datetime($data, [ qw(start_date end_date) ]);
	
    { # get select option maps (don't need antecedent data, but all rest req'd):
		my $select_option_data = $self->_get_select_option_data();
		$data->{maps} = $select_option_data;
	}
	{ # treatment details for treatment_type:
		my $sql = q!select id,description from hmrn.treatment_details where type_id = ?!;
		my $tx_details = $dbix->query($sql, $data->{tx_type_id})->map;
		# tx_details is ajax function in original form, so not loaded in _get_select_option_data()
		$data->{maps}->{tx_details} = $tx_details; 
	}

	return $data;
}

#-------------------------------------------------------------------------------
sub new_treatment_data {
	my $self = shift;
	my $args = shift; # warn Dumper $args;
	
	my $tbl = 'hmrn.patient_treatment';
	
	my $meta = $self->get_meta($tbl); # warn Dumper $meta;
	
	my @cols = grep { $_ !~ /\A(id|timestamp)\Z/ } keys %$meta; # warn Dumper \@cols;

	my %data = map {
		$_ => $args->{$_};
	} grep $args->{$_}, @cols; warn Dumper \%data; return 1;
	
	my $dbix = $self->lims_dbix;
	
	my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;

	my $new = sub {
		$dbix->insert($tbl, \%data);
		$self->add_to_actions('added new treatment dataset');
		$self->do_history($data{patient_id});
	};
	
	my $ok = $db->do_transaction($new); 
	
	# don't need return value unless error:
    return $ok ? 0 : 'new_treatment_data() error - ' . $db->error;	
}

#-------------------------------------------------------------------------------
sub update_treatment_data {
	my $self = shift;
	my $args = shift; # warn Dumper $args;
	
	my $tbl = 'hmrn.patient_treatment';
	
	my $meta = $self->get_meta($tbl); # warn Dumper $meta;
	
	# get patient_treatment data cols (ie not PK, timestamp, patient_id):	
	my @cols = grep { $_ !~ /\A(id|patient_id|timestamp)\Z/ } keys %$meta; # warn Dumper \@cols;
	# date cols:
	my @date_cols = grep $meta->{$_}->{type} eq 'date', keys %$meta; # warn Dumper \@date_cols;
	
	$args->{$_} = LIMS::Local::Utils::to_datetime_using_datecalc($args->{$_}) 
		for grep $args->{$_}, @date_cols; # warn Dumper $args;

	my $dbix = $self->lims_dbix;

	my $data = $dbix->query("select * from $tbl where id = ?", $args->{id})->hash;
	$self->inflate_mysql_dates_to_datetime($data, \@date_cols); # inflate $data dates
	
	my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;

	my $update = sub {
		my @updates = ();
		# non-date cols:
		COL: for my $col(@cols) {
			next COL if $meta->{$col}->{type} eq 'date'; # skip date cols - done later
			
			my $new = $args->{$col};
			my $old = $data->{$col};
			
			if ($new && $old && $new ne $old) { # changed
				push @updates, ( $col => $new );
				$self->add_to_actions("updated treatment $col [id = $args->{id}]");
			}
			elsif ($new && ! $old) {
				push @updates, ( $col => $new );
				$self->add_to_actions("added new treatment $col [id = $args->{id}]");
			}
			elsif ($old && ! $new) {
				push @updates, ( $col => undef );
				$self->add_to_actions("deleted treatment $col [id = $args->{id}]");
			}
			else { next COL } # both same or null so skip
		}
		# date cols:
		COL: for my $col(@date_cols) {
			my $new = $args->{$col}; # warn $new->datetime
			my $old = $data->{$col}; # warn $old->datetime
			
			if ($new && $old) {
				next COL unless DateTime->compare($old, $new); # true if different
				push @updates, ( $col => $new->ymd );
				$self->add_to_actions("updated treatment $col [id = $args->{id}]");
			}
			elsif ($new && ! $old) {
				push @updates, ( $col => $new->ymd );
				$self->add_to_actions("added new treatment $col [id = $args->{id}]");
			}
			elsif ($old && ! $new) {
				push @updates, ( $col => undef );
				$self->add_to_actions("deleted treatment $col [id = $args->{id}]");
			}
			else { next COL } # both null so skip
		}
		
		if (@updates) { warn Dumper \@updates; warn Dumper [$self->all_actions];
			#$dbix->update($tbl, { @updates }, { id => $args->{id} });
			#$self->do_history($data->{patient_id});
		}
	};
	
	my $ok = $db->do_transaction($update); 
	
	# don't need return value unless error:
    return $ok ? 0 : 'update_treatment_data() error - ' . $db->error;
}

#-------------------------------------------------------------------------------
sub update_mdt_date {
	my $self = shift;
	my $args = shift; # warn Dumper $args;
	
	my $date = LIMS::Local::Utils::to_datetime_using_datecalc($args->{date});
	
	my $tbl = 'hmrn.patient_mdt_dates';
	
	my $dbix = $self->lims_dbix;
	
	my $patient_id
		= $dbix->query("select patient_id from $tbl where id = ?", $args->{id})->list;
	
	my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;

	my $update = sub {
		$dbix->update('hmrn.patient_mdt_dates',
			{ date => $date->ymd },
			{ id => $args->{id} }
		);
		$self->add_to_actions("updated mdt date [id = $args->{id}]");
		$self->do_history($patient_id);
	};
	
	my $ok = $db->do_transaction($update);
	
	# don't need return value unless error:
    return $ok ? 0 : 'update_mdt_date() error - ' . $db->error;
}

#-------------------------------------------------------------------------------
sub delete_mdt_date {
	my ($self, $id) = @_;
	
	my $dbix = $self->lims_dbix;

	my $tbl = 'hmrn.patient_mdt_dates';
	
	my $patient_id
		= $dbix->query("select patient_id from $tbl where id = ?", $id)->list;
	
	my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;

	my $delete = sub {
		$dbix->delete($tbl, { id => $id });
		$self->add_to_actions('deleted mdt date');
		$self->do_history($patient_id);
	};
	
	my $ok = $db->do_transaction($delete);
	
	# don't need return value unless error:
    return $ok ? 0 : 'delete_mdt_date() error - ' . $db->error;
}

#-------------------------------------------------------------------------------
sub get_new_diagnoses {
	my $self = shift;
	my $args = shift;
	
    # get HMRN parent organisation ids:
    my $o = LIMS::DB::LocalNetworkLocation::Manager->get_local_network_locations;
    my @parent_organisation_ids = map { $_->parent_id } @$o;	
	
	# get referral_type.id for practices (saves multi_many_ok flag in query):
	my $ref_type = LIMS::DB::ReferralType->new(description => 'practice')->load;

	my @query = (
		'request_history.action' => 'authorised',
		or => [ # any network hospital or GP practice:
			'parent_organisations.id' => \@parent_organisation_ids,
			'parent_organisations.referral_type_id' => $ref_type->id, # GP's
		],		
		or => [ # ICDO3 or MGUS diagnoses:
			'request_report.diagnosis.icdo3' => { like => '%3' },
			'request_report.diagnosis.icdo3' => '9765/1', # MGUS
		],
	);
	
	{ # calculate requested duration (previous_week, days, date_range, etc):
		my $constraints = $self->_get_hmrn_new_diagnoses_constraints($args);
		push @query, @$constraints;
	}
	
	my @tables = qw( patients diagnoses parent_organisations request_history
		referrers );	
	my $relationships = $self->get_relationships(\@tables);

	my @params = (
		query => \@query,
		require_objects => $relationships,
	);	
	
	my $cases = LIMS::DB::Request::Manager->get_requests(@params);
	
	return $cases;
}

# ------------------------------------------------------------------------------
sub get_patient_demographics {
	my ($self, $patient_id) = @_;
	
	my $data = LIMS::DB::PatientDemographic->new(patient_id => $patient_id)
		->load( with => [ 'referrer', 'practice' ], speculative => 1 );
	
	return $data;
}

# ------------------------------------------------------------------------------
sub update_patient_demographics {
	my ($self, $args) = @_; # warn Dumper $args;
	
	my $patient_id = $args->{patient_id};
	
	my $user_id = $self->user_profile->{id};

	my $o = LIMS::DB::PatientDemographic->new(patient_id => $patient_id);
	
	my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;
	
	my $update = sub {
		if ($o->load_speculative) {
			my $old = $o->clone->as_tree;
			
			# update object with new data:
			map {
				$o->$_($args->{$_})
			} grep $_ ne 'patient_id', keys %$args;
			$o->save(changes_only => 1);
	
			my $new = $o->clone->as_tree;
			my @changed = do {
				no warnings 'uninitialized';
				grep { $new->{$_} ne $old->{$_} } keys %$old; 
			}; # warn Dumper \@new;
			
			for my $field (@changed) {
				my $action  = qq!updated '$field' from $old->{$field}!;
				my %data = (
					patient_id => $patient_id,
					user_id    => $user_id,
					action 	   => $action,
				);
				LIMS::DB::PatientDemographicHistory->new(%data)->save;
			}
		}
		else { # create new:
			map { $o->$_($args->{$_}) } keys %$args;
			$o->save;		
		}
	};
	
	my $ok = $db->do_transaction($update);
	
	# don't need return value unless error:
    return $ok ? 0 : 'update_patient_demographics() error - ' . $db->error;
}

# ------------------------------------------------------------------------------
sub update_antecedent_events {
	my ($self, $args) = @_; # warn Dumper $args;
	
	my $patient_id = $args->{patient_id};
	
	my $dbix = $self->lims_dbix;
	
	my $antecedent_tbl = 'hmrn.patient_antecedent';
	my $prior_tx_tbl   = 'hmrn.patient_prior_therapies';
	
	my $therapy_opts = $self->get_enum_opts($prior_tx_tbl, 'therapy'); # ie Rx, Cx
	
	my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;

	my $update = sub {
		{ # antecedent event:
			my $sql = qq!select * from $antecedent_tbl where patient_id = ?!;
			if ( my $data = $dbix->query($sql, $patient_id)->hash ) { # warn Dumper $data;
				my %data = ( event_id => $args->{event_id} || undef );
				$dbix->update($antecedent_tbl, \%data, { patient_id => $patient_id });
				my $action = $args->{event_id}
					? "updated antecedent event"
					: "deleted antecedent event";
				$self->add_to_actions($action);
			}
			elsif ( my $event_id = $args->{event_id} ) {
				my %data = (
					patient_id => $patient_id,
					event_id   => $event_id,
				);
				$dbix->insert($antecedent_tbl, \%data);
				$self->add_to_actions("added new antecedent event");
			}
		}
		{ # prior therapies:
			my $sql = qq!select therapy from $prior_tx_tbl where patient_id = ?!;
			if ( my $data = $dbix->query($sql, $patient_id)->flat ) { # warn Dumper $data;
				foreach my $tx(@$therapy_opts) {
					my %data = (
						patient_id => $patient_id,
						therapy    => $tx,
					);

					my $new = $args->{$tx};
					my $old = $data->{$tx};
					
					if ( $new && ! $old ) {
						$dbix->insert($prior_tx_tbl, \%data);
						$self->add_to_actions("added new prior Tx $tx");
					}
					elsif ( $old && ! $new ) {
						$dbix->delete($prior_tx_tbl, \%data );
						$self->add_to_actions("deleted prior Tx $tx entry");
					}
					else {} # old & new both same value or null, so skip
				}
			}
			else {
				foreach my $tx(@$therapy_opts) {
					next unless $args->{$tx};
					my %data = (
						patient_id => $patient_id,
						therapy    => $tx,						
					);
					$dbix->insert($prior_tx_tbl, \%data);
					$self->add_to_actions("added new prior Tx $tx");
				}
			}
		}
		$self->do_history($patient_id);
	};
	
	my $ok = $db->do_transaction($update);
	
	# don't need return value unless error:
    return $ok ? 0 : 'update_antecedent_events() error - ' . $db->error;
}

# ------------------------------------------------------------------------------
sub update_patient_chronologies {
	my ($self, $args) = @_; # warn Dumper $args; # patient_id + dates

	my $patient_id = $args->{patient_id};
	
	my $dbix = $self->lims_dbix;
	
	my $table = 'hmrn.patient_chronologies';

	# get date cols in patient_chronologies table:
	my $meta = $self->get_meta($table);
	my @date_cols = grep { $meta->{$_}->{type} eq 'date' } keys %$meta; # warn Dumper \@date_cols;

	my $db = $self->lims_db; # ie LIMS::DB->new_or_cached;

	my $update = sub {
		# get existing chronologies:
		my $sql = qq!select * from $table where patient_id = ?!;
		if ( my $data = $dbix->query($sql, $patient_id)->hash ) { # warn Dumper $data;
			$self->inflate_mysql_dates_to_datetime($data, \@date_cols);
			
			my @updates = ();
			
			COL: for my $col(@date_cols) {
				my $new = $args->{$col}; # in EU format
				my $old = $data->{$col}; # in DT format
				
				if ( $new && $old ) {
					# convert new to DT object:
					my $new_dt = LIMS::Local::Utils::to_datetime_using_datecalc($new);
					
					next COL unless DateTime->compare($old, $new_dt); # true if different
					push @updates, ( $col => $new_dt->ymd );
					$self->add_to_actions("updated date $col");
				}
				elsif ( $old && ! $new ) {
					push @updates, ( $col => undef );
					$self->add_to_actions("deleted date $col");
				}
				elsif ( $new && ! $old ) {
					my $dt = LIMS::Local::Utils::to_datetime_using_datecalc($new);
					push @updates, ( $col => $dt->ymd );
					$self->add_to_actions("added new date $col");
				}
				else { next COL } # ignore if no new or old
			}
			
			if (@updates) { # warn Dumper \@updates;
				$dbix->update($table, { @updates }, { patient_id => $patient_id } );
			}
		}
		else { # insert new data:
			my $cols = keys %$meta;
			my %data = map { $_ => $args->{$_} } @$cols; # warn Dumper \%data;
			$dbix->insert($table, \%data);
			$self->add_to_actions("added new chronology data");
		}
		
		# mdt_date always new (not edited):
		if ( my $mdt_date = $args->{mdt_date} ) {
			my $date = LIMS::Local::Utils::date_to_mysql($mdt_date);
			my %data = (
				patient_id => $patient_id,
				date       => $date,
			); # warn Dumper \%data;
			$dbix->insert('hmrn.patient_mdt_dates', \%data);
			$self->add_to_actions("added new mdt meeting date");
		}
		
		$self->do_history($patient_id);
	};
	
	my $ok = $db->do_transaction($update);
	
	# don't need return value unless error:
    return $ok ? 0 : 'update_patient_demographics() error - ' . $db->error;
}

sub do_history {
	my ($self, $patient_id) = @_;
	
	my @actions = $self->all_actions;
	
	my $dbix = $self->lims_dbix;

	my $user_id = $self->user_profile->{id};
	
	for my $action(@actions) {
		my %data = (
			patient_id => $patient_id,
			user_id    => $user_id,
			action 	   => $action,
		); # warn Dumper \%data;
		$dbix->insert('hmrn.history', \%data);
	}	
}

# ------------------------------------------------------------------------------
sub is_in_outreach {
	my ($self, $patient_id) = @_;
	
	my $dbix = $self->lims_dbix;
	
	my $sql = 'select 1 from outreach.dispatch_details where patient_id = ?';
	return $dbix->query( $sql, $patient_id )->list;	
}

# ------------------------------------------------------------------------------
sub get_tx_details_for_tx_type {
	my ($self, $type_id) = @_;
	
	my $dbix = $self->lims_dbix;

	my $sql = q!select id, description from hmrn.treatment_details where
		type_id = ? order by description!;
	return $dbix->query( $sql, $type_id )->hashes; # array(ref) of hashes
}

# ----------------------- private methods --------------------------------------
sub _get_select_option_data {
	my $self = shift;
	
	my $dbix = $self->lims_dbix;

	my %maps = ();
	
	{ # locations:
		my $locations = $dbix->query(q!select location,id from hmrn.locations!)->map;
		$maps{location} = $locations;
	}
	{ # antecedent events:
		my $antecedent
			= $dbix->query(q!select event,id from hmrn.antecedent_events!)->map;
		$maps{antecedent} = $antecedent;
	}
	{ # treatment types:
		my $tx_types
			= $dbix->query(q!select description,id from hmrn.treatment_types!)->map;
		$maps{tx_type} = $tx_types;
	}
	{ # unique tx_type_ids from treatment_details table:
		my $sql = q!select distinct(type_id) from hmrn.treatment_details!;
		my $unique_tx_type_ids = $dbix->query($sql)->flat; # warn Dumper $unique_tx_type_ids;
		$maps{tx_type_ids} = $unique_tx_type_ids;
	}
	{ # treatment reponses:
		my $opts = $self->get_enum_opts('hmrn.patient_treatment', 'response');		
		$maps{response} = $opts; # warn Dumper $opts;
	}
	
    return \%maps;
}

1;