VAQCON95 ;ALB/JRP - MESSAGE CONSTRUCTION;20-APR-93
;;1.5;PATIENT DATA EXCHANGE;;NOV 17, 1993
PHA10 ;BUILD PHARMACY DATA BLOCK FOR 1.0 MESSAGE
; DECLARATIONS DONE IN $$DATA10^VAQCON97
S SEGABB="PDX*MPL"
;LONG FORMAT NOT PRESENT - SWITCH TO SHORT FORMAT (SAME INFO)
S:('$D(@ROOT@(SEGABB))) SEGABB="PDX*MPS"
;PHARMACY DATA NOT PRESENT - PLACE NULLS INTO MESSAGE
I ('$D(@ROOT@(SEGABB))) D NULLS Q
;PLACE NARRATIVE INTO MESSAGE
S FILE=55
S FIELD=1
S VALUE=$G(@ROOT@(SEGABB,"VALUE",FILE,FIELD,0))
S INFO="PHA"_"^"_FILE_"^"_FIELD_"^"_VALUE
S:('MESSNUM) @ARRAY@(LINE)=INFO
S:(MESSNUM) X=$$ADDLINE^VAQCON1(INFO,MESSNUM,LINE)
S LINE=LINE+1
;PLACE ALERGIES & REACTIONS INTO MESSAGE (STORE IN 2.55;.01)
S FILE=120.8
S FIELD=.02
S INFO="PHA"_"^"_(2.55)_"^"_(.01)
S SEQ=""
F S SEQ=$O(@ROOT@(SEGABB,"VALUE",FILE,FIELD,SEQ)) Q:(SEQ="") D
.S VALUE=$G(@ROOT@(SEGABB,"VALUE",FILE,FIELD,SEQ))
.I (($L(INFO)+$L(VALUE)+$L(FIELD)+1)>239) D
..S:('MESSNUM) @ARRAY@(LINE)=INFO
..S:(MESSNUM) X=$$ADDLINE^VAQCON1(INFO,MESSNUM,LINE)
..S LINE=LINE+1
..S INFO="PHA"_"^"_(2.55)_"^"_(.01)
.S INFO=INFO_"^"_VALUE
S:('MESSNUM) @ARRAY@(LINE)=INFO
S:(MESSNUM) X=$$ADDLINE^VAQCON1(INFO,MESSNUM,LINE)
S LINE=LINE+1
;STORE NULL VALUES FOR 2.57;.01
S INFO="PHA"_"^"_(2.57)_"^"_(.01)
S:('MESSNUM) @ARRAY@(LINE)=INFO
S:(MESSNUM) X=$$ADDLINE^VAQCON1(INFO,MESSNUM,LINE)
S LINE=LINE+1
;PLACE DISABILITIES INTO MESSAGE
;ASSUMES THAT ALL SEQUENCES IN THE SUBFILE ARE THE SAME
S FILE=2.04
S SEQFIELD=.01
S SEQ=""
S INFO="PHA"_"^"_FILE_"^"_".01;2;3"
F S SEQ=$O(@ROOT@(SEGABB,"VALUE",FILE,SEQFIELD,SEQ)) Q:(SEQ="") D
.S INFO="PHA"_"^"_FILE_"^"_".01;2;3"
.F FIELD=.01,2,3 D
..S VALUE=$G(@ROOT@(SEGABB,"VALUE",FILE,FIELD,SEQ))
..S INFO=INFO_"^"_VALUE
.S:('MESSNUM) @ARRAY@(LINE)=INFO
.S:(MESSNUM) X=$$ADDLINE^VAQCON1(INFO,MESSNUM,LINE)
.S LINE=LINE+1
;STORE NULL DISABILITIES (IF NEEDED)
I ($L(INFO,"^")<4) D
.S:('MESSNUM) @ARRAY@(LINE)=INFO
.S:(MESSNUM) X=$$ADDLINE^VAQCON1(INFO,MESSNUM,LINE)
.S LINE=LINE+1
;NO PRESCRIPTION INFORMATION - STORE NULLS
I ('$D(@ROOT@(SEGABB,"VALUE",52,.01))) D NULLRX Q
;STORE PRESCRIPTION INFORMATION
;ASSUMES ALL PRESCRIPTION INFO HAVE SAME SEQUENCE
S FILE=52
S SEQFIELD=.01
S SEQ=""
F S SEQ=$O(@ROOT@(SEGABB,"VALUE",FILE,SEQFIELD,SEQ)) Q:(SEQ="") D
.;GET RX#
.S FIELD=.01
.S VALUE=$G(@ROOT@(SEGABB,"VALUE",FILE,FIELD,SEQ))
.Q:(VALUE="")
.S INFO="PHA"_"^"_FILE_"^"_FIELD_"^"_VALUE
.;GET REST OF PRESCRIPTION INFO
.F S FIELD=$O(@ROOT@(SEGABB,"VALUE",FILE,FIELD)) Q:(FIELD="") D
..S VALUE=$G(@ROOT@(SEGABB,"VALUE",FILE,FIELD,SEQ))
..;CONVERT DATES TO FILEMAN FORMAT
..I (VALUE'="") S:($P($G(^DD(FILE,FIELD,0)),"^",2)["D") VALUE=$$DATE^VAQUTL99(VALUE)
..I (($L(INFO)+$L(VALUE)+$L(FIELD)+2)>239) D
...S:('MESSNUM) @ARRAY@(LINE)=INFO
...S:(MESSNUM) X=$$ADDLINE^VAQCON1(INFO,MESSNUM,LINE)
...S LINE=LINE+1
...S X=INFO
...S INFO="PHA"_"^"_(52)_"^"_(.01)_"^"_($P(X,"^",4))
..S X=$P(INFO,"^",3)
..S $P(INFO,"^",3)=$S((X=""):FIELD,1:(X_";"_FIELD))
..S INFO=INFO_"^"_VALUE
.I ($P(INFO,"^",3)[";") D
..S:('MESSNUM) @ARRAY@(LINE)=INFO
..S:(MESSNUM) X=$$ADDLINE^VAQCON1(INFO,MESSNUM,LINE)
..S LINE=LINE+1
;STORE REFILL INFORMATION
S FILE=52.1
S FIELD=.01
S SEQ=""
F S SEQ=$O(@ROOT@(SEGABB,"VALUE",FILE,FIELD,SEQ)) Q:(SEQ="") D
.;GET RX
.S TMP=$G(@ROOT@(SEGABB,"ID",FILE,FIELD,SEQ))
.Q:(TMP="")
.;SPECIAL CASE DATA LINE
.S INFO="PHA"_"^"_FILE_"^"_FIELD_"~"_TMP
.S VALUE=$G(@ROOT@(SEGABB,"VALUE",FILE,FIELD,SEQ))
.;CONVERT DATE TO FILEMAN FORMAT
.S:(VALUE'="") VALUE=$$DATE^VAQUTL99(VALUE)
.S INFO=INFO_"^"_VALUE
.S:('MESSNUM) @ARRAY@(LINE)=INFO
.S:(MESSNUM) X=$$ADDLINE^VAQCON1(INFO,MESSNUM,LINE)
.S LINE=LINE+1
Q
NULLS ;NO PRESCRIPTION INFO (STORE NULLS)
;PATIENT INFO
F SEQ=1:1 D Q:('SEQ)
.S TMP=$P($T(RXPAT+SEQ^VAQDBII1),";;",2)
.I (TMP="") S SEQ=0 Q
.S TMP=$TR(TMP,";","^")
.S TMP=$TR(TMP,",",";")
.S INFO="PHA"_"^"_TMP
.S:('MESSNUM) @ARRAY@(LINE)=INFO
.S:(MESSNUM) X=$$ADDLINE^VAQCON1(INFO,MESSNUM,LINE)
.S LINE=LINE+1
NULLRX ;PRESCRIPTION INFO
F SEQ=1:1 D Q:('SEQ)
.S TMP=$P($T(PROFILE+SEQ^VAQDBII1),";;",2)
.I (TMP="") S SEQ=0 Q
.S TMP=$TR(TMP,";","^")
.S TMP=$TR(TMP,",",";")
.;.01 MUST BE FIRST FIELD FOR FILE 52
.I ($P(TMP,"^",1)=52) D
..S X=$P(TMP,"^",2)
..S:($P(X,";",1)'=".01") X=".01;"_X
..S $P(TMP,"^",2)=X
.S INFO="PHA"_"^"_TMP
.S:('MESSNUM) @ARRAY@(LINE)=INFO
.S:(MESSNUM) X=$$ADDLINE^VAQCON1(INFO,MESSNUM,LINE)
.S LINE=LINE+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAQCON95 4587 printed Sep 23, 2025@20:00:32 Page 2
VAQCON95 ;ALB/JRP - MESSAGE CONSTRUCTION;20-APR-93
+1 ;;1.5;PATIENT DATA EXCHANGE;;NOV 17, 1993
PHA10 ;BUILD PHARMACY DATA BLOCK FOR 1.0 MESSAGE
+1 ; DECLARATIONS DONE IN $$DATA10^VAQCON97
+2 SET SEGABB="PDX*MPL"
+3 ;LONG FORMAT NOT PRESENT - SWITCH TO SHORT FORMAT (SAME INFO)
+4 if ('$DATA(@ROOT@(SEGABB)))
SET SEGABB="PDX*MPS"
+5 ;PHARMACY DATA NOT PRESENT - PLACE NULLS INTO MESSAGE
+6 IF ('$DATA(@ROOT@(SEGABB)))
DO NULLS
QUIT
+7 ;PLACE NARRATIVE INTO MESSAGE
+8 SET FILE=55
+9 SET FIELD=1
+10 SET VALUE=$GET(@ROOT@(SEGABB,"VALUE",FILE,FIELD,0))
+11 SET INFO="PHA"_"^"_FILE_"^"_FIELD_"^"_VALUE
+12 if ('MESSNUM)
SET @ARRAY@(LINE)=INFO
+13 if (MESSNUM)
SET X=$$ADDLINE^VAQCON1(INFO,MESSNUM,LINE)
+14 SET LINE=LINE+1
+15 ;PLACE ALERGIES & REACTIONS INTO MESSAGE (STORE IN 2.55;.01)
+16 SET FILE=120.8
+17 SET FIELD=.02
+18 SET INFO="PHA"_"^"_(2.55)_"^"_(.01)
+19 SET SEQ=""
+20 FOR
SET SEQ=$ORDER(@ROOT@(SEGABB,"VALUE",FILE,FIELD,SEQ))
if (SEQ="")
QUIT
Begin DoDot:1
+21 SET VALUE=$GET(@ROOT@(SEGABB,"VALUE",FILE,FIELD,SEQ))
+22 IF (($LENGTH(INFO)+$LENGTH(VALUE)+$LENGTH(FIELD)+1)>239)
Begin DoDot:2
+23 if ('MESSNUM)
SET @ARRAY@(LINE)=INFO
+24 if (MESSNUM)
SET X=$$ADDLINE^VAQCON1(INFO,MESSNUM,LINE)
+25 SET LINE=LINE+1
+26 SET INFO="PHA"_"^"_(2.55)_"^"_(.01)
End DoDot:2
+27 SET INFO=INFO_"^"_VALUE
End DoDot:1
+28 if ('MESSNUM)
SET @ARRAY@(LINE)=INFO
+29 if (MESSNUM)
SET X=$$ADDLINE^VAQCON1(INFO,MESSNUM,LINE)
+30 SET LINE=LINE+1
+31 ;STORE NULL VALUES FOR 2.57;.01
+32 SET INFO="PHA"_"^"_(2.57)_"^"_(.01)
+33 if ('MESSNUM)
SET @ARRAY@(LINE)=INFO
+34 if (MESSNUM)
SET X=$$ADDLINE^VAQCON1(INFO,MESSNUM,LINE)
+35 SET LINE=LINE+1
+36 ;PLACE DISABILITIES INTO MESSAGE
+37 ;ASSUMES THAT ALL SEQUENCES IN THE SUBFILE ARE THE SAME
+38 SET FILE=2.04
+39 SET SEQFIELD=.01
+40 SET SEQ=""
+41 SET INFO="PHA"_"^"_FILE_"^"_".01;2;3"
+42 FOR
SET SEQ=$ORDER(@ROOT@(SEGABB,"VALUE",FILE,SEQFIELD,SEQ))
if (SEQ="")
QUIT
Begin DoDot:1
+43 SET INFO="PHA"_"^"_FILE_"^"_".01;2;3"
+44 FOR FIELD=.01,2,3
Begin DoDot:2
+45 SET VALUE=$GET(@ROOT@(SEGABB,"VALUE",FILE,FIELD,SEQ))
+46 SET INFO=INFO_"^"_VALUE
End DoDot:2
+47 if ('MESSNUM)
SET @ARRAY@(LINE)=INFO
+48 if (MESSNUM)
SET X=$$ADDLINE^VAQCON1(INFO,MESSNUM,LINE)
+49 SET LINE=LINE+1
End DoDot:1
+50 ;STORE NULL DISABILITIES (IF NEEDED)
+51 IF ($LENGTH(INFO,"^")<4)
Begin DoDot:1
+52 if ('MESSNUM)
SET @ARRAY@(LINE)=INFO
+53 if (MESSNUM)
SET X=$$ADDLINE^VAQCON1(INFO,MESSNUM,LINE)
+54 SET LINE=LINE+1
End DoDot:1
+55 ;NO PRESCRIPTION INFORMATION - STORE NULLS
+56 IF ('$DATA(@ROOT@(SEGABB,"VALUE",52,.01)))
DO NULLRX
QUIT
+57 ;STORE PRESCRIPTION INFORMATION
+58 ;ASSUMES ALL PRESCRIPTION INFO HAVE SAME SEQUENCE
+59 SET FILE=52
+60 SET SEQFIELD=.01
+61 SET SEQ=""
+62 FOR
SET SEQ=$ORDER(@ROOT@(SEGABB,"VALUE",FILE,SEQFIELD,SEQ))
if (SEQ="")
QUIT
Begin DoDot:1
+63 ;GET RX#
+64 SET FIELD=.01
+65 SET VALUE=$GET(@ROOT@(SEGABB,"VALUE",FILE,FIELD,SEQ))
+66 if (VALUE="")
QUIT
+67 SET INFO="PHA"_"^"_FILE_"^"_FIELD_"^"_VALUE
+68 ;GET REST OF PRESCRIPTION INFO
+69 FOR
SET FIELD=$ORDER(@ROOT@(SEGABB,"VALUE",FILE,FIELD))
if (FIELD="")
QUIT
Begin DoDot:2
+70 SET VALUE=$GET(@ROOT@(SEGABB,"VALUE",FILE,FIELD,SEQ))
+71 ;CONVERT DATES TO FILEMAN FORMAT
+72 IF (VALUE'="")
if ($PIECE($GET(^DD(FILE,FIELD,0)),"^",2)["D")
SET VALUE=$$DATE^VAQUTL99(VALUE)
+73 IF (($LENGTH(INFO)+$LENGTH(VALUE)+$LENGTH(FIELD)+2)>239)
Begin DoDot:3
+74 if ('MESSNUM)
SET @ARRAY@(LINE)=INFO
+75 if (MESSNUM)
SET X=$$ADDLINE^VAQCON1(INFO,MESSNUM,LINE)
+76 SET LINE=LINE+1
+77 SET X=INFO
+78 SET INFO="PHA"_"^"_(52)_"^"_(.01)_"^"_($PIECE(X,"^",4))
End DoDot:3
+79 SET X=$PIECE(INFO,"^",3)
+80 SET $PIECE(INFO,"^",3)=$SELECT((X=""):FIELD,1:(X_";"_FIELD))
+81 SET INFO=INFO_"^"_VALUE
End DoDot:2
+82 IF ($PIECE(INFO,"^",3)[";")
Begin DoDot:2
+83 if ('MESSNUM)
SET @ARRAY@(LINE)=INFO
+84 if (MESSNUM)
SET X=$$ADDLINE^VAQCON1(INFO,MESSNUM,LINE)
+85 SET LINE=LINE+1
End DoDot:2
End DoDot:1
+86 ;STORE REFILL INFORMATION
+87 SET FILE=52.1
+88 SET FIELD=.01
+89 SET SEQ=""
+90 FOR
SET SEQ=$ORDER(@ROOT@(SEGABB,"VALUE",FILE,FIELD,SEQ))
if (SEQ="")
QUIT
Begin DoDot:1
+91 ;GET RX
+92 SET TMP=$GET(@ROOT@(SEGABB,"ID",FILE,FIELD,SEQ))
+93 if (TMP="")
QUIT
+94 ;SPECIAL CASE DATA LINE
+95 SET INFO="PHA"_"^"_FILE_"^"_FIELD_"~"_TMP
+96 SET VALUE=$GET(@ROOT@(SEGABB,"VALUE",FILE,FIELD,SEQ))
+97 ;CONVERT DATE TO FILEMAN FORMAT
+98 if (VALUE'="")
SET VALUE=$$DATE^VAQUTL99(VALUE)
+99 SET INFO=INFO_"^"_VALUE
+100 if ('MESSNUM)
SET @ARRAY@(LINE)=INFO
+101 if (MESSNUM)
SET X=$$ADDLINE^VAQCON1(INFO,MESSNUM,LINE)
+102 SET LINE=LINE+1
End DoDot:1
+103 QUIT
NULLS ;NO PRESCRIPTION INFO (STORE NULLS)
+1 ;PATIENT INFO
+2 FOR SEQ=1:1
Begin DoDot:1
+3 SET TMP=$PIECE($TEXT(RXPAT+SEQ^VAQDBII1),";;",2)
+4 IF (TMP="")
SET SEQ=0
QUIT
+5 SET TMP=$TRANSLATE(TMP,";","^")
+6 SET TMP=$TRANSLATE(TMP,",",";")
+7 SET INFO="PHA"_"^"_TMP
+8 if ('MESSNUM)
SET @ARRAY@(LINE)=INFO
+9 if (MESSNUM)
SET X=$$ADDLINE^VAQCON1(INFO,MESSNUM,LINE)
+10 SET LINE=LINE+1
End DoDot:1
if ('SEQ)
QUIT
NULLRX ;PRESCRIPTION INFO
+1 FOR SEQ=1:1
Begin DoDot:1
+2 SET TMP=$PIECE($TEXT(PROFILE+SEQ^VAQDBII1),";;",2)
+3 IF (TMP="")
SET SEQ=0
QUIT
+4 SET TMP=$TRANSLATE(TMP,";","^")
+5 SET TMP=$TRANSLATE(TMP,",",";")
+6 ;.01 MUST BE FIRST FIELD FOR FILE 52
+7 IF ($PIECE(TMP,"^",1)=52)
Begin DoDot:2
+8 SET X=$PIECE(TMP,"^",2)
+9 if ($PIECE(X,";",1)'=".01")
SET X=".01;"_X
+10 SET $PIECE(TMP,"^",2)=X
End DoDot:2
+11 SET INFO="PHA"_"^"_TMP
+12 if ('MESSNUM)
SET @ARRAY@(LINE)=INFO
+13 if (MESSNUM)
SET X=$$ADDLINE^VAQCON1(INFO,MESSNUM,LINE)
+14 SET LINE=LINE+1
End DoDot:1
if ('SEQ)
QUIT
+15 QUIT
