Truncating a segment using TCL

[Matt Estrella]

Hello all,

Does anyone have a TCL procedure that can truncate a segment at a user defined location? For example, if I want to end the PID segment at the 15th field and omit the remaining fields. I know this can be done with a xlate, but I would like to use TCL.

Thanks,

Matt

Topic

[Tom Weber]

If LPID is your PID field list, you could use:

set LPID [lrange $LPID 0 14]

That gives you the first 15 values in LPID.  Then you would join LPID back to the message.

[Russ Ross]

Now days I would accomplish what you want by doing a field by field copy in the xlate of only the desired fields and avoid bulkcopy.

Another quick alternative I’ve used in the past is this TPS proc after my xlate (thanks to Gotham for writting it).

Code:

################################################################################
# Name: tps_truncate_segments
# 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 CONTINUE
#
# Notes :       This proc keeps only the fields required by receving system
#               This proc is a generic proc and can be used for multiple  
#               segments at the same time.
# Example :     If the receving system requires only two fields of EVN segement
#               and 18-fields for PID segments. Configure as below as ARGS.
#              
#               “^” Splits the Segment and Req’d fields
#               “|” Splits multiple segments
#
#               {KEEPLIST EVN^2}————— For One segment
#               {KEEPLIST EVN^2|PID^18}——– For Multiple segment
#                
#          
#
# Author : Goutham Mullaguru (Healthcare.com)
# Date   : 07/17/00
#
################################################################################
proc tps_truncate_segments { args } {
  keylget args MODE mode
  switch -exact — $mode {

     start {
              #  Perform special init functions
              return “”
     }

     run   {
              keylget args MSGID mh
              keylget args ARGS.KEEPLIST keeplist
#
              set msg [msgget $mh]
              set segments [split $msg “r”]
              set field_separator [csubstr $msg 3 1]
         
              set seg_list [split $keeplist “|”]
              set argcntr [llength $keeplist]

              set out “”
#
              set cntr 0

              foreach seg $seg_list {
                set sublist [split $seg “^”]

                set subseg [lindex $sublist 0]
                set keepfields [lindex $sublist 1]

                set segment_location [lsearch -regexp $segments “^$subseg”]
                    if [cequal $segment_location “”] {continue}

                set segment [lindex $segments $segment_location]
                set reqd_fields [lrange [split $segment $field_separator] 0 $keepfields]

                set new_segment [join $reqd_fields $field_separator]
                set segments [lreplace $segments $segment_location $segment_location $new_segment]

                    if ![cequal $cntr $argcntr] {incr cntr}
              }
              set new_message [join $segments r]
              msgset $mh $new_message
              return “{CONTINUE $mh}”

     }

shutdown {
   # Doing some clean-up work
}

     default {
              return “”
              error “Unknown mode ‘$mode’ in tps_truncate_segments”
     }

  }

}

and here is the counter part TPS proc that will pad with empty segments if necessary:

Code:

################################################################################
# Name: tps_pad_segments
# 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 CONTINUE
#
# Notes :      
#              
#            
#———
# History:  
#———
#
# 2000.07.17 Goutham Mullaguru
#          – wrote initial version
#
# 2000.07.20 Russ Ross
#          – fixed bug that errors out and causes the message to be lost
#            when $add_fields = 0
#
################################################################################
proc tps_pad_segments { args } {
  keylget args MODE mode
  switch -exact — $mode {

     start {
              #  Perform special init functions
              return “”
     }

     run   {
              keylget args MSGID mh
              keylget args ARGS.KEEPLIST keeplist
#
              set msg [msgget $mh]
              set segments [split $msg “r”]
              set field_separator [csubstr $msg 3 1]
         
              set seg_list [split $keeplist “|”]
              set argcntr [llength $keeplist]

#
              set cntr 0

              foreach seg $seg_list {
                set sublist [split $seg “^”]
                set subseg [lindex $sublist 0]
                set keepfields [lindex $sublist 1]

                set segment_location [lsearch -regexp $segments “^$subseg”]
                set segment [lindex $segments $segment_location]
                    if [cequal $segment “”] {continue}
                set no_of_fields [regsub -all — {|} $segment “” segout]
                set add_fields [expr $keepfields – $no_of_fields]  
                   if {$add_fields <= 0} {continue}                    if {$add_fields > 0 } {
                set new_fields [replicate | $add_fields]
                set new_segment “$segment$new_fields”
                }
                set segments [lreplace $segments $segment_location $segment_location $new_segment]

                    if ![cequal $cntr $argcntr] {incr cntr}
              }
              set new_message [join $segments r]
              msgset $mh $new_message
              return “{CONTINUE $mh}”

     }

shutdown {
   # Doing some clean-up work
}

     default {
              return “”
              error “Unknown mode ‘$mode’ in tps_pad_segments”
     }

  }

}

here is another TPS proc that is also in the ball park with these that removes undesirable segmetns altogether:

Code:

######################################################################
# Name:     tps_remove_segment
#
# Author:   Chris Hale
#
# Date:    
# 1999.03.10 Chris Hale
#          – wrote intitial version          
#
# 1999.05.24 Russ Ross
#          – fixed to not have memory leaks when creating new message
#
# Purpose:  Removes a segment(s) within a message.
# UPoC type:   tps
# Args:  tps keyedlist containing the following keys:
#        MODE    run mode (”start”, “run” or “time”)
#        MSGID   message handle
#        ARGS    user-supplied arguments:
#                 SEGMENTS – Segments that you wish to have removed.
#           The segments should be passed with no
#           spaces.  This allows you to delete as many
#           segments as you like.
#           EXAMPLE:
#              {SEGMENTS PV1NK1OBX}
#
# Returns: tps disposition list:
#    CONTINUE – original message will be overwritten
#               with new messages that has the specified
#               segments removed

proc tps_remove_segment { args } {
  keylget args MODE mode                 ;# Fetch mode
  keylget args ARGS.SEGMENTS segments

  set dispList {}            ;# Nothing to return

  switch -exact — $mode {
 
     start {
        return “”
     }

     run {
        # ‘run’ mode always has a MSGID; fetch and process it
        keylget args MSGID mh

        # Initialize variables
        set segname_list {}
        set index1 0
        set index2 2
        set count 1
        set new_msg {}

        # Determine number of segments that you want to have eliminated
        # and put them in list format
        set arg_length [clength $segments]
        set num_segments [expr $arg_length/3]
        while {$count <= $num_segments} {            lappend segname_list [crange $segments $index1 $index2]            incr count            incr index1 3            incr index2 3         }         # echo REMOVING SEGMENTS ($segname_list)         # Retrieve the message and create a new message that         # contains only the segments that are wanted.         set msg [msgget $mh]         set seg_list [split $msg r]         foreach item $seg_list {            if {[cequal $item {}]} continue            set seg_id [crange $item 0 2]            set found_list [intersect $segname_list $seg_id]            if {[cequal $found_list {}]} {               append new_msg $item r            }         }                 msgset $mh $new_msg         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_remove_segment"      }   }    return $dispList }

Russ Ross
RussRoss318@gmail.com

[Author]

Replies