source: FOIAVistA/trunk/r/PATIENT_DATA_EXCHANGE-VAQ/VAQDBIP6.m@ 674

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

initial load of FOIAVistA 6/30/08 version
File size: 4.9 KB
Line 
1VAQDBIP6 ;ALB/JRP - CONTINUATIONS FOR VAQDBIP4;25-MAR-93
2 ;;1.5;PATIENT DATA EXCHANGE;**41**;NOV 17, 1993
3ELIG ;EXTRACT ELIGIBILITIES
4 ; DECLARATIONS TAKEN CARE OF IN VAQDBIP4
5 S TMP=$T(ELIG+1^VAQDBII1)
6 S FLDS=$TR($P(TMP,";",4),",",";")
7 ;ENCRYPT PATIENT NAME
8 S STRING=$P($$PATINFO^VAQUTL1(DFN),"^",1)
9 S ENCSTR=STRING
10 I $$NCRPFLD^VAQUTL2(2,.01) X ENCRYPT
11 S NAME=ENCSTR
12 ;DETERMINE PRIMARY ELIGIBILITY
13 S DIC="^DPT("
14 S DA=DFN
15 S DR=.361
16 S DIQ(0)="E"
17 K ^UTILITY("DIQ1",$J)
18 D EN^DIQ1
19 S PRIME=$G(^UTILITY("DIQ1",$J,2,DFN,.361,"E"))
20 ;GET OTHER ELIGIBILITIES
21 S TMP=0
22 F S TMP=$O(^DPT(DFN,"E",TMP)) Q:('TMP) D
23 .S DIC="^DPT("
24 .S DA=DFN
25 .S DR=361
26 .S DIQ(0)="E"
27 .S DA(2.0361)=TMP
28 .S DR(2.0361)=FLDS
29 .K ^UTILITY("DIQ1",$J)
30 .D EN^DIQ1
31 .;SCREEN OUT PRIMARY ELIGIBILITY
32 .S Y=$G(^UTILITY("DIQ1",$J,2.0361,DA(2.0361),.01,"E"))
33 .Q:(Y=PRIME)
34 .S SEQ=$$GETSEQ^VAQDBIP(ARRAY,2.0361,.01)
35 .;ENCRYPT VALUE
36 .S STRING=Y
37 .S ENCSTR=STRING
38 .I $$NCRPFLD^VAQUTL2(2.0361,.01) X ENCRYPT
39 .S @ARRAY@("ID",2.0361,.01,SEQ)=NAME
40 .S @ARRAY@("VALUE",2.0361,.01,SEQ)=ENCSTR
41 .S Y=ENCSTR
42 .;MOVE INFORMATION INTO EXTRACTION ARRAY
43 .F X=1:1:$L(FLDS,";") D
44 ..S Z=$P(FLDS,";",X)
45 ..;STORE ID
46 ..S @ARRAY@("ID",2.0361,Z,SEQ)=Y
47 ..;ENCRYPT VALUE
48 ..S STRING=$G(^UTILITY("DIQ1",$J,2.0361,DA(2.0361),Z,"E"))
49 ..S ENCSTR=STRING
50 ..I $$NCRPFLD^VAQUTL2(2.0361,Z) X ENCRYPT
51 ..S @ARRAY@("VALUE",2.0361,Z,SEQ)=ENCSTR
52 .K ^UTILITY("DIQ1",$J)
53 Q
54 ;
55APPOINT ;EXTRACT APPOINTMENTS
56 N VAQDT
57 ; DECLARATIONS TAKEN CARE OF IN VAQDBIP4
58 S TMP=$T(APPOINT+1^VAQDBII1)
59 S FLDS=$TR($P(TMP,";",4),",",";")
60 ;ENCRYPT PATIENT NAME
61 S STRING=$P($$PATINFO^VAQUTL1(DFN),"^",1)
62 S ENCSTR=STRING
63 I $$NCRPFLD^VAQUTL2(2,.01) X ENCRYPT
64 S NAME=ENCSTR
65 D APPGET ; Get last 5 appointments
66 S VAQDT="" ; Process in reverse order
67 F VAQDT=$O(^UTILITY("DIQ1",$J,2.98,VAQDT),-1) Q:VAQDT="" D
68 .S Y=VAQDT D DD^%DT
69 .S SEQ=$$GETSEQ^VAQDBIP(ARRAY,2.98,.001)
70 .;ENCRYPT VALUE
71 .S STRING=Y
72 .S ENCSTR=STRING
73 .I $$NCRPFLD^VAQUTL2(2.98,.001) X ENCRYPT
74 .S @ARRAY@("ID",2.98,.001,SEQ)=NAME
75 .S @ARRAY@("VALUE",2.98,.001,SEQ)=ENCSTR
76 .S Y=ENCSTR
77 .;MOVE INFORMATION INTO EXTRACTION ARRAY
78 .F X=1:1:$L(FLDS,";") D
79 ..S Z=$P(FLDS,";",X)
80 ..;STORE ID
81 ..S @ARRAY@("ID",2.98,Z,SEQ)=Y
82 ..;ENCRYPT VALUE
83 ..S STRING=$G(^UTILITY("DIQ1",$J,2.98,VAQDT,Z,"E"))
84 ..S ENCSTR=STRING
85 ..I $$NCRPFLD^VAQUTL2(2.98,Z) X ENCRYPT
86 ..S @ARRAY@("VALUE",2.98,Z,SEQ)=ENCSTR
87 K ^UTILITY("DIQ1",$J)
88 Q
89APPGET ; Get last 5 appointments.
90 ; Prior to patch *41, we retrieved data directly from the APPOINTMENTS
91 ; subfile (#2.98) of the PATIENT file. Now, we retrieve using the new
92 ; Scheduling Replacement API from a central database.
93 ; Fields requested:
94 ; Old Description New
95 ; --- ---------------- ---
96 ; .001 Appt date/time 1
97 ; .01 Clinic 2
98 ; 3 Status 3
99 ; 9 Purpose of Visit 18
100 ; 9.5 Appt type 10
101 N X,VAQSD,VAQDT,VAQREC
102 S VAQSD(4)=DFN
103 S VAQSD("FLDS")="1;2;3;18;10"
104 S VAQSD("SORT")="P" ; Sort by patient only (not clinic)
105 S VAQSD("MAX")=-5 ; Return last 5 appts.
106 S X=$$SDAPI^SDAMA301(.VAQSD)
107 ; For each of the last 5 appts, move to Utility global,
108 ; with VAQDT being the date/time of the appt.
109 K ^UTILITY("DIQ1",$J)
110 S VAQDT=""
111 F S VAQDT=$O(^TMP($J,"SDAMA301",DFN,VAQDT)) Q:VAQDT="" S VAQREC=^(VAQDT) D
112 . S ^UTILITY("DIQ1",$J,2.98,VAQDT,.01,"E")=$P($P(VAQREC,U,2),";",2)
113 . S ^UTILITY("DIQ1",$J,2.98,VAQDT,3,"E")=$P($P(VAQREC,U,3),";",2)
114 . S ^UTILITY("DIQ1",$J,2.98,VAQDT,9,"E")=$P($P(VAQREC,U,18),";",2)
115 . S ^UTILITY("DIQ1",$J,2.98,VAQDT,9.5,"E")=$P($P(VAQREC,U,10),";",2)
116 K ^TMP($J,"SDAMA301")
117 Q
118 ;
119DENTAL ;EXTRACT DENTAL APPOINTMENTS
120 ; DECLARATIONS TAKEN CARE OF IN VAQDBIP4
121 S TMP=$T(DENTAL+1^VAQDBII1)
122 S FLDS=$TR($P(TMP,";",4),",",";")
123 ;ENCRYPT PATIENT NAME
124 S STRING=$P($$PATINFO^VAQUTL1(DFN),"^",1)
125 S ENCSTR=STRING
126 I $$NCRPFLD^VAQUTL2(2,.01) X ENCRYPT
127 S NAME=ENCSTR
128 ;PUT DENTAL APPOINTMENTS IN REVERS ORDER
129 S TMP=0
130 K ^TMP("VAQ",$J,$J)
131 F S TMP=$O(^DPT(DFN,.37,TMP)) Q:('TMP) D
132 .S X=+$G(^DPT(DFN,.37,TMP,0))
133 .Q:('X)
134 .S ^TMP("VAQ",$J,$J,(9999999-X))=TMP_"^"_X
135 S TMP=""
136 ;EXTRACT 5 DENTAL APPOINTMENTS
137 F LOOP=1:1:5 S TMP=$O(^TMP("VAQ",$J,$J,TMP)) Q:(TMP="") D
138 .S DIC="^DPT("
139 .S DA=DFN
140 .S DR=.37
141 .S DIQ(0)="E"
142 .S DA(2.11)=+^TMP("VAQ",$J,$J,TMP)
143 .S DR(2.11)=FLDS
144 .K ^UTILITY("DIQ1",$J)
145 .D EN^DIQ1
146 .;MOVE DATE OF DENTAL APPOINTMENT INTO EXTRACTION ARRAY
147 .S Y=+$P(^TMP("VAQ",$J,$J,TMP),"^",2) D DD^%DT
148 .S SEQ=$$GETSEQ^VAQDBIP(ARRAY,2.11,.01)
149 .;ENCRYPT VALUE
150 .S STRING=Y
151 .S ENCSTR=STRING
152 .I $$NCRPFLD^VAQUTL2(2.11,.01) X ENCRYPT
153 .S @ARRAY@("ID",2.11,.01,SEQ)=NAME
154 .S @ARRAY@("VALUE",2.11,.01,SEQ)=ENCSTR
155 .S Y=STRING
156 .;MOVE INFO INTO EXTRACTION ARRAY
157 .F X=1:1:$L(FLDS,";") D
158 ..S Z=$P(FLDS,";",X)
159 ..Q:(Z=.01)
160 ..;STORE ID
161 ..S @ARRAY@("ID",2.11,Z,SEQ)=Y
162 ..;ENCRYPT VALUE
163 ..S STRING=$G(^UTILITY("DIQ1",$J,2.11,DA(2.11),Z,"E"))
164 ..S ENCSTR=STRING
165 ..I $$NCRPFLD^VAQUTL2(2.11,Z) X ENCRYPT
166 ..S @ARRAY@("VALUE",2.11,Z,SEQ)=ENCSTR
167 .K ^UTILITY("DIQ1",$J)
168 K ^TMP("VAQ",$J,$J)
169 Q
Note: See TracBrowser for help on using the repository browser.