package LIMS::Local::Billing;
use Moo;
use Data::Printer alias => 'ddp';
use MooX::HandlesVia;
use DateTime::Format::MySQL;
use Types::Standard qw(ArrayRef HashRef);
use LIMS::Local::Utils;
use feature 'say';
#===============================================================================
my $debug = $ENV{DEBUG_ON} || 0; # verbose output for testing
has settings => ( is => 'ro', isa => HashRef, required => 1 );
# keeps track of whether request has a sample type set to BMASEQ:
has bmaseq => (
is => 'rw',
handles_via => 'Hash',
handles => {
get_bmaseq => 'get',
set_bmaseq => 'set',
all_bmaseq => 'keys',
},
default => sub { {} },
);
# hash of molecular sequencing tests:
has mol_seq_tests => (
is => 'lazy',
isa => HashRef,
builder => 1,
);
# list of request ids with BMA/BMAT sample (supplied by caller):
has bone_marrow_requests => (
is => 'rw',
handles_via => 'Hash',
);
# list of private patients:
has private_patients => (
is => 'rw',
handles_via => 'Hash',
);
# rows for billing data file:
has rows => (
is => 'rw',
handles => {
add_row => 'push',
get_all_rows => 'elements', # returns array NOT arrayref
},
default => sub { [] },
handles_via => 'Array',
);
my $delimiter = '|';
sub set_initial_charge_code {
my ($self, $vars) = @_;
my $request_id = $vars->{id};
# non-NHS sources unless in trial/study:
if ( $vars->{organisation_code} =~ /^NT\d{3}|8EQ15/ ) {
$vars->{category} = '04' unless $vars->{category} eq 'ST';
}
# private patient in NHS hospital:
elsif ( $self->private_patients->{$request_id} ) {
$vars->{category} = '02'; # p $request_id;
}
}
sub apply_local_rules {
my ($self, $vars) = @_; # p $vars; exit; # hashref
my $request_id = $vars->{id};
my $lab_tests = $vars->{request_lab_tests};
my $settings = $self->settings;
# override ST code and charge as normal sample:
my $chargable_trials = $settings->{chargable_trials}; # p $chargable_trials;
# get map of higher-charge molecular sequencing tests:
my $mol_seq_tests = $self->mol_seq_tests; # p $mol_seq_tests;
my $has_bone_marrow = $self->bone_marrow_requests->{$request_id};
if (
$vars->{first_name} =~ /\A(lgi|pin)\Z/i ||
$vars->{last_name} =~ /\Ahtg\d+/i
) {
$vars->{first_name} = uc $vars->{first_name};
}
# $vars->{unit_number} = '' if $vars->{unit_number} eq 'UNKNOWN';
# downstream system can't handle d.o.b eg 1/1/1000, replace with NULL:
if ( my $dob = $vars->{dob} ) { # ddp $dob;
my $date = DateTime::Format::MySQL->parse_date($dob);
if ( $date->year <= 1900 ) { # p $dob;
$vars->{dob} = $vars->{age} = undef; # p @{$vars}{'dob','age'};
}
else { # to save rpt D::F::MySQL in parse_data():
$vars->{dob} = $date->dmy('/'); # convert to activity data format
}
}
# avoid uninitialized value error:
map $vars->{$_} ||= '', qw(trial_name presentation);
my $presentation = $vars->{presentation};
# haematology needs to be clinical not laboratory:
$vars->{hospital_department_code} =~ s/823/303/;
# Castleford & Normanton DH now RGX18, unless Dermatology which has its own code:
if ( $vars->{organisation_code} eq 'RXF07' ) {
if ( # examine both speciality & specimen:
$vars->{hospital_department_code} == 330 ||
$vars->{sample_description} =~ /^skin/i
) {
$vars->{organisation_code} = '5N301D';
}
else {
$vars->{organisation_code} = 'RGX18';
}
}
# Birmingham Royal Orthopaedic Hospital - handles Leeds cases so don't charge:
elsif ( $vars->{organisation_code} eq 'RRJ05' ) {
$vars->{category} = 'ST';
}
{ # branch => parent practices map:
my $org_code = $vars->{organisation_code};
if ( my $parent = $settings->{location_codes_map}->{$org_code} ) {
$vars->{organisation_code} = $parent;
}
}
# maybe change sample type based on presentation or test type - PB only:
if ( $vars->{sample_code} =~ /^PB/ ) {
my $set_code_map = $settings->{set_codes_map};
# force specimen code to PBSEQ if at least one molecular sequencing test:
if ( grep $mol_seq_tests->{$_}, @$lab_tests ) { # warn '=' x 30;
$vars->{sample_code} = 'PBSEQ'; # p $request_id;
}
elsif ( my $set_code = $set_code_map->{$presentation} ) { # eg PB => PBCML:
# $vars->{sample_code} .= $set_code if $vars->{sample_code} eq 'PB';
$vars->{sample_code} =~ s/^PB$/${set_code}/; # p $vars->{sample_code};
}
}
# override 01 category for research PB samples from LTH source:
if ( $vars->{sample_code} eq 'RXPB' && $vars->{organisation_code} =~ /^RR8/) {
$vars->{category} = 'ST';
}
# presentation / screened as:
#===============================================================================
# Outreach:
if ( $presentation =~ /Outreach/ ) { # billed directly now
$vars->{category} = 'ST';
}
# NCG PNH (PB & BMAT):
# TODO: change to /^PNH NCG/ after April 2019 run:
elsif ( $presentation =~ /^(?:NCG )?PNH(?: NCG)?$/ ) { # billed directly now
$vars->{category} = 'ST';
}
#===============================================================================
# elsif ( $presentation eq 'HTS myeloid only' ) { # until April 2017:
# $vars->{sample_code} = 'BMASEQ' unless
# grep $vars->{parent_organisation_id} eq $_, @local_network_locations;
# }
# HTS myeloid test (from Apr/17) needs to generate a new row for all referral
# sources if HTS myeloid requested *in addition to* any other test(s) except
# hts_quantification, dna_extraction & molecular srsf2 (which is also part of
# HTS section but never requested individually), unless screened as "HTS
# myeloid only" in which case sample set to BMASEQ & any other rows set to ST:
if ( grep $_ eq 'hts_myeloid', @$lab_tests ) {
# ddp $self->all_bmaseq;
output( $vars->{request_number} . ': ' . $vars->{sample_code} );
# create list of other requested tests (exclude some irrelevant ones):
my @non_hts_myeloid_tests = grep {
$_ !~ /^(srsf2|hts_myeloid|dna_extraction|hts_quantification)/
} @$lab_tests;
# make a new row if any other tests, not screened as 'HTS myeloid only'
# and not already done for this request (ie has multiple samples, none
# yet set to BMASEQ):
if (
( scalar @non_hts_myeloid_tests >= 1 ) # any other tests
and ( $presentation ne 'HTS myeloid only' ) # not screened as
and ( not $self->get_bmaseq($request_id) ) # not already done
)
{
output( 'no BMASEQ, have other tests, not screened as HTS myeloid '
. 'only, creating new BMASEQ' );
$self->set_bmaseq($request_id => 1); # p $vars;
# clone data and change sample type to BMASEQ:
my $ref = LIMS::Local::Utils::clone($vars);
$ref->{sample_code} = 'BMASEQ'; # p $ref;
# !!! this action will skip all further local rules on this new sample:
my $data = $self->parse_data($ref);
$self->add_row($data);
}
# change existing sample code to BMASEQ if we don't already have one:
elsif ( not $self->get_bmaseq($request_id) ) {
output( "no BMASEQ, changing $vars->{sample_code} to BMASEQ" );
$vars->{sample_code} = 'BMASEQ';
$self->set_bmaseq($request_id => 1);
}
# if screened as 'HTS myeloid only' & no other tests performed and
# already has a BMASEQ, set any other(s) to ST:
elsif ( $presentation eq 'HTS myeloid only'
and scalar @non_hts_myeloid_tests == 0 )
{
output( 'already have BMASEQ, screened as HTS myeloid only and no '
. 'additional tests, setting charge code ST' );
$vars->{category} = 'ST';
}
# ignore it, existing sample type retained:
else {
output( "screened as $presentation, has previous BMASEQ, retaining "
. 'sample type');
}
} # p @rows;
output( "final sample code $vars->{sample_code}; charge code "
. $vars->{category} );
output( '=' x 30 ); # exit if $vars->{request_number} > 169;
#===============================================================================
# EQA samples:
if ( $vars->{last_name} eq 'ceqas' && length $vars->{first_name} == 2 ) {
$vars->{category} = 'ST';
}
# set category to ST for PB if accompanied by BMA[T] (skip if already set to ST):
if ( $vars->{sample_code} eq 'PB' && $vars->{category} ne 'ST' ) {
$vars->{category} = 'ST' if $has_bone_marrow;
}
# trial sample ST code overriden and billed as normal:
if ( grep $vars->{trial_name} eq $_, @$chargable_trials ) {
$vars->{category} = '01'; # override ST code
}
# FLAIR trial:
if ( $presentation =~ /FLAIR/ || $vars->{trial_name} =~ /CLL FLAIR/ ) {
my @flair_followups = ( # FLMRD
'FLAIR follow-up (I/IR/I+V/unstated)',
'FLAIR MRD confirmation/EoT',
'FLAIR response BM',
);
# set default charge to ST (all samples):
$vars->{category} = 'ST';
my $sample = $vars->{sample_code};
# baseline requests:
if ( $presentation eq 'FLAIR baseline' ) {
# require BSL sample code & category 01 if BMA(T) or PB without a BMA(T):
do { $vars->{sample_code} = 'FLBSL'; $vars->{category} = '01' }
if $sample =~ /^BMA/
|| ( $sample =~ /^PB/ && ! $has_bone_marrow );
}
# disease progression:
elsif ( $presentation eq 'FLAIR disease progression' ) {
if ( $sample =~ /^BMA/ ) { # should never get BM for this screen
$vars->{sample_code} = 'FLMRD'; $vars->{category} = '01';
}
# PB only (ie without a BMA/T - don't want FLMRD as well as FLRES:
elsif ( $sample =~ /^PB/ && ! $has_bone_marrow ) {
$vars->{sample_code} = 'FLMRD'; $vars->{category} = '01'
}
}
# other follow-ups:
elsif ( grep $presentation eq $_, @flair_followups ) {
# BMA/T:
if ( $sample =~ /^BMA/ ) { # should never get BM for these screens
$vars->{sample_code} = 'FLRES'; $vars->{category} = '01';
}
# PB only (ie without a BMA/T - don't want FLMRD as well as FLRES:
elsif ( $sample =~ /^PB/ && ! $has_bone_marrow ) {
$vars->{sample_code} = 'FLMRD'; $vars->{category} = '01'
}
}
# warn Dumper [$request_id, $vars->{sample_code}, $vars->{category} ];
}
}
sub parse_data {
my ($self, $vars) = @_; # hashref
my $line = join $delimiter, (
'HMDS',
'H' . $vars->{request_number} . '/' . ( $vars->{year} - 2000 ),
uc $vars->{last_name},
( join ' ', map ucfirst $vars->{$_}, grep $vars->{$_}, qw/first_name middle_name/ ),
$vars->{unit_number}, # have to handle default unknown
$vars->{dob} || '', # already converted to dmy('/') in apply_local_rules()
$vars->{age} || '',
$vars->{gender} || 'U',
$vars->{organisation_code},
$vars->{referrer_code},
$vars->{organisation_code} =~ /\A(RR8|RAE)/ ? $vars->{hospital_department_code} : '',
'HM' . $vars->{sample_code},
'HM' . $vars->{sample_code},
$vars->{category},
$vars->{on_call},
DateTime::Format::MySQL->parse_datetime($vars->{created_at})->dmy('/'),
DateTime::Format::MySQL->parse_datetime($vars->{created_at})->strftime('%d/%m/%Y:%H:%M'),
$vars->{trial_number} || '', # external ref field
$vars->{nhs_number} || '',
);
return $line;
}
sub output {
return unless $debug; # ENV{DEBUG_ON} true
say $_[0];
}
sub _build_mol_seq_tests { # only returning map of molecular_sequencing_tests now:
my $self = shift;
my $test_names = $self->settings->{molecular_sequencing_tests}; # p $test_names;
my %map = map { $_ => 1 } @$test_names; # p %map;
return \%map;
}
1;
