#! /usr/bin/perl -w
# emgdb.pl databáze vyšetření
my $version = '0.48'; # gain -> table `bin`
#
#...:....|....:....|....:....|....:....|....:....|....:....|....:....|....:....|....:....|....:....|
# ../emgdb.pl --verbose=4 --delpro=all --addpro=test.pro
# dokončen přesun podprogramů do modulu
# --delcomm
use strict;
use Getopt::Long;
use Pod::Usage;
use DBI;
use File::Copy;
use Fcntl;
use lib '/Data60G/huge/EMG/perl';
use emg;
# command line options:
my $verbose = 0;
my $ev = 0; # list events
my $full = 0; # full list
my $fulltime = 0; # full list with full precision time
my $anal = 0; # analysis
my $recstop = 0; # print record stop
my $chp = 0; # analyze&print checkpoints
#globals
my $nchan = undef; # number of channels
my $sample_int_us = undef; # sampling interval [us]
my $sfreq = undef; # sampling frequency
my $last_duration = 0; # trvání posledního záznamu v us
my $curr_binfilesize = 0; # current binary_file size [Bytes]
my $calib = 0; # duration of the current calibration [s]
my $calib_us = 1000000; # calibration time [us]
my $last_chp_us = undef; # last checkpoint time [us]
my $last_chp_MB = undef; # last checkpoint MB
my $gdffilename = undef;
my $gdfeventsbuf = ''; # eventy ve formátu GDF event table
my $togdf = undef; # filename of GDF file converted to. default = '';
sub filesfromdir { # returns sorted list of all files from this dir
my ($dir) = @_; # dirname relative to $emg::allcddir
$dir = $emg::allcddir . $dir;
unless(opendir(DIR, $dir)){
print STDERR "Nemohu otevřít adresář $dir: $!\n";
return ();
}
my @files = readdir DIR; # list of all files
closedir DIR;
sort grep(!/^[.:]/ && !/\.IN\$/, @files); # vyhoď, co začíná tečkou či dvojtečkou,
# *.IN$ ignoruj a setřiď
}
sub printlist { # vytiskne seznam do řádky; první v seznamu je separátor
my $sep = shift @_;
for my $item(@_) {print $sep.$item;}
}
sub togdf { # converts EXP to GDF using exp2gdf
my($inv, $ltr, $expfile) = @_;
printf "inv=%s, ltr=%s, expfile=%s\n", $inv, $ltr, $expfile;
$expfile = $emg::allcddir . $expfile;
my $gdffilename = $togdf eq '' ? $emg::gdfdir.'/'.$inv.$ltr.'-5k.gdf' : $togdf; # nebezpečná volba – při více souborech se to přepisuje
# printf "\t%s => %s\n", $expfile, $togdf;
my $cmd = sprintf "/usr/local/bin/exp2gdf -d 4 %s %s\n", $expfile, $gdffilename;
print "\t$cmd";
print `$cmd`;
}
sub dbload { # nacpe tabulky `invor` a `bin` do databáze podle adresáře souborů
#=========
my $dbh = db_connect;
my $invor_insert= $dbh->prepare
("INSERT INTO `invor` VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)");# 18 polí
my $bin_insert = $dbh->prepare
("INSERT INTO `bin` VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)"); # 13 polí
my $fmt_r3 = " %-10s %-10s %-15s%-10s %3s %1s %3d %3d %3d %-15s %-15s\n";
my $fmt_r4 = "%+15s %-19s";
printf "%14s", '';
printf $fmt_r3, 'inv_date', 'birthdate','surname','name','age','x',1,6,7, 'inv_comment', 'dg';
printf $fmt_r4, 'file', 'local_mtime';
print "\n-------------------------------------------------------------------------------------------------------------------\n";
for my $cd(&filesfromdir('')){ # projdu adresáře se všemi CD
$cd =~ /\d+/;
my $cdn = $&; # číslo CD
for my $exam(&filesfromdir($cd)){ # projdu adresáře s vyšetřeními na jednom CD
my $inv_id = length($exam)<2 ? '1'.$exam : $exam; # id vyšetření přidá 1
printf "%-5s( %-5s):", $inv_id, $cd;
my @files=&filesfromdir($cd.'/'.$exam);
unless (@files) {
printf " (%s soubor %s není adresářem)\n", $cd, $exam;
next;
}
my $invfilepathname = my $invfilename = '';
for my $file(@files) { # projdu vš. soubory kromě souborů '.IN$'
if($file =~ /\.INV$/) {
$invfilename=$file;
$invfilepathname="$cd/$exam/$invfilename";
last;
}
}
if (!$invfilepathname) { print "\n ????????.INV chybí!\n";}
else {
my %inv = invfile($invfilepathname); # načtu soubor.INV do hashe
$invfilename =~ /\d*/;
my $num = $&;
$inv{mtime} =~ /\d*/; my $inv_year = $&;
isodate($inv{birth}) =~ /\d*/; my $birth_year = $&;
my $age = $inv_year - $birth_year;
my $person = substr($inv{surname},0,3).substr($inv{name},0,1);
my $sex = $inv{sex} ? 'f' : 'm';
my $height = $inv{n7};
my $text; #undef $text; # později pro vložení textu, nyní NULL
my @values = ( # 17 polí
$inv_id, $num, $cdn, $invfilename, $inv{mtime}, isodate($inv{invdate}),
$age, $person, isodate($inv{birth}), $inv{surname}, $inv{name},
$sex, $inv{n1} ,$inv{n6}, $height, $inv{invcomm},
$inv{dg}, $text
);
printf $fmt_r3, isodate($inv{invdate}), isodate($inv{birth}),
$inv{surname}, $inv{name}, $age, $inv{sex}, $inv{n1}, $inv{n6}, $inv{n7},
$inv{invcomm}, $inv{dg};
printf $fmt_r4, $invfilename, $inv{mtime};
print " n2 = $inv{n2};" if $inv{n2};
print " n3 = $inv{n3};" if $inv{n3};
print " n4 = $inv{n4};" if $inv{n4};
print " n5 = $inv{n5};" if $inv{n5};
print "\n";
my $rv = $invor_insert->execute(@values); #print "rv = '$rv'\n";
}
for my $somefile(@files) { # projdu vš. soubory
next if($somefile eq $invfilename); # *.INV už jsme probrali
printf "%+15s", $somefile;
unless (open SOMEFILE, "$emg::allcddir$cd/$exam/$somefile") {
print " nelze otevřít $emg::allcddir$cd/$exam/$somefile\n";}
else {
$somefile =~ /(.*?)\.(.*)/; my $onlyname=$1; my $ext= $2;
$onlyname =~ s/ori$//; # originální EXP soubory
my $invlabel = substr $onlyname, 0, -4;
my $num = substr $onlyname, -4;
my $ltr = '-'; # letter = rozlišovací písmeno záznamu
my @fstat = stat(SOMEFILE);
my $mtime = time2isodatetime($fstat[9]);
my $size = $fstat[7];
undef $nchan;
undef $sfreq;
my @gain;
my $gainstr = '';
my $duration; undef $duration;
my $comment; undef $comment;
if ($ext eq 'EXP'){ # EMG Export file
#$ltr = substr($invlabel,2); # rozliš. písmeno: normálně 3. znak labelu
#$ltr = substr($invlabel,-1) if $inv_id=~/^[1Z]/; #posl.znak labelu(bylo dřív)
$invlabel =~ /.*([A-Z])/; $ltr = $1 if $1;
$ltr = 'A' if $invlabel eq '2BCh'; # výjimka
$ltr = 'B' if $invlabel eq '2BSi'; # výjimka
$ltr = 'A' if $invlabel eq '2CSi'; # výjimka
my $expfilepathname = "$emg::allcddir$cd/$exam/$somefile";
#? open (EXPFILE, $expfilepathname)
#? or die "Nemohu otevřít EXP: $expfilepathname: $!\n";
($nchan, $sample_int_us, @gain) = my @exphdr = expfilehdr(*SOMEFILE);
#? close EXPFILE;
# foreach my $item(@exphdr){print " $item,"}; print "\n";
$duration = int(($size-4-2*$nchan) * $sample_int_us / (2 * $nchan));
# délka záz. [mikrosec.]
$sfreq = 1000000/$sample_int_us;
for my $item (@gain) {$gainstr .= "$item,";} chop $gainstr;
}
my @values = ($inv_id, $ltr, $somefile, $invlabel, $num, $ext, $mtime, $size,
$nchan, $sfreq, $gainstr, $duration, $comment);
printf " %19s %11d %2s %3s kHz %-20s %11s %-7s\n", $mtime, $size,
$nchan?$nchan:'--', $sfreq?$sfreq/1000:'--', $gainstr,
$duration?usec2timestr($duration):'--',
$comment?$comment:'--';
#if($duration) {print "dur=$duration\n";}
#foreach my $val(@values){print "\"$val\", ";} print "\n"; # debug
my $rv = $bin_insert->execute(@values); #print "rv = '$rv'\n";
close SOMEFILE;
}
}
print "\n";
}
}
$invor_insert->finish;
$bin_insert->finish;
$dbh->disconnect;
} # dbload
sub add_comment { # přidá komentáře do tabulky
#==============
my ($COMMENTFILE) = @_; # handle otevřeného souboru s komentáři
my $dbh = db_connect;
my $comm = $dbh->prepare("INSERT INTO `comm` (`inv`, `comment`) VALUES (?,?)"); # 2 pole
while(<$COMMENTFILE>) {
next if /^#/;
chomp; my $inv = $_; my $text = '';
if (length($inv)<2){$inv = ' '. $inv;} # id vyšetření zarovná vpravo
print "$inv:\n";
while(<$COMMENTFILE>) {
next if /^#/;
last if /^$/;
$text .= $_;
}
print $text;
$comm->execute($inv, $text);
}
$dbh->disconnect;
}
my %ev = (
# 'press' => 0,
'record' => 1, # red full
# 'calib' => 2, # brown
# 'gain' => 3, # green-gray
'signal' => 4, # orange
# 'breath' => 6, # cyan
'motion' => 7, # violet
'speech' => 7, # violet
'disturbance' => 7, # violet
'other' => 7, # violet
'picture' => 8, # yellow full
'needle' => 9, # green
'electrode' => 9, # green
'mark' => 9, # green
# '' => ,
);
my %attr = (
'other' => 0,
'arm' => 0,
'sole' => 1,
'calf' => 2,
'HMS' => 3,
'paracocc' => 4,
'ang_costae5' => 5,
'ang_costae6' => 5,
'ang_costae' => 5,
'm_trapesius' => 6,
'infraspinatus' => 7,
);
my %side = (
'sin' => 10, # blue
'dx' => 20, # red
);
sub add_protocol { # přidá protokol do tabulky `event`
#===============
my ($PROTOCOLFILE) = @_; # handle otevřeného souboru s komentáři
my $dbh = db_connect;
my $form = "%3s/%1s %3s %3s %4s %7s %5s %7s %6s %5s %5s %5s %5s %3s %-10s %-16s %-5s %-5s %-4s %s";
# inv/ltr n ev typ t1s dts t2s t1 dt t2 MB1 MB2 ch event attr side value unit comment
my $insert_event = $dbh->prepare("INSERT INTO `event`
(`inv`,`ltr`,`n`,`ev`,`typ`,`t1s`,`dts`,`t2s`,`t1`,`dt`,`t2`,`MB1`,`MB2`,`ch`,`event`,`attr`,`side`,`value`,`unit`,`comment`)
VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)"); # 20 columns
my $evn; # GDF event counter
# my ($inv,$ltr,$t1,$dt,$t2,$MB1,$MB2,$ch,$event,$attr,$side,$value,$unit,$comment); # předtím
my ($inv,$ltr,$n,$ev,$typ,$t1s,$dts,$t2s,$t1,$dt,$t2,$MB1,$MB2,$ch,$event,$attr,$side,$value,$unit,$comment);
my ($date, $person, $expfile) = ('','','');
while(<$PROTOCOLFILE>) {
next if /^$/; # prázdná řádka
if (/^;/) {print; next;} # ; = comment
if(/^(\w+):\s+(.+)/) { # identifikátor: (na začátku řádky, jinak by to byl event)
my ($id, $value) = ($1, $2);
for ($id) {
if ($_ eq 'investigation') {$inv = $value;}
elsif($_ eq 'date') {$date = $value;}
elsif($_ eq 'person') {$person = $value;}
elsif($_ eq 'letter') {$ltr = $value; $n = 0; $evn=0; $calib=0;} # new EMG record
elsif($_ eq 'expfile') { $expfile = $value;
if ($verbose >= 2) {print "\n$inv/$ltr $date $person $expfile:\n";}
if ($verbose >= 3) {printf $form."\n", 'inv','l','n','ev','typ','t1s','dts','t2s','t1','dt','t2',
'MB1','MB2','ch','event', 'attr','side','value','unit','comment';}
}
else {die "Neznámý identifikátor $_\n";}
}
next;
}
$n++; # should be event line
$t1s= $dts= $t2s= $t1= $dt= $t2= $MB1= $MB2= $ch= $event= $attr= $side= $value= $unit= $comment= undef;
sub hhmmss { # převede čas na formát hh:mm:ss
my ($t) = @_;
if ($t =~ /(\d\d):(\d\d)/){
return sprintf "00:%02d:%02d", $1, $2;
} else {
my $min = int($t / 60);
# return printf "00:%02d:%06.3f\n", $min, $t - 60*$min;
# return sprintf "00:%02d:%06.3f", $min, $t - 60*$min;
return sprintf "00:%02d:%02d", $min, $t - 60*$min;
}
}
sub flt { # převede čas na float
my ($time, $cal) = @_; # $cal: jestli se přičte čas kalibrace
my $t;
if ($cal) {$cal = $calib;} else {$cal = 0;}
if ($time =~ /(\d+):(\d+\.\d+)/) {
return 60*$1 + $2 + $cal;
} elsif ($time =~ /(\d+):(\d+)/) {
return 60*$1 + $2 + $cal;
} else {
return $time;
}
}
if(/^(\S+)\s+(.*)/) { # event line with timepoint or timeinterval
my ($timefield, $eventfield) = ($1, $2);
#print "[$timefield|$eventfield]";
if ($timefield =~ /(\S+)-(\S+)/) { # - interval
print "[$1|$2]";
($t1, $t2 ) = (hhmmss($1), hhmmss($2)); $dt = undef;
($t1s, $t2s) = (flt($1, 1), flt($2, 1)); $dts = $t2s - $t1s;
}
elsif ($timefield =~ /(\S+)\+(\S+)/) { # + increment
#print "[$1|$2]";
($t1, $dt ) = (hhmmss($1), hhmmss($2)); $t2 = undef;
($t1s, $dts) = (flt($1, 1), flt($2, 0)); $t2s = $t1s + $dts;
}
else { # single timepoint
#$t1 = ($timefield ne '~') ? hhmmss($timefield) : undef; # ~
#$t2 = $dt = undef;
#$t1s = ($timefield ne '~') ? flt($timefield) : undef; # ~
#$t2s = $t1s; $dts = 0;
#$t2s = $t1s; $dts = 0;
if ($timefield ne '~') {
$t1 = hhmmss($timefield); $t1s = flt($timefield, 1);
$dts = 0;
$t2s = $t1s;
}
}
if ($eventfield =~ s/\s*;(.*)//) { $comment = $1;}
my $orig_eventfield = $eventfield;
if ($eventfield =~ s/\s*~(\S+) \[MB\]//) { # MB
my $MB = $1;
if($MB =~ /-/) {($MB1, $MB2) = ($`, $');}
else {($MB1, $MB2) = ($MB, undef);}
}
if ($eventfield =~ s/\s*=(\S+) \[(\S+)\]//) {($value, $unit) = ($1, $2);}
if ($eventfield =~ s/\s*(sin|dx|med|bilat|left|right|central|middle)//) { # side:
$side = $1; # left, right, atc: deprecated!
}
if ($eventfield =~ s/\s*\#(\S+)\s+//) { # #channel_mumber
$ch = $1;
}
if ($eventfield =~ s/\s*(\S+):\s*//) { # event
$event = $1;
}
$attr = $eventfield; # the rest = attributes
#GDF
$typ = undef; #event type
if($event){
if($event eq 'calib'){
$typ = 2;
unless($value){$value = 1;} # default 1s
$t1s = $calib;
$dts = $value;
$t2s = $t1s+$dts;
$calib += $dts;
#print "{cal=$calib}";
} else {
unless($t1) {goto NOEVENT;}
if($event eq 'electrode' && ($attr eq 'surface' || $attr eq 'coaxial')) {goto NOEVENT;}
unless($typ = $ev{$event}) { # už se dál neanalyzuje
if($event eq 'press') {
unless (defined($attr{$attr})) {print "$inv/$ltr, po $evn: press-chybí attr: '$attr' !!\n"; goto NOEVENT;}
unless (defined($side{$side})) {print "$inv/$ltr, po $evn: press-chybí sin/dx: '$side' !!\n"; goto NOEVENT;}
$typ = $attr{$attr} + $side{$side};
}
elsif($event eq 'breath' && $attr eq 'inspir') {$typ = 6;}
elsif($event eq 'amplifier' && $attr eq 'gain') {$typ = 3;}
else {goto NOEVENT;}
}
}
}
NOEVENT:
if($typ) {$ev = ++$evn;}
else {$ev = undef;}
my ($howmuchch, @chanarray);
if($ch and ($howmuchch = scalar(@chanarray = split /,/, $ch)) > 1) {$evn += $howmuchch-1;}
#GDF-END
my @eventrecord =
($inv,$ltr,$n,$ev,$typ,$t1s,$dts,$t2s,$t1,$dt,$t2,$MB1,$MB2,$ch,$event,$attr,$side,$value,$unit,$comment);
#20 vars
my $rv = $insert_event->execute(@eventrecord);
if ($verbose>=3) {
if ($t1s) {$t1s = sprintf "%7.1f", $t1s;}
if (defined($dts)) {$dts = sprintf "%5.1f", $dts;}
if ($t2s) {$t2s = sprintf "%7.1f", $t2s;}
@eventrecord =
($inv,$ltr,$n,$ev,$typ,$t1s,$dts,$t2s,$t1,$dt,$t2,$MB1,$MB2,$ch,$event,$attr,$side,$value,$unit,$comment);
foreach my $item(@eventrecord) {$item='--' unless defined $item; $item=~s/^00://;}
printf $form, @eventrecord;
print ">$orig_eventfield" if $verbose>=6;
print "\n";
my $warns_ref = $dbh->selectall_arrayref("SHOW WARNINGS",{Slice=>{}});#arr.of hsh
foreach my $warn ( @$warns_ref ) {
print "\t< $warn->{Level} $warn->{Code}: $warn->{Message} >\n"; #col. names
}
# Alternativní zápis (nemusíme znát názvy sloupců):
# my $warns2_ref = $dbh->selectall_arrayref("SHOW WARNINGS"); # array of arrays
# foreach my $wr ( @$warns2_ref ) {
# print "\t<! $wr->[0] $wr->[1]: $wr->[2] >\n"; # indexes
# }
} else { # warningy každopádně
my $warns_ref = $dbh->selectall_arrayref("SHOW WARNINGS", {Slice=>{}});#arr of hsh
foreach my $warn ( @$warns_ref ) {
print STDERR
"n=$n: $warn->{Level} $warn->{Code}: $warn->{Message} ($orig_eventfield)\n";
}
}
}
else {die "Divný řádek '$_'\n";}
}
print $dbh->do("SHOW DATABASES");
$dbh->disconnect;
}
my $fmt_inv = "%-2s (%4s)%5s %-19s %-4s %4s %1s %3s %3d %3d %3d %-15s %-15s\n";
my @fmt_inv_title = ('in','CD ','numb','mtime','Pers','birt','x','age',1,6,7,'comment','dg');
my $fmt_bin = "%-2s/%1s %-5s%4s %-19s %3s %13s %11s %2s %6s %-20s %11s %-15s \n";
my @fmt_bin_title = ('in','x','lbl','numb','mtime','ext','filename','size','ch','sfreq', 'gain',
'min:sec ','comment');
my $fmt_line = "-------------------------------------------------------------------------------------------------------------------\n";
sub list_invor { # vypíše celou tabulku vyšetření `invor`
my $dbh = db_connect;
my $inv = $dbh->prepare("SELECT * FROM `invor` ORDER BY `num`"); # 17 polí
$inv->execute();
printf $fmt_inv, @fmt_inv_title; print $fmt_line;
while(my @row = $inv->fetchrow_array) {
my ($id, $num, $cdn, $invfile, $mtime, $date, $age, $pers, $birth, $name, $surname,
$sex, $n1 ,$n6, $height, $comment, $dg, $text) = @row;
$birth =~ /\d*/; $birth = $&;
printf $fmt_inv, $id, $cdn, $num, $mtime, $pers, $birth, $sex, $age,
$n1, $n6, $height, $comment, $dg;
}
$inv->finish;
$dbh->disconnect;
}
sub list_bin { # vypíše celou tabulku binárních záznamů `bin`
my $dbh = db_connect;
my $bin = $dbh->prepare("SELECT * FROM `bin` ORDER BY `mtime`"); # 8 polí
$bin->execute();
printf $fmt_bin, @fmt_bin_title; print $fmt_line;
while(my @row = $bin->fetchrow_array) {
foreach my $item(@row){if(! defined $item){$item = '--';}}
my ($inv, $ltr, $filename, $invlabel, $numb, $ext, $mtime, $size, $nchan, $sfreq,
$duration, $comment) = @row;
printf $fmt_bin, $inv, $ltr, $invlabel, $numb, $mtime, $ext, $filename, $size,
$nchan, $sfreq eq '--'?$sfreq:sprintf("%2s kHz", $sfreq/1000),
usec2timestr($duration), $comment;
$last_duration = $duration;
}
$bin->finish;
$dbh->disconnect;
}
sub events { # operace nad tabulkou eventů, volá fce: event_print, event_compute
#=========
my ($fce, @inv) = @_; # odkaz na funkci a seznam vyšetření
#printlist (' ', 'events=', @inv, ":\n");
my $dbh = db_connect;
my $event;
if (@inv) { # byl zadaný seznam?
for my $inv(@inv) {
if ($inv =~ m|(\S*)/(\S)|) { # vyšetření/písmeno
my ($invv, $ltr) = ($1, $2);
#print "$inv = $invv / $ltr\n";
$event = $dbh->prepare("SELECT * FROM `event` WHERE `inv`=? AND `ltr`=? ORDER BY `n`");
$event->execute($invv, $ltr);
} else {
$event = $dbh->prepare("SELECT * FROM `event` WHERE `inv`=? ORDER BY `ltr`, `n`");
$event->execute($inv);
}
&$fce($event);
}
} else { # - jinak se zpracují všechny záznamy
$event = $dbh->prepare("SELECT * FROM `event` ORDER BY `inv`, `ltr`, `n`"); # 8 polí
$event->execute();
&$fce($event);
}
$event->finish;
$dbh->disconnect;
}
sub time_s { # converts mm:ss -> sec
my($ts) = @_; # timestring ve tvaru mm:ss – odstraní hodiny a převede v případě žádosti na sekundy
#print "[[$ts]]";
if($ts =~ /(\d\d):(\d\d)/) {
return 60*$1 + $2;
} else {
print "!!time-s($ts)";
return 0;
}
}
sub secs {
my($time) = @_;
sprintf "%04d", time_s($time)+$calib;
}
sub event_print { # vypíše tabulku `event` podle
my ($event) = @_; # otevřeného handle pro čtení z tabulky `events`
my $curr_inv=''; my $curr_ltr=''; my $curr_n='';
$last_chp_us = $calib_us;
$last_chp_MB = 0;
#printf $fmt_bin, @fmt_bin_title; print $fmt_line;
print "Výpis tabulky `event`:\n" if $verbose>=2;
while(my @row = $event->fetchrow_array) {
# foreach my $item(@row){if(! defined $item){$item = '--';}}
# my ($inv,$ltr,$n,$t1,$dt,$t2,$MB1,$MB2,$ch,$event,$attr,$side,$value,$unit,$comment) = @row;
my ($inv,$ltr,$n,$ev,$typ,$t1s,$dts,$t2s,$t1,$dt,$t2,$MB1,$MB2,$ch,$event,$attr,$side,$value,$unit,$comment) = @row;
#printf "[[t1s %s, dts %s, t2s %s, side %s]]\n", defined($t1s) ? "defined($t1s)" : 'undef', defined($dts) ? "defined($dts)" : 'undef', defined($t2s) ? "defined($t2s)" : 'undef', defined($side) ? "defined($side)" : 'undef';
if ($verbose>=8){
my @line=@row;
foreach my $item(@line){if(! defined $item){$item = '..';} $item .= ', ';}
print @line, "\n";
}
if($inv ne $curr_inv) { # current investigation
$curr_inv=$inv; $curr_ltr='';
#printf $full ? "\ninvestigation:\t%s" : "\n%s ", $curr_inv;
printf $full ? "" : " * %s", $curr_inv;
}
if($ltr ne $curr_ltr) { # current letter
$curr_ltr=$ltr;
#printf $full ? "\nletter:\t\t%s\n" : " /%s", $curr_ltr;
if($full) {print "\n*** $curr_inv/$curr_ltr ***\n";}
else {
print " /$curr_ltr";
if($recstop or $chp) {print "\n";}
}
}
my $timestr=''; # timestring
my $sstr=''; # secondsstring
if($t1) {$t1=~s/^00://; $timestr.= "$t1"; $sstr.=secs($t1);} else {$timestr.= '~'; $sstr.='~';}
if($dt) {$dt=~s/^00://; $timestr.= "+$dt"; $sstr.='+'.secs($dt);}
if($t2) {$t2=~s/^00://; $timestr.= "-$t2"; $sstr.='-'.secs($t2);}
my $MB = ''; if ($MB1) { $MB = $MB2 ? "$MB1-$MB2" : $MB1;}
my $diff_p = ''; # difference percent
if ($chp) { # compute&print checkpoints
if ($MB1){
my $chp_us = timestr2usec($timestr);
if ($chp_us) {
#print "** timestr = $timestr, chp_us = $chp_us,";
$chp_us += $calib_us;
my $chp_interval_us = $chp_us - $last_chp_us;
#print " ** chp_us = $chp_us, last_chp_us = $last_chp_us, chp_interval_us = $chp_interval_us **\n";
my $chp_interval_MB = $MB1 - $last_chp_MB;
my $chp_interval_MB2us = int( $chp_interval_MB * 1000000 * $sample_int_us / (2 * $nchan));
$diff_p = sprintf (" %+.1f %% ", 100 * ($chp_interval_MB2us - $chp_interval_us)/$chp_interval_us);
unless ($full){
printf("%-10s %-12s %-10s %-15s %-4s %-1s %-1s %-1s\n",
$sstr, $timestr, , $event?"$event:":'', $attr, $side, $MB?"~$MB [MB]":'', $diff_p, $comment?";$comment":'');
}
}
}
}
if($value) {$value = "=$value";}
if ($full) {
# printf("%-10s %-12s %-4s %-10s %-15s %-4s %5s %-5s %-1s %-1s %-1s\n",
# $sstr, $timestr, $ch?'#'.$ch:'', $event?"$event:":'', $attr, $side, $value,
# $unit?"[$unit]":'', $MB?"~$MB [MB]":'', $diff_p, $comment?";$comment":'');
my $form;
# inv/ltr n ev typ t1s dts t2s t1 dt t2 MB1 MB2 ch event attr side value unit comment
if ($fulltime) {
$form = "%3s %3s %4s %10s %8s %10s %5s %5s %5s %5s %5s %3s %-6s: %-16s %-5s %-5s %-4s %s\n";
# n ev typ t1s dts t2s t1 dt t2 MB1 MB2 ch event attr side value unit comment
if (defined($t1s)) {$t1s = sprintf "%10.4f", $t1s;}
if (defined($dts)) {$dts = sprintf "%8.4f", $dts;}
if (defined($t2s)) {$t2s = sprintf "%10.4f", $t2s;}
} else {
$form = "%3s %3s %4s %7s %5s %7s %5s %5s %5s %5s %5s %3s %-6s: %-16s %-5s %-5s %-4s %s\n";
# n ev typ t1s dts t2s t1 dt t2 MB1 MB2 ch event attr side value unit comment
if (defined($t1s)) {$t1s = sprintf "%7.1f", $t1s;}
if (defined($dts)) {$dts = sprintf "%5.1f", $dts;}
if (defined($t2s)) {$t2s = sprintf "%7.1f", $t2s;}
}
my @line = ($n,$ev,$typ,$t1s,$dts,$t2s,$t1,$dt,$t2,$MB1,$MB2,$ch,$event,$attr,$side,$value,$unit,$comment);
#printf ($form, $n,$ev,$typ,$t1s,$dts,$t2s,$t1,$dt,$t2,$MB1,$MB2,$ch,$event,$attr,$side,$value,$unit,$comment);
foreach my $item(@line){if(! defined $item){$item = '--';}}
printf $form, @line ;
}
if ($recstop and defined($event) and $event eq 'record' and $attr=~/stop/) {
print " recstop = $timestr";
if (my $recstop_us = timestr2usec($timestr)) {
#printf " = %s us", $recstop_us;
#printf ", čas bin. souboru = %d", $last_duration;
my $recordtime_us = timestr2usec($timestr);
my $difference_us = $last_duration - $recordtime_us;
printf ", odchylka času = %s = %+.2f %%",
usec2timestr($difference_us), 100*$difference_us/$recordtime_us;
if($MB1) {
my $binfilesizeMB = (int(($curr_binfilesize/100000)+0.5)/10);
print (", velikosti = $MB1 - $binfilesizeMB = ", $MB1 - $binfilesizeMB, ' MB');
}
print "\n";
if($full) {print "\n";}
}
}
}
print "\n" unless $full;
}
sub event_compute { # bude počítat něco s těmi eventy - zatím jen zkopírovaná fce event_print
my ($event) = @_;
my $curr_inv=''; my $curr_ltr=''; my $curr_n='';
#printf $fmt_bin, @fmt_bin_title; print $fmt_line;
print "Výpis tabulky `event`:\n" if $verbose>=2;
while(my @row = $event->fetchrow_array) {
foreach my $item(@row){if(! defined $item){$item = '';}}
my ($inv,$ltr,$n,$t1,$dt,$t2,$MB1,$MB2,$ch,$event,$attr,$side,$value,$unit,$comment) = @row;
print "$inv,$ltr,$n,$t1,$dt,$t2,$MB1,$MB2,$ch,$event,$attr,$side,$value,$unit,$comment\n"
if $verbose>=3;
if($inv ne $curr_inv) {$curr_inv=$inv; $curr_ltr=''; print "\ninvestigation:\t$curr_inv\n";}
if($ltr ne $curr_ltr) {$curr_ltr=$ltr; print "\nletter:\t\t$curr_ltr\n";} # current letter
my $timestr='';
if($t1) {$t1=~s/^00://; $timestr.= "$t1";} else {$timestr.= '~';}
if($dt) {$dt=~s/^00://; $timestr.= "+$dt";}
if($t2) {$t2=~s/^00://; $timestr.= "-$t2";}
my $MB = $MB1.$MB2 ? "$MB1-$MB2" : '';
if($value) {$value = "=$value";}
printf("%-12s %-4s %-10s %-15s %-4s %5s %-5s %-1s %-1s\n",
$timestr, $ch?'#'.$ch:'', $event?"$event:":'', $attr, $side, $value,
$unit?"[$unit]":'', $MB?"~$MB [MB]":'', $comment?";$comment":'');
}
}
sub list {
#=======
my @invs = @_; # list of investigations
my $dbh = db_connect;
my $invor= $dbh->prepare("SELECT * FROM `invor` ORDER BY `num`, `inv`"); # 18 polí
my $comm = $dbh->prepare("SELECT `comment` FROM `comm` WHERE `inv` = ? ORDER BY `n`");# 3 pole
my $bin = $dbh->prepare("SELECT * FROM `bin` WHERE `inv` = ? ORDER BY `inv`, `ltr`, `filename`"); # 8 polí
$invor->execute(); # `invor` = vyšetření
printf $fmt_inv, @fmt_inv_title;
printf $fmt_bin, @fmt_bin_title;
print $fmt_line;
while(my @row = $invor->fetchrow_array) {
my ($id, $num, $cdn, $invfile, $mtime, $date, $age, $pers, $birth, $name, $surname,
$sex, $n1 ,$n6, $height, $comment, $dg, $text) = @row;
next if(@invs and not (grep /$id/, @invs)); # přeskočí všechny kromě vyžadovaných
$birth =~ /\d*/; $birth = $&;
my $cddirname = sprintf "CD%02d", $cdn;
printf $fmt_inv, $id, $cddirname, $num, $mtime, $pers, $birth, $sex, $age,
$n1, $n6, $height, $comment, $dg;
$comm->execute($id); # `comm` = comments
while(my @row = $comm->fetchrow_array) {
my($comment) = @row;
print $comment;
}
$bin->execute($id); # `bin` = binary file
my @binlist = grep m|$id/|, @invs;
while(my @row = $bin->fetchrow_array) {
foreach my $item(@row){if(! defined $item){$item = '--';}}
my ($inv, $ltr, $filename, $invlabel, $numb, $ext, $mtime, $size, $ch,
$sf, $gainstr, $duration, $comment) = @row;
next if(@binlist and not (grep m|$inv/$ltr|, @binlist)); # přeskoč nevyžadované
$nchan = $ch;
$sfreq = $sf;
if($sfreq eq '--') {undef $sfreq;}
if($sfreq) {$sample_int_us = 1000000/$sfreq;} else {undef $sample_int_us;}
$last_duration = $duration;
$curr_binfilesize = $size;
#print ">>> sfreq = $sfreq <<<";
printf $fmt_bin, $inv, $ltr, $invlabel, $numb, $mtime, $ext, $filename,
$size, $nchan, $sfreq ? sprintf("%2s kHz", $sfreq/1000) : '--', $gainstr,
usec2timestr($duration), $comment;
if($ev) {events(\&event_print, "$inv/$ltr");}
if(defined $togdf && $ext eq 'EXP') { togdf($inv, $ltr, $cddirname.'/'.$id.'/'.$filename);}
}
#$bin->finish;
print "\n";
}
#$invor->finish;
$dbh->disconnect;
}
sub prtempl { # protocol templates = udělá šablony pro protokoly
#============
my @invs = @_; # list of investigations
my $dbh = db_connect;
my $invor= $dbh->prepare("SELECT * FROM `invor` ORDER BY `num`, `inv`"); # 18 polí
my $bin = $dbh->prepare("SELECT * FROM `bin` WHERE `inv` = ? ORDER BY `mtime`"); # 8 polí
$invor->execute(); # `invor` = vyšetření
while(my @row = $invor->fetchrow_array) {
my ($id, $num, $cdn, $invfile, $mtime, $date, $age, $pers, $birth, $name, $surname,
$sex, $n1 ,$n6, $height, $comment, $dg, $text) = @row;
next if(@invs and not (grep /$id/, @invs)); # přeskočí všechny kromě vyžadovaných
$birth =~ /\d*/; $birth = $&;
my $cddirname = sprintf "CD%02d", $cdn;
my $invdate = substr($mtime,0,10);
my $outfilename = $outdir.$id.'-'.$invdate.'.prt';
unless (open(OUTFILE, '>', $outfilename)) {print STDERR "Neotevřu $outfilename pro zápis!\n"; next;}
#print "$id, $cddirname, $num, $mtime, $pers, $birth, $sex, $age, $n1, $n6, $height, $comment, $dg \n";
print OUTFILE "!TEMPLATE!\n$id\n$invdate\n$pers\n\n";
print OUTFILE ";v. $version\n";
print OUTFILE "%ang_costae\t5\n";
$bin->execute($id); # `bin` = binary file
my @binlist = grep m|$id/|, @invs;
while(my @row = $bin->fetchrow_array) {
foreach my $item(@row){if(! defined $item){$item = '--';}}
my ($inv, $ltr, $filename, $invlabel, $numb, $ext, $mtime, $size, $nchan,
$sfreq, $duration, $comment) = @row;
next unless($ext eq 'EXP'); # jen EXP soubory
next if(@binlist and not (grep m|$inv/$ltr|, @binlist)); # přeskoč nevyžadované
#printf $fmt_bin, $inv, $ltr, $invlabel, $numb, $mtime, $ext, $filename,
# $size, $nchan, $sfreq eq '--'?$sfreq:sprintf("%2s kHz", $sfreq/1000),
# usec2timestr($duration), $comment;
#print "$inv, $ltr, $invlabel, $numb, $mtime, $ext, $filename, $size, $nchan, $sfreq ", usec2timestr($duration)," $comment\n";
print OUTFILE "\n$ltr\n$filename\n";
#$last_duration = $duration;
#if($ev) {events(\&event_print, "$inv/$ltr");}
print OUTFILE <<"END";
\t\tafflicted:
%4chLRsc
%simons
~\t\t%gain 10
~\t\tposition: head right
~\t\tneedle: sin depth mm
~\t\tneedle: dx depth mm
~\t\tneedle: bilat depth mm
00:00\t\trecord: start,localtime CEST
\t #
\t\tneedle: sin push,fascia
\t\tneedle: sin tautband,in
\t\tsignal: sin AP,vanished
\t\tsignal: sin coax,activity
\t # signal: NPN
\t\tsignal: surface,both,AP
\t\t%stim1
\t\t%breath1 12
\t\tbreath: normal
\t\t%breath2 8
\t\tbreath: normal
\t\tmotion: head
\t\telectrode: sin surface,touch
\t\tneedle: sin move,fix
\t\tneedle: sin tautband,off
\t\tneedle: dx tautband,off
\t\tneedle: sin pull,off,!roof,blood
\t\tneedle: dx pull,off,!roof,blood
:\trecord: stop,localtime CEST MB
END
}
#$bin->finish;
#print "\n";
close OUTFILE;
}
#$invor->finish;
$dbh->disconnect;
}
sub events2gdf_test100{ # zapíše tabulku eventů do gdfbufferu
my $nev = 100; # number of events
my $sfreq = 5000;
my $nev1 = $nev & 0xff; # the lower significance byte
my $nev2 = ($nev >> 8) & 0xff; # the middel byte
my $nev3 = ($nev >> 16) & 0xff; # the higher byte
my $gdfeventtblstruct =
'C'. # 8bit: typ = 3
'C3'. # 24bit: NEV = number of events
'f'; # 32bit float: sample rate
# my $gdfeventitemstruct =
# 'L'. # ULong=uint32: position (samples)
# 'S'. # UShort: type
# 'S'. # Ushort: channel
# 'L'; # ULong: duration (samples)
$gdfeventsbuf = pack $gdfeventtblstruct, 3, $nev1, $nev2, $nev3, $sfreq;
my $evtype = 0;
for(my $ev=0; $ev<$nev; $ev++){ # position
$gdfeventsbuf .= pack 'L', $ev*$sfreq;
}
for(my $ev=0; $ev<$nev; $ev++){ # type
$gdfeventsbuf .= pack 'S', $evtype++;
}
for(my $ev=0; $ev<$nev; $ev++){ #channel
$gdfeventsbuf .= pack 'S', $ev%5;
}
for(my $ev=0; $ev<$nev; $ev++){ #duration
$gdfeventsbuf .= pack 'L', 1000;
}
}
sub events2gdf_test1 { # zapíše tabulku eventů do gdfbufferu
my $nev = 1; # number of events
my $sfreq = 5000;
my $nev1 = $nev & 0xff; # the lower significance byte
my $nev2 = ($nev >> 8) & 0xff; # the middel byte
my $nev3 = ($nev >> 16) & 0xff; # the higher byte
my $gdfeventtblstruct =
'C'. # 8bit: typ = 3
'C3'. # 24bit: NEV = number of events
'f'; # 32bit float: sample rate
# my $gdfeventitemstruct =
# 'L'. # ULong=uint32: position (samples)
# 'S'. # UShort: type
# 'S'. # Ushort: channel
# 'L'; # ULong: duration (samples)
$gdfeventsbuf = pack $gdfeventtblstruct, 3, $nev1, $nev2, $nev3, $sfreq;
my $evtype = 0;
for(my $ev=0; $ev<$nev; $ev++){ # position
$gdfeventsbuf .= pack 'L', 105*$sfreq;
}
for(my $ev=0; $ev<$nev; $ev++){ # type
$gdfeventsbuf .= pack 'S', 4;
}
for(my $ev=0; $ev<$nev; $ev++){ #channel
$gdfeventsbuf .= pack 'S', 2;
}
for(my $ev=0; $ev<$nev; $ev++){ #duration
$gdfeventsbuf .= pack 'L', 10*$sfreq;
}
}
sub event_gdf { # připojí event-table za GDF soubor
my ($event) = @_;
my $curr_inv=''; my $curr_ltr=''; my $curr_n='';
#printf $fmt_bin, @fmt_bin_title; print $fmt_line;
my $sfreq = 5000; # sampling frequency – default 5 kHz
my $gdfeventtblstruct =
'C'. # 8bit: typ = 3
'C3'. # 24bit: NEV = number of events
'f'; # 32bit float: sample rate
# my $gdfeventitemstruct =
# 'L'. # ULong=uint32: position (samples)
# 'S'. # UShort: type
# 'S'. # Ushort: channel
# 'L'; # ULong: duration (samples)
my $form1 = "%2d: %7.1f %5.1f %7.1f %2d %04d";
my @evnumber;
my @position; # seconds
my @type;
my @channel;
my @duration; # seconds
my $nev = 0; # number of events
$calib = 0;
while(1) {
my @row = $event->fetchrow_array;
my ($inv,$ltr,$n,$ev,$typ,$t1s,$dts,$t2s,$t1,$dt,$t2,$MB1,$MB2,$ch,$event,$attr,$side,$value,$unit,$comment) = @row;
if(!@row or $inv ne $curr_inv or $ltr ne $curr_ltr) { # IT WILL BE A NEW EMG RECORD
if ($nev) { # the non-zero event table will be appended to the GDF file
printf ("---------%3d events: t1s dts position duration\n", $nev) if $verbose >=5;
if($verbose>=6){
my $form = " %3d %4d %9.4f %7.4f %9d %9d\n";
for(my $e=0; $e<$nev; $e++){ # print
printf $form, $evnumber[$e], $type[$e], $position[$e], $duration[$e], $position[$e]*$sfreq, $duration[$e]*$sfreq;
}
}
my $nev1 = $nev & 0xff; # the lower significance byte
my $nev2 = ($nev >> 8) & 0xff; # the middel byte
my $nev3 = ($nev >> 16) & 0xff; # the higher byte
$gdfeventsbuf = pack $gdfeventtblstruct, 3, $nev1, $nev2, $nev3, $sfreq;
# if($verbose >= 9) {printf "%0x %0x %0x %0x\n",$ ,$ ,$ ,$ ;}
if($verbose >= 9) {printf "---------------------------\n%02x %02x %02x %02x %f->4byte_float\n",
3, $nev1, $nev2, $nev3, $sfreq ;}
#my $evtype = 0;
for(my $e=0; $e<$nev; $e++){ # position
$gdfeventsbuf .= pack 'L', my $tmp = (shift @position) * $sfreq + 1; # position of the first sample is 1
if($verbose >= 9) {printf " %08x", $tmp;}
}
if($verbose >= 9) {print "\n";}
for(my $e=0; $e<$nev; $e++){ # type
$gdfeventsbuf .= pack 'S', my $tmp = shift @type;
if($verbose >= 9) {printf " %04x", $tmp;}
}
if($verbose >= 9) {print "\n";}
for(my $e=0; $e<$nev; $e++){ #channel
$gdfeventsbuf .= pack 'S', my $tmp = shift @channel;
if($verbose >= 9) {printf " %04x", $tmp;}
}
if($verbose >= 9) {print "\n";}
for(my $e=0; $e<$nev; $e++){ #duration
$gdfeventsbuf .= pack 'L', my $tmp = (shift @duration) * $sfreq;
if($verbose >= 9) {printf " %08x", $tmp;}
}
if($verbose >= 9) {print "\n---------------------------\n";}
my $gdffilename0 = "$emg::gdfdir/$curr_inv$curr_ltr-5k0.gdf";
-e $gdffilename0 or die "Neexistuje původní soubor gdffilename0";
my $gdffilename = "$emg::gdfdir/$curr_inv$curr_ltr-5k.gdf";
if(!(-e $gdffilename) or ((-s $gdffilename) != (-s $gdffilename0))) {
copy($gdffilename0, $gdffilename) or die "Nepodařilo se zkopírovat soubor: $!";
}
printf "%d bytes table >> %s\n\n", length($gdfeventsbuf), $gdffilename;
sysopen (GDFFILE, $gdffilename, O_WRONLY | O_APPEND) or die "Nelze otevřít \"$gdffilename\" pro navěšení: $!\n";
#print GDFFILE '';
print GDFFILE $gdfeventsbuf;
close(GDFFILE) or die "Nelze uzavřít \"$gdffilename\" po zápisu eventtable: $!\n";
my $command = "ls -l $emg::gdfdir/$curr_inv$curr_ltr*\n";
print $command;
print `$command`;
$nev = 0; # number of events
$calib = 0;
@evnumber = @position = @type = @channel = @duration = ();
}
if(@row){
$curr_inv = $inv; $curr_ltr = $ltr;
print "\n========= $curr_inv/$curr_ltr ==========\n";
} else { last;}
}
if ($verbose>=3 and @row){
my @line = @row;
foreach my $item(@line){if(! defined $item){$item = '--';}}
my $form = "%2s/%s %3s %3s %4s %9s %7s %9s %8s %8s %8s %5s %5s %4s %-5s %-16s %-5s %-5s %-4s %s\n";
printf $form, @line;
}
# my $timestr=''; # timestring
# if($t1) {$t1=~s/^00://; $timestr.= "$t1";} else {$timestr.= '~'}
# if($dt) {$dt=~s/^00://; $timestr.= "+$dt";}
# if($t2) {$t2=~s/^00://; $timestr.= "-$t2";}
# my $MB = $MB1.$MB2 ? "$MB1-$MB2" : '';
# my $ev=0; #event type
# my ($pos, $dur, $typ, $cha);
if($ev){
$nev++;
push @evnumber, $ev;
push @type, $typ;
push @position, $t1s; #print "[[t1s=$t1s]]";
push @duration, $dts;
if($ch and $ch ne 'all'){ # for some channel only
my @chnls = split /,/,$ch;
push @channel, shift @chnls;
for my $otherch(@chnls){
$nev++;
push @evnumber, ++$ev;
push @type, $typ;
push @position, $t1s;
push @duration, $dts;
push @channel, $otherch;
}
#print "[[$ch = jen něco: @chnls a_to: $channel[$nev]]]";
} else { # 0 = for all channels
#print "[[$ch = všechny]]";
push @channel, 0;
#printf $form1, $nev+1, $pos, $dur, $pos+$dur, $cha, $typ;
}
# print "nev=$nev, evnumber=$ev\n";
} else {
# print " ";
}
# my $evstr = $ev ? sprintf "%02d", $ev : '';
# printf("%-10s %-2s %-12s %-4s %-10s %-15s %-4s %5s %-5s %-1s %-1s\n",
# $sstr, $evstr, $timestr, $ch?'#'.$ch:'', $event?"$event:":'', $attr, $side, $value,
# $unit?"[$unit]":'', $MB?"~$MB [MB]":'', $comment?";$comment":'');
# if($value) {$value = "=$value";}
# printf(" %-12s %-4s %-10s %-15s %-4s %5s %-5s %-1s %-1s\n",
# $timestr, $ch?'#'.$ch:'', $event?"$event:":'', $attr, $side, $value,
# $unit?"[$unit]":'', $MB?"~$MB [MB]":'', $comment?";$comment":'');
}
}
sub get_help {
print <<'END';
emgdb.pl - skript pro údržbu MySQL databáze EMG vyšetření
Základní volby (alepoň jedna musí být uvedena):
--help tato nápověda
--truncate smaže tabulky `invor` (vyšetření) a `bin` (binární záznamy EMG)
--load projde adresáře CD s EMG soubory a uloží data do tabulek `invor` a `bin`
--addcomm file přidá komentáře ze souboru "file"
--delcomm vymaže tabulku komentářů `comm`
--addpro file přidá protokoly vyšetření ze souboru "file" do tabulky událostí
--delpro=2B vymaže vyšetření (např. 2B) z tabulky událostí
--delpro=all vymaže celou tabulku událostí
--invor vypíše tabulku `invor` = seznam vyšetření dle souborů *.INV
--bin vypíše tabulku `bin` = seznam souborů s binárními záznamy EMG
--events [inv] vypíše tabulku `event` = tabulka všech EMG událostí
--list [inv] vypíše tabulky `invor` a `bin` = seznam vyšetření a binární záznamy EMG
--prtempl [inv] generuje šablony *.pr pro zápis protokolů
kde:
[inv] je volitelné oznčení vyšetření (případně s lomítkem)
Doplňkové volby:
--verbose=číslo upovídané operace; číslo od 0 výše
--ev vypisuje eventy u volby --list
--full úplný výpis eventů
--fulltime úplný výpis eventů s časem v plné přesnosti
--recstop čas konce záznamu
--anal analýza u volby --list
--gdfevents otevře GDF file – append event table
--togdf=gdffilename při list konvertuje do GDF (jméno souboru je volitelné; default=zkratka, 5 kHz)
END
}
################## MAIN ####################
#my $get_help=''; my $get_man='';
#my $dbtruncate=''; my $dbload='';
#my $commentfile=''; my $delete_comments=''; my $protocolfile=''; my $del_events;
#my $list_invor=''; my $list_bin=''; my $list_events=''; my $compute_events = '';
#my $list='';
my ($get_help, $get_man, $dbtruncate, $dbload, $commentfile, $delete_comments,
$protocolfile, $del_events, $list_invor, $list_bin, $list_events, $compute_events,
$list, $prtempl);
GetOptions (
'help|?' => \$get_help,
'man' => \$get_man,
'truncate' => \$dbtruncate,
'load' => \$dbload,
'addcomm' => \$commentfile,
'delcomm' => \$delete_comments,
'addpro' => \$protocolfile,
'delpro=s' => \$del_events,
'invor' => \$list_invor,
'bin' => \$list_bin,
'events' => \$list_events,
'compute' => \$compute_events,
'list' => \$list,
'verbose=s' => \$verbose,
'ev' => \$ev,
'gdfevents' => \$gdffilename,
'full' => \$full,
'fulltime' => \$fulltime,
'recstop' => \$recstop,
'anal' => \$anal,
'prtempl' => \$prtempl,
'chp' => \$chp, # checkpoints
'togdf:s' => \$togdf,
) or pod2usage(1); # or pod2usage(2);
if ($get_help) {get_help;}
#if($get_help) {pod2usage(1);}
if($get_man) {pod2usage(-exitstatus => 0, -verbose => 2);}
if($fulltime) {$full = 1;} # --fulltime implikuje --full
if($dbtruncate) {
my $dbh = db_connect;
$dbh->do("TRUNCATE `invor`");
$dbh->do("TRUNCATE `bin`");
$dbh->disconnect;
print "Tabulky `invor` a `bin` vyprázdněny\n";
}
if($del_events) { # vymaže protokol z tabulky `event`
my $dbh = db_connect;
if($del_events eq 'all') {$dbh->do("TRUNCATE `event`");
print "Tabulka `event` vyprázdněna.\n";}
else {$dbh->do("DELETE FROM `event` WHERE `inv`='$del_events'");}
$dbh->disconnect;
}
if($dbload) {dbload;}
if($commentfile) {
unless (scalar(@ARGV)) {print "! Chybí zadání souboru s komentářem!\n\n"; get_help;}
else {
while (my $commentfile = shift @ARGV) {
open(my $COMMENTFILE, $commentfile) or die "Nelze otevřít \"$commentfile\": $!\n";
print ">>>>>Soubor komentářů: $commentfile>>>>>\n" if $verbose;
add_comment($COMMENTFILE);
close $COMMENTFILE;
}
}
}
if($delete_comments) {
my $dbh = db_connect;
$dbh->do("TRUNCATE `comm`");
$dbh->disconnect;
print "Tabulka `comm` byla vyprázdněna\n";
}
if($protocolfile) {
unless (scalar(@ARGV)) {print "! Chybí zadání souboru s protokolem!\n\n"; get_help;}
else {
while (my $protocolfile = shift @ARGV) {
open(my $PROTOCOLFILE, $protocolfile) or die "Nelze otevřít \"$protocolfile\": $!\n";
print "\n>>>>>Soubor protokolu: $protocolfile>>>>>\n" if $verbose;
add_protocol($PROTOCOLFILE);
close $PROTOCOLFILE;
}
}
}
if($list_invor) {list_invor;}
if($list_bin) {list_bin;}
if($list_events) {events(\&event_print, @ARGV);}
if($compute_events) {events(\&event_compute, @ARGV);}
if($list) {list(@ARGV);}
if($prtempl) {prtempl(@ARGV);}
if($gdffilename){
open (my $GDFFILE, ">>$gdffilename") or die "Nelze otevřít \"$gdffilename\": $!\n";
# events2gdf();
events(\&event_gdf, @ARGV);
# print $GDFFILE $gdfeventsbuf;
close($GDFFILE) or die "Nelze zavřít \"$gdffilename\": $!\n";
}
#use utf8;
__END__
=head1 NAME
emgdb - skript pro údržbu MySQL databáze EMG vyšetření
=head1 SYNOPSIS
emgdb [options]
emgdb --help
=head1 OPTIONS
=over 8
=item B<--help>
Tato nápověda.
=item B<--man>
Vypíše manuálovou stránku.
=item B<--truncate>
Smaže tabulky `invor` a `bin`.
=item B<--load>
Projde adresář s EMG soubory a uloží data do tabulek `invor` a `bin`.
=item B<--addcomm> I<file>
Přidá komentáře ze souboru I<file> do tabulky `comm`.
=item B<--delcomm>
Vymaže tabulku komentářů `comm`.
=item B<--addpro> I<file>
Přidá protokoly vyšetření ze souboru I<file> do tabulky `event`
=item B<--delpro=>I<inv>
Vymaže protokoly vyšetření I<inv> z tabulky událostí `event`
=item B<--delpro=all>
Vymaže celou tabulku událostí `event`
=item B<--invor>
Vypíše tabulku `invor` = databáze vyšetření dle originálních souborů *.INV
=item B<--bin>
Vypíše tabulku `bin` = seznam souborů s binárními záznamy EMG
=item B<--events>
Vypíše tabulku `event` = seznam souborů s binárními záznamy EMG
=item B<--list>
Vypíše tabulky `invor`, `bin`, `comm` = seznam vyšetření a binární záznamy EMG včetně komentářů
=item B<--verbose=>I<n>
Upovídané operace; I<n> je stupeň upovídanosti.
=back
=head1 DESCRIPTION
B<emgdb> je skript pro údržbu MySQL databáze EMG vyšetření.
=cut
