VAQPAR11 ;ALB/JRP - MESSAGE PARSING;10-MAY-93
;;1.5;PATIENT DATA EXCHANGE;;NOV 17, 1993
DATA10(ARRAY,BLOCK,BLOCKNUM) ;PARSE DATA BLOCKS FOR 1.0 MESSAGE
;INPUT : ARRAY - Array containing pre-parsed version 1.0 transmission
; (full global reference)
; BLOCK - Version 1.0 block name (MIN,MAS,PHA)
; BLOCKNUM - Block sequence number (defaults to 1)
; (As defined by MailMan)
; XMFROM, XMREC, XMZ
; (Declared in SERVER^VAQADM2)
; XMER, XMRG, XMPOS
;OUTPUT : XMER - Exit condition
; 0 = Success
; -1^Error_Text = Error
; Parsed array will be same as parsed array for version
; 1.5 message and have the format:
; ARRAY(2,"DATA",BLOCKNUM,Line)
;
;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
I ($G(BLOCK)="") S XMER="-1^Did not pass data block name" Q
I ((BLOCK'="MIN")&(BLOCK'="MAS")&(BLOCK'="PHA")) S XMER="-1^Did not pass valid version 1.0 data block name" Q
S:($G(BLOCKNUM)="") BLOCKNUM=1
;DECLARE VARIABLES
N LINE,X,Y,TMP,OFFSET,FILE,FIELD,FIELDS,VALUES,SEQ,TMPARR
N FLDCNT,VALCNT,LOOP1,LOOP2,REPCNT,ID,PATNAME,RXNUM,VALUE
;GET PATIENT'S NAME
S PATNAME=$G(@ARRAY@(2,"PATIENT",1,3))
I (PATNAME="") S XMER="-1^Patient's name was not contained in the transmission" Q
;SET UP TEMPORARY PARSING ARRAY
S TMP=$P(ARRAY,"(",1)
S X=$P(ARRAY,"(",2)
S Y=$P(X,")",1)
S:(Y="") TMPARR=TMP_"("_3_")"
S:(Y'="") TMPARR=TMP_"("_Y_","_3_")"
K @TMPARR
S XMER=0
;LINE 1
S @ARRAY@(2,"DATA",BLOCKNUM,1)="$DATA"
S X="PDX*"_BLOCK
S:(BLOCK="PHA") X="PDX*MPL"
S @ARRAY@(2,"DATA",BLOCKNUM,2)=X
;PRE-PARSE DATA BLOCK
S OFFSET=""
F S OFFSET=$O(@ARRAY@(1,BLOCK,OFFSET)) Q:(OFFSET="") D
.S TMP=$G(@ARRAY@(1,BLOCK,OFFSET))
.Q:(TMP="")
.S FILE=$P(TMP,"^",1)
.S FIELDS=$P(TMP,"^",2)
.S VALUES=$P(TMP,"^",3,($L(TMP,"^")))
.S RXNUM=""
.I (FILE=52.1) D
..S RXNUM=$P(FIELDS,"~",2)
..S FIELDS=$P(FIELDS,"~",1)
.I ((FILE=52)&($P(FIELDS,";",1)=.01)) D
..S RXNUM=$P(VALUES,"^",1)
.S FLDCNT=$L(FIELDS,";")
.S VALCNT=$L(VALUES,"^")
.S REPCNT=(VALCNT\FLDCNT)-1
.S:(REPCNT<0) REPCNT=0
.F LOOP1=0:1:REPCNT D
..F LOOP2=1:1:FLDCNT D
...S FIELD=$P(FIELDS,";",LOOP2)
...S VALUE=$P(VALUES,"^",((LOOP1*FLDCNT)+LOOP2))
...;CONVERT DATES
...S:($P($G(^DD(FILE,FIELD,0)),"^",2)["D") VALUE=$$DOBFMT^VAQUTL99(VALUE,1)
...;CONVERT STATES
...I ((+$P($P($G(^DD(FILE,FIELD,0)),"^",2),"P",2))=5) D
....Q:(VALUE="")
....S X=$O(^DIC(5,"C",VALUE,""))
....I (X="") S VALUE="" Q
....S VALUE=$P($G(^DIC(5,X,0)),"^",1)
...S SEQ=""
...F Q:($O(@TMPARR@("VALUE",FILE,FIELD,SEQ))="") S SEQ=$O(@TMPARR@("VALUE",FILE,FIELD,SEQ)) Q:((FILE=52)&(FIELD=.01)&($G(@TMPARR@("VALUE",FILE,FIELD,SEQ))=VALUE))
...S SEQ=$S((SEQ=""):0,((FILE=52)&(FIELD=.01)&($G(@TMPARR@("VALUE",FILE,FIELD,SEQ))=VALUE)):SEQ,1:SEQ+1)
...S @TMPARR@("VALUE",FILE,FIELD,SEQ)=VALUE
...I (BLOCK="MIN") S ID=PATNAME
...I (BLOCK="PHA") D
....I (FILE=52) S ID=$S((FIELD=.01):PATNAME,1:RXNUM) Q
....I (FILE=52.1) S ID=RXNUM Q
....I ((FILE=2)!(FILE=55)) S ID=PATNAME Q
....I (FIELD=.01) S ID=PATNAME Q
....S ID=$G(@TMPARR@("VALUE",FILE,.01,SEQ))
...I (BLOCK="MAS") D
....I (FILE=2) S ID=PATNAME Q
....I (FILE=2.98) S ID=$S((FIELD=.001):PATNAME,1:$G(@TMPARR@("VALUE",2.98,.001,SEQ))) Q
....I (FIELD=.01) S ID=PATNAME Q
....I (FILE=36) S ID=$G(@TMPARR@("VALUE",2.312,.01,SEQ)) Q
....S ID=$G(@TMPARR@("VALUE",FILE,.01,SEQ))
...S @TMPARR@("ID",FILE,FIELD,SEQ)=ID
;STORE INTO PARSE ARRAY
S LINE=3
S FILE=""
F S FILE=$O(@TMPARR@("VALUE",FILE)) Q:(FILE="") D
.S FIELD=""
.F S FIELD=$O(@TMPARR@("VALUE",FILE,FIELD)) Q:(FIELD="") D
..S VALUES=0
..F Q:($O(@TMPARR@("VALUE",FILE,FIELD,VALUES))="") S VALUES=$O(@TMPARR@("VALUE",FILE,FIELD,VALUES))
..S VALUES=VALUES+1
..S @ARRAY@(2,"DATA",BLOCKNUM,LINE)=0_"^"_FILE_"^"_FIELD_"^"_VALUES
..S LINE=LINE+1
..S SEQ=""
..F S SEQ=$O(@TMPARR@("VALUE",FILE,FIELD,SEQ)) Q:(SEQ="") D
...S VALUE=$G(@TMPARR@("VALUE",FILE,FIELD,SEQ))
...S @ARRAY@(2,"DATA",BLOCKNUM,LINE)=VALUE
...S LINE=LINE+1
...S ID=$G(@TMPARR@("ID",FILE,FIELD,SEQ))
...S @ARRAY@(2,"DATA",BLOCKNUM,LINE)=ID
...S LINE=LINE+1
;DONE
S @ARRAY@(2,"DATA",BLOCKNUM,LINE)="$$DATA"
K @TMPARR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAQPAR11 4435 printed Apr 09, 2024@21:28:20 Page 2
VAQPAR11 ;ALB/JRP - MESSAGE PARSING;10-MAY-93
+1 ;;1.5;PATIENT DATA EXCHANGE;;NOV 17, 1993
DATA10(ARRAY,BLOCK,BLOCKNUM) ;PARSE DATA BLOCKS FOR 1.0 MESSAGE
+1 ;INPUT : ARRAY - Array containing pre-parsed version 1.0 transmission
+2 ; (full global reference)
+3 ; BLOCK - Version 1.0 block name (MIN,MAS,PHA)
+4 ; BLOCKNUM - Block sequence number (defaults to 1)
+5 ; (As defined by MailMan)
+6 ; XMFROM, XMREC, XMZ
+7 ; (Declared in SERVER^VAQADM2)
+8 ; XMER, XMRG, XMPOS
+9 ;OUTPUT : XMER - Exit condition
+10 ; 0 = Success
+11 ; -1^Error_Text = Error
+12 ; Parsed array will be same as parsed array for version
+13 ; 1.5 message and have the format:
+14 ; ARRAY(2,"DATA",BLOCKNUM,Line)
+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 IF ($GET(BLOCK)="")
SET XMER="-1^Did not pass data block name"
QUIT
+20 IF ((BLOCK'="MIN")&(BLOCK'="MAS")&(BLOCK'="PHA"))
SET XMER="-1^Did not pass valid version 1.0 data block name"
QUIT
+21 if ($GET(BLOCKNUM)="")
SET BLOCKNUM=1
+22 ;DECLARE VARIABLES
+23 NEW LINE,X,Y,TMP,OFFSET,FILE,FIELD,FIELDS,VALUES,SEQ,TMPARR
+24 NEW FLDCNT,VALCNT,LOOP1,LOOP2,REPCNT,ID,PATNAME,RXNUM,VALUE
+25 ;GET PATIENT'S NAME
+26 SET PATNAME=$GET(@ARRAY@(2,"PATIENT",1,3))
+27 IF (PATNAME="")
SET XMER="-1^Patient's name was not contained in the transmission"
QUIT
+28 ;SET UP TEMPORARY PARSING ARRAY
+29 SET TMP=$PIECE(ARRAY,"(",1)
+30 SET X=$PIECE(ARRAY,"(",2)
+31 SET Y=$PIECE(X,")",1)
+32 if (Y="")
SET TMPARR=TMP_"("_3_")"
+33 if (Y'="")
SET TMPARR=TMP_"("_Y_","_3_")"
+34 KILL @TMPARR
+35 SET XMER=0
+36 ;LINE 1
+37 SET @ARRAY@(2,"DATA",BLOCKNUM,1)="$DATA"
+38 SET X="PDX*"_BLOCK
+39 if (BLOCK="PHA")
SET X="PDX*MPL"
+40 SET @ARRAY@(2,"DATA",BLOCKNUM,2)=X
+41 ;PRE-PARSE DATA BLOCK
+42 SET OFFSET=""
+43 FOR
SET OFFSET=$ORDER(@ARRAY@(1,BLOCK,OFFSET))
if (OFFSET="")
QUIT
Begin DoDot:1
+44 SET TMP=$GET(@ARRAY@(1,BLOCK,OFFSET))
+45 if (TMP="")
QUIT
+46 SET FILE=$PIECE(TMP,"^",1)
+47 SET FIELDS=$PIECE(TMP,"^",2)
+48 SET VALUES=$PIECE(TMP,"^",3,($LENGTH(TMP,"^")))
+49 SET RXNUM=""
+50 IF (FILE=52.1)
Begin DoDot:2
+51 SET RXNUM=$PIECE(FIELDS,"~",2)
+52 SET FIELDS=$PIECE(FIELDS,"~",1)
End DoDot:2
+53 IF ((FILE=52)&($PIECE(FIELDS,";",1)=.01))
Begin DoDot:2
+54 SET RXNUM=$PIECE(VALUES,"^",1)
End DoDot:2
+55 SET FLDCNT=$LENGTH(FIELDS,";")
+56 SET VALCNT=$LENGTH(VALUES,"^")
+57 SET REPCNT=(VALCNT\FLDCNT)-1
+58 if (REPCNT<0)
SET REPCNT=0
+59 FOR LOOP1=0:1:REPCNT
Begin DoDot:2
+60 FOR LOOP2=1:1:FLDCNT
Begin DoDot:3
+61 SET FIELD=$PIECE(FIELDS,";",LOOP2)
+62 SET VALUE=$PIECE(VALUES,"^",((LOOP1*FLDCNT)+LOOP2))
+63 ;CONVERT DATES
+64 if ($PIECE($GET(^DD(FILE,FIELD,0)),"^",2)["D")
SET VALUE=$$DOBFMT^VAQUTL99(VALUE,1)
+65 ;CONVERT STATES
+66 IF ((+$PIECE($PIECE($GET(^DD(FILE,FIELD,0)),"^",2),"P",2))=5)
Begin DoDot:4
+67 if (VALUE="")
QUIT
+68 SET X=$ORDER(^DIC(5,"C",VALUE,""))
+69 IF (X="")
SET VALUE=""
QUIT
+70 SET VALUE=$PIECE($GET(^DIC(5,X,0)),"^",1)
End DoDot:4
+71 SET SEQ=""
+72 FOR
if ($ORDER(@TMPARR@("VALUE",FILE,FIELD,SEQ))="")
QUIT
SET SEQ=$ORDER(@TMPARR@("VALUE",FILE,FIELD,SEQ))
if ((FILE=52)&(FIELD=.01)&($GET(@TMPARR@("VALUE",FILE,FIELD,SEQ))=VALUE))
QUIT
+73 SET SEQ=$SELECT((SEQ=""):0,((FILE=52)&(FIELD=.01)&($GET(@TMPARR@("VALUE",FILE,FIELD,SEQ))=VALUE)):SEQ,1:SEQ+1)
+74 SET @TMPARR@("VALUE",FILE,FIELD,SEQ)=VALUE
+75 IF (BLOCK="MIN")
SET ID=PATNAME
+76 IF (BLOCK="PHA")
Begin DoDot:4
+77 IF (FILE=52)
SET ID=$SELECT((FIELD=.01):PATNAME,1:RXNUM)
QUIT
+78 IF (FILE=52.1)
SET ID=RXNUM
QUIT
+79 IF ((FILE=2)!(FILE=55))
SET ID=PATNAME
QUIT
+80 IF (FIELD=.01)
SET ID=PATNAME
QUIT
+81 SET ID=$GET(@TMPARR@("VALUE",FILE,.01,SEQ))
End DoDot:4
+82 IF (BLOCK="MAS")
Begin DoDot:4
+83 IF (FILE=2)
SET ID=PATNAME
QUIT
+84 IF (FILE=2.98)
SET ID=$SELECT((FIELD=.001):PATNAME,1:$GET(@TMPARR@("VALUE",2.98,.001,SEQ)))
QUIT
+85 IF (FIELD=.01)
SET ID=PATNAME
QUIT
+86 IF (FILE=36)
SET ID=$GET(@TMPARR@("VALUE",2.312,.01,SEQ))
QUIT
+87 SET ID=$GET(@TMPARR@("VALUE",FILE,.01,SEQ))
End DoDot:4
+88 SET @TMPARR@("ID",FILE,FIELD,SEQ)=ID
End DoDot:3
End DoDot:2
End DoDot:1
+89 ;STORE INTO PARSE ARRAY
+90 SET LINE=3
+91 SET FILE=""
+92 FOR
SET FILE=$ORDER(@TMPARR@("VALUE",FILE))
if (FILE="")
QUIT
Begin DoDot:1
+93 SET FIELD=""
+94 FOR
SET FIELD=$ORDER(@TMPARR@("VALUE",FILE,FIELD))
if (FIELD="")
QUIT
Begin DoDot:2
+95 SET VALUES=0
+96 FOR
if ($ORDER(@TMPARR@("VALUE",FILE,FIELD,VALUES))="")
QUIT
SET VALUES=$ORDER(@TMPARR@("VALUE",FILE,FIELD,VALUES))
+97 SET VALUES=VALUES+1
+98 SET @ARRAY@(2,"DATA",BLOCKNUM,LINE)=0_"^"_FILE_"^"_FIELD_"^"_VALUES
+99 SET LINE=LINE+1
+100 SET SEQ=""
+101 FOR
SET SEQ=$ORDER(@TMPARR@("VALUE",FILE,FIELD,SEQ))
if (SEQ="")
QUIT
Begin DoDot:3
+102 SET VALUE=$GET(@TMPARR@("VALUE",FILE,FIELD,SEQ))
+103 SET @ARRAY@(2,"DATA",BLOCKNUM,LINE)=VALUE
+104 SET LINE=LINE+1
+105 SET ID=$GET(@TMPARR@("ID",FILE,FIELD,SEQ))
+106 SET @ARRAY@(2,"DATA",BLOCKNUM,LINE)=ID
+107 SET LINE=LINE+1
End DoDot:3
End DoDot:2
End DoDot:1
+108 ;DONE
+109 SET @ARRAY@(2,"DATA",BLOCKNUM,LINE)="$$DATA"
+110 KILL @TMPARR
+111 QUIT
