Tcl to Map NK1.3 based on table only mapping first NK1 not conescutive

[hharp]

I have a Tcl script that maps a contacts relationship in the NK1.3 field based on a table. There can sometimes be multipl NK1 segments but my script is only mapping the first NK1.3 not the consecutive ones listed.

The script does a bunch of other stuff as well, I'm not sure how to get it to map the other NK1 segments as well.
Example Message:
MSH|^~\&||ZZZ|||202106301008||ADT^A05|EFORM-ADT.1.16343|D|2.4|||AL|NE|
EVN||202106301008|||HHAPPY^HAPPY^HAPPY^^^^^^^^^XX|202106301030|
PID|1||M0009999^^^^MR~999-99-9999^^^^SS~M9999^^^^PI||TEST^CPSINTERFACE^1^^^^L~TESTING^CPS^INT^^^^M|TESTER,MOM|19820504|M||U|123 SILLY STREET^^NOTOWN^WA^99999^^^^ZZ||(999)999-9999^PRN|(999)999-9999^WPN||S|NA|G000099999|
ROL|1|AD|FHCP|ZZZZZ^ZUPER^ZUPER^S^^ARNP^^^^^^^XX|
ROL|2|AD|PP|ZZZZ^ZUPER^ZUPER^S^^ARNP^^^^^^^XX|
NK1|1|TESTER^GRANDMOTHER|GM|825 SILLY STREET^^NOTOWN^WA^99999|(999)999-9999||NOK|
NK1|2|TESTER^MOTHER|MO|725 SILLY STREET^^NOTOWN^WA^99999|(999)999-9999||NOT|
NK1|3|7-11CP||5801 OLYMPIC HWY^^ABERDEEN^WA^98520||(360)999-9999|EMP|||CHECKER|||7-11 CENTRAL PARK|
PV1|1|P|RHC.HHH|EL|||ZZZZZ^ZUPER^ZUPER^S^^ARNP^^^^^^^XX|||||||PR||||POV||CM|||||||||||||||||||ZZZ||PRE|||202106301030||||||||ZZZZZ^ZUPER^ZUPER^S^^ARNP^^^^^^^XX|
PV2|||TESTING INTERFACE RELATIONSHIP||||||||||||||||||||||EL|||||||||||N|
ROL|1|AD|AT|ZZZZZ^ZUPER^ZUPER^S^^ARNP^^^^^^^XX|
GT1|1||TEST^CPSINTERFACE^1||123 SILLY STREET^^NOTOWN^WA^99999^^^^ZZ|(999)999-9999|||||SA|999-99-9999||||7-11CP|5801 OLYMPIC HWY^^ABERDEEN^WA^98520^^^^GH|(999)999-9999|
IN1|1|PACC||PACC|13221 SW 68TH PKWY STE 200^^TIGARD^OR^97223-8328||(999)999-9999||||7-11CP|||||TEST^CPSINTERFACE^1|SA|19820504|123 SILLY STREET^^ABERDEEN^WA^98520|||||||||||||||||789456123||||||FT|M|^^ABERDEEN|
IN1|2|NALC||CIGNA/NALC|PO BOX 188004^^CHATTANOOGA^TN^37422-8004||(888)636-6252||||7-11CP|||||TEST^CPSINTERFACE^1|SA|19820504|123 SILLY STREET^^ABERDEEN^WA^98520|||||||||||||||||456789123||||||FT|M|^^ABERDEEN|
IN2|1|999-99-9999||||||||||||||||||||||||||||||||||||||||U|S||||||||||||||||||||(999)999-9999|
IN2|2|555-66-2222||||||||||||||||||||||||||||||||||||||||U|S||||||||||||||||||||(999)999-9999|
ZCD|1|ADM.ADIR^THE PATIENT'S ADVANCED DIRECTIVE IS:^ADN|
ZCD|2|ADM.HB11^Registration clerk initials:|
ZCD|3|ADM.HB8^explained?|
ZCD|4|ADM.HB9a^safety concerns?|
ZCD|5|ADM.HCB^PT given FOUR STEPS TO HEALTHCARE Brochure?|
ZCD|6|ADM.LANG^PT PREFERRED LANGUAGE:|

