- This topic has 0 replies, 1 voice, and was last updated 6 years, 7 months ago by
.
-
Topic
-
###################################################################### # Name: swap_cerner_pid2_pid3.tcl
# Purpose: KILL or CONTINUE a message based on a user defined content
# UPoC type: tps
# Args: tps keyedlist containing the following keys:
# MODE run mode (“start”, “run” or “time”)
# MSGID message handle
# ARGS user-supplied arguments:
# KILLCOND Literal that the field will be qualifying on
# SEGNAME Segment to check
# FIELDNUM Field number to check within the segment
# SUBFIELDNUM Subfield to check within the field
#
# Returns: tps disposition list:
# KILL: if field matches user defined literal
# CONTINUE: if field does not match user defined literal
#
proc swap_cerner_pid2_pid3 { args } {
keylget args MODE mode ;# Fetch mode
set dispList {} ;# Nothing to return
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 mh
set msg [msgget $mh] ;# Get message
set outbuf {}
#
# Split the message and get fields to check
# First set up some constants
#
set sep [csubstr $msg 3 1] ;# HL7 field separator
set sub [csubstr $msg 4 1] ;# HL7 subfield separator
set rep [csubstr $msg 5 1]
set segments [split $msg r] ;# Get segments
#
# LOOP through to find the qualifying field
#
set pid2 “”
set newp3pi “”
set new3mr “”
set newp3oth “”
foreach seg $segments {
if [cequal $seg “”] { continue } ;# Just in case
if {[cequal $segtype “PID”]} { ;# MSH, EVN, PID, etc.?
set fields [split $seg $sep]
set newp3mr {}
set newp3cmrn {}
set newp3oth {}
set newpid3mr {}
set newpid3cmrn {}
set newpid3oth {}
set pid3 [lindex $fields 3]
set pid3R [split $pid3 $rep]
foreach number $pid3R {
set pidL [split $number $sub]
if {[cequal [lindex $pidL 3] “MRN”]} {
set mr [lindex $pidL 0]
set newpidL [lreplace $pidL 3 4 “ST01$msh4” “MR”]
set newpid3 [join $newpidL $sub]
lappend newpid3mr $newpid3
} elseif {[cequal [lindex $pidL 3] “CMRN”]} {
set newpid3L [lreplace $pidL 3 4 “ST01” “PI”]
set newpid3 [join $newpid3L $sub]
lappend newpid3cmrn $newpid3
set pid2 “^^^”
set pid2L [split #pid “^”]
set pid2L [lreplace $pid2L 0 3 [lindex $pidL 0] “” “” “ST01”]
set pid2 [join $pid2L $sub]
} else {
set newpid3L [join $pidL $sub]
lappend newpid3oth $newpid3L
}
}
set newp3mr [join $newpid3mr $rep]
set newp3cmrn [join $newpid3cmrn $rep]
set newp3oth [join $newpid3oth $rep]
set newp3L “”
if {![cequal $newp3mr “”]} { set newp3L $newp3mr }
if {![cequal $newp3cmrn “”]} { set newp3L [cconcat $newp3L “~” $newp3cmrn]}
if {![cequal $newp3oth “”]} { set newp3L [cconcat $newp3L “~” $newp3oth]}
# set newp3L [cconcat $newp3mr “~” $newp3cmrn “~” $newp3oth]
set fields [lreplace $fields 2 3 $pid2 $newp3L]
set pid15 [lindex $fields 15]
if {[cequal $pid15 “ENG”]} {
set fields [lreplace $fields 15 15 “E$subZ ENGLISH$subHL70296$subE$subZ ENGLISH$sub99CLAN”]
}
set pid18 [lindex $fields 18]
set pid18L [split $pid18 $sub]
set pid18L [lreplace $pid18L 3 4 “ST01$msh4” “”]
set pid18L [join $pid18L $sub]
set fields [lreplace $fields 18 18 $pid18L]
set seg [join $fields $sep]
}
if {[cequal $segtype “PD1”]} { ;# MSH, EVN, PID, etc.?
set fields [split $seg $sep] ;# List of Fields
set drL {}
set dr4num [lindex $fields 4]
set dr4L [split $dr4num $rep]
foreach dr $dr4L {
set drnum [lindex [split $dr $sub] 0]
set dr4 [tbllookup -side input CernerStar_Dr.tbl $drnum]
if {![cequal $dr4 “”]} {
set dr4 [tbllookup -side input CernerStar_Dr.tbl $drnum]
lappend drL $dr4
}
}
set drout [join $drL $rep]
catch { set fields [lreplace $fields 4 4 $drout] }
set seg [join $fields $sep]
}
if {[cequal $segtype “PV1”]} { ;# MSH, EVN, PID, etc.?
set drL {}
set fields [split $seg $sep] ;# List of Fields
set pv1_3 [lindex $fields 3]
set pv1_6 [lindex $fields 6]
set pv1_3L [split $pv1_3 $sub]
set pv1_3L1 [split [lindex $pv1_3L 0] ” “]
set pv1_3L [lreplace $pv1_3L 0 0 [lindex $pv1_3L1 1]]
set pv1_3L [lreplace $pv1_3L 3 3 $msh4]
set pv1_3new [join $pv1_3L $sub]
set fields [lreplace $fields 3 3 $pv1_3new]
set pv1_6L [split $pv1_6 $sub]
set pv1_6L1 [split [lindex $pv1_6L 0] ” “]
set pv1_6L [lreplace $pv1_6L 0 0 [lindex $pv1_6L1 1]]
set pv1_6L [lreplace $pv1_6L 3 3 $msh4]
set pv1_6new [join $pv1_6L $sub]
set fields [lreplace $fields 6 6 $pv1_6new]
set dr7num [lindex $fields 7]
set dr7L [split $dr7num $rep]
foreach dr $dr7L {
set drnum [lindex [split $dr $sub] 0]
set dr7 [tbllookup -side input CernerStar_Dr.tbl $drnum]
if {![cequal $dr7 “”]} {
set dr7 [tbllookup -side input CernerStar_Dr.tbl $drnum]
lappend drL $dr7
}
}
set drout [join $drL $rep]
set fields [lreplace $fields 7 7 $drout]
set drL {}
set dr8num [lindex $fields 8]
set dr8L [split $dr8num $rep]
foreach dr $dr8L {
set drnum [lindex [split $dr $sub] 0]
set dr8 [tbllookup -side input CernerStar_Dr.tbl $drnum]
if {![cequal $dr8 “”]} {
set dr8 [tbllookup -side input CernerStar_Dr.tbl $drnum]
lappend drL $dr8
}
}
set drout [join $drL $rep]
set fields [lreplace $fields 8 8 $drout]
set drL {}
set dr9num [lindex $fields 9]
set dr9L [split $dr8num $rep]
foreach dr $dr8L {
set drnum [lindex [split $dr $sub] 0]
set dr9 [tbllookup -side input CernerStar_Dr.tbl $drnum]
if {![cequal $dr9 “”]} {
set dr9 [tbllookup -side input CernerStar_Dr.tbl $drnum]
lappend drL $dr8
}
}
set drout [join $drL $rep]
set fields [lreplace $fields 9 9 $drout]
set drL {}
set dr17num [lindex $fields 8]
set dr17L [split $dr17num $rep]
foreach dr $dr17L {
set drnum [lindex [split $dr $sub] 0]
set dr17 [tbllookup -side input CernerStar_Dr.tbl $drnum]
if {![cequal $dr17 “”]} {
set dr17 [tbllookup -side input CernerStar_Dr.tbl $drnum]
lappend drL $dr17
}
}
set drout [join $drL $rep]
set fields [lreplace $fields 17 17 $drout]
set fields [lreplace $fields 39 39 $msh4]
set seg [join $fields $sep]
}
append outbuf ${seg}r
} ;# end of ‘foreach’
#
# Qualify whether to KILL or CONTINUE
#
msgset $mh $outbuf
lappend dispList “CONTINUE $mh”
} ;# end of ‘run’
time {
# Timer-based processing
# N.B.: there may or may not be a MSGID key in args
}
shutdown {
#No shutdown code
}
}
return $dispList
}
- The forum ‘Tcl Library’ is closed to new topics and replies.
