#!/usr/bin/perl
use strict;
use warnings;
use lib '/home/raj/perl5/lib/perl5';
use IO::All;
use IO::Socket;
use IO::Handle;
use Data::Dumper;
use Daemon::Control;
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 = '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
);
my %SQL = (
get_status => qq!select status from $tbl where lab_number = ?!,
has_result => qq!SELECT 1 FROM $tbl WHERE lab_number = ? AND status = 'verified'!,
);
# 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 => '163.160.171.48', # full IP address to accept external connections
LocalPort => 9001,
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 ( $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 $data = shift; # warn length $data;
my %h = (); # data hash to return
my ($labno, @params) = $data =~ /
D1U\d{16} # year, month, day + sample ID padding (8 zeros)
([\d-]{8}) # sample ID = 8 char, right-aligned eg 000012_1, 0012_100, 12_10000, etc
(\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
# .*{5} # rdw - don't need
# .*{5} # pdw - don't need
# .*{5} # mpv - don't need
# .*{5} # p-lrc - don't need
/xo;
return 0 unless $labno && @params;
# split $labno on '-' (if exists):
my ($yr, $request_number) = split '-', $labno;
# check have both, and int $yr = 2-digits (eg 00012):
return 0 unless $yr && $request_number && length(int $yr) == 2; # warn Dumper [$yr, $request_number];
# create hash of data:
@h{@fields} = @params; # warn Dumper \%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->query($SQL{has_result}, $lab_number)->list;
# insert new data (can have multiple entries until verification):
$dbix->insert($tbl, $data);
return 1;
=cut
# does request already have a result:
$dbix->query($SQL{get_status}, $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($tbl, { lab_number => $lab_number }); # warn 'OVERWRITE';
}
# insert new data:
$dbix->insert($tbl, $data);
return 1;
}
sub do_log { # log with timestamp:
my $data = shift;
print $fh $tools->time_now->datetime . "\n$data\n";
# 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($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 $data = shift;
my $msg = join "\n", 'SYSMEX POSSIBLE DATA CORRUPTION:', $data;
$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
