- MAG7UP ;WOIFO/MLH,PMK - Imaging - HL7 - utilities - break out message into a parse tree ;25 May 2017 2:30 PM
- ;;3.0;IMAGING;**11,51,183**;MAR 19, 2002;Build 11;JUN 16, 2006
- ;; Per VHA Directive 2004-038, this routine should not be modified.
- ;; +---------------------------------------------------------------+
- ;; | Property of the US Government. |
- ;; | No permission to copy or redistribute this software is given. |
- ;; | Use of unreleased versions of this software requires the user |
- ;; | to execute a written test agreement with the VistA Imaging |
- ;; | Development Office of the Department of Veterans Affairs, |
- ;; | telephone (301) 734-0100. |
- ;; | The Food and Drug Administration classifies this software as |
- ;; | a medical device. As such, it may not be changed in any way. |
- ;; | Modifications to this software may result in an adulterated |
- ;; | medical device under 21CFR820, the use of which is considered |
- ;; | to be a violation of US Federal Statutes. |
- ;; +---------------------------------------------------------------+
- ;;
- Q
- ;
- PARSE(XMSG,XTREE) ; break the HL7 message lines into a parse tree
- ;
- ; INPUT: The single-dimensional array of message lines
- ;
- ; OUTPUT: The parse tree, in the structure
- ; @XTREE@(NSEG,0) segment name
- ; @XTREE@(NSEG,NFLD,NREP,NCMP,NSCM) element data
- ; @XTREE@("B",SEGID,NSEG) null
- ;
- N I,J,K,L,M,X,Z ; --------------------- scratch vars
- N IMSG ; ------------------------------ message array index
- N ISUBSEG ; --------------------------- index of continuation data for long segs
- N ISUCC ; ----------------------------- successor element index
- N FERR ; ------------------------------ error flag
- N SEG ; ------------------------------- segment data
- N SEGTAG ; ---------------------------- segment ID ("0th" piece)
- N UFS,UCS,URS,UEC,USS ;---------------- HL7 delimiters (universal)
- N ENC ;-------------------------------- HL7 encoding characters
- N UFSESC,UCSESC,URSESC,UECESC,USSESC ;- HL7 escape sequences for delimiters (universal)
- N PATTERN ; --------------------------- pattern match for spanned record
- N NSEG ; ------------------------------ segment number in the parse tree
- N NSEGINPT ; -------------------------- segment number of input HL7 data
- N NFLD ; ------------------------------ field number in the segment
- N FLD ; ------------------------------- field data
- ;
- S FERR=0 ; assume no error
- S IMSG=""
- ;
- ; process MSH segment
- ; If there's a message problem, return it in an NTE segment.
- ;
- S IMSG=$O(@XMSG@(IMSG)) ; array sent?
- I IMSG="" D Q FERR ; no
- . S FERR=-1
- . ; have to use default field separator
- . S @XMSG@(0)="NTE|1||"_FERR_";no input array found"
- . Q
- S SEG=$G(@XMSG@(IMSG)) Q:$E(SEG,1,3)'="MSH" -2 ; an HL7 message?
- I $E(SEG,1,3)'="MSH" D Q FERR ; no
- . S FERR=-2
- . S ISUCC=$O(@XMSG@(IMSG)) S:'ISUCC ISUCC=IMSG+1
- . ; have to use default field separator
- . S @XMSG@(IMSG+ISUCC/2)="NTE|1||"_FERR_";invalid HL7 message (1st 3 chars must be MSH)"
- . Q
- ;
- ; set up delimiters and escape sequences
- S UFS=$E(SEG,4),@XTREE@(1,1,1,1,1)=UFS
- S ENC=$P(SEG,UFS,2),@XTREE@(1,2,1,1,1)=ENC
- S UCS=$E(ENC),URS=$E(ENC,2),UEC=$E(ENC,3),USS=$E(ENC,4)
- S UFSESC=UEC_"F"_UEC,UCSESC=UEC_"S"_UEC,URSESC=UEC_"R"_UEC,UECESC=UEC_"E"_UEC,USSESC=UEC_"T"_UEC
- S PATTERN="1A2AN1"""_UFS_""""
- S @XTREE@(1,0)="MSH",@XTREE@("B","MSH",1)=""
- F NFLD=3:1:$L(SEG,UFS) S FLD=$P(SEG,UFS,NFLD) D
- . I FLD]"" D PROCFLD(XTREE,1,NFLD,FLD)
- . Q
- ; process the remaining segments
- S SEG="" ; SEG will be a concatenated series of spanned records
- S NSEG=2 ; next segment in the parse tree will be #2
- F NSEGINPT=2:1 S IMSG=$O(@XMSG@(IMSG)) Q:IMSG="" D Q:FERR
- . S SEG=$G(@XMSG@(IMSG)) Q:SEG=""
- . S ISUBSEG="" ; prepare to handle very long HL7 segments (up to 32K)
- . F S ISUBSEG=$O(@XMSG@(IMSG,ISUBSEG)) Q:ISUBSEG="" D
- . . S SEG=SEG_$G(@XMSG@(IMSG,ISUBSEG))
- . . Q
- . S SEGTAG=$P(SEG,UFS) I SEGTAG'?1U2.3UN S FERR=-3 Q
- . S @XTREE@(NSEG,0)=SEGTAG,@XTREE@("B",SEGTAG,NSEG)=""
- . F NFLD=2:1:$L(SEG,UFS) D
- . . S FLD=$P(SEG,UFS,NFLD)
- . . I FLD]"" D PROCFLD(XTREE,NSEG,NFLD-1,FLD)
- . . Q
- . S SEG="" ; reinitialize SEG for the next possible concatenation
- . S NSEG=NSEG+1 ; increment counter for next segment in the parse tree
- . Q
- Q FERR
- ;
- PROCFLD(XTREE,XNSEG,XNFLD,XFLD) ; process a field
- ;
- ; input: XTREE name of MUMPS array for parse tree ($NA format)
- ; XNSEG segment number for parse tree
- ; XNFLD field number for parse tree
- ; XFLD field data
- ;
- N SG ; ------ segment name
- N NREP ; ---- repetition (occurrence) number
- N REP ; ----- repetition data
- N NCMP ; ---- component number
- N CMP ; ----- component data
- N NSCM ; ---- subcomponent number
- N SCM ; ----- subcomponent data
- ;
- S SG=@XTREE@(XNSEG,0)
- ; Per DICOM meeting 2004-02-24, reaffirmed that data may need to be
- ; retrieved above the subcomponent level, and that those data will
- ; need to be de-escaped because the receiving application won't have
- ; access to the delimiters from the original message.
- S @XTREE@(XNSEG,XNFLD)=$$DEESC(XFLD)
- ;
- ; Break out to the lowest delimiter level too. This is not strictly an
- ; HL7 parse because it does not take actual HL7 (or realm constraining)
- ; data types into account.
- ;
- F NREP=1:1:$L(XFLD,URS) S REP=$P(XFLD,URS,NREP) I REP]"" D
- . F NCMP=1:1:$L(REP,UCS) S CMP=$P(REP,UCS,NCMP) I CMP]"" D
- . . ; Per DICOM meeting 2004-02-24, reaffirmed that data may need to be
- . . ; retrieved above the subcomponent level, and that those data will
- . . ; need to be de-escaped because the receiving application won't have
- . . ; access to the delimiters from the original message.
- . . S @XTREE@(XNSEG,XNFLD,NREP,NCMP)=$$DEESC(CMP)
- . . F NSCM=1:1:$L(CMP,USS) S SCM=$P(CMP,USS,NSCM) I SCM]"" D
- . . . S @XTREE@(XNSEG,XNFLD,NREP,NCMP,NSCM)=$$DEESC(SCM)
- . . . Q
- . . Q
- . Q
- Q
- ;
- DEESC(XSCM) ; replace escape sequences with delimiter characters
- ;
- ; input: XSCM element data before replacement
- ;
- ; expects: UFSESC, UCSESC, URSESC, UECESC, USSESC
- ; delimiter escape sequences
- ;
- ; function return: element data after replacement
- ;
- N HIT ; need another pass after each hit
- F D Q:'$D(HIT)
- . K HIT
- . I XSCM[UFSESC S XSCM=$P(XSCM,UFSESC)_UFS_$P(XSCM,UFSESC,2,99999),HIT=1
- . I XSCM[UCSESC S XSCM=$P(XSCM,UCSESC)_UCS_$P(XSCM,UCSESC,2,99999),HIT=1
- . I XSCM[URSESC S XSCM=$P(XSCM,URSESC)_URS_$P(XSCM,URSESC,2,99999),HIT=1
- . I XSCM[UECESC S XSCM=$P(XSCM,UECESC)_UEC_$P(XSCM,UECESC,2,99999),HIT=1
- . I XSCM[USSESC S XSCM=$P(XSCM,USSESC)_USS_$P(XSCM,USSESC,2,99999),HIT=1
- . Q
- Q $E(XSCM,1,510)
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAG7UP 6835 printed Feb 18, 2025@23:25:53 Page 2
- MAG7UP ;WOIFO/MLH,PMK - Imaging - HL7 - utilities - break out message into a parse tree ;25 May 2017 2:30 PM
- +1 ;;3.0;IMAGING;**11,51,183**;MAR 19, 2002;Build 11;JUN 16, 2006
- +2 ;; Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;; +---------------------------------------------------------------+
- +4 ;; | Property of the US Government. |
- +5 ;; | No permission to copy or redistribute this software is given. |
- +6 ;; | Use of unreleased versions of this software requires the user |
- +7 ;; | to execute a written test agreement with the VistA Imaging |
- +8 ;; | Development Office of the Department of Veterans Affairs, |
- +9 ;; | telephone (301) 734-0100. |
- +10 ;; | The Food and Drug Administration classifies this software as |
- +11 ;; | a medical device. As such, it may not be changed in any way. |
- +12 ;; | Modifications to this software may result in an adulterated |
- +13 ;; | medical device under 21CFR820, the use of which is considered |
- +14 ;; | to be a violation of US Federal Statutes. |
- +15 ;; +---------------------------------------------------------------+
- +16 ;;
- +17 QUIT
- +18 ;
- PARSE(XMSG,XTREE) ; break the HL7 message lines into a parse tree
- +1 ;
- +2 ; INPUT: The single-dimensional array of message lines
- +3 ;
- +4 ; OUTPUT: The parse tree, in the structure
- +5 ; @XTREE@(NSEG,0) segment name
- +6 ; @XTREE@(NSEG,NFLD,NREP,NCMP,NSCM) element data
- +7 ; @XTREE@("B",SEGID,NSEG) null
- +8 ;
- +9 ; --------------------- scratch vars
- NEW I,J,K,L,M,X,Z
- +10 ; ------------------------------ message array index
- NEW IMSG
- +11 ; --------------------------- index of continuation data for long segs
- NEW ISUBSEG
- +12 ; ----------------------------- successor element index
- NEW ISUCC
- +13 ; ------------------------------ error flag
- NEW FERR
- +14 ; ------------------------------- segment data
- NEW SEG
- +15 ; ---------------------------- segment ID ("0th" piece)
- NEW SEGTAG
- +16 ;---------------- HL7 delimiters (universal)
- NEW UFS,UCS,URS,UEC,USS
- +17 ;-------------------------------- HL7 encoding characters
- NEW ENC
- +18 ;- HL7 escape sequences for delimiters (universal)
- NEW UFSESC,UCSESC,URSESC,UECESC,USSESC
- +19 ; --------------------------- pattern match for spanned record
- NEW PATTERN
- +20 ; ------------------------------ segment number in the parse tree
- NEW NSEG
- +21 ; -------------------------- segment number of input HL7 data
- NEW NSEGINPT
- +22 ; ------------------------------ field number in the segment
- NEW NFLD
- +23 ; ------------------------------- field data
- NEW FLD
- +24 ;
- +25 ; assume no error
- SET FERR=0
- +26 SET IMSG=""
- +27 ;
- +28 ; process MSH segment
- +29 ; If there's a message problem, return it in an NTE segment.
- +30 ;
- +31 ; array sent?
- SET IMSG=$ORDER(@XMSG@(IMSG))
- +32 ; no
- IF IMSG=""
- Begin DoDot:1
- +33 SET FERR=-1
- +34 ; have to use default field separator
- +35 SET @XMSG@(0)="NTE|1||"_FERR_";no input array found"
- +36 QUIT
- End DoDot:1
- QUIT FERR
- +37 ; an HL7 message?
- SET SEG=$GET(@XMSG@(IMSG))
- if $EXTRACT(SEG,1,3)'="MSH"
- QUIT -2
- +38 ; no
- IF $EXTRACT(SEG,1,3)'="MSH"
- Begin DoDot:1
- +39 SET FERR=-2
- +40 SET ISUCC=$ORDER(@XMSG@(IMSG))
- if 'ISUCC
- SET ISUCC=IMSG+1
- +41 ; have to use default field separator
- +42 SET @XMSG@(IMSG+ISUCC/2)="NTE|1||"_FERR_";invalid HL7 message (1st 3 chars must be MSH)"
- +43 QUIT
- End DoDot:1
- QUIT FERR
- +44 ;
- +45 ; set up delimiters and escape sequences
- +46 SET UFS=$EXTRACT(SEG,4)
- SET @XTREE@(1,1,1,1,1)=UFS
- +47 SET ENC=$PIECE(SEG,UFS,2)
- SET @XTREE@(1,2,1,1,1)=ENC
- +48 SET UCS=$EXTRACT(ENC)
- SET URS=$EXTRACT(ENC,2)
- SET UEC=$EXTRACT(ENC,3)
- SET USS=$EXTRACT(ENC,4)
- +49 SET UFSESC=UEC_"F"_UEC
- SET UCSESC=UEC_"S"_UEC
- SET URSESC=UEC_"R"_UEC
- SET UECESC=UEC_"E"_UEC
- SET USSESC=UEC_"T"_UEC
- +50 SET PATTERN="1A2AN1"""_UFS_""""
- +51 SET @XTREE@(1,0)="MSH"
- SET @XTREE@("B","MSH",1)=""
- +52 FOR NFLD=3:1:$LENGTH(SEG,UFS)
- SET FLD=$PIECE(SEG,UFS,NFLD)
- Begin DoDot:1
- +53 IF FLD]""
- DO PROCFLD(XTREE,1,NFLD,FLD)
- +54 QUIT
- End DoDot:1
- +55 ; process the remaining segments
- +56 ; SEG will be a concatenated series of spanned records
- SET SEG=""
- +57 ; next segment in the parse tree will be #2
- SET NSEG=2
- +58 FOR NSEGINPT=2:1
- SET IMSG=$ORDER(@XMSG@(IMSG))
- if IMSG=""
- QUIT
- Begin DoDot:1
- +59 SET SEG=$GET(@XMSG@(IMSG))
- if SEG=""
- QUIT
- +60 ; prepare to handle very long HL7 segments (up to 32K)
- SET ISUBSEG=""
- +61 FOR
- SET ISUBSEG=$ORDER(@XMSG@(IMSG,ISUBSEG))
- if ISUBSEG=""
- QUIT
- Begin DoDot:2
- +62 SET SEG=SEG_$GET(@XMSG@(IMSG,ISUBSEG))
- +63 QUIT
- End DoDot:2
- +64 SET SEGTAG=$PIECE(SEG,UFS)
- IF SEGTAG'?1U2.3UN
- SET FERR=-3
- QUIT
- +65 SET @XTREE@(NSEG,0)=SEGTAG
- SET @XTREE@("B",SEGTAG,NSEG)=""
- +66 FOR NFLD=2:1:$LENGTH(SEG,UFS)
- Begin DoDot:2
- +67 SET FLD=$PIECE(SEG,UFS,NFLD)
- +68 IF FLD]""
- DO PROCFLD(XTREE,NSEG,NFLD-1,FLD)
- +69 QUIT
- End DoDot:2
- +70 ; reinitialize SEG for the next possible concatenation
- SET SEG=""
- +71 ; increment counter for next segment in the parse tree
- SET NSEG=NSEG+1
- +72 QUIT
- End DoDot:1
- if FERR
- QUIT
- +73 QUIT FERR
- +74 ;
- PROCFLD(XTREE,XNSEG,XNFLD,XFLD) ; process a field
- +1 ;
- +2 ; input: XTREE name of MUMPS array for parse tree ($NA format)
- +3 ; XNSEG segment number for parse tree
- +4 ; XNFLD field number for parse tree
- +5 ; XFLD field data
- +6 ;
- +7 ; ------ segment name
- NEW SG
- +8 ; ---- repetition (occurrence) number
- NEW NREP
- +9 ; ----- repetition data
- NEW REP
- +10 ; ---- component number
- NEW NCMP
- +11 ; ----- component data
- NEW CMP
- +12 ; ---- subcomponent number
- NEW NSCM
- +13 ; ----- subcomponent data
- NEW SCM
- +14 ;
- +15 SET SG=@XTREE@(XNSEG,0)
- +16 ; Per DICOM meeting 2004-02-24, reaffirmed that data may need to be
- +17 ; retrieved above the subcomponent level, and that those data will
- +18 ; need to be de-escaped because the receiving application won't have
- +19 ; access to the delimiters from the original message.
- +20 SET @XTREE@(XNSEG,XNFLD)=$$DEESC(XFLD)
- +21 ;
- +22 ; Break out to the lowest delimiter level too. This is not strictly an
- +23 ; HL7 parse because it does not take actual HL7 (or realm constraining)
- +24 ; data types into account.
- +25 ;
- +26 FOR NREP=1:1:$LENGTH(XFLD,URS)
- SET REP=$PIECE(XFLD,URS,NREP)
- IF REP]""
- Begin DoDot:1
- +27 FOR NCMP=1:1:$LENGTH(REP,UCS)
- SET CMP=$PIECE(REP,UCS,NCMP)
- IF CMP]""
- Begin DoDot:2
- +28 ; Per DICOM meeting 2004-02-24, reaffirmed that data may need to be
- +29 ; retrieved above the subcomponent level, and that those data will
- +30 ; need to be de-escaped because the receiving application won't have
- +31 ; access to the delimiters from the original message.
- +32 SET @XTREE@(XNSEG,XNFLD,NREP,NCMP)=$$DEESC(CMP)
- +33 FOR NSCM=1:1:$LENGTH(CMP,USS)
- SET SCM=$PIECE(CMP,USS,NSCM)
- IF SCM]""
- Begin DoDot:3
- +34 SET @XTREE@(XNSEG,XNFLD,NREP,NCMP,NSCM)=$$DEESC(SCM)
- +35 QUIT
- End DoDot:3
- +36 QUIT
- End DoDot:2
- +37 QUIT
- End DoDot:1
- +38 QUIT
- +39 ;
- DEESC(XSCM) ; replace escape sequences with delimiter characters
- +1 ;
- +2 ; input: XSCM element data before replacement
- +3 ;
- +4 ; expects: UFSESC, UCSESC, URSESC, UECESC, USSESC
- +5 ; delimiter escape sequences
- +6 ;
- +7 ; function return: element data after replacement
- +8 ;
- +9 ; need another pass after each hit
- NEW HIT
- +10 FOR
- Begin DoDot:1
- +11 KILL HIT
- +12 IF XSCM[UFSESC
- SET XSCM=$PIECE(XSCM,UFSESC)_UFS_$PIECE(XSCM,UFSESC,2,99999)
- SET HIT=1
- +13 IF XSCM[UCSESC
- SET XSCM=$PIECE(XSCM,UCSESC)_UCS_$PIECE(XSCM,UCSESC,2,99999)
- SET HIT=1
- +14 IF XSCM[URSESC
- SET XSCM=$PIECE(XSCM,URSESC)_URS_$PIECE(XSCM,URSESC,2,99999)
- SET HIT=1
- +15 IF XSCM[UECESC
- SET XSCM=$PIECE(XSCM,UECESC)_UEC_$PIECE(XSCM,UECESC,2,99999)
- SET HIT=1
- +16 IF XSCM[USSESC
- SET XSCM=$PIECE(XSCM,USSESC)_USS_$PIECE(XSCM,USSESC,2,99999)
- SET HIT=1
- +17 QUIT
- End DoDot:1
- if '$DATA(HIT)
- QUIT
- +18 QUIT $EXTRACT(XSCM,1,510)
- +19 ;