VAQDBIP1 ;ALB/JRP - PHARMACY EXTRACTION;16-MAR-93
;;1.5;PATIENT DATA EXCHANGE;**31**;NOV 17, 1993
RXXTRCT(TRAN,DFN,ARRAY,CUTOFF) ;EXTRACT PHARMACY INFORMATION
;INPUT : TRAN - Pointer to VAQ - TRANSACTION file
; DFN - Pointer to patient in PATIENT file
; ARRAY - Where to store information (full global reference)
; CUTOFF - Number of days to cut off expired/canceled RXs
; (defaults to 90)
;OUTPUT : 0 - Extraction was successfull
; -1^Error_Text - Extraction was not successfull
;NOTE : If the pharmacy information can not be extracted,
; the "VALUE" and "ID" nodes in ARRAY will be deleted.
; : If TRAN is passed
; The patient pointer of the transaction will be used
; Encryption will be based on the transaction
; If DFN is passed
; Encryption will be based on the site parameter
; : Pointer to transaction takes precedence over DFN ... if
; TRAN>0 the DFN will be based on the transaction
;
;CHECK INPUT
S TRAN=+$G(TRAN)
S DFN=+$G(DFN)
Q:(('TRAN)&('DFN)) "-1^Did not pass pointer to transaction or patient"
I (TRAN) Q:('$D(^VAT(394.61,TRAN))) "-1^Did not pass valid pointer to VAQ - TRANSACTION file"
I (TRAN) S DFN=+$P($G(^VAT(394.61,TRAN,0)),"^",3) Q:('DFN) "-1^Transaction did not contain pointer to PATIENT file"
Q:('$D(^DPT(DFN))) "-1^Did not pass valid pointer to PATIENT file"
Q:($G(ARRAY)="") "-1^Did not pass output array"
S:('$D(CUTOFF)) CUTOFF=90
S CUTOFF=+$G(CUTOFF)
;DECLARE VARIABLES
N TMP,LOOP,ERROR,X1,X2,X,CUTDATE,RXIFN,SEQ,ENCRYPT,DECRYPT
N J,RX0,RX2,RX3,ST,ST0,ZII,Y,%DT,GMRAL,GMRA,ENCSTR
N DECSTR,STRING,ENCPTR,KEY1,KEY2,SENDER
S ERROR=0
;DETERMINE IF ENCRYPTION IS ON - SAVE POINTER TO ENCRYPTION METHOD
S:('TRAN) ENCPTR=$$NCRYPTON^VAQUTL2(0)
S:(TRAN) ENCPTR=$$TRANENC^VAQUTL3(TRAN,1)
;SET UP EXECUTABLE CALL TO ENCRYPT
S:(ENCPTR) ENCRYPT=$$ENCMTHD^VAQUTL2(ENCPTR,0)
S:('ENCPTR) ENCRYPT=""
S:(ENCRYPT'="") ENCRYPT=("S ENCSTR="_ENCRYPT)
S:(ENCRYPT="") ENCRYPT="S ENCSTR=STRING"
;SET UP EXECUTABLE CALL TO DECRYPT
S:(ENCPTR) DECRYPT=$$ENCMTHD^VAQUTL2(ENCPTR,1)
S:('ENCPTR) DECRYPT=""
S:(DECRYPT'="") DECRYPT=("S DECSTR="_DECRYPT)
S:(DECRYPT="") DECRYPT="S DECSTR=STRING"
;DETERMINE PRIMARY KEY
I (TRAN) S SENDER=$$SENDER^VAQCON2(TRAN) Q:($P(SENDER,"^",1)="-1") "-1^Could not determine encryption keys"
S:(TRAN) SENDER=$P(SENDER,"^",1)
S:(TRAN) KEY1=$$NAMEKEY^VAQUTL3(SENDER,1)
S:('TRAN) KEY1=$$DUZKEY^VAQUTL3($G(DUZ),1)
;DETERMINE SECONDARY KEY
S:(TRAN) KEY2=$$NAMEKEY^VAQUTL3(SENDER,0)
S:('TRAN) KEY2=$$DUZKEY^VAQUTL3($G(DUZ),0)
I (ENCPTR) Q:((KEY1="")!(KEY2="")) "-1^Could not determine encryption keys"
;EXTRACT NON-PRESCRIPTION INFO
F LOOP=1:1 D Q:(ERROR)
.S TMP=$T(RXPAT+LOOP^VAQDBII1)
.I ($P(TMP,";;",2)="") S ERROR=1 Q
.S ERROR=$$XTRCT^VAQDBIP2(TMP,DFN,"",ARRAY,ENCPTR,KEY1,KEY2)
.I ERROR D Q
..S TMP=$$KILLARR^VAQUTL1(ARRAY,"VALUE")
..S TMP=$$KILLARR^VAQUTL1(ARRAY,"ID")
Q:(ERROR<0) ERROR
;EXTRACT ALLERGIES & ADVERSE REACTIONS
;(LOCATION OF INFO IS IN TRANSITION; USE SUPPORTED CALL)
S GMRA="0^0^111"
D EN1^GMRADPT
;MOVE ALLERGIES & REACTIONS INTO EXTRACTION ARRAY
S ERROR=0
I $D(GMRAL) D
.;PATIENT IS IDENTIFIER
.S ERROR=$$PATINFO^VAQUTL1(DFN)
.S STRING=$P(ERROR,"^",1)
.Q:(STRING="-1")
.;ENCRYPT PATIENT NAME
.S ENCSTR=STRING
.I $$NCRPFLD^VAQUTL2(2,.01) X ENCRYPT
.S TMP=ENCSTR
.S ERROR=0
.; Before GMRA*4*10, if patient had NKA (no known allergies) EN1^GMRADPT
.; returned GMRAL=0 and GMRAL(<ptr to file 120.8>)=DFN_"^NKA^0^1"
.; After that patch, it just returned GMRAL=0. So we must dummy up
.; the missing array element to make this routine work as it had before.
.I GMRAL=0,'$O(GMRAL(0)) S GMRAL(1)="^NKA" ; VAQ*1.5*31
.S GMRA=""
.F SEQ=0:1 D Q:(GMRA="")
..S GMRA=$O(GMRAL(GMRA))
..Q:(GMRA="")
..S J=$P(GMRAL(GMRA),"^",2)
..Q:(J="")
..;ENCRYPT VALUE
..S STRING=J
..S ENCSTR=STRING
..I $$NCRPFLD^VAQUTL2(120.8,.02) X ENCRYPT
..;STORE INFORMATION
..S @ARRAY@("VALUE",120.8,.02,SEQ)=ENCSTR
..S @ARRAY@("ID",120.8,.02,SEQ)=TMP
I ERROR D Q ERROR
.S TMP=$$KILLARR^VAQUTL1(ARRAY,"VALUE")
.S TMP=$$KILLARR^VAQUTL1(ARRAY,"ID")
;EXTRACT PRESCRIPTION INFORMATION
D SCRIPTS^VAQDBIP8
I ERROR D Q ERROR
.S TMP=$$KILLARR^VAQUTL1(ARRAY,"VALUE")
.S TMP=$$KILLARR^VAQUTL1(ARRAY,"ID")
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAQDBIP1 4449 printed Sep 23, 2025@20:00:48 Page 2
VAQDBIP1 ;ALB/JRP - PHARMACY EXTRACTION;16-MAR-93
+1 ;;1.5;PATIENT DATA EXCHANGE;**31**;NOV 17, 1993
RXXTRCT(TRAN,DFN,ARRAY,CUTOFF) ;EXTRACT PHARMACY INFORMATION
+1 ;INPUT : TRAN - Pointer to VAQ - TRANSACTION file
+2 ; DFN - Pointer to patient in PATIENT file
+3 ; ARRAY - Where to store information (full global reference)
+4 ; CUTOFF - Number of days to cut off expired/canceled RXs
+5 ; (defaults to 90)
+6 ;OUTPUT : 0 - Extraction was successfull
+7 ; -1^Error_Text - Extraction was not successfull
+8 ;NOTE : If the pharmacy information can not be extracted,
+9 ; the "VALUE" and "ID" nodes in ARRAY will be deleted.
+10 ; : If TRAN is passed
+11 ; The patient pointer of the transaction will be used
+12 ; Encryption will be based on the transaction
+13 ; If DFN is passed
+14 ; Encryption will be based on the site parameter
+15 ; : Pointer to transaction takes precedence over DFN ... if
+16 ; TRAN>0 the DFN will be based on the transaction
+17 ;
+18 ;CHECK INPUT
+19 SET TRAN=+$GET(TRAN)
+20 SET DFN=+$GET(DFN)
+21 if (('TRAN)&('DFN))
QUIT "-1^Did not pass pointer to transaction or patient"
+22 IF (TRAN)
if ('$DATA(^VAT(394.61,TRAN)))
QUIT "-1^Did not pass valid pointer to VAQ - TRANSACTION file"
+23 IF (TRAN)
SET DFN=+$PIECE($GET(^VAT(394.61,TRAN,0)),"^",3)
if ('DFN)
QUIT "-1^Transaction did not contain pointer to PATIENT file"
+24 if ('$DATA(^DPT(DFN)))
QUIT "-1^Did not pass valid pointer to PATIENT file"
+25 if ($GET(ARRAY)="")
QUIT "-1^Did not pass output array"
+26 if ('$DATA(CUTOFF))
SET CUTOFF=90
+27 SET CUTOFF=+$GET(CUTOFF)
+28 ;DECLARE VARIABLES
+29 NEW TMP,LOOP,ERROR,X1,X2,X,CUTDATE,RXIFN,SEQ,ENCRYPT,DECRYPT
+30 NEW J,RX0,RX2,RX3,ST,ST0,ZII,Y,%DT,GMRAL,GMRA,ENCSTR
+31 NEW DECSTR,STRING,ENCPTR,KEY1,KEY2,SENDER
+32 SET ERROR=0
+33 ;DETERMINE IF ENCRYPTION IS ON - SAVE POINTER TO ENCRYPTION METHOD
+34 if ('TRAN)
SET ENCPTR=$$NCRYPTON^VAQUTL2(0)
+35 if (TRAN)
SET ENCPTR=$$TRANENC^VAQUTL3(TRAN,1)
+36 ;SET UP EXECUTABLE CALL TO ENCRYPT
+37 if (ENCPTR)
SET ENCRYPT=$$ENCMTHD^VAQUTL2(ENCPTR,0)
+38 if ('ENCPTR)
SET ENCRYPT=""
+39 if (ENCRYPT'="")
SET ENCRYPT=("S ENCSTR="_ENCRYPT)
+40 if (ENCRYPT="")
SET ENCRYPT="S ENCSTR=STRING"
+41 ;SET UP EXECUTABLE CALL TO DECRYPT
+42 if (ENCPTR)
SET DECRYPT=$$ENCMTHD^VAQUTL2(ENCPTR,1)
+43 if ('ENCPTR)
SET DECRYPT=""
+44 if (DECRYPT'="")
SET DECRYPT=("S DECSTR="_DECRYPT)
+45 if (DECRYPT="")
SET DECRYPT="S DECSTR=STRING"
+46 ;DETERMINE PRIMARY KEY
+47 IF (TRAN)
SET SENDER=$$SENDER^VAQCON2(TRAN)
if ($PIECE(SENDER,"^",1)="-1")
QUIT "-1^Could not determine encryption keys"
+48 if (TRAN)
SET SENDER=$PIECE(SENDER,"^",1)
+49 if (TRAN)
SET KEY1=$$NAMEKEY^VAQUTL3(SENDER,1)
+50 if ('TRAN)
SET KEY1=$$DUZKEY^VAQUTL3($GET(DUZ),1)
+51 ;DETERMINE SECONDARY KEY
+52 if (TRAN)
SET KEY2=$$NAMEKEY^VAQUTL3(SENDER,0)
+53 if ('TRAN)
SET KEY2=$$DUZKEY^VAQUTL3($GET(DUZ),0)
+54 IF (ENCPTR)
if ((KEY1="")!(KEY2=""))
QUIT "-1^Could not determine encryption keys"
+55 ;EXTRACT NON-PRESCRIPTION INFO
+56 FOR LOOP=1:1
Begin DoDot:1
+57 SET TMP=$TEXT(RXPAT+LOOP^VAQDBII1)
+58 IF ($PIECE(TMP,";;",2)="")
SET ERROR=1
QUIT
+59 SET ERROR=$$XTRCT^VAQDBIP2(TMP,DFN,"",ARRAY,ENCPTR,KEY1,KEY2)
+60 IF ERROR
Begin DoDot:2
+61 SET TMP=$$KILLARR^VAQUTL1(ARRAY,"VALUE")
+62 SET TMP=$$KILLARR^VAQUTL1(ARRAY,"ID")
End DoDot:2
QUIT
End DoDot:1
if (ERROR)
QUIT
+63 if (ERROR<0)
QUIT ERROR
+64 ;EXTRACT ALLERGIES & ADVERSE REACTIONS
+65 ;(LOCATION OF INFO IS IN TRANSITION; USE SUPPORTED CALL)
+66 SET GMRA="0^0^111"
+67 DO EN1^GMRADPT
+68 ;MOVE ALLERGIES & REACTIONS INTO EXTRACTION ARRAY
+69 SET ERROR=0
+70 IF $DATA(GMRAL)
Begin DoDot:1
+71 ;PATIENT IS IDENTIFIER
+72 SET ERROR=$$PATINFO^VAQUTL1(DFN)
+73 SET STRING=$PIECE(ERROR,"^",1)
+74 if (STRING="-1")
QUIT
+75 ;ENCRYPT PATIENT NAME
+76 SET ENCSTR=STRING
+77 IF $$NCRPFLD^VAQUTL2(2,.01)
XECUTE ENCRYPT
+78 SET TMP=ENCSTR
+79 SET ERROR=0
+80 ; Before GMRA*4*10, if patient had NKA (no known allergies) EN1^GMRADPT
+81 ; returned GMRAL=0 and GMRAL(<ptr to file 120.8>)=DFN_"^NKA^0^1"
+82 ; After that patch, it just returned GMRAL=0. So we must dummy up
+83 ; the missing array element to make this routine work as it had before.
+84 ; VAQ*1.5*31
IF GMRAL=0
IF '$ORDER(GMRAL(0))
SET GMRAL(1)="^NKA"
+85 SET GMRA=""
+86 FOR SEQ=0:1
Begin DoDot:2
+87 SET GMRA=$ORDER(GMRAL(GMRA))
+88 if (GMRA="")
QUIT
+89 SET J=$PIECE(GMRAL(GMRA),"^",2)
+90 if (J="")
QUIT
+91 ;ENCRYPT VALUE
+92 SET STRING=J
+93 SET ENCSTR=STRING
+94 IF $$NCRPFLD^VAQUTL2(120.8,.02)
XECUTE ENCRYPT
+95 ;STORE INFORMATION
+96 SET @ARRAY@("VALUE",120.8,.02,SEQ)=ENCSTR
+97 SET @ARRAY@("ID",120.8,.02,SEQ)=TMP
End DoDot:2
if (GMRA="")
QUIT
End DoDot:1
+98 IF ERROR
Begin DoDot:1
+99 SET TMP=$$KILLARR^VAQUTL1(ARRAY,"VALUE")
+100 SET TMP=$$KILLARR^VAQUTL1(ARRAY,"ID")
End DoDot:1
QUIT ERROR
+101 ;EXTRACT PRESCRIPTION INFORMATION
+102 DO SCRIPTS^VAQDBIP8
+103 IF ERROR
Begin DoDot:1
+104 SET TMP=$$KILLARR^VAQUTL1(ARRAY,"VALUE")
+105 SET TMP=$$KILLARR^VAQUTL1(ARRAY,"ID")
End DoDot:1
QUIT ERROR
+106 QUIT 0