Tcl Script:
proc tps_reformat_gry_centricity_adt06302021 { 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

####Data variable initialization####
set data [set flddel [set compsep [set repsep [set esccharc [set subcompsep [set guarName ""]]]]]]
set segList [set Seg [set Segindex [set SegID [set IN1Length [set evn1 [set Tempfieldlist ""]]]]]]
set MSHList [set PIDfieldlist [set pidlength [set pidIdList [set pidIdType [set pidPhoneList ""]]]]]
set pidMRNList [set mrn [set ptAcct [set ROLfieldlist [set phyType [set ppDoc [set ckEmail ""]]]]]]
set newPD1Seg [set PV1fieldlist [set ptLocList [set ptLocation [set IN1fieldlist [set insSetId ""]]]]]
set pv1seg [set NK1Seg [set pv1fieldlist [set pv1Loc [set pv1LocList [set loc [set checkLoc [set ptSSN ""]]]]]]]
####Extract message
keylget args MSGID mh
set data [msgget $mh]

####Extract Defined HL7 Encoding Characters####
set flddel [string index $data 3]
set subflddel [string index $data 4]
set repsep [string index $data 5]
set esccharc [string index $data 6]
set subcompsep [string index $data 7]

####Split Message Into Segment List####
set segList [split $data "\r"]
set segindex [lsearch $segList "PV1*"]
if {$segindex > -1} {
set pv1seg [lindex $segList $segindex]
set pv1fieldlist [split $pv1seg $flddel]
set pv1Loc [lindex $pv1fieldlist 3]
set pv1LocList [split $pv1Loc $subflddel]
if {[llength $pv1LocList] > 1} {
set loc [lindex $pv1LocList 0]
} else {
set loc $pv1Loc
}
if {$loc != "" } {
set checkLoc [tbllookup centricityLocations $loc]
}
if { $checkLoc != $loc} {
lappend dispList "KILL $mh"
return $dispList
}
}
set segList [split $data "\r"]
set segindex [lsearch $segList "NK1*"]
if {$segindex > -1} {
set NK1seg [lindex $segList $segindex]
set NK1fieldlist [split $NK1seg $flddel]
set NK1Rel [lindex $NK1fieldlist 3]
set NK1RelList [split $NK1Rel $subflddel]
if {[llength $NK1RelList] > 1} {
set Rel [lindex $NK1RelList 0]
} else {
set Rel $NK1Rel
}
if {$Rel != "" } {
set MappedRel [tbllookup CPSContactRelationship $Rel]
}
echo $MappedRel
}

##REMAP Admit type and Hospital Servcie
foreach Seg $segList {
set Segindex [lsearch -exact $segList $Seg]
set SegID [string range $Seg 0 2]
switch -exact -- $SegID {
MSH {
####Replace msh-3 componet 2 with universal id#####
set MSHseg [lindex $segList $Segindex]
set MSHlist [split $MSHseg $flddel]
set MSHlist [lreplace $MSHlist 2 2 "ADM"]
set evn1 [lindex [split [lindex $MSHlist 8 ] $subflddel ] 1]
set MSHlist [lreplace $MSHlist 10 10 "P"]
set MSHlist [lreplace $MSHlist 11 11 "2.3"]
set facilityId [lindex $MSHlist 3]
set MSHseg [join $MSHlist $flddel]
set segList [lreplace $segList $Segindex $Segindex $MSHseg]
}
EVN {
set EVNseg [lindex $segList $Segindex]
set EVNfieldlist [split $EVNseg $flddel]
set EVNfieldlist [lreplace $EVNfieldlist 1 1 $evn1]
set EVNseg [join $EVNfieldlist $flddel]
set segList [lreplace $segList $Segindex $Segindex $EVNseg]
}
PID {
#### PID remaps####
set PIDseg [lindex $segList $Segindex]
set PIDfieldlist [split $PIDseg $flddel]
#### Add Segments if less than 20
set pidlength [llength $PIDfieldlist]
while {$pidlength < 41} {
lappend PIDfieldlist {}
set pidlength [llength $PIDfieldlist]
}
set MRNlist [lindex $PIDfieldlist 3]
if {[string first ~ $MRNlist] < 0} {
set MRNfieldlist [split $MRNlist $subflddel]
set MRNflag [lindex $MRNfieldlist 4]
} else {
set Tempfieldlist [split $MRNlist "~"]
set MRNfieldlist0 [lindex $Tempfieldlist 0]
set MRNfieldlist [split $MRNfieldlist0 $subflddel]
set MRNflag [lindex $MRNfieldlist 4]
}
#### Concatenate MRN and patient account separated by a dash and move to PID-4
set ptAcct [lindex $PIDfieldlist 18]
if {$MRNflag eq "MR"} {
set mrn [lindex $MRNfieldlist 0]
set PIDfieldlist [lreplace $PIDfieldlist 2 2 $mrn]
set PIDfieldlist [lreplace $PIDfieldlist 4 4 $mrn]
set PIDfieldlist [lreplace $PIDfieldlist 3 3 $mrn-$ptAcct]
} else {
set PIDfieldlist [lreplace $PIDfieldlist 3 3 $ptAcct]
}
#### Add quotes to PID-11.2 Second Address if not populated - prevents issues in Centricity
set pidAddList [split [lindex $PIDfieldlist 11] $subflddel]
set pidAddLen [llength $pidAddList]
while {$pidAddLen < 3} {
lappend pidAddList {}
set pidAddLen [llength $pidAddList]
}

set pidAltAddress [lindex $pidAddList 1]
if {$pidAltAddress == ""} {
set pidAddList [lreplace $pidAddList 1 1 \"\"]
set pidAddList [join $pidAddList $subflddel]
set PIDfieldlist [lreplace $PIDfieldlist 11 11 $pidAddList]

}
#### IF email is not populated hardcode "NONE" in PID-13.3
set pidPhoneList [split [lindex $PIDfieldlist 13] $subflddel]
set pidPhoneLen [llength $pidPhoneList]
while {$pidPhoneLen < 4} {
lappend pidPhoneList {}
set pidPhoneLen [llength $pidPhoneList]
}
set ckEmail [lindex $pidPhoneList 4]
if {$ckEmail != "" } {
set pidPhoneList [lreplace $pidPhoneList 3 3 "NONE"]
set pidPhoneList [join $pidPhoneList $subflddel]
set PIDfieldlist [lreplace $PIDfieldlist 13 13 $pidPhoneList]
}
#### Truncate SSN to 11 Characters
set ptSSN [lindex $PIDfieldlist 19]
set lenPtSSN [string length $ptSSN]
if {$lenPtSSN > 11} {
set newSSN [string range $ptSSN 0 10]
set PIDfieldlist [lreplace $PIDfieldlist 19 19 $newSSN]
}
#### Map Ethnicity PID-22
#######################################

#### Hardcode preferred contact to "H" home phone
set PIDfieldlist [lreplace $PIDfieldlist 40 40 "H"]
set PIDseg [join $PIDfieldlist $flddel]
set segList [lreplace $segList $Segindex $Segindex $PIDseg]
}

ROL {
####Create PD1 Segment - capture primary care physician####
set ROLseg [lindex $segList $Segindex]
set ROLfieldlist [split $ROLseg $flddel]
set phyType [lindex $ROLfieldlist 3]
set ppDoc [lindex $ROLfieldlist 4]
if { $phyType eq "PP" } {
if { $ppDoc != "" } {
set newPD1Seg "PD1||||$ppDoc"
set segList [lreplace $segList $Segindex $Segindex $newPD1Seg]
} else {
set segList [lreplace $segList $Segindex $Segindex]
}
} else {
set segList [lreplace $segList $Segindex $Segindex]
}
}
AL1 {
####Remove DG1 ####
set segList [lreplace $segList $Segindex $Segindex]
}
PV1 {
#### PV1 remaps####
set PV1seg [lindex $segList $Segindex]
set PV1fieldlist [split $PV1seg $flddel]
#set ptLocList [split [lindex $PV1fieldlist 3] $subflddel]
if { $loc != "" } {
set PV1fieldlist [lreplace $PV1fieldlist 3 3 ^^^$loc]
}
if { $ppDoc != "" } {
set PV1fieldlist [lreplace $PV1fieldlist 7 7 $ppDoc]
}
set PV1fieldlist [lreplace $PV1fieldlist 10 10 ""]
set PV1fieldlist [lreplace $PV1fieldlist 18 18 ""]
set PV1fieldlist [lreplace $PV1fieldlist 36 36 ""]
set PV1fieldlist [lreplace $PV1fieldlist 39 39 ""]
set PV1fieldlist [lreplace $PV1fieldlist 41 41 ""]
set PV1fieldlist [lreplace $PV1fieldlist 44 44 ""]
set PV1seg [join $PV1fieldlist $flddel]
set segList [lreplace $segList $Segindex $Segindex $PV1seg]
}
PV2 {
####Remove PV2####
set segList [lreplace $segList $Segindex $Segindex]
}
NK1 {
#### NK1 remaps####
set NK1seg [lindex $segList $Segindex]
set NK1fieldlist [split $NK1seg $flddel]
if { $Rel != "" } {
set NK1fieldlist [lreplace $NK1fieldlist 3 3 $MappedRel]
set NK1seg [join $NK1fieldlist $flddel]
set segList [lreplace $segList $Segindex $Segindex $NK1seg]
}
}
GT1 {
set GT1seg [lindex $segList $Segindex]
set GT1fieldlist [split $GT1seg $flddel]
set guarName [lindex $GT1fieldlist 3]
if { $guarName != "" } {
set segList [lreplace $segList $Segindex $Segindex $GT1seg]
} else {
set segList [lreplace $segList $Segindex $Segindex]
}
}
OBX {
####Remove OBX ####
set segList [lreplace $segList $Segindex $Segindex]
}
DG1 {
####Remove DG1 ####
set segList [lreplace $segList $Segindex $Segindex]
}
PR1 {
####Remove PR1 ####
set segList [lreplace $segList $Segindex $Segindex]
}


#### Remove GT1 if no name in GT1-3

ZCD {
####Remove ZCD ####
set segList [lreplace $segList $Segindex $Segindex]
}
default {}
}
}
set data [join $segList "\r"]
msgset $mh $data
lappend dispList "CONTINUE $mh"
}
time {
# Timer-based processing
# N.B.: there may or may not be a MSGID key in args

}

shutdown {
# Doing some clean-up work

}

default {
error "Unknown mode '$mode' in tps_reformat_gry_centricity_adt06302021"
}
}

return $dispList
}