source: FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRSTBAD.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 8.0 KB
Line 
1DGRSTBAD ;JDH,EG,PHH-STATE FILE REPORT ; 03/16/2007 4:15 PM
2 ;;5.3;Registration;**694,738**;Aug 13, 1993;Build 6
3 Q
4EN N %ZIS,DGNS,DIR,X,Y,DGRPTYP,DIRUT,MSG,POP,ZTSK
5 S DIR("A")="Report on States Not Recognized by AAC or Inactive Counties for"
6 S DGRPTYP(1)="US and US Possessions Only"
7 S DGRPTYP(2)="Foreign Addresses Only"
8 S DIR("B")=1
9 S DIR(0)="S^1:"_DGRPTYP(1)_";2:"_DGRPTYP(2)_";3:Both"
10 D ^DIR G:$D(DIRUT) EXIT
11 S DGRPTYP=Y
12 S MSG(1)=""
13 S MSG(2)="This report may take a long time to generate. It is recommended that the report"
14 S MSG(3)="be queued to print."
15 S MSG(4)=""
16 D BMES^XPDUTL(.MSG)
17 S %ZIS="Q" D ^%ZIS G:POP EXIT
18 S DGNS="DGRSTBAD"
19 I $D(IO("Q")) D ZTSK G EXIT
20 D PROC(DGNS,.DGRPTYP),^%ZISC
21 Q
22EXIT D HOME^%ZIS
23 Q
24 ;
25ZTSK ;
26 N ZTSAVE,ZTDTH,ZTRTN,ZTDESC,Y
27 S (ZTSAVE("DGRPTYP"),ZTSAVE("DGRPTYP("),ZTSAVE("DGNS"))=""
28 S %DT("A")="Requested Start Time: ",%DT="FATE"
29 S %DT(0)="NOW",%DT("B")="NOW" D ^%DT K %DT(0) I Y<0 Q
30 S ZTDTH=Y
31 S ZTDESC="INVALID STATE/INACTIVE COUNTY REPORT"
32 S ZTRTN="PROC^"_DGNS_"(DGNS,.DGRPTYP)"
33 D ^%ZTLOAD
34 I $D(ZTSK) D
35 .W !!,"REPORT QUEUED"
36 E W !!,"REPORT NOT QUEUED"
37 Q
38 ;
39PROC(DGNS,DGRPTYP) ;
40 N X,DGFARR,DGFORR,DGSARR,DFN,DGD1,DGGLB,DGFILEP,DGPARR,DGIENS,DGFILE,DGNODE,DGPTYP,DGTARR,DGNAME
41 N DGIENS,DGSSN,DGPAGE,DGFLDNO,DGFLDS,DGPTR,DGTXT,DGFLD,DGQUIT,DGEND,DGSTRT,X1
42 S DGFILE=2
43 S DGGLB="^DPT"
44 K ^TMP($J,DGNS)
45 D FILE2(.DGFORR,"FOTXT")
46 D FILE2(.DGFARR,"FATXT")
47 S DGSTRT=$S(DGRPTYP=3:1,1:DGRPTYP)
48 S DGEND=$S(DGRPTYP=3:2,1:DGRPTYP)
49 S DFN=0
50 F S DFN=$O(^DPT(DFN)) Q:'DFN D
51 . K DGPARR
52 . I $$ISACT(DFN)'="Y" Q
53 . D FLDL
54 . Q
55 D RPT(DGNS,.DGRPTYP,DGSTRT,DGEND)
56 D XMY(.DGSARR,.DGRPTYP)
57 K ^TMP($J,DGNS)
58 Q
59 ;
60FLDL ;
61 I DGRPTYP'=2 D
62 . S DGFILEP=0
63 . F S DGFILEP=$O(DGFARR(1,DGFILEP)) Q:'DGFILEP D FLDLG
64 . Q
65 I DGRPTYP'=1 D
66 . S DGFILEP=0
67 . F S DGFILEP=$O(DGFORR(1,DGFILEP)) Q:'DGFILEP D FLDLG
68 . Q
69 D:$D(DGPARR) BUILD(DGNS,DFN,.DGPARR,.DGFARR,.DGSARR)
70 Q
71FLDLG ;
72 I DGFILEP=DGFILE D
73 . S DGIENS=DFN_","
74 . D CHECK1(DGRPTYP,.DGFARR,.DGFORR,DGFILEP,DGIENS,.DGPARR,DGSTRT,DGEND)
75 . Q
76 E D
77 . S X=+$O(^DD(DGFILE,"SB",DGFILEP,0))
78 . S DGNODE=$P($P($G(^DD(DGFILE,X,0)),U,4),";") Q:'$L(DGNODE)
79 . S DGD1=0
80 . F S DGD1=$O(@DGGLB@(DFN,DGNODE,DGD1)) Q:'DGD1 D
81 .. S DGIENS=DGD1_","_DFN_","
82 .. D CHECK1(DGRPTYP,.DGFARR,.DGFORR,DGFILEP,DGIENS,.DGPARR,DGSTRT,DGEND)
83 .. Q
84 . Q
85 Q
86CHECK1(DGRPTYP,DGFARR,DGFORR,DGFILEP,DGIENS,DGPARR,DGSTRT,DGEND) ;
87 ;
88 ;For each report type
89 F DGPTYP=DGSTRT:1:DGEND D CHG
90 Q
91CHG ;
92 N FOREIGN
93 ;Extract appropriate fields for report type
94 I DGPTYP=1 S DGFLDS=DGFARR(1,DGFILEP)
95 E S DGFLDS=DGFORR(1,DGFILEP)
96 K DGTARR,DGERR,SDQUERY,SDQDATA
97 N I D GETS^DIQ(DGFILEP,DGIENS,DGFLDS,"I","DGTARR","DGERR")
98 S DGFLD=0
99 F S DGFLD=$O(DGTARR(DGFILEP,DGIENS,DGFLD)) Q:'DGFLD D
100 . S DGPTR=DGTARR(DGFILEP,DGIENS,DGFLD,"I") Q:'DGPTR
101 . S FOREIGN=$$FOREIGN(DGPTR)
102 . I FOREIGN="Y",DGPTYP=1 Q
103 . I FOREIGN="N",DGPTYP=2 Q
104 . ;Check county inactive date for both foreign and US
105 . I DGFLD=.117 D
106 .. S X1=DGTARR(DGFILEP,DGIENS,.115,"I")
107 .. S X=$G(^DIC(5,X1,1,DGPTR,0))
108 .. S:$P(X,U,5)!$D(DGPARR(DGPTYP,DGFILEP,DGIENS,.115)) DGPARR(DGPTYP,DGFILEP,DGIENS,DGFLD)=$P(X,U)
109 .. Q
110 . S X=$G(^DIC(5,DGPTR,0))
111 . I '$P(X,U,5)!($E($P(X,U,1),1)="Z") S DGPARR(DGPTYP,DGFILEP,DGIENS,DGFLD)=$P(X,U)
112 . Q
113 Q
114 ;
115BUILD(DGNS,DGDO,DGPARR,DGFARR,DGSARR) ;
116 ;
117 N X,DGNAME,DGSSN,DGPTYP
118 S X=$G(^DPT(DFN,0))
119 S DGNAME=$P(X,U) Q:'$L(DGNAME)
120 S DGSSN=$P(X,U,9)
121 S:'$L(DGSSN) DGSSN="NONE"
122 S DGPTYP=0
123 F S DGPTYP=$O(DGPARR(DGPTYP)) Q:'DGPTYP D DGFILEP
124 Q
125DGFILEP ;
126 N DGFILEP
127 S DGFILEP=0
128 F S DGFILEP=$O(DGPARR(DGPTYP,DGFILEP)) Q:'DGFILEP D DGIENS
129 Q
130DGIENS ;
131 N DGIENS
132 S DGIENS=""
133 F S DGIENS=$O(DGPARR(DGPTYP,DGFILEP,DGIENS)) Q:DGIENS="" D DGFLD
134 Q
135DGFLD ;
136 N DGFLD
137 S DGFLD=0
138 F S DGFLD=$O(DGPARR(DGPTYP,DGFILEP,DGIENS,DGFLD)) Q:'DGFLD D
139 . I DGPTYP=1 D
140 .. S ^TMP($J,DGNS,DGPTYP,DGNAME,DGSSN,DGIENS,DGFARR(0,DGFILEP,DGFLD))=DGPARR(DGPTYP,DGFILEP,DGIENS,DGFLD)
141 .. S DGSARR(DGPTYP,DGFARR(0,DGFILEP,DGFLD))=$G(DGSARR(DGPTYP,DGFARR(0,DGFILEP,DGFLD)))+1
142 .. Q
143 . I DGPTYP=2 D
144 .. S ^TMP($J,DGNS,DGPTYP,DGNAME,DGSSN,DGIENS,DGFORR(0,DGFILEP,DGFLD))=DGPARR(DGPTYP,DGFILEP,DGIENS,DGFLD)
145 .. S DGSARR(DGPTYP,DGFORR(0,DGFILEP,DGFLD))=$G(DGSARR(DGPTYP,DGFORR(0,DGFILEP,DGFLD)))+1
146 .. Q
147 . Q
148 Q
149 ;
150HDR(DGRPTYP,DGPTYP,DGPAGE) ;
151 N DGQUIT
152 S DGQUIT=0
153 I DGPAGE,$E(IOST,1,2)="C-" K X,Y,DIR S DIR(0)="E" D ^DIR S DGQUIT=$D(DIRUT)
154 D:'DGQUIT
155 .W @IOF
156 .S X="Report of States Not Recognized by AAC and Inactive Counties"
157 .W ?(IOM\2-($L(X)\2)),X
158 .S X=DGRPTYP(DGPTYP)
159 .W !,?(IOM\2-($L(X)\2)),X
160 .S DGPAGE=DGPAGE+1
161 .W ?(IOM-10),"PAGE: "_DGPAGE
162 .W !!,"NAME",?26,"SSN",?38,"FIELD",?68,"STATE/COUNTY"
163 .W !
164 Q DGQUIT
165 ;
166RPT(DGNS,DGRPTYP,DGSTRT,DGEND) ;
167 N DGPAGE,DGQUIT,DGPTYP
168 S DGPAGE=0
169 S DGQUIT=0
170 S DGPTYP=0
171 F DGPTYP=DGSTRT:1:DGEND Q:DGQUIT D RPTG
172 Q
173RPTG ;
174 N DGNAME,CNT
175 S CNT=0
176 S DGQUIT=$$HDR(.DGRPTYP,DGPTYP,.DGPAGE)
177 Q:DGQUIT
178 S DGNAME=""
179 F S DGNAME=$O(^TMP($J,DGNS,DGPTYP,DGNAME)) Q:'$L(DGNAME) Q:DGQUIT D RDGSSN
180 W !!,"Total records reported: ",CNT
181 Q
182RDGSSN ;
183 N DGSSN
184 S DGSSN=""
185 F S DGSSN=$O(^TMP($J,DGNS,DGPTYP,DGNAME,DGSSN)) Q:'$L(DGSSN) Q:DGQUIT D RDGIENS
186 Q
187RDGIENS ;
188 N DGIENS
189 S DGIENS=""
190 F S DGIENS=$O(^TMP($J,DGNS,DGPTYP,DGNAME,DGSSN,DGIENS)) Q:DGIENS="" Q:DGQUIT D RDGTXT
191 Q
192RDGTXT ;
193 N DGTEXT
194 S DGTXT=""
195 F S DGTXT=$O(^TMP($J,DGNS,DGPTYP,DGNAME,DGSSN,DGIENS,DGTXT)) Q:'$L(DGTXT) D Q:DGQUIT
196 . I $Y>(IOSL-4) S DGQUIT=$$HDR(.DGRPTYP,DGPTYP,.DGPAGE) Q:DGQUIT
197 . S DGTEXT=$G(^TMP($J,DGNS,DGPTYP,DGNAME,DGSSN,DGIENS,DGTXT))
198 . W !,$E(DGNAME,1,25),?26,DGSSN,?38,DGTXT,?68,$E($P(DGTEXT,U,1),1,12)
199 . S CNT=CNT+1
200 . Q
201 Q
202 ;
203XMY(DGSARR,DGRPTYP) ;
204 N DGTXT,XMDUZ,XMSUB,XMY,XMTEXT,MSG,DGLINE,X
205 S XMY(DUZ)="",XMTEXT="MSG(",XMDUZ=.5
206 S XMSUB="Invalid State/Inactive County Report Summary"
207 S MSG(1)="The following counts have been found in the PATIENT file:"
208 S MSG(5)=""
209 S DGPTYP=0
210 S DGLINE=10
211 I DGRPTYP'=2,'$D(DGSARR(1)) D
212 . S DGLINE=DGLINE+1
213 . S MSG(DGLINE)=DGRPTYP(1)
214 . S DGLINE=DGLINE+1
215 . S MSG(DGLINE)=" No Invalid States or Inactive Counties Found"
216 . Q
217 I DGRPTYP'=1,'$D(DGSARR(2)) D
218 . S DGLINE=DGLINE+1
219 . S MSG(DGLINE)=DGRPTYP(2)
220 . S DGLINE=DGLINE+1
221 . S MSG(DGLINE)=" No Invalid States or Inactive Counties Found"
222 . Q
223 F S DGPTYP=$O(DGSARR(DGPTYP)) Q:'DGPTYP D
224 . S DGLINE=DGLINE+1
225 . S MSG(DGLINE)=""
226 . S DGLINE=DGLINE+1
227 . S MSG(DGLINE)=DGRPTYP(DGPTYP)
228 . S DGLINE=DGLINE+1
229 . S MSG(DGLINE)=""
230 . S DGTXT=""
231 . F S DGTXT=$O(DGSARR(DGPTYP,DGTXT)) Q:'$L(DGTXT) D
232 .. S DGLINE=DGLINE+1
233 .. S X="",$P(X," ",32-$L(DGTXT))=""
234 .. S MSG(DGLINE)=" "_DGTXT_X_DGSARR(DGPTYP,DGTXT)
235 .. Q
236 . Q
237 D ^XMD
238 Q
239 ;
240FILE2(DGFARR,TAG) ;
241 N I,X,DGFILED,DGFLDNO
242 F I=1:1 S X=$P($T(@TAG+I),";;",2) Q:X="END" D
243 .S DGFILED=$P(X,";"),DGFLDNO=$P(X,";",2),DGFARR(0,DGFILED,DGFLDNO)=$P(X,";",3) S:'$D(DGFARR(1,DGFILED)) DGFARR(1,DGFILED)=""
244 .S DGFARR(1,DGFILED)=DGFARR(1,DGFILED)_$E(";",$L(DGFARR(1,DGFILED))>0)_DGFLDNO
245 Q
246 ;
247FOTXT ;
248 ;;2;.115;Permanent Address - State
249 ;;2;.1215;Temporary Address - State
250 ;;2;.1415;Confidential Address - State
251 ;;END
252 ;
253FATXT ;
254 ;;2;.093;Place of Birth
255 ;;2;.115;Permanent Address - State
256 ;;2;.117;Permanent Address - County
257 ;;2;.1215;Temporary Address - State
258 ;;2;.12111;Temporary Address - County
259 ;;2;.1415;Confidential Address - State
260 ;;2;.14111;Confidential Address - County
261 ;;2;.1654;Ineligible TWX
262 ;;2;.1659;Missing Person TWX
263 ;;2;.217;Next of Kin
264 ;;2;.2197;Next of Kin 2
265 ;;2;.256;Spouse's Employer
266 ;;2;.2917;VA Guardian
267 ;;2;.2927;Civil Guardian
268 ;;2;.3117;Employer
269 ;;2;.3317;Emergency Contact 2
270 ;;2;.337;Emergency Contact
271 ;;2;.347;Designee
272 ;;2;2.06;Insurance Type - Emp Claims
273 ;;2;3.09;Insurance Type - Insured's
274 ;;2;13;Insurance Type - Agent's
275 ;;2;35;Attorney
276 ;;END
277 ;
278ISACT(DFN) ;
279 N X,DGACT,HLQ
280 S HLQ=""""""
281 S DGACT=$P($G(^DPT(DFN,.35)),U) ; date of death
282 I DGACT Q "N"
283 S DGACT=$S(+$$LTD^VAFHUTL(DFN)=-1:0,1:+$$LTD^VAFHUTL(DFN)) ; active appointment
284 S:'DGACT DGACT=$$PHARM^IVMLDEM6(DFN) ; active RX
285 Q $S(DGACT:"Y",1:"N")
286 ;
287FOREIGN(STATE) ;uses state to determine foreign address
288 ;someday should use country codes in the patient file
289 N DESC,X
290 I $G(STATE)="" Q "N"
291 S X=$G(^DIC(5,STATE,0))
292 I $P(X,"^",6)=1 Q "N"
293 Q "Y"
Note: See TracBrowser for help on using the repository browser.