Remove all OBX segments from a HL7 message - tcl

I have the following code which removed all OBX segments prior to the first one that contains addendum:
# This Cloverleaf TPS script removes all OBX segments prior to the first one that contains "ADDENDUM".
# This script also renumbers the OBX segments.
#
# See http://clovertech.healthvision.com/viewtopic.php?t=5953
proc remove_prior_to_addendum {args} {
# set the procedure name
# This is used for error messages
set procname [lindex [info level [info level]] 0]
# bring some common variables into the scope of this proc
global HciSite HciSiteDir HciProcessesDir HciConnName HciRootDir ibdir
# fetch mode
keylget args MODE mode
# keylget args ARGS.ARGNAME argname
switch -exact -- $mode {
start {
# Perform special init functions
# N.B.: there may or may not be a MSGID key in args
}
run {
# 'run' mode always has a MSGID; fetch and process it
keylget args MSGID msgid
# get the message
set msgdata [msgget $msgid]
# does this message have "ADDENDUM"?
if {! [regexp {OBX[^\r]*\|ADDENDUM} $msgdata] } {
# This message does not have an ADDENDUM, so continue the message
return "{CONTINUE $msgid}"
}
# if we get here, we have an ADDENDUM
# get the separators
set segment_sep \r
# process the message
if { [catch {
# commands
# split the message into segments
set segments [split $msgdata $segment_sep]
# find the first OBX with an ADDENDUM
set addendum_index [lsearch -regexp $segments {^OBX[^\r]*\|ADDENDUM}]
# renumber the OBX segments that will remain
set i 1
foreach index [lsearch -all -regexp -start $addendum_index $segments {^OBX}] {
set segment [lindex $segments $index]
set segments [lreplace $segments $index $index [regsub {^OBX\|[0-9]*\|} $segment "OBX|$i|"]]
incr i
}
# now find any OBX segments prior to the ADDENDUM segment
set obx_indexes [lsearch -all -regexp [lrange $segments 0 [expr $addendum_index - 1]] {^OBX}]
# sort the indexes descending so that we can safely remove the indexes
set obx_indexes [lsort -decreasing -integer $obx_indexes]
# remove each segment
foreach index $obx_indexes {
set segments [lreplace $segments $index $index]
}
# rebuild the message
set msgdata [join $segments $segment_sep]
} errmsg ] } {
# the commands errored
global errorInfo
msgmetaset $msgid USERDATA "ERROR: $errmsg\n*** Tcl TRACE ***\n$errorInfo"
# rethrow the error
error $errmsg $errorInfo
}
# set the output message
msgset $msgid $msgdata
# return whether to kill, continue, etc. the message
return "{CONTINUE $msgid}"
}
time {
# Timer-based processing
# N.B.: there may or may not be a MSGID key in args
}
shutdown {
# Do some clean-up work
}
default {
error "Unknown mode in $procname: $mode"
return "" ;# Dont know what to do
}
}
}
How do I edit the script so it removed ALL OBX segments from the message?

I don't know much about hl7 (in fact I know nothing about it) but it looks like you want to remove those lines:
# does this message have "ADDENDUM"?
if {! [regexp {OBX[^\r]*\|ADDENDUM} $msgdata] } {
# This message does not have an ADDENDUM, so continue the message
return "{CONTINUE $msgid}"
}

Related

Why does the channel event readable keep firing in this code?

Could you tell me what in this code would cause the chan event $sock readable [list ReadLine $sock] to repeatedly be fired after a socket has been reset?
I'm trying to keep the socket open on an extremely simple local server by resetting the socket to read again at the first line.
I'm not sure if it is the browser or the Tcl code. I flush the socket before sending each response using chan flush $sock; so, I don't think there should be any data left in the input buffer to fire the readable event.
Everything works fine until I stop using the application for a few minutes, and then procedure ReadLine is repeatedly invoked with a state of 1 but no data.
I included procedure GetLexi at the end because its the one I've been testing when this started occurring and, perhaps, I'm doing something wrong there and the browser doesn't know the response is complete. I should add also that it is called from with procedure GetHandler and should return back to the switch block and be reset. I did test that the socket is reset after an invocation of GetLexi.
Thank you for any guidance you may be able to provide.
proc ResetSock {sock} {
global state
set state($sock) {1}
chan configure $sock -encoding iso8859-1 -translation crlf
}; #close ResetSock
proc ClientConnect {sock client_ip client_port} {
global state
if {![info exists state($sock)]} {
set state($sock) {1}; # 1 for first line; 2 for any other header line.
chan configure $sock -buffering line -blocking 0 -encoding iso8859-1 -translation crlf
}
chan event $sock readable [list ReadLine $sock]
}; #close ClientConnect
proc ReadLine {sock} {
global state
set sptr state($sock)
set row [lindex [set $sptr] 0]
if {[catch {gets $sock line} len]} {
# Handle this error.
return
}
if {$len == 0} {
#According to Tclhttpd, in between requests, a row 1 and len 0
#combination can occur. There, it is ignored.
if {$row == 2 } {
switch [lindex [set $sptr] 1] {
"POST" {
set post [PostHandler $sock [lindex [set $sptr] 3]]
puts stdout "Posted: $post"
ResetSock $sock
}
"GET" {
GetHandler $sock [lindex [set $sptr] 2]
ResetSock $sock
}
default { CloseSock $sock }
}
}
} elseif {$len > 0} {
switch $row {
1 {
# First row of request.
lassign [split [string trim $line]] op arg rest
lappend $sptr $op $arg
lset $sptr 0 0 2
}
2 {
# Read headers.
}
default { }
}
} else {
# Only other option for $len is a negative value;
# thus, an error to be handled.
}
}; #close ReadLine
proc GetLexi { nbr sock } {
chan flush $sock
set sql { select img_base64 from lexi_raw where strongs_no = $nbr }
dbws eval $sql {
set lexi [binary format a* "{\"lexi\":\"$img_base64\"}"]
}
set headers ""
append headers "HTTP/1.1 200 OK\n"
append headers "Content-Type: application/json; charset: utf-8\n"
append headers "Content-length: [string length $lexi]\n"
append headers "Connection: Keep-Alive\n"
puts $sock $headers
chan configure $sock -translation binary
puts $sock $lexi
}; #close GetLexi
set state(x) {}
if [catch {set listener [socket -server ClientConnect -myaddr 127.0.0.1 8000]}] {
error "couldn't open listening socket"
}
vwait forever
catch {close $listener}
It's possible for the amount of data received in a packet to be not enough to complete a line. TCP hides most of the details, of course, but it remains entirely possible for the readable event to fire when a complete line is not available. As you've put the socket in non-blocking mode, that means that gets will do a zero length read (empty string written to line, len becomes 0); if the socket was blocking, the gets would block the thread until a complete line was available. You can also get zero-length reads if the channel is closed; detection of closure isn't very reliable with TCP (because networking is like that) but may happen. When the socket is closed, all reading from it in non-blocking mode results in zero-length results.
How do you distinguish these cases?
First, we check for end-of-stream:
if {[chan eof $sock]} {
# It's gone; there's not much else you can do at this point except log it I guess
close $sock
return
}
Then we need to see if things are blocked, and if so, how much is buffered:
if {[chan blocked $sock]} {
set bufferSize [chan pending input $sock]
if {$bufferSize > 4096} { # 4k is enough for most things
# Line is too long; client not well-behaved…
# You *might* send an error here.
close $sock
return
}
}
If it's neither of those cases, we've actually read a line.
if {$len == 0} {
# Empty line; end of HTTP header
} else {
# etc.
}

In a tcl script how can i use puts to write a string to the console and to a file at the same time?

# Prints the string in a file
puts $chan stderr "$timestamp - Running test: $test"
# Prints the string on a console
puts "$timestamp - Running test: $test"
Is there a way I can send the output of puts to the screen and to a log file at the same time? Currently I have both the above two lines one after the other in my script to achieve this.
Or is there any other solution in tcl ?
Use the following proc instead of puts:
proc multiputs {args} {
if { [llength $args] == 0 } {
error "Usage: multiputs ?channel ...? string"
} elseif { [llength $args] == 1 } {
set channels stdout
} else {
set channels [lrange $args 0 end-1]
}
set str [lindex $args end]
foreach ch $channels {
puts $ch $str
}
}
Examples:
# print on stdout only
multiputs "1"
# print on stderr only
multiputs stderr "2"
set brieflog [open brief.log w]
set fulllog [open detailed.log w]
# print on stdout and in the log files
multiputs stdout $brieflog $fulllog "3"
This isn't something I've used extensively, but it seems to work (Tcl 8.6+ only):
You need the channel transform tcl::transform::observe package:
package require tcl::transform::observe
Open a log file for writing and set buffering to none:
set f [open log.txt w]
chan configure $f -buffering none
Register stdout as a receiver:
set c [::tcl::transform::observe $f stdout {}]
Anything written to the channel $c will now go to both the log file and stdout.
puts $c foobar
Note that it would seem to make more sense to have the channel transformation on top of stdout, with the channel to the log file as receiver, but I haven't been able to make that work.
Documentation:
chan,
open,
package,
puts,
set,
tcl::transform::observe (package)

how to create tcl proc with hyphen flag arguments

Im searching all over the internet , i guess im searching not the right keywords
i tried most of them :)
i want to create in tcl/bash a proc with hyphen flags to get arguments with flags from the user
ex.
proc_name -color red -somethingselse black
It's very easy to do, actually. This code allows abbreviated option names, flag options (-quxwoo in the example) and the ability to stop reading options either with a -- token or with a non-option argument appearing. In the example, unknown option names raise errors. After passing the option-parsing loop, args contains the remaining command-line arguments (not including the -- token if it was used).
proc foo args {
array set options {-bargle {} -bazout vampires -quxwoo 0}
while {[llength $args]} {
switch -glob -- [lindex $args 0] {
-bar* {set args [lassign $args - options(-bargle)]}
-baz* {set args [lassign $args - options(-bazout)]}
-qux* {set options(-quxwoo) 1 ; set args [lrange $args 1 end]}
-- {set args [lrange $args 1 end] ; break}
-* {error "unknown option [lindex $args 0]"}
default break
}
}
puts "options: [array get options]"
puts "other args: $args"
}
foo -barg 94 -quxwoo -- abc def
# => options: -quxwoo 1 -bazout vampires -bargle 94
# => other args: abc def
This is how it works. First set default values for the options:
array set options {-bargle {} -bazout vampires -quxwoo 0}
Then enter a loop that processes the arguments, if there are any (left).
while {[llength $args]} {
During each iteration, look at the first element in the argument list:
switch -glob -- [lindex $args 0] {
String-match ("glob") matching is used to make it possible to have abbreviated option names.
If a value option is found, use lassign to copy the value to the corresponding member of the options array and to remove the first two elements in the argument list.
-bar* {set args [lassign $args - options(-bargle)]}
If a flag option is found, set the corresponding member of the options array to 1 and remove the first element in the argument list.
-qux* {set options(-quxwoo) 1 ; set args [lrange $args 1 end]}
If the special -- token is found, remove it from the argument list and exit the option-processing loop.
-- {set args [lrange $args 1 end] ; break}
If an option name is found that hasn't already been dealt with, raise an error.
-* {error "unknown option [lindex $args 0]"}
If the first argument doesn't match any of the above, we seem to have run out of option arguments: just exit the loop.
default break
Documentation: array, break, error, lassign, lindex, llength, proc, puts, set, switch, while
With array set, we can assign the parameters and their values into an array.
proc getInfo {args} {
# Assigning key-value pair into array
# If odd number of arguments passed, then it should throw error
if {[catch {array set aInfo $args} msg]} {
return $msg
}
parray aInfo; # Just printing for your info
}
puts [getInfo -name Dinesh -age 25 -id 974155]
will produce the following output
aInfo(-age) = 25
aInfo(-id) = 974155
aInfo(-name) = Dinesh
The usual way to handle this in Tcl is by slurping the values into an array or dictionary and then picking them out of that. It doesn't offer the greatest amount of error checking, but it's so easy to get working.
proc myExample args {
# Set the defaults
array set options {-foo 0 -bar "xyz"}
# Read in the arguments
array set options $args
# Use them
puts "the foo option is $options(-foo) and the bar option is $options(-bar)"
}
myExample -bar abc -foo [expr {1+2+3}]
# the foo option is 6 and the bar option is abc
Doing error checking takes more effort. Here's a simple version
proc myExample args {
array set options {-foo 0 -bar "xyz"}
if {[llength $args] & 1} {
return -code error "must have even number of arguments in opt/val pairs"
}
foreach {opt val} $args {
if {![info exist options($opt)]} {
return -code error "unknown option \"$opt\""
}
set options($opt) $val
}
# As before...
puts "the foo option is $options(-foo) and the bar option is $options(-bar)"
}
myExample -bar abc -foo [expr {1+2+3}]
# the foo option is 6 and the bar option is abc
# And here are the errors it spits out...
myExample -spregr sgkjfd
# unknown option "-spregr"
myExample -foo
# must have even number of arguments in opt/val pairs
#flag defaults
set level 1
set inst ""
# Parse Flags
while {[llength $args]} {
set flag [lindex $args 0]
#puts "flag: ($flag)"
switch -glob $flag {
-level {
set level [lindex $args 1]
set args [lrange $args 2 end]
puts "level:($level) args($args)"
} -inst {
set autoname 0
set inst [lindex $args 1]
set args [lrange $args 2 end]
puts "inst:($inst) args($args)"
} -h* {
#help
puts "USAGE:"
exit 1
} -* {
# unknown option
error "unknown option [lindex $args 0]"
} default break
}
}
# remaining arguments
set filename "$args"
puts "filename: $args"

How to find the script location where the called proc resides?

The script have sourced N number of files..,
source file 1
source file 2
.
.
source file N
when particular procedure A called ., Its actually present in most of the sourced files., anyway the last sourced file containing that proc A will do the function.,
how to find which file containing the proc is used when i call the proc ?
Any code i can use to achieve it ?
The simplest way (assuming Tcl 8.5 or 8.6) is to use an execution trace to call info frame to get the details of the call stack.
trace add execution A enter callingA
proc callingA args {
set ctxt [info frame -1]
if {[dict exists $ctxt file] && [dict exists $ctxt proc]} {
puts "Called [lindex $args 0 0] from [dict get $ctxt proc] in [dict get $ctxt file]"
} elseif {[dict exists $ctxt proc]} {
puts "Called [lindex $args 0 0] from [dict get $ctxt proc] (unknown location)"
} else {
# Fallback
puts "Called [lindex $args 0 0] from within [file normalize [info script]]"
}
}
There's quite a bit of other information in the dictionary returned by info frame.
For Tcl 8.4
In Tcl 8.4, you don't have info frame and Tcl doesn't remember where procedures are defined by default. You still have execution traces though (they were a new feature of Tcl 8.4) so that's OK then. (We have to be a bit careful with info script as that's only valid during the source and not after it finishes; procedures tend to be called later.)
To get where every procedure is defined, you have to intercept proc itself, and to do so early in your script execution! (Procedures defined before you set up the interceptor aren't noticed; Tcl's semantics are purely operational.) Fortunately, you can use an execution trace for this.
proc procCalled {cmd code args} {
if {$code==0} {
global procInFile
set procName [uplevel 1 [list namespace which [lindex $cmd 1]]]
set procInFile($procName) [file normalize [info script]]
}
}
# We use a leave trace for maximum correctness
trace add execution proc leave procCalled
Then, you use another execution trace on the command that you want to know the callers of to look up what that command is called, and hence where it was defined.
proc callingA args {
# Wrap in a catch so a lookup failure doesn't cause problems
if {[catch {
set caller [lindex [info level -1] 0]
global procInFile
set file $procInFile($caller)
puts "Calling [lindex $args 0 0] from $caller in $file"
}]} {
# Not called from procedure!
puts "Calling [lindex $args 0 0] from within [file normalize [info script]]"
}
}
trace add execution A enter callingA

How TCL stores variable in Memory

file1.txt
dut1Loop1Net = [::ip::contract [::ip::prefix 1.1.1.1/24]]/24
My script is
set in [open file1.txt r]
set line [gets $in]
if {[string trim [string range $line1 0 0]] != "#"} {
set devicePort [string trim [lindex $line1 0]]
set mark [expr [string first "=" $line1] + 1]
set val [string trim [string range $line1 $mark end]]
global [set t $devicePort]
set [set t $devicePort] $val
}
close $in
Problem
I am getting output as
% set dut1Loop1Net
[::ip::contract [::ip::prefix 1.1.1.1/24]]/24
Here i am getting the string without evaluating.
I am expecting the output as 1.1.1.0/24. Because TCL does not evaluate code here, it is printing like a string.
I am interesting to know how TCL stores the data and in which form it will retreive the data.
How Tcl stores values.
The short story:
Everything is a string
The long strory
Tcl stores the data in the last used datatype, calculate the string representation only when nessecary, uses copy on write, a simple refcount memory managment.
The answer how you evaluate it is with eval or subst. In your case probably subst.
Edit:
If your config file looks like this:
# This is a comment
variable = value
othervar = [doStuff]
you can use some tricks to get Tcl parsing it for you:
rename ::unknown ::_confp_unknown_orig
proc unknown args {
if {[llength $args] == 3 && [lindex $args 1] eq "="} {
# varname = value
uplevel 1 [list set [lindex $args 0] [lindex $args 2]
return [lindex $args 2]
}
# otherwise fallback to the original unknown
uplevel 1 [linsert $args 0 ::_confp_unknown_orig]
# if you are on 8.6, replace the line above with
# tailcall ::_confp_unknown_orig {*}$args
}
# Now just source the file:
source file1.txt
# cleanup - if you like
rename ::unknown {}
rename ::_confp_unknown_orig ::unknown
An other way to do that is to use a safe interp, but in this case using your main interp looks fine.
The problem is that the code you store inside val is never executed.
You access it using $val, but this way you get the code itself, and not the result of its execution.
To solve it, you must be sure [::ip::contract [::ip::prefix 1.1.1.1/24]]/24 is executed, and you can do that by replacing this line
set val [string trim [string range $line1 $mark end]]
with this one
eval "set val [string trim [string range $line1 $mark end]]"
Why? Here's my simple explaination:
The parser sees the "..." part, so it performs substitutions inside it
The first substitution is the execution of the string range $line1 $mark end command
The second substitution is the execution of the string trim ... command
So, when substitutions are complete and the eval command is ready to run, its like your line has become
eval {set val [::ip::contract [::ip::prefix 1.1.1.1/24]]/24}
Now the eval command is executed, it calls recursively the interpreter, so the string set val [::ip::contract [::ip::prefix 1.1.1.1/24]]/24 goes to another substitution phase, which finally runs what you want and puts the string 1.1.1/24 into the variable val.
I hope this helps.