Help replacing final OBX-5 field
› Clovertech Forums › Read Only Archives › Cloverleaf › Cloverleaf › Help replacing final OBX-5 field
- This topic has 8 replies, 4 voices, and was last updated 12 years, 2 months ago by
Charlie Bursell.
-
CreatorTopic
-
May 7, 2013 at 4:50 pm #53645
I’m in the process of fumbling through teaching myself TCL. -
CreatorTopic
-
AuthorReplies
-
-
May 7, 2013 at 4:52 pm #78417
######################################################################
# Name: coag_result_footer.tcl
# Purpose: Insert a line of text into the final OBX segment on Coag results.
# UPoC type: tps
# Args: tps keyedlist containing the following keys:
# MODE run mode (“start”, “run” or “time”)
# MSGID message handle
######################################################################
proc coag_result_footer { args } {
keylget args MODE mode ;# Fetch mode
set dispList {} ;# Nothing to return
switch -exact — $mode {
start {
}
run {
keylget args MSGID mh
######################################################################
# Setting preliminary values
######################################################################
set msg [msgget $mh] ;# Get message
set outbuf {} ;# Creates a variable to write to
set sep [csubstr $msg 3 1] ;# HL7 field separator
set sub [csubstr $msg 4 1] ;# HL7 subfield separator
set rep [csubstr $msg 7 1]
set segments [split $msg r] ;# Get segments
set obx_cnt “0” ;# Starts OBX counter
######################################################################
# First foreach to grab variables and write non OBX segments to outbuf
######################################################################
foreach seg $segments {
if [cequal $seg “”] { continue } ;# Just in case
set segtype [csubstr $seg 0 3] ;# Get segment name
if {[cequal $segtype OBR]} {
set obr_fields [split $seg $sep] ;# List of Fields
set timestamp [lindex $obr_fields 7]
set pharma [lindex $obr_fields 16]
set seg [join $obr_fields $sep]
}
if {[cequal $segtype OBX]} {
set obx_cnt [expr {$obx_cnt + 1}]
}
} ;# end of ‘foreach’
######################################################################
# Condition the footer for outbuf
######################################################################
set pharma_fields [split $pharma $sub]
set pharma_first [lindex $pharma_fields 2]
set pharma_last [lindex $pharma_fields 1]
set y [string range [lindex $timestamp 0] 0 3]
set m [string range [lindex $timestamp 0] 4 5]
set d [string range [lindex $timestamp 0] 6 7]
set hh [string range [lindex $timestamp 0] 8 9]
set mm [string range [lindex $timestamp 0] 10 11]
set footer “Document finalized by $pharma_first $pharma_last on $m/$d/$y $hh:$mm”
######################################################################
# Second foreach to write OBX data
######################################################################
foreach seg $segments {
if [cequal $seg “”] { continue } ;# Just in case
set segtype [csubstr $seg 0 3] ;# Get segment name
if {[cequal $segtype OBX]} {
set obx_fields [split $seg $sep] ;# List of Fields
set obx1 [lindex $obx_fields 1]
if {[cequal $obx1 $obx_cnt]} { ;# Gets final OBX segment
set obx_fields [lreplace $obx_fields 5 5 $footer] ;# Replaces OBX-5 with the footer
set seg [join $obx_fields $sep] ;# Joins segment
} else {
set seg [join $obx_fields $sep] ;# Joins segment
}
}
append $outbuf ${seg}r
} ;# end of ‘foreach’
######################################################################
# Clean up work
######################################################################
msgset $mh $outbuf
echo $seg
lappend dispList “CONTINUE $mh”
} ;# End of ‘Run’
time {
}
shutdown {
}
} ;# End of ‘Mode’
return $dispList
} ;# End of ‘Proc’
-
May 8, 2013 at 1:53 am #78418
At a quick look
append $outbuf ${seg}r
should be
append outbuf ${seg}r
Also apparently the c string functions (csubstr, cequal) are to be depreciated, and it is recommended to use string range or string equal instead.
There are a few examples of how to handle splitting and joining messages scattered through this forum using tcl. You can also use an Xlate to do this with the GUI.
-
May 8, 2013 at 4:52 am #78419
An awful lot of wasted CPU time with un-neessary looping
Try this:
There may be some “fat-finger” errors as i did not test it
proc coag_result_footer { args } {
keylget args MODE mode ;# Fetch mode
switch -exact — $mode {
start {
return “” ;# Nothing specifice
}
run {
keylget args MSGID mh
# Setting preliminary values
set msg [msgget $mh] ;# Get message
set sep [string index $msg 3] ;# HL7 field separator
set sub [string index $msg 4] ;# HL7 subfield separator
set segments [split $msg r] ;# Get segments
# Need OBR.16
set OBR [split [lsearch -inline -regexp $segments {^OBR}] $sep]
# Assumes timestamp is YYYYMMDDHHMM
# Convert to MM/DD/YYYY HH:MM
# If invalid date, leave as is
set timestamp [lindex $OBR 7]
regsub — {(d{4})(d{2})(d{2})(d{2})(d{2}).*}
$timestamp {2/3/1 4:5} timestamp
# pharma subfields from OBR.16 (OBR.16.2 and OBR.16.3)
lassign [split [lindex $OBR 16] $sub] {} pharma_last pharma_first
# Build footer
set footer “Document finalized by $pharma_first $pharma_last
on $timestamp”
# Put footer in last OBX
set finalLoc [lindex [lsearch -all -regexp $segments {^OBX}] end]
# Get that OBX
set OBX [split [lindex $segments $finalLoc] $sep]
# Replace OBX.5
set OBX [lreplace $OBX 5 5 $footer]
# Put it back in
set segments [lreplace $segments $finalLoc $finalLoc
[join $OBX $sep]]
# Set new message
msgset $mh [join $segments r]
# Send it on
return “{CONTINUE $mh}”
}
}
}
-
May 8, 2013 at 1:52 pm #78420
Thanks for the help.
You were both correct.
-
May 8, 2013 at 1:57 pm #78421
You really need a tcl class
When use lreplace you have to provide a value to replace the old value with set x [lreplace $y 1 1 $new]
To do a foreach over all the OBX segments remember lsearch will return a list of locations if 0all is used without the -inline
foreach lo [lsearch -all -regexp $segments {^OBX}] {
Will iterate over each OBX segment location
}
If I have time I may address some of the other issues later
-
May 8, 2013 at 2:16 pm #78422
The:
set segments [lreplace $segments 17 17]
actually worked how I wanted it to. It wiped the segment without leaving an extra carriage return. Nonetheless, I’d agree with the tcl class comment. It will happen eventually. I appreciate the help.
-
May 9, 2013 at 9:40 pm #78423
One gotcha with lreplace. If your list doesn’t have enough elements, i.e., in your example you are replacing the 18th (17) element of the list, and if you list only has a list length of 10, you will get a TCL error.
Robert Milfajt
Northwestern Medicine
Chicago, IL -
May 9, 2013 at 11:38 pm #78424
That is right Bob so will linsert. It has been an argument in the Tcl communuty for a long time. I always suggest if any doubt you do something like:
while {[llength $var] < } {lappend var {}}
Where len is the length the list must be. Remember if inserting at field 17 the list must be length 18 – it is 0 based
-
-
AuthorReplies
- The forum ‘Cloverleaf’ is closed to new topics and replies.
