Well, I spoke to soon on this. After doing some more investigation it appears the “extra” r is being added in by the engine (or some tcl code). The following two procs touch all the ADT messages, so I am thinking one of them may be the issue. Unfortunately, I don’t see anything, but I am no tcl pro and these procs were written years ago. At any rate I am posting both procs here in the hopes someone “sees” something.
#####################################################################
# Name: tps_adt_normalize
# Purpose: Normalizes HBOC HL7 message by removing 2nd subfield
# from message type. And removes the leading zeros from Med. Rec.# and
# ACCT.#. Proc will also KILL message if “acct_ln” (PID:18) is true (temp number),
# which is not a valid account number
#
# UPoC type: sms_ib_data
# Insert proc after acknowledge procedure
# ARGS: {ACCTLN number} : Default number is 6.
# Length of PID:18, account number field
# {DEBUG value} : 0= off
# 1= on
# Returns: CONTINUE modified message if acct_ln is not true, else KILL message
#
# Usage:
# STAR sends HL7 messages with 3 subfields in the message
# type, ie., ADT^A01^05. Cloverleaf cannot handle this. This
# proc removes the 2nd subfield and stores it in field 7
# (Security, unused) of the MSH segment. This can be undone using
# the unnormalize.tcl proc I could not find this procedure on the
# server, but leaving this comment for historical purposes.
#
# VERSION HISTORY: 10/16/2008 Gary Atkinson
# Added check for invalid account number length
# Added in some echos (module and msg) and debug option
#
proc tps_adt_normalize { args } {
global HciConnName
if ![info exists HciConnName] { set HciConnName UNKNOWN }
set module “(tps_adt_normalize/$HciConnName)” ;# For error reorting
keylget args MODE mode ;# What mode
keylget args CONTEXT context ;# What context
keylget args ARGS uargs ;# Get User Args and set defaults if not defined
set acctln 6 ; keylget uargs ACCTLN acctln
set debug 0 ; keylget uargs DEBUG debug
set dispList {} ;#Nothning to return
switch -exact — $mode {
start {
echo “$module: Using settings – ACCTLN = $acctln, DEBUG = $debug”
return “” ;# Nothing specific
}
run {
keylget args MSGID mh ;# Get message handle
set msg [msgget $mh] ;# Get message
#
# Validate context
#
if ![cequal $context sms_ib_data] {
echo “$module: Called with Invalid Context. S/B sms_ib_data is $context!”
echo “Continuing message – No action taken”
lappend dispList “CONTINUE $mh”
}
#
# 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 segments [split $msg r] ;# Get segments
set outbuf “” ;# Holds outbound message
#
# LOOP through and make changes
#
foreach seg $segments {
set segtype [csubstr $seg 0 3] ;# segment type
if [cequal $segtype MSH] { ;# MSH?
set fields [split $seg $sep] ;# Fields
set type [lindex $fields 8] ;# Version
set subfields [split $type $sub] ;# subfields
set newtype [lindex $subfields 0]$sub[lindex $subfields 1]
set xtrig [lindex $subfields 2] ;# Extra trigger
set fields [lreplace $fields 7 8 $xtrig $newtype]
set seg [join $fields $sep]
}
if [cequal $segtype PID] {
set fields [split $seg $sep]
set pid3 [lindex $fields 3]
set pid18 [lindex $fields 18]
#puts “This is the before account#: $pid18”
set new_pid3 [string trimleft $pid3 0]
set new_pid18 [string trimleft $pid18 0]
#puts “This is the after account#: $new_pid18”
set new_pid18_ln [ string length [ lindex [ split $new_pid18 $sub ] 0] ]
#puts “This is the new PID:18 length: $new_pid18_ln”
set fields [lreplace $fields 3 3 $new_pid3]
set fields [lreplace $fields 18 18 $new_pid18]
set seg [join $fields $sep]
}
append outbuf ${seg}r
}
#
# Put modified message in message handle and KILL msg if acctln is less or equal to PID:18
#
msgset $mh $outbuf
if {$new_pid18_ln <= $acctln && $new_pid18_ln != 0} {
lappend dispList "KILL $mh"
if {$debug} {
echo "The following message contained an invalid account number, which length is $new_pid18_ln"
echo [msgget $mh]n
}
} else {
lappend dispList "CONTINUE $mh"
}
}
shutdown {
# Doing some clean-up work
}
default {
error "Unknown mode '$mode' in $module"
}
}
return $dispList
}
######################################################################
# Name: nah_char_reformat
# Purpose: North Arundel Hospital.
# The messages contain the character "&" in the several fields.
# The "&" character in HL7 is used to denote sub-components. Therefore,
# Cloverleaf will treat the "&" segments as if it denoting a sub-component.
# A table is read to obtain the Segment and the number of the field(s) within
# the segment to check. The field numbers must be separated by a dash.
# The specified field is checked, all occurrences of & are replaced with +.
# The new message is then created, the original message killed,
# and the new message is continued.
#
# Written By: Donna Snider, Park City Solutions
# Date: 02/26/2003
#
# UPoC type: tps Must be used/entered in TSP Inbound Data
# on Inbound Thread
# Args: tps keyed list containing the following keys:
# MODE run mode ("start", "run" or "time")
# MSGID message handle
# ARGS
# name of table used:
# {SEGMENTBL CIS_TABLE}
#
# Returns: tps disposition list:
# If the message contains any & (except encoding characters in MSH)
# A new reformattted messages is created.
# The new (copied) message is CONTINUE.
# The original message is KILL.
# Otherwise
# The origianl message is CONTINUE.
########################################
proc nah_char_reformat { args } {
keylget args MODE mode ;# Fetch mode
set dispList {} ;# Nothing to return
switch -exact — $mode {
start {
return {}
}
run {
set datList [datlist]
set mh [keylget args MSGID]
set segtable [keylget args ARGS.SEGMENTBL]
set msg [msgget $mh]
# Create a copy of the message omitting the encoding characters and check
# Do any & exist in the remaining message – if yes, reformat else continue msg
set chkmsg [crange $msg 9 end]
if {[regexp "&" $chkmsg] == 1} {
# Get field separator from MSH segment
set fieldSeparator [crange $msg 3 3]
# Split message into segments
set segmentList [split $msg r]
set newSegmentList ""
# Search table for each Segment
# When match on Segment ID, field numbers to check are returned
foreach segment $segmentList {
set tblfieldlist 0
set segmentID [crange $segment 0 2]
set tblfieldlist [tbllookup $segtable $segmentID]
if {$tblfieldlist != 0} {
set fieldIDlist [split $tblfieldlist "-"]
set fieldList [split $segment $fieldSeparator]
foreach fieldID $fieldIDlist {
set oldfield ""
set oldfield [lindex $fieldList $fieldID]
if {$oldfield != ""} {
regsub -all — "&" $oldfield "+" newfield
set fieldList [lreplace $fieldList $fieldID $fieldID $newfield]
}
}
set segment [join $fieldList $fieldSeparator]
}
set newSegmentList [lappend newSegmentList $segment]
}
set newMsg [join $newSegmentList r]
set mhNew [msgcopy $mh]
msgset $mhNew $newMsg
lappend dispList "KILL $mh"
lappend dispList "CONTINUE $mhNew"
} else {
lappend dispList "CONTINUE $mh"
}
}
shutdown {
# Doing some clean-up work
}
default {
error "Unknown mode '$mode' in nah_char_reformat"
}
}
return $dispList
}
.
