MAG7UM ;WOIFO/MLH - Imaging - HL7 - utilities - make a message from a parse tree; 05/18/2007 11:23
;;3.0;IMAGING;**11,54**;03-July-2009;;Build 1424
;; 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
;
MAKE(XTREE,XMSG) ; make a parse tree into an array of message lines
;
; INPUT: XTREE The name of the parse tree ($NA format)
; Parse tree structure:
; @XTREE@(NSEG,0) segment name
; @XTREE@(NSEG,NFLD,NREP,NCMP,NSCM) element data
; @XTREE@("B",SEGID,NSEG) null
;
; XMSG The name of a single-dimensional array to be populated
; with message lines ($NA format). This array is
; cleared on invocation.
;
; OUTPUT: XMSG The array after being populated with message lines
;
N UFS,UCS,URS,UEC,USS ;---------------- HL7 delimiters (universal)
N X,I ; --------------------------------- scratch var
N ERR ; ------------------------------- error flag
N ENC ; ------------------------------- encoding characters string
N NSEG ; ------------------------------ segment number in the parse tree
N NMSEG ; ----------------------------- segment number in the message
N IMSG ; ------------------------------ message array index
N SEG ; ------------------------------- segment data
N NFLD ; ------------------------------ field number in the segment
N FLD ; ------------------------------- field data
;
K @XMSG ; refresh target array
; process MSH segment
Q:$D(@XTREE)<10 -1 ; parse tree sent?
S NSEG=$O(@XTREE@("")),NMSEG=1
Q:$G(@XTREE@(NSEG,0))'="MSH" -2 ; an HL7 message?
Q:$D(@XTREE@(NSEG,9,1,1,1))#10=0 -3 ; message type provided?
; get delimiters or define defaults
S UFS=$G(@XTREE@(NSEG,1,1,1,1)) I $L(UFS)-1 S UFS="|"
S ENC=$G(@XTREE@(NSEG,2,1,1,1)) I $L(ENC)-4 S ENC="^~\&"
S UCS=$E(ENC),URS=$E(ENC,2),UEC=$E(ENC,3),USS=$E(ENC,4)
I $D(@XTREE@(NSEG,3,1,1,1))#10=0 S @XTREE@(1,3,1,1,1)="VistA Imaging"
S @XTREE@(NSEG,7,1,1,1)=$$NOW^XLFDT()+17000000*1000000
I $D(@XTREE@(NSEG,10,1,1,1))#10=0 D
. S X=""
. F I=1:1:16 S X=X_$E("0123456789ABCDEF",$R(16)+1)
. S @XTREE@(NSEG,10,1,1,1)=X
. Q
I $D(@XTREE@(NSEG,11,1,1,1))#10=0 S @XTREE@(NSEG,11,1,1,1)="D"
I $D(@XTREE@(NSEG,12,1,1,1))#10=0 S @XTREE@(NSEG,12,1,1,1)="2.3.1"
S SEG="MSH"_UFS_ENC
S NFLD=2
F S NFLD=$O(@XTREE@(NSEG,NFLD)) Q:NFLD="" D PROCFLD(XTREE,NSEG,NFLD,.SEG)
S @XMSG@(NMSEG)=SEG
F S NSEG=$O(@XTREE@(NSEG)) Q:'NSEG D
. K SEG
. S NMSEG=NMSEG+1
. S NFLD=0
. F S NFLD=$O(@XTREE@(NSEG,NFLD)) Q:NFLD="" D PROCFLD(XTREE,NSEG,NFLD,.SEG)
. S @XMSG@(NMSEG)=$G(@XTREE@(NSEG,0))_$S($G(SEG)]"":UFS_SEG,1:"")
. Q
Q 0
;
PROCFLD(XTREE,XNSEG,XNFLD,XSEG) ; 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
; .XSEG segment before addition of field
;
; output: .XSEG segment after addition of field
;
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
N FLD ; ----- field data
;
S NREP=""
F S NREP=$O(@XTREE@(XNSEG,XNFLD,NREP)) Q:NREP="" D
. K REP
. S NCMP=""
. F S NCMP=$O(@XTREE@(XNSEG,XNFLD,NREP,NCMP)) Q:NCMP="" D
. . K CMP
. . S NSCM=""
. . F S NSCM=$O(@XTREE@(XNSEG,XNFLD,NREP,NCMP,NSCM)) Q:NSCM="" D
. . . S SCM=@XTREE@(XNSEG,XNFLD,NREP,NCMP,NSCM)
. . . S $P(CMP,USS,NSCM)=$$ESC(.SCM)
. . . Q
. . S $P(REP,UCS,NCMP)=CMP
. . Q
. S $P(FLD,URS,NREP)=REP
. Q
S $P(XSEG,UFS,NFLD)=$G(FLD)
Q
;
ESC(XDTA) ;apply escape sequence to data
; Insert an intermediate token, then expand the intermediate token to
; the real escape sequence. (We have to do 2 steps because the escape
; sequence uses the escape character.)
F Q:XDTA'[UFS S XDTA=$P(XDTA,UFS)_$C(1)_$P(XDTA,UFS,2,999)
F Q:XDTA'[UCS S XDTA=$P(XDTA,UCS)_$C(2)_$P(XDTA,UCS,2,999)
F Q:XDTA'[URS S XDTA=$P(XDTA,URS)_$C(3)_$P(XDTA,URS,2,999)
F Q:XDTA'[UEC S XDTA=$P(XDTA,UEC)_$C(4)_$P(XDTA,UEC,2,999)
F Q:XDTA'[USS S XDTA=$P(XDTA,USS)_$C(5)_$P(XDTA,USS,2,999)
F Q:XDTA'[$C(1) S XDTA=$P(XDTA,$C(1))_UEC_"F"_UEC_$P(XDTA,$C(1),2,999)
F Q:XDTA'[$C(2) S XDTA=$P(XDTA,$C(2))_UEC_"S"_UEC_$P(XDTA,$C(2),2,999)
F Q:XDTA'[$C(3) S XDTA=$P(XDTA,$C(3))_UEC_"R"_UEC_$P(XDTA,$C(3),2,999)
F Q:XDTA'[$C(4) S XDTA=$P(XDTA,$C(4))_UEC_"E"_UEC_$P(XDTA,$C(4),2,999)
F Q:XDTA'[$C(5) S XDTA=$P(XDTA,$C(5))_UEC_"T"_UEC_$P(XDTA,$C(5),2,999)
Q XDTA
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAG7UM 5645 printed Sep 23, 2025@19:35:33 Page 2
MAG7UM ;WOIFO/MLH - Imaging - HL7 - utilities - make a message from a parse tree; 05/18/2007 11:23
+1 ;;3.0;IMAGING;**11,54**;03-July-2009;;Build 1424
+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 ;
MAKE(XTREE,XMSG) ; make a parse tree into an array of message lines
+1 ;
+2 ; INPUT: XTREE The name of the parse tree ($NA format)
+3 ; Parse tree structure:
+4 ; @XTREE@(NSEG,0) segment name
+5 ; @XTREE@(NSEG,NFLD,NREP,NCMP,NSCM) element data
+6 ; @XTREE@("B",SEGID,NSEG) null
+7 ;
+8 ; XMSG The name of a single-dimensional array to be populated
+9 ; with message lines ($NA format). This array is
+10 ; cleared on invocation.
+11 ;
+12 ; OUTPUT: XMSG The array after being populated with message lines
+13 ;
+14 ;---------------- HL7 delimiters (universal)
NEW UFS,UCS,URS,UEC,USS
+15 ; --------------------------------- scratch var
NEW X,I
+16 ; ------------------------------- error flag
NEW ERR
+17 ; ------------------------------- encoding characters string
NEW ENC
+18 ; ------------------------------ segment number in the parse tree
NEW NSEG
+19 ; ----------------------------- segment number in the message
NEW NMSEG
+20 ; ------------------------------ message array index
NEW IMSG
+21 ; ------------------------------- segment data
NEW SEG
+22 ; ------------------------------ field number in the segment
NEW NFLD
+23 ; ------------------------------- field data
NEW FLD
+24 ;
+25 ; refresh target array
KILL @XMSG
+26 ; process MSH segment
+27 ; parse tree sent?
if $DATA(@XTREE)<10
QUIT -1
+28 SET NSEG=$ORDER(@XTREE@(""))
SET NMSEG=1
+29 ; an HL7 message?
if $GET(@XTREE@(NSEG,0))'="MSH"
QUIT -2
+30 ; message type provided?
if $DATA(@XTREE@(NSEG,9,1,1,1))#10=0
QUIT -3
+31 ; get delimiters or define defaults
+32 SET UFS=$GET(@XTREE@(NSEG,1,1,1,1))
IF $LENGTH(UFS)-1
SET UFS="|"
+33 SET ENC=$GET(@XTREE@(NSEG,2,1,1,1))
IF $LENGTH(ENC)-4
SET ENC="^~\&"
+34 SET UCS=$EXTRACT(ENC)
SET URS=$EXTRACT(ENC,2)
SET UEC=$EXTRACT(ENC,3)
SET USS=$EXTRACT(ENC,4)
+35 IF $DATA(@XTREE@(NSEG,3,1,1,1))#10=0
SET @XTREE@(1,3,1,1,1)="VistA Imaging"
+36 SET @XTREE@(NSEG,7,1,1,1)=$$NOW^XLFDT()+17000000*1000000
+37 IF $DATA(@XTREE@(NSEG,10,1,1,1))#10=0
Begin DoDot:1
+38 SET X=""
+39 FOR I=1:1:16
SET X=X_$EXTRACT("0123456789ABCDEF",$RANDOM(16)+1)
+40 SET @XTREE@(NSEG,10,1,1,1)=X
+41 QUIT
End DoDot:1
+42 IF $DATA(@XTREE@(NSEG,11,1,1,1))#10=0
SET @XTREE@(NSEG,11,1,1,1)="D"
+43 IF $DATA(@XTREE@(NSEG,12,1,1,1))#10=0
SET @XTREE@(NSEG,12,1,1,1)="2.3.1"
+44 SET SEG="MSH"_UFS_ENC
+45 SET NFLD=2
+46 FOR
SET NFLD=$ORDER(@XTREE@(NSEG,NFLD))
if NFLD=""
QUIT
DO PROCFLD(XTREE,NSEG,NFLD,.SEG)
+47 SET @XMSG@(NMSEG)=SEG
+48 FOR
SET NSEG=$ORDER(@XTREE@(NSEG))
if 'NSEG
QUIT
Begin DoDot:1
+49 KILL SEG
+50 SET NMSEG=NMSEG+1
+51 SET NFLD=0
+52 FOR
SET NFLD=$ORDER(@XTREE@(NSEG,NFLD))
if NFLD=""
QUIT
DO PROCFLD(XTREE,NSEG,NFLD,.SEG)
+53 SET @XMSG@(NMSEG)=$GET(@XTREE@(NSEG,0))_$SELECT($GET(SEG)]"":UFS_SEG,1:"")
+54 QUIT
End DoDot:1
+55 QUIT 0
+56 ;
PROCFLD(XTREE,XNSEG,XNFLD,XSEG) ; 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 ; .XSEG segment before addition of field
+6 ;
+7 ; output: .XSEG segment after addition of field
+8 ;
+9 ; ---- repetition (occurrence) number
NEW NREP
+10 ; ----- repetition data
NEW REP
+11 ; ---- component number
NEW NCMP
+12 ; ----- component data
NEW CMP
+13 ; ---- subcomponent number
NEW NSCM
+14 ; ----- subcomponent data
NEW SCM
+15 ; ----- field data
NEW FLD
+16 ;
+17 SET NREP=""
+18 FOR
SET NREP=$ORDER(@XTREE@(XNSEG,XNFLD,NREP))
if NREP=""
QUIT
Begin DoDot:1
+19 KILL REP
+20 SET NCMP=""
+21 FOR
SET NCMP=$ORDER(@XTREE@(XNSEG,XNFLD,NREP,NCMP))
if NCMP=""
QUIT
Begin DoDot:2
+22 KILL CMP
+23 SET NSCM=""
+24 FOR
SET NSCM=$ORDER(@XTREE@(XNSEG,XNFLD,NREP,NCMP,NSCM))
if NSCM=""
QUIT
Begin DoDot:3
+25 SET SCM=@XTREE@(XNSEG,XNFLD,NREP,NCMP,NSCM)
+26 SET $PIECE(CMP,USS,NSCM)=$$ESC(.SCM)
+27 QUIT
End DoDot:3
+28 SET $PIECE(REP,UCS,NCMP)=CMP
+29 QUIT
End DoDot:2
+30 SET $PIECE(FLD,URS,NREP)=REP
+31 QUIT
End DoDot:1
+32 SET $PIECE(XSEG,UFS,NFLD)=$GET(FLD)
+33 QUIT
+34 ;
ESC(XDTA) ;apply escape sequence to data
+1 ; Insert an intermediate token, then expand the intermediate token to
+2 ; the real escape sequence. (We have to do 2 steps because the escape
+3 ; sequence uses the escape character.)
+4 FOR
if XDTA'[UFS
QUIT
SET XDTA=$PIECE(XDTA,UFS)_$CHAR(1)_$PIECE(XDTA,UFS,2,999)
+5 FOR
if XDTA'[UCS
QUIT
SET XDTA=$PIECE(XDTA,UCS)_$CHAR(2)_$PIECE(XDTA,UCS,2,999)
+6 FOR
if XDTA'[URS
QUIT
SET XDTA=$PIECE(XDTA,URS)_$CHAR(3)_$PIECE(XDTA,URS,2,999)
+7 FOR
if XDTA'[UEC
QUIT
SET XDTA=$PIECE(XDTA,UEC)_$CHAR(4)_$PIECE(XDTA,UEC,2,999)
+8 FOR
if XDTA'[USS
QUIT
SET XDTA=$PIECE(XDTA,USS)_$CHAR(5)_$PIECE(XDTA,USS,2,999)
+9 FOR
if XDTA'[$CHAR(1)
QUIT
SET XDTA=$PIECE(XDTA,$CHAR(1))_UEC_"F"_UEC_$PIECE(XDTA,$CHAR(1),2,999)
+10 FOR
if XDTA'[$CHAR(2)
QUIT
SET XDTA=$PIECE(XDTA,$CHAR(2))_UEC_"S"_UEC_$PIECE(XDTA,$CHAR(2),2,999)
+11 FOR
if XDTA'[$CHAR(3)
QUIT
SET XDTA=$PIECE(XDTA,$CHAR(3))_UEC_"R"_UEC_$PIECE(XDTA,$CHAR(3),2,999)
+12 FOR
if XDTA'[$CHAR(4)
QUIT
SET XDTA=$PIECE(XDTA,$CHAR(4))_UEC_"E"_UEC_$PIECE(XDTA,$CHAR(4),2,999)
+13 FOR
if XDTA'[$CHAR(5)
QUIT
SET XDTA=$PIECE(XDTA,$CHAR(5))_UEC_"T"_UEC_$PIECE(XDTA,$CHAR(5),2,999)
+14 QUIT XDTA
+15 ;
