- 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 23, 2025@18:40:10 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
