VAQPAR1 ;ALB/JRP - MESSAGE PARSING;28-APR-93
;;1.5;PATIENT DATA EXCHANGE;;NOV 17, 1993
PREPRS10(ARRAY) ;PRE-PARSE VERSION 1.0 TRANSMISSION
;INPUT : ARRAY - Parsing array (full global reference)
; (As defined by MailMan)
; XMFROM, XMREC, XMZ
; (Declared in SERVER^VAQADM2)
; XMER, XMRG, XMPOS
;OUTPUT : XMER - Exit condition
; 0 = Success
; -1^Error_Text = Error
; XMPOS - Last line [number] read in transmission
; (if NULL end of transmission reached)
;
;NOTES : Parsing array will have the following format
; ARRAY(1,BlockName,LineNumber) = Value
; : Calling routine responsible for ARRAY clean up before
; and after call
; : This is not a function
;
;CHECK INPUT
I ($G(ARRAY)="") S XMER="-1^Did not pass reference to parsing array" Q
;DECLARE VARIABLES
N LINE,ERR,BLOCK,TMP,X
S XMER=0
S LINE=1
;READ HEADER
S BLOCK="HEADER"
X XMREC
I ((XMER<0)!(XMRG="")) S XMER="-1^Transmission did not contain any information" Q
S @ARRAY@(1,BLOCK,LINE)=XMRG
S LINE=LINE+1
;QUIT IF TRANSMISSION IS AN ACK
Q:($P(XMRG,"^",1)="ACK")
X XMREC
I ((XMER<0)!(XMRG="")) S XMER="-1^Transmission was not complete" Q
S @ARRAY@(1,BLOCK,LINE)=XMRG
S LINE=LINE+1
;CHECK TRANSMISSION TYPE
S TMP=+$P(@ARRAY@(1,BLOCK,1),"^",12)
;TRANSMISSION TYPE NOT SUPPORTED
I ((TMP=17)!(TMP=19)!(TMP=20)) S XMER="-1^Transmission type not supported" Q
F X=10:1:21 Q:(TMP=X)
I (X=21) S XMER="-1^Transmission type not supported" Q
;NO DATA BLOCKS IN TRANSMISSION
Q:((TMP'=15)&(TMP'=16))
;READ DATA BLOCKS
S XMER=0
F X XMREC Q:(XMER<0) D
.;GET DATA BLOCK TYPE
.S TMP=$P(XMRG,"^",1)
.;NEW DATA BLOCK TYPE
.S:(TMP'=BLOCK) LINE=1
.;BLOCK NOT SUPPORTED (SKIP)
.Q:((TMP'="MIN")&(TMP'="MAS")&(TMP'="PHA"))
.S BLOCK=TMP
.S @ARRAY@(1,BLOCK,LINE)=$P(XMRG,"^",2,($L(XMRG,"^")))
.S LINE=LINE+1
S XMER=0
Q
;
PARSE10(ARRAY) ;PARSE 1.0 MESSAGE
;INPUT : ARRAY - Array containing pre-parsed version 1.0 transmission
; (full global reference)
; (As defined by MailMan)
; XMFROM, XMREC, XMZ
; (Declared in SERVER^VAQADM2)
; XMER, XMRG, XMPOS
;OUTPUT : XMER - Exit condition
; 0 = Success
; -1^Error_Text = Error
;NOTES : Pre-parsed transmsission will be deleted from ARRAY
; and replaced with parsed array. Parsed array will be same
; as parsed array for version 1.5 message and have the format:
; ARRAY(2,BlockName,BlockSeq,Line)
; : This is not a function
;
;CHECK INPUT
I ($G(ARRAY)="") S XMER="-1^Did not pass reference to parsing array" Q
I ('$D(@ARRAY@(1))) S XMER="-1^Parsing array did not contain pre-parsed transmission" Q
;DECLARE VARIABLES
N TMP,BLOCK,ACK,TYPE,STATUS,X,Y
S XMER=0
;DETERMINE IF MESSAGE IS AN ACKNOWLEDGMENT
S TMP=$G(@ARRAY@(1,"HEADER",1))
I (TMP="") S XMER="-1^Header did not exist in pre-parsed message" Q
S ACK=($P(TMP,"^",1)="ACK")
;ACK
I (ACK) D
.;MAKE HEADER BLOCK
.S @ARRAY@(2,"HEADER",1,1)="$HEADER"
.S @ARRAY@(2,"HEADER",1,2)="ACK"
.S @ARRAY@(2,"HEADER",1,3)="VAQ-RQACK"
.S @ARRAY@(2,"HEADER",1,4)=1.0
.S @ARRAY@(2,"HEADER",1,5)=$$NOW^VAQUTL99(0,0)
.S @ARRAY@(2,"HEADER",1,6)=$G(XMZ)
.S @ARRAY@(2,"HEADER",1,7)=$P($G(@ARRAY@(1,"HEADER",1)),"^",2)
.S @ARRAY@(2,"HEADER",1,8)=""
.S @ARRAY@(2,"HEADER",1,9)="$$HEADER"
;NOT AN ACK
I ('ACK) D
.;DETERMINE STATUS & TYPE
.S TMP=$G(@ARRAY@(1,"HEADER",1))
.S X=$P(TMP,"^",12)
.S:(X=10) STATUS="VAQ-RQST",TYPE="REQ"
.S:(X=11) STATUS="VAQ-AMBIG",TYPE="RES"
.S:(X=12) STATUS="VAQ-NTFND",TYPE="RES"
.S:((X=13)!(X=14)!(X=18)) STATUS="VAQ-REJ",TYPE="RES"
.S:(X=15) STATUS="VAQ-RSLT",TYPE="RES"
.S:(X=16) STATUS="VAQ-UNSOL",TYPE="UNS"
.S @ARRAY@(2,"HEADER",1,1)="$HEADER"
.S @ARRAY@(2,"HEADER",1,2)=TYPE
.S @ARRAY@(2,"HEADER",1,3)=STATUS
.S @ARRAY@(2,"HEADER",1,4)=1.0
.S X=+$P(TMP,"^",9)
.S Y=$P(X,".",2)
.S Y=Y_"000000"
.S $P(X,".",2)=Y
.S Y=$$DOBFMT^VAQUTL99(X)
.I (Y'="") D
..S X=$P(X,".",2)
..S Y=Y_"@"_$E(X,1,2)_":"_$E(X,3,4)_":"_$E(X,5,6)
.S @ARRAY@(2,"HEADER",1,5)=Y
.S @ARRAY@(2,"HEADER",1,6)=$G(XMZ)
.S X=""
.S:((TYPE="RES")!(TYPE="REQ")) X=+TMP
.S @ARRAY@(2,"HEADER",1,7)=X
.S @ARRAY@(2,"HEADER",1,8)=""
.S @ARRAY@(2,"HEADER",1,9)="$$HEADER"
;MAKE DOMAIN BLOCK
S @ARRAY@(2,"DOMAIN",1,1)="$DOMAIN"
S X=$P($G(@ARRAY@(1,"HEADER",2)),"^",1)
S:(X="") X=$P($G(XMFROM),"@",2)
S @ARRAY@(2,"DOMAIN",1,2)=X
S @ARRAY@(2,"DOMAIN",1,3)=""
S @ARRAY@(2,"DOMAIN",1,4)="$$DOMAIN"
;DONE IF ACK
Q:(ACK)
;GO TO CONTINUATION ROUTINE
D PARCON^VAQPAR10
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAQPAR1 4738 printed Sep 23, 2025@20:01:47 Page 2
VAQPAR1 ;ALB/JRP - MESSAGE PARSING;28-APR-93
+1 ;;1.5;PATIENT DATA EXCHANGE;;NOV 17, 1993
PREPRS10(ARRAY) ;PRE-PARSE VERSION 1.0 TRANSMISSION
+1 ;INPUT : ARRAY - Parsing array (full global reference)
+2 ; (As defined by MailMan)
+3 ; XMFROM, XMREC, XMZ
+4 ; (Declared in SERVER^VAQADM2)
+5 ; XMER, XMRG, XMPOS
+6 ;OUTPUT : XMER - Exit condition
+7 ; 0 = Success
+8 ; -1^Error_Text = Error
+9 ; XMPOS - Last line [number] read in transmission
+10 ; (if NULL end of transmission reached)
+11 ;
+12 ;NOTES : Parsing array will have the following format
+13 ; ARRAY(1,BlockName,LineNumber) = Value
+14 ; : Calling routine responsible for ARRAY clean up before
+15 ; and after call
+16 ; : This is not a function
+17 ;
+18 ;CHECK INPUT
+19 IF ($GET(ARRAY)="")
SET XMER="-1^Did not pass reference to parsing array"
QUIT
+20 ;DECLARE VARIABLES
+21 NEW LINE,ERR,BLOCK,TMP,X
+22 SET XMER=0
+23 SET LINE=1
+24 ;READ HEADER
+25 SET BLOCK="HEADER"
+26 XECUTE XMREC
+27 IF ((XMER<0)!(XMRG=""))
SET XMER="-1^Transmission did not contain any information"
QUIT
+28 SET @ARRAY@(1,BLOCK,LINE)=XMRG
+29 SET LINE=LINE+1
+30 ;QUIT IF TRANSMISSION IS AN ACK
+31 if ($PIECE(XMRG,"^",1)="ACK")
QUIT
+32 XECUTE XMREC
+33 IF ((XMER<0)!(XMRG=""))
SET XMER="-1^Transmission was not complete"
QUIT
+34 SET @ARRAY@(1,BLOCK,LINE)=XMRG
+35 SET LINE=LINE+1
+36 ;CHECK TRANSMISSION TYPE
+37 SET TMP=+$PIECE(@ARRAY@(1,BLOCK,1),"^",12)
+38 ;TRANSMISSION TYPE NOT SUPPORTED
+39 IF ((TMP=17)!(TMP=19)!(TMP=20))
SET XMER="-1^Transmission type not supported"
QUIT
+40 FOR X=10:1:21
if (TMP=X)
QUIT
+41 IF (X=21)
SET XMER="-1^Transmission type not supported"
QUIT
+42 ;NO DATA BLOCKS IN TRANSMISSION
+43 if ((TMP'=15)&(TMP'=16))
QUIT
+44 ;READ DATA BLOCKS
+45 SET XMER=0
+46 FOR
XECUTE XMREC
if (XMER<0)
QUIT
Begin DoDot:1
+47 ;GET DATA BLOCK TYPE
+48 SET TMP=$PIECE(XMRG,"^",1)
+49 ;NEW DATA BLOCK TYPE
+50 if (TMP'=BLOCK)
SET LINE=1
+51 ;BLOCK NOT SUPPORTED (SKIP)
+52 if ((TMP'="MIN")&(TMP'="MAS")&(TMP'="PHA"))
QUIT
+53 SET BLOCK=TMP
+54 SET @ARRAY@(1,BLOCK,LINE)=$PIECE(XMRG,"^",2,($LENGTH(XMRG,"^")))
+55 SET LINE=LINE+1
End DoDot:1
+56 SET XMER=0
+57 QUIT
+58 ;
PARSE10(ARRAY) ;PARSE 1.0 MESSAGE
+1 ;INPUT : ARRAY - Array containing pre-parsed version 1.0 transmission
+2 ; (full global reference)
+3 ; (As defined by MailMan)
+4 ; XMFROM, XMREC, XMZ
+5 ; (Declared in SERVER^VAQADM2)
+6 ; XMER, XMRG, XMPOS
+7 ;OUTPUT : XMER - Exit condition
+8 ; 0 = Success
+9 ; -1^Error_Text = Error
+10 ;NOTES : Pre-parsed transmsission will be deleted from ARRAY
+11 ; and replaced with parsed array. Parsed array will be same
+12 ; as parsed array for version 1.5 message and have the format:
+13 ; ARRAY(2,BlockName,BlockSeq,Line)
+14 ; : This is not a function
+15 ;
+16 ;CHECK INPUT
+17 IF ($GET(ARRAY)="")
SET XMER="-1^Did not pass reference to parsing array"
QUIT
+18 IF ('$DATA(@ARRAY@(1)))
SET XMER="-1^Parsing array did not contain pre-parsed transmission"
QUIT
+19 ;DECLARE VARIABLES
+20 NEW TMP,BLOCK,ACK,TYPE,STATUS,X,Y
+21 SET XMER=0
+22 ;DETERMINE IF MESSAGE IS AN ACKNOWLEDGMENT
+23 SET TMP=$GET(@ARRAY@(1,"HEADER",1))
+24 IF (TMP="")
SET XMER="-1^Header did not exist in pre-parsed message"
QUIT
+25 SET ACK=($PIECE(TMP,"^",1)="ACK")
+26 ;ACK
+27 IF (ACK)
Begin DoDot:1
+28 ;MAKE HEADER BLOCK
+29 SET @ARRAY@(2,"HEADER",1,1)="$HEADER"
+30 SET @ARRAY@(2,"HEADER",1,2)="ACK"
+31 SET @ARRAY@(2,"HEADER",1,3)="VAQ-RQACK"
+32 SET @ARRAY@(2,"HEADER",1,4)=1.0
+33 SET @ARRAY@(2,"HEADER",1,5)=$$NOW^VAQUTL99(0,0)
+34 SET @ARRAY@(2,"HEADER",1,6)=$GET(XMZ)
+35 SET @ARRAY@(2,"HEADER",1,7)=$PIECE($GET(@ARRAY@(1,"HEADER",1)),"^",2)
+36 SET @ARRAY@(2,"HEADER",1,8)=""
+37 SET @ARRAY@(2,"HEADER",1,9)="$$HEADER"
End DoDot:1
+38 ;NOT AN ACK
+39 IF ('ACK)
Begin DoDot:1
+40 ;DETERMINE STATUS & TYPE
+41 SET TMP=$GET(@ARRAY@(1,"HEADER",1))
+42 SET X=$PIECE(TMP,"^",12)
+43 if (X=10)
SET STATUS="VAQ-RQST"
SET TYPE="REQ"
+44 if (X=11)
SET STATUS="VAQ-AMBIG"
SET TYPE="RES"
+45 if (X=12)
SET STATUS="VAQ-NTFND"
SET TYPE="RES"
+46 if ((X=13)!(X=14)!(X=18))
SET STATUS="VAQ-REJ"
SET TYPE="RES"
+47 if (X=15)
SET STATUS="VAQ-RSLT"
SET TYPE="RES"
+48 if (X=16)
SET STATUS="VAQ-UNSOL"
SET TYPE="UNS"
+49 SET @ARRAY@(2,"HEADER",1,1)="$HEADER"
+50 SET @ARRAY@(2,"HEADER",1,2)=TYPE
+51 SET @ARRAY@(2,"HEADER",1,3)=STATUS
+52 SET @ARRAY@(2,"HEADER",1,4)=1.0
+53 SET X=+$PIECE(TMP,"^",9)
+54 SET Y=$PIECE(X,".",2)
+55 SET Y=Y_"000000"
+56 SET $PIECE(X,".",2)=Y
+57 SET Y=$$DOBFMT^VAQUTL99(X)
+58 IF (Y'="")
Begin DoDot:2
+59 SET X=$PIECE(X,".",2)
+60 SET Y=Y_"@"_$EXTRACT(X,1,2)_":"_$EXTRACT(X,3,4)_":"_$EXTRACT(X,5,6)
End DoDot:2
+61 SET @ARRAY@(2,"HEADER",1,5)=Y
+62 SET @ARRAY@(2,"HEADER",1,6)=$GET(XMZ)
+63 SET X=""
+64 if ((TYPE="RES")!(TYPE="REQ"))
SET X=+TMP
+65 SET @ARRAY@(2,"HEADER",1,7)=X
+66 SET @ARRAY@(2,"HEADER",1,8)=""
+67 SET @ARRAY@(2,"HEADER",1,9)="$$HEADER"
End DoDot:1
+68 ;MAKE DOMAIN BLOCK
+69 SET @ARRAY@(2,"DOMAIN",1,1)="$DOMAIN"
+70 SET X=$PIECE($GET(@ARRAY@(1,"HEADER",2)),"^",1)
+71 if (X="")
SET X=$PIECE($GET(XMFROM),"@",2)
+72 SET @ARRAY@(2,"DOMAIN",1,2)=X
+73 SET @ARRAY@(2,"DOMAIN",1,3)=""
+74 SET @ARRAY@(2,"DOMAIN",1,4)="$$DOMAIN"
+75 ;DONE IF ACK
+76 if (ACK)
QUIT
+77 ;GO TO CONTINUATION ROUTINE
+78 DO PARCON^VAQPAR10
+79 QUIT
