#!/usr/bin/env perl
=begin
socket for sysmex haematology cell-counter, controlled by init.d & Daemon::Control
errors go to /run/sysmex/sysmex.out
start test instance using "sudo perl $0 --test_mode -p <port> start" # unused port
tail -f /run/sysmex/sysmex.out
tail -f ~/apps/hilis4/logs/sysmex.log
sudo perl $0 stop
to test, use netcat, with '_TEST_' in 6-char pda field:
echo 'D1U<yyyymmdd>00000<11-char labnum>_TEST_<96-char numeric string>' | nc \
-w 1 127.0.0.1 <port> # -w = wait time (sec)
96-char numeric string example:
001151048000155004510094000323103440017000535000830038220062000100004300462001270009800084201310
labnum format; always 11-chars; needs to match format defined in $regex or input
string dumped to logs/sysmex.log:
15_12345_RF
00H01234/15
00015-12345
=cut
# address & port for host socket, maybe overridden to localhost using --test_mode:
my $host_addr = '163.160.171.48';
my $host_port = 9001;
my $test_mode = 0;
use Getopt::Long;
GetOptions (
"test_mode" => \$test_mode, # flag
"port|p=i" => \$host_port, # int
); # warn $localhost; warn $host_port; exit;
$host_addr = '127.0.0.1' if $test_mode; # warn $host_addr; warn $host_port; exit;
# three regex variants:
# manual input (yy-nnnnn)
# barcode scan (Hnnnnn/yy)
# barcode scan (yy_nnnnn_RF):
my $regex = qr!D1U
# next 24 chars depend on labnum format:
#===============================================================================
# for barcode scan of label (eg H01234/15):
\d{15} # yyyymmdd + sample ID padding (7 zeros)
H(\d{5})/(\d{2}) # sample ID (H + zero-padded 5-digits + '/' + 2-digits)
#-------------------------------------------------------------------------------
# new barcode scan using '_RF' suffix:
# \d{13} # yyyymmdd + sample ID padding (5 zeros)
# (\d{2})_(\d{5})_RF # sample ID (2-digits + '_' + zero-padded 5-digits + '_RF')
#-------------------------------------------------------------------------------
# for manual input using yy-ddddd labno format:
# \d{16} # yyyymmdd + sample ID padding (8 zeros)
# (\d{2})-(\d{5}) # sample ID (2-digits + '-' + zero-padded 5-digits)
#===============================================================================
(\w{6}) # PDA info
\d # RDW select || reserve
([\d*]{4})(\d) # wbc + flag
([\d*]{4})(\d) # rbc + flag
([\d*]{4})(\d) # hb + flag
([\d*]{4})(\d) # hct + flag
([\d*]{4})(\d) # mcv + flag
([\d*]{4})(\d) # mch + flag
([\d*]{4})(\d) # mchc + flag
([\d*]{4})(\d) # plt + flag
([\d*]{4})(\d) # lymph (%) + flag
([\d*]{4})(\d) # mixed (%) + flag
([\d*]{4})(\d) # neutr (%) + flag
([\d*]{4})(\d) # lymph (#) + flag
([\d*]{4})(\d) # mixed (#) + flag
([\d*]{4})(\d) # neutr (#) + flag
([\d*]{4})(\d) # rdw-sd + flag
([\d*]{4})(\d) # rdw-cv + flag
# .* # don't need remaining
!x; # p $re;
use strict;
use warnings;
use lib '/home/raj/perl5/lib/perl5';
use IO::All;
use IO::Socket;
use IO::Handle;
use Try::Tiny;
use Data::Dumper;
use Data::Printer;
use Daemon::Control;
use Time::Out qw(timeout);
use FindBin qw($Bin); # load AFTER local::lib Carp or FindBin loads system
use lib "$Bin/../lib";
use LIMS::Local::ScriptHelpers;
my $tools = LIMS::Local::ScriptHelpers->new();
$tools->use_path("$Bin/.."); # for ScriptHelpers to find correct path to app root
my $cfg = $tools->get_settings; # warn Dumper $cfg;
my $tbl_name = 'request_haematology';
my $log_file = "$Bin/../logs/sysmex.log";
my @fields = qw(
pda wbc wbc_f rbc rbc_f hb hb_f hct hct_f mcv mcv_f mch mch_f mchc mchc_f
plt plt_f lymph_percent lymph_percent_f mixed_percent mixed_percent_f
neutr_percent neutr_percent_f lymph lymph_f mixed mixed_f neutr neutr_f
rdw_sd rdw_sd_f rdw_cv rdw_cv_f
);
# flush after every write
$| = 1;
open my $fh, '>>', $log_file or die $!;
$fh->autoflush(1);
my %args = (
name => 'sysmex',
# lsb_start => '$syslog $remote_fs',
# lsb_stop => '$syslog',
lsb_sdesc => 'sysmex daemon',
lsb_desc => 'Controls the sysmex socket',
path => "$Bin/sysmex.pl",
program => \&open_socket,
program_args => [ ],
pid_file => '/var/run/sysmex/sysmex.pid',
stderr_file => '/var/run/sysmex/sysmex.out',
stdout_file => '/var/run/sysmex/sysmex.out',
fork => 2,
);
Daemon::Control->new(\%args)->run;
sub open_socket {
# open a socket:
my $socket = IO::Socket::INET->new(
LocalHost => $host_addr, # full IP address to accept external connections
LocalPort => $host_port,
Proto => 'tcp',
Listen => 1,
ReuseAddr => 1
) or die "Could not create socket: $!\n";
our ($r); # output from sysmex analyser
while ( my $client_socket = $socket->accept ) {
# my $peer_addr = $client_socket->peerhost();
# my $peer_port = $client_socket->peerport();
# print "Accepted new client connection from $peer_addr, $peer_port\n";
READ: # read in 131-char chunks:
while ( timeout 30 => sub { $client_socket->read($r, 131) } ) { # warn Dumper $r;
# print $fh DateTime->now->datetime . "\n$r\n";
my $data = parse_data($r); # warn Dumper $data; # returns hashref or 0
if ($data) {
my $ok = process_data($data); # method returns 1 on success
next READ if $ok;
}
do_log($r); # no $data or process_data() returns false
}
}
close $socket;
}
sub parse_data {
my $str = shift; # warn length $str;
my %h = (); # data hash to return
my (@params) = $str =~ /$regex/o; # warn Dumper [ @params[0,1] ];
return 0 unless @params; # $str doesn't match regex
my ($request_number, $yr);
# for ddddd + yy formats:
if ( length $params[0] == 5 && length $params[1] == 2 ) {
($request_number, $yr) = splice @params, 0, 2;
}
# for yy + dddddd formats:
elsif ( length $params[0] == 2 && length $params[1] == 5 ) {
($yr, $request_number) = splice @params, 0, 2;
} # warn Dumper [$request_number, $yr];
return 0 unless $request_number && $yr && @params; # p $request_number; p $yr;
# create hash of data:
@h{@fields} = @params; # p %h;
# add lab number (yy_nnnnn format):
$h{lab_number} = sprintf '%02d_%05d', $yr, $request_number;
return \%h;
}
sub process_data {
my $data = shift;
my $lab_number = $data->{lab_number};
my $dbix = get_dbix(); # get new dbix object
=begin # to activate when request_haem table has new primary key
# return if request already has verified result - will need to delete in app to over-write:
return 0 if $dbix->select($tbl, 1,
{ lab_number => $lab_number, status => 'verified' })->list;
# insert new data (can have multiple entries until verification):
$dbix->insert($tbl, $data);
return 1;
=cut
# using pda field as flag for test function:
my $dbname = $data->{pda} eq '_TEST_' ? 'lims_test' : 'hilis4'; # warn $dbname;
my $db_tbl = join '.', $dbname, $tbl_name;
# does request already have a result:
$dbix->select($db_tbl, 1, { lab_number => $lab_number })->into(my $status);
if ($status) { # exists - can only over-write if not already verified:
return 0 if $status eq 'verified'; # can't overwite here (delete in app)
$dbix->delete($db_tbl, { lab_number => $lab_number }); # warn 'OVERWRITE';
}
# insert new data, dbix error kills socket so catch & handle it:
try {
$dbix->insert($db_tbl, $data);
}
catch {
alert_admin($dbix->error);
};
return 1;
}
sub do_log { # log with timestamp:
my $data = shift;
print $fh $tools->time_now->datetime . "\n$data\n" || warn $!;
# leading char should be '02H' hex char; ord(02H) = 2, so chr(2) should re-encode for use in var:
my $stx = chr(2); # warn Dumper $stx; - will be undef
alert_admin( "SYSMEX POSSIBLE DATA CORRUPTION:\n" . $data )
if $data !~ /^${stx}D1U/; # indicates possible data stream corruption
}
# return a new dbix object for each dataset - not using ScriptHelpers::get_dbix()
# to avoid cacheing db connection and MySQL timeout after >8hrs idle:
sub get_dbix {
my $uid = $cfg->{db_user_id};
my $pwd = $cfg->{db_password};
my $db = $cfg->{production_db};
my $dsn = "dbi:mysql:$db";
my $dbix = DBIx::Simple->connect($dsn, $uid, $pwd, { RaiseError => 1 });
return $dbix;
}
sub alert_admin {
my $msg = shift;
my $now = $tools->time_now->datetime; warn "${now}: $msg";
$tools->mail_admin({ script => io($0)->filename, msg => $msg });
}
__END__
#!/bin/sh
### BEGIN INIT INFO
# Provides: sysmex
# Required-Start:
# Required-Stop:
# Default-Start: 2 3 4 5
# Default-Stop: 0 1 6
# Short-Description: sysmex daemon
# Description: Controls the sysmex_daemon script
### END INIT INFO
SCRIPT_DIR=/home/raj/apps/HILIS4/script
SCRIPT=sysmex.pl
if [ -x $SCRIPT_DIR/$SCRIPT ];
then
/usr/bin/perl $SCRIPT_DIR/$SCRIPT $1
else
echo "Required program $SCRIPT_DIR/$SCRIPT not found!"
exit 1;
fi
