VAQDBIP8 ;ALB/JRP - CONTINUATIONS FOR VAQDBIP1;31-MAR-93
;;1.5;PATIENT DATA EXCHANGE;;NOV 17, 1993
SCRIPTS ;EXTRACT PRESCRIPTION INFORMATION
; DECLARATIONS TAKEN CARE OF IN VAQDBIP1
;DETERMINE CUTOFF DATE
S X1=DT,X2=-CUTOFF
D C^%DTC
S CUTDATE=X
;GET LIST OF PRESCRIPTIONS
F CUTDATE=CUTDATE:0 D Q:('CUTDATE)
.S CUTDATE=$O(^PS(55,DFN,"P","A",CUTDATE))
.Q:('CUTDATE)
.F RXIFN=0:0 D Q:('RXIFN)
..S RXIFN=$O(^PS(55,DFN,"P","A",CUTDATE,RXIFN))
..Q:('RXIFN)
..;EXTRACT PRESCRIPTION INFORMATION
..F LOOP=1:1 D Q:(ERROR)
...S TMP=$T(PROFILE+LOOP^VAQDBII1)
...I ($P(TMP,";;",2)="") S ERROR=1 Q
...S ERROR=$$XTRCT^VAQDBIP2(TMP,DFN,RXIFN,ARRAY,ENCPTR,KEY1,KEY2)
...I ERROR D Q
....S TMP=$$KILLARR^VAQUTL1(ARRAY,"VALUE")
....S TMP=$$KILLARR^VAQUTL1(ARRAY,"ID")
Q:(ERROR<0)
;CONVERT/CALCULATE INFORMATION THAT WILL NOT BE CORRECT
S SEQ=""
F S SEQ=$O(@ARRAY@("VALUE",52,.01,SEQ)) Q:(SEQ="") D RXCNVRT
S ERROR=0
Q
;
RXCNVRT ;CONVERT/CALCULATE PRESCRIPTION INFORMATION
;GET IFN OF PRESCRIPTION
S TMP=$G(@ARRAY@("VALUE",52,.01,SEQ))
Q:(TMP="")
;DECRYPT RX#
S STRING=TMP
S DECSTR=STRING
I $$NCRPFLD^VAQUTL2(52,.01) X DECRYPT
S TMP=DECSTR
S RXIFN=$O(^PSRX("B",TMP,""))
Q:(RXIFN="")
;GET FILL DATE (USE AS LAST FILL DATE IF HASN'T BEEN REFILLED)
S STRING=$G(@ARRAY@("VALUE",52,22,SEQ))
;DECRYPT
S DECSTR=STRING
I $$NCRPFLD^VAQUTL2(52,22) X DECRYPT
;CALCULATE LAST FILL DATE
S J=0,RX3=""
F S J=$O(^PSRX(RXIFN,1,J)) Q:('J) S RX3=+^PSRX(RXIFN,1,J,0)
S Y=RX3
I (Y'="") D DD^%DT S STRING=Y
I (Y="") S STRING=DECSTR
;ENCRYPT INFORMATION
S ENCSTR=STRING
I $$NCRPFLD^VAQUTL2(52,101) X ENCRYPT
S @ARRAY@("VALUE",52,101,SEQ)=ENCSTR
;CALCULATE STATUS (RX3 ALREADY DEFINED)
S J=RXIFN
S RX0=$G(^PSRX(RXIFN,0))
S RX2=$G(^PSRX(RXIFN,2))
D STAT^PSOEXDT
;ENCRYPT INFORMATION
S STRING=$G(ST)
S ENCSTR=STRING
I (ENCSTR'="") I $$NCRPFLD^VAQUTL2(52,100) X ENCRYPT
S @ARRAY@("VALUE",52,100,SEQ)=ENCSTR
;CONVERT SIG TO NON-ABBREVIATION FORMAT
S STRING=$G(@ARRAY@("VALUE",52,10,SEQ))
;DECRYPT INFORMATION
S DECSTR=STRING
I $$NCRPFLD^VAQUTL2(52,10) X DECRYPT
S TMP=DECSTR
I (TMP'="") D
.S J=""
.F LOOP=1:1:$L(TMP," ") S X=$P(TMP," ",LOOP) D:(X'="")
..S Y=$G(^PS(51,"A",X))
..S X1=$P(Y,"^",1)
..S X2=$P(Y,"^",2)
..S:(X1="") X1=X
..I (X2'="") D
...S X=+$P(TMP," ",(LOOP-1))
...S:(X>1) X1=X2
..I (J="") S J=X1 Q
..S J=J_" "_X1
.S TMP=J
;ENCRYPT INFORMATION
S STRING=TMP
S ENCSTR=STRING
I $$NCRPFLD^VAQUTL2(52,10) X ENCRYPT
S @ARRAY@("VALUE",52,10,SEQ)=ENCSTR
;CONVERT DRUG NAME TO NATION DRUG NAME (IF AVAILABLE)
S STRING=$G(@ARRAY@("VALUE",52,6,SEQ))
;DECRYPT INFORMATION
S DECSTR=STRING
I $$NCRPFLD^VAQUTL2(52,6) X DECRYPT
S TMP=DECSTR
I (TMP'="") D
.S J=$O(^PSDRUG("B",TMP,""))
.Q:(J="")
.S TMP=+$G(^PSDRUG(J,"ND"))
.Q:('TMP)
.S J=$P($G(^PSNDF(TMP,0)),"^")
.Q:(J="")
.;ENCRYPT INFORMATION
.S STRING=J
.S ENCSTR=STRING
.I $$NCRPFLD^VAQUTL2(52,6) X ENCRYPT
.S @ARRAY@("VALUE",52,6,SEQ)=ENCSTR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAQDBIP8 3071 printed Sep 23, 2025@20:00:55 Page 2
VAQDBIP8 ;ALB/JRP - CONTINUATIONS FOR VAQDBIP1;31-MAR-93
+1 ;;1.5;PATIENT DATA EXCHANGE;;NOV 17, 1993
SCRIPTS ;EXTRACT PRESCRIPTION INFORMATION
+1 ; DECLARATIONS TAKEN CARE OF IN VAQDBIP1
+2 ;DETERMINE CUTOFF DATE
+3 SET X1=DT
SET X2=-CUTOFF
+4 DO C^%DTC
+5 SET CUTDATE=X
+6 ;GET LIST OF PRESCRIPTIONS
+7 FOR CUTDATE=CUTDATE:0
Begin DoDot:1
+8 SET CUTDATE=$ORDER(^PS(55,DFN,"P","A",CUTDATE))
+9 if ('CUTDATE)
QUIT
+10 FOR RXIFN=0:0
Begin DoDot:2
+11 SET RXIFN=$ORDER(^PS(55,DFN,"P","A",CUTDATE,RXIFN))
+12 if ('RXIFN)
QUIT
+13 ;EXTRACT PRESCRIPTION INFORMATION
+14 FOR LOOP=1:1
Begin DoDot:3
+15 SET TMP=$TEXT(PROFILE+LOOP^VAQDBII1)
+16 IF ($PIECE(TMP,";;",2)="")
SET ERROR=1
QUIT
+17 SET ERROR=$$XTRCT^VAQDBIP2(TMP,DFN,RXIFN,ARRAY,ENCPTR,KEY1,KEY2)
+18 IF ERROR
Begin DoDot:4
+19 SET TMP=$$KILLARR^VAQUTL1(ARRAY,"VALUE")
+20 SET TMP=$$KILLARR^VAQUTL1(ARRAY,"ID")
End DoDot:4
QUIT
End DoDot:3
if (ERROR)
QUIT
End DoDot:2
if ('RXIFN)
QUIT
End DoDot:1
if ('CUTDATE)
QUIT
+21 if (ERROR<0)
QUIT
+22 ;CONVERT/CALCULATE INFORMATION THAT WILL NOT BE CORRECT
+23 SET SEQ=""
+24 FOR
SET SEQ=$ORDER(@ARRAY@("VALUE",52,.01,SEQ))
if (SEQ="")
QUIT
DO RXCNVRT
+25 SET ERROR=0
+26 QUIT
+27 ;
RXCNVRT ;CONVERT/CALCULATE PRESCRIPTION INFORMATION
+1 ;GET IFN OF PRESCRIPTION
+2 SET TMP=$GET(@ARRAY@("VALUE",52,.01,SEQ))
+3 if (TMP="")
QUIT
+4 ;DECRYPT RX#
+5 SET STRING=TMP
+6 SET DECSTR=STRING
+7 IF $$NCRPFLD^VAQUTL2(52,.01)
XECUTE DECRYPT
+8 SET TMP=DECSTR
+9 SET RXIFN=$ORDER(^PSRX("B",TMP,""))
+10 if (RXIFN="")
QUIT
+11 ;GET FILL DATE (USE AS LAST FILL DATE IF HASN'T BEEN REFILLED)
+12 SET STRING=$GET(@ARRAY@("VALUE",52,22,SEQ))
+13 ;DECRYPT
+14 SET DECSTR=STRING
+15 IF $$NCRPFLD^VAQUTL2(52,22)
XECUTE DECRYPT
+16 ;CALCULATE LAST FILL DATE
+17 SET J=0
SET RX3=""
+18 FOR
SET J=$ORDER(^PSRX(RXIFN,1,J))
if ('J)
QUIT
SET RX3=+^PSRX(RXIFN,1,J,0)
+19 SET Y=RX3
+20 IF (Y'="")
DO DD^%DT
SET STRING=Y
+21 IF (Y="")
SET STRING=DECSTR
+22 ;ENCRYPT INFORMATION
+23 SET ENCSTR=STRING
+24 IF $$NCRPFLD^VAQUTL2(52,101)
XECUTE ENCRYPT
+25 SET @ARRAY@("VALUE",52,101,SEQ)=ENCSTR
+26 ;CALCULATE STATUS (RX3 ALREADY DEFINED)
+27 SET J=RXIFN
+28 SET RX0=$GET(^PSRX(RXIFN,0))
+29 SET RX2=$GET(^PSRX(RXIFN,2))
+30 DO STAT^PSOEXDT
+31 ;ENCRYPT INFORMATION
+32 SET STRING=$GET(ST)
+33 SET ENCSTR=STRING
+34 IF (ENCSTR'="")
IF $$NCRPFLD^VAQUTL2(52,100)
XECUTE ENCRYPT
+35 SET @ARRAY@("VALUE",52,100,SEQ)=ENCSTR
+36 ;CONVERT SIG TO NON-ABBREVIATION FORMAT
+37 SET STRING=$GET(@ARRAY@("VALUE",52,10,SEQ))
+38 ;DECRYPT INFORMATION
+39 SET DECSTR=STRING
+40 IF $$NCRPFLD^VAQUTL2(52,10)
XECUTE DECRYPT
+41 SET TMP=DECSTR
+42 IF (TMP'="")
Begin DoDot:1
+43 SET J=""
+44 FOR LOOP=1:1:$LENGTH(TMP," ")
SET X=$PIECE(TMP," ",LOOP)
if (X'="")
Begin DoDot:2
+45 SET Y=$GET(^PS(51,"A",X))
+46 SET X1=$PIECE(Y,"^",1)
+47 SET X2=$PIECE(Y,"^",2)
+48 if (X1="")
SET X1=X
+49 IF (X2'="")
Begin DoDot:3
+50 SET X=+$PIECE(TMP," ",(LOOP-1))
+51 if (X>1)
SET X1=X2
End DoDot:3
+52 IF (J="")
SET J=X1
QUIT
+53 SET J=J_" "_X1
End DoDot:2
+54 SET TMP=J
End DoDot:1
+55 ;ENCRYPT INFORMATION
+56 SET STRING=TMP
+57 SET ENCSTR=STRING
+58 IF $$NCRPFLD^VAQUTL2(52,10)
XECUTE ENCRYPT
+59 SET @ARRAY@("VALUE",52,10,SEQ)=ENCSTR
+60 ;CONVERT DRUG NAME TO NATION DRUG NAME (IF AVAILABLE)
+61 SET STRING=$GET(@ARRAY@("VALUE",52,6,SEQ))
+62 ;DECRYPT INFORMATION
+63 SET DECSTR=STRING
+64 IF $$NCRPFLD^VAQUTL2(52,6)
XECUTE DECRYPT
+65 SET TMP=DECSTR
+66 IF (TMP'="")
Begin DoDot:1
+67 SET J=$ORDER(^PSDRUG("B",TMP,""))
+68 if (J="")
QUIT
+69 SET TMP=+$GET(^PSDRUG(J,"ND"))
+70 if ('TMP)
QUIT
+71 SET J=$PIECE($GET(^PSNDF(TMP,0)),"^")
+72 if (J="")
QUIT
+73 ;ENCRYPT INFORMATION
+74 SET STRING=J
+75 SET ENCSTR=STRING
+76 IF $$NCRPFLD^VAQUTL2(52,6)
XECUTE ENCRYPT
+77 SET @ARRAY@("VALUE",52,6,SEQ)=ENCSTR
End DoDot:1
+78 QUIT
