source: WorldVistAEHR/trunk/r/PATIENT_DATA_EXCHANGE-VAQ/VAQDBIP1.m@ 1639

Last change on this file since 1639 was 613, checked in by George Lilly, 15 years ago

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