assistance with Tcl list

[Shaun Beckman]

Below is a script I got from Goutham. One of our vendors needs us to do the following, which I am having troiuble accomplishing. They want the physician’s code from PV1_7 copied to OBR_16, only if it is one of the args (in this case a licensed eClinicalWorks physician), otherwise copy the first physician’s code that does turn-up in the list. The remaining physician codes that are in the list, they want copied to OBR_28.

Any assistance would be greatly appreciated.

An example of the args:{DRCODES {123|4567|13456|15889}}

For example, if physician’s code ‘4567’ is in PV1_7, then it should be copied to OBR_16. If none of the physician’s codes in the above example are in PV1_7, then copy the first one that does appear (say ‘13456’ is in PV1_9), then copy it to OBR_16. Any remaining physician’s codes that match the search criteria are found in the result message, should be copied to OBR_28.

######################################################################

# Name: filter_nonphysician

# Purpose:

# UPoC type: tps

# Args: tps keyedlist containing the following keys:

#       MODE    run mode (“start”, “run” or “time”)

#       MSGID   message handle

#       ARGS    user-supplied arguments:

#              

#

# Returns: tps disposition list:

#          

# Created 09/25/07 – gm

# Physician list: {DRCODES {123|4567|13456|15889}}

proc filter_nonphysican {args} {

   keylget args MODE mode

   keylget args ARGS uargs

   switch -exact — $mode {

      start {

          return “”

      }

      run {

          set drcodes UNKNOWN  ;# default value

          keylget args MSGID mh

  keylget uargs DRCODES drcodes

  # init – variables

  set pv1_7_1 “”;set pv1_8_1 “”;set pv1_9_1 “”;set pv1_17_1 “”

  set obr_16_1 “”

          # get message

  set msg [split [msgget $mh] r]

  # PV1 Seg – extract Dr codes from pv1 – 7.1,8.1,9.1 & 17.1

  set pv1_loc [lsearch -regexp $msg {^PV1}]

  set pv1_seg [lindex $msg $pv1_loc]

  echo $pv1_seg

  set pv1_7_1 [lindex [split [lindex [split $pv1_seg |] 7] ^] 0]

  set pv1_8_1 [lindex [split [lindex [split $pv1_seg |] 8] ^] 0]

  set pv1_9_1 [lindex [split [lindex [split $pv1_seg |] 9] ^] 0]

  set pv1_17_1 [lindex [split [lindex [split $pv1_seg |] 17] ^] 0]

  set dr_cd_in_msg “${pv1_7_1} ${pv1_8_1} ${pv1_9_1} ${pv1_17_1} “

          # OBR seg – extract Dr codes from obr – 16.1

  set obr_loc [lsearch -regexp $msg {^OBR}]

  set obr_seg [lindex $msg $obr_loc]

  set obr_16_1 [lindex [split [lindex [split $obr_seg |] 16] ^] 0]

  append dr_cd_in_msg $obr_16_1

          # Check if the physician codes are in pv1 7.1,8.1,9.1,17.1 or obr16.1

  # If found continue message else kill message

          if {[regexp $drcodes $dr_cd_in_msg]} {

     echo “Found a Match … continue message”

     echo DR_CD_IN_MSG: $dr_cd_in_msg

     return “{CONTINUE $mh}”

  } else {

     echo “Dr code not in message .. message killed”

     echo “Dr codes in Message: $dr_cd_in_msg”

     echo “Wanted Dr codes : $drcodes”

     return “{KILL $mh}”

  }

      }

   }

}

Topic