#!/usr/bin/env perl
=begin
to use hl7d:
* config in /usr/local/hl7/hl7d.conf
* plugins /usr/local/hl7/plugins
* start hl7d: cd /usr/local/hl7d && sudo perl -T hl7d.pl --nodetach --debug
usage: perl $0 [-tq] -d <days> [-p <port>]
* t = test mode (requires hl7d running)
* q = output query to stdout
use $Net::HL7::NULL (double-quotation marks), or default (undef) for null fields
* use of default (undef) generates following warning: "Use of uninitialized value
$field in concatenation (.) or string at Net/HL7/Segment.pm line 187"
reason: my $field = $self->{FIELDS}->[$index];
$self->{FIELDS} = [
[0] "OBX",
...
[9] undef,
[10] undef,
[11] "F"
so index value of 9 or 10 will trigger warning - suppressed using Net::HL7::NULL
[9] ""
[10] ""
$Net::HL7::NULL set to 'true' if running under test mode (hl7d complains about undef fields)
=cut
use Getopt::Std;
getopts('d:p:tqo'); # port, days, testing, output sql query, output hl7 response
our($opt_d,$opt_o,$opt_p,$opt_q,$opt_t); # warn $opt_d; exit;
use strict;
use warnings;
use lib '/home/raj/perl5/lib/perl5';
use Data::Printer alias => 'p';
use Net::HL7::Connection;
use SQL::Abstract::More;
use FindBin qw($Bin); # warn $Bin;
use Data::Dumper;
use lib '/home/raj/perl-lib';
use Local::DB;
use lib $Bin . '/../../../lib';
use LIMS::Local::Utils;
use LIMS::Local::HL7;
# ==============================================================================
my $JUST_TESTING = $opt_t; # overrides addr:port with localhost:12002
$ENV{SQL_TRACE} = $opt_q; # warn $ENV{SQL_TRACE}; switch on query trace
# does ICE server expect empty strings or undef fields?
my $use_hl7_null = 0; # $Net::HL7::NULL (double-quotation marks), or undef
my $duration = $opt_d // 1; # days ago (allow 0)
my $port = $opt_p || 3306; # eg 3307 via localhost tunnel - for testing
my @locations = (
'RA701', # BRI
'RA709', # Bristol Dental Hospital
'RA710', # Bristol Haematology & Oncology Ctr
'RA723', # Bristol Childrens Hospital
'RA799', # Bristol Oncology Centre (ficticious code)
'RD130', # RUH, Bath
'RVJ01', # Southmead
# 'RVJ20', # Frenchay (defunct)
); # also including all GP practices from Aug/2018
# ==============================================================================
my $app_dir = $Bin . '/../../../'; # warn $app_dir;
my $now = LIMS::Local::Utils::time_now();
my $cfg_file = $app_dir . '/script/crons/lib/settings.cfg';
my $settings = Config::Auto::parse($cfg_file); # warn Dumper $settings; exit;
my $ref_date = $now->clone->subtract(days => $duration)->ymd;
# copy bristol_ice_server data to $settings for use in LIMS::Local::HL7:
$settings->{hl7d_addr} = $settings->{bristol_ice_server}->{remote_addr};
$settings->{hl7d_port} = $settings->{bristol_ice_server}->{remote_port};
# set null character - $Net::HL7::NULL (double-quotation marks), or undef:
$settings->{use_hl7_null} = $use_hl7_null;
my ($hl7_log, $hl7_ice);
if ($JUST_TESTING) { # overrides addr:port with localhost:12002
$settings->{hl7d_addr} = 'localhost';
$settings->{hl7d_port} = 12002;
$settings->{use_hl7_null} ||= 1;
# don't open logs unless called as command using -t opt:
open $hl7_log, '>', $app_dir . '/logs/hl7_log.txt' or die $!;
open $hl7_ice, '>', $app_dir . '/logs/hl7_ice.txt' or die $!;
} # p $settings; exit;
my $dbix = do {
my %h = (
dbname => 'bristol',
port => $port,
);
Local::DB->dbix(\%h);
};
# increase max length of group_concat; permitted range (32-bit system) 4 .. 4294967295
$dbix->dbh->do('SET group_concat_max_len = 3072');
# get sql statments:
my ($sql, @bind) = _get_query_params();
my @requests = $dbix->query($sql, @bind)->hashes; # p @requests; exit;
exit unless @requests;
# args for LIMS::Local::HL7->new():
my $hl7_socket = _build_hl7_socket(); # open connection to hl7 server once only
my %hl7_args = (
sending_application => 'ULTRA',
receiving_facility => 'ICE00',
sending_facility => 'BHODS',
receiving_system => 'ICE',
hl7_socket => $hl7_socket,
settings => $settings,
); # p %hl7_args; exit;
my $i = 0; # auto-incrementing message id
for my $vars ( @requests ) { # p $vars; next;
my $hl7 = LIMS::Local::HL7->new(\%hl7_args); # pass socket & settings args
# build HL7 message:
$hl7->build_msh_segment(++$i); # message id counter
$hl7->build_pid_segment($vars);
$hl7->build_nte_segment($vars);
$hl7->build_pv1_segment($vars);
$hl7->build_orc_segment($vars);
$hl7->build_obr_segment($vars);
# $hl7->build_obx_segment($vars); # handled by _build_report()
# $hl7->build_report_segment($vars); # handled by _build_report()
# add report (comment, diagnosis, etc) to HL7 message:
_build_report($hl7, $vars);
# message should now be complete, send it
my $response = $hl7->send_message(); # p $response;
# dump msg, vars & response to log (and stdout if test mode):
_dump_msg($vars, $hl7->msg, $response);
}
$hl7_socket->close();
# ------------------------------------------------------------------------------
sub _build_report {
my ($hl7, $vars) = @_;
# create text string from samples code(s):
$vars->{specimen_type} = $hl7->specimen_summary($vars->{sample_code});
my @report = (
[ 'Specimen type', $vars->{specimen_type} ],
[ 'Specimen quality', $vars->{specimen_quality} ],
[ 'Gross description', $vars->{gross_description} ],
[ 'Results summary', $vars->{result_summaries} ],
[ 'Clinical details', $vars->{clinical_details} ],
[ 'Morphology/comment', $vars->{comment} ],
[ 'Diagnosis', $vars->{diagnosis} ],
[ 'ICDO3', $vars->{icdo3} ],
);
my $n = 0; # incremental OBX counter
$hl7->build_obx_segment(@$_, ++$n) for @report; # field, value, counter
}
# ------------------------------------------------------------------------------
sub _build_hl7_socket {
# open HL7 connection via socket
my ($addr, $port) = @{$settings}{ qw(hl7d_addr hl7d_port) };
my $socket = new Net::HL7::Connection($addr, $port)
or die "Could not connect to HL7d $addr on port $port: $!";
return $socket;
}
# ------------------------------------------------------------------------------
sub _dump_msg { # write to interface logs
my ($vars, $msg, $response) = @_; # warn Dumper $msg;
# $vars - hashref of request data
# $msg - HL7 msg object
# $response - hl7d return string
my $request_number = _get_request_number($vars);
# my $dow = $now->day_name; # warn $dow;
# log to db or output to stdout & log files:
if ( $JUST_TESTING ) {
p $msg->toString(1); # Net::HL7::Request object
p $response;
printf $hl7_log "%s: %s\n\n", $request_number, $response;
print $hl7_log $msg->toString(1)."\n";
# print $hl7_log Dumper $msg;
print $hl7_log "=" x 100;
printf $hl7_ice "%s %s\n", $request_number, '=' x 100;
while ( my @pair = map { $_ ||= 'NULL' } each %$vars ) {
printf $hl7_ice "%s: %s\n", @pair;
}
}
else { # log to db:
my %h = (
request_id => $vars->{request_id},
response => $response,
); # p %h;
$dbix->insert('request_hl7_log', \%h);
}
print $response if $opt_o; # flag passed by HILIS, returns HL7 response
}
# ------------------------------------------------------------------------------
sub _get_request_number {
my $vars = shift;
return join '/', $vars->{request_number}, $vars->{year} - 2000;
}
sub _get_query_params { # bristol don't authorise so using report_date as auth_date
my $rs = q!
group_concat(distinct(ls.section_name),':',rrs.results_summary,'|')!;
my @cols = (
qw/
p.last_name
p.first_name
p.middle_name
p.dob
p.nhs_number
p.gender
pc.unit_number
rs.display_name|location
rs.organisation_code
ref.name|referrer_name
ref.national_code|referrer_code
r.id|request_id
r.request_number
r.year
r.created_at
r.updated_at
rr.status
rr.specimen_quality
group_concat(distinct(s.description))|specimen
group_concat(distinct(s.sample_code))|sample_code
d.name|diagnosis
d.icdo3
rsv.username|report_by
rsv.time|auth_date
/,
"$rs|result_summaries",
); # p @cols;
my @rels = (
'requests|r' => q{r.patient_case_id=pc.id} ,
'patient_case|pc' => q{pc.patient_id=p.id} ,
'patients|p' => q{pc.referral_source_id=rs.id} ,
'referral_sources|rs' => q{r.referrer_department_id=rd.id} ,
'referrer_department|rd' => q{rd.referrer_id=ref.id} ,
'referrers|ref' => q{rh.request_id=r.id} ,
'request_history|rh' => q{rr.request_id=r.id} ,
'request_report_view|rr' => q{rr.diagnosis_id=d.id} ,
'diagnoses|d' => q{rrs.request_id=r.id} ,
'request_result_summaries|rrs' => q{rrs.lab_section_id=ls.id} ,
'lab_sections|ls' => q{rs2.request_id=r.id} ,
'request_specimen|rs2' => q{rs2.specimen_id=s.id} ,
'specimens|s' => q{=>rdh.request_id=r.id} ,
'request_diagnosis_history|rdh' =>
q{rsv.request_id=r.id,rsv.action='reported'},
'request_status_view|rsv' => q{rs.referral_type_id=rt.id} ,
'referral_types|rt'
);
# reported, request_report updated, request_diagnosis_history updated, or
# patient table updated:
my %where = (
-and => [
[
'rs.organisation_code' => { -in => \@locations },
'rt.description' => 'practice',
],
'rh.action' => 'reported',
-or => [
'DATE(rh.time)' => $ref_date,
'DATE(rdh.time)' => $ref_date,
'DATE(rr.updated_at)' => $ref_date,
-and => {
'DATE(p.updated_at)' => $ref_date,
'DATE(rh.time)' => { '<' => $ref_date },
},
],
]
);
my @args = (
-columns => \@cols,
-from => [ -join => @rels ],
-where => \%where,
-group_by => 'r.id',
-order_by => 'r.id',
); # p @args;
my ($sql, @bind) = SQL::Abstract::More->new->select(@args); # p $sql; p \@bind;
# $dbix->dump_query($sql, @bind); exit;
return ($sql, @bind);
}
=BEGIN
# ------------------------------------------------------------------------------
sub _get_query_params {
my $sql = _get_sql(); # library.sql [ice_report] entry
# count number of placeholders in $sql:
my $n = () = $sql =~ /\?/g; # p $n;
# bind one $duration per placeholder:
my @bind = map $duration, (1..$n); # p \@bind;
return ($sql, @bind);
}
# ------------------------------------------------------------------------------
sub _get_sql {
return q!
SELECT
p.last_name,
p.first_name,
p.middle_name,
p.dob,
p.nhs_number,
p.gender,
pc.unit_number,
rs.display_name as 'location',
rs.organisation_code,
rf.name as 'referrer_name',
rf.national_code as 'referrer_code',
req.id as 'request_id',
req.request_number,
req.year,
req.created_at,
req.updated_at,
rr.status,
rr.specimen_quality,
group_concat(distinct sp.description) as 'specimen',
group_concat(distinct sp.sample_code) as 'sample_code',
d.name as 'diagnosis',
d.icdo3,
rsv.username as 'report_by',
rsv.time as 'auth_date', /* bristol don't authorise */
group_concat( distinct ls.section_name,':',rrs.results_summary,'|')
as 'result_summaries'
FROM
requests req
join patient_case pc on req.patient_case_id = pc.id
join patients p on pc.patient_id = p.id
join referral_sources rs on pc.referral_source_id = rs.id
join referrer_department rd on req.referrer_department_id = rd.id
join referrers rf on rd.referrer_id = rf.id
join request_history h on h.request_id = req.id
join request_report_view rr on rr.request_id = req.id
join diagnoses d on rr.diagnosis_id = d.id
join request_result_summaries rrs on rrs.`request_id` = req.id
join lab_sections ls on rrs.`lab_section_id` = ls.id
join request_specimen rsp on rsp.`request_id` = req.id
join specimens sp on rsp.`specimen_id` = sp.id
join request_status_view rsv on rsv.request_id = req.id
and rsv.`action` = 'reported'
left join `request_diagnosis_history` rdh on rdh.`request_id` = req.id
WHERE
( /* reported, request_report updated, request_diagnosis_history updated, or patient table updated: */
( h.`action` = 'reported' and
DATE(h.`time`) = DATE_SUB(CURRENT_DATE(), INTERVAL ? DAY) ) or
DATE(rr.`updated_at`) = DATE_SUB(CURRENT_DATE(), INTERVAL ? DAY) or
DATE(rdh.`time`) = DATE_SUB(CURRENT_DATE(), INTERVAL ? DAY) or
( /* previously reported: */
DATE(h.`time`) < DATE_SUB(CURRENT_DATE(), INTERVAL ? DAY) and
DATE(p.`updated_at`) = DATE_SUB(CURRENT_DATE(), INTERVAL ? DAY)
)
AND rs.organisation_code IN (??)
)
GROUP BY req.id!;
}
=cut
