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

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

initial load of FOIAVistA 6/30/08 version

File size: 9.4 KB
Line 
1DGMSRPT1 ;ALB/LBD,BRM - Military Service Inconsistency Report; 01/05/04 ; 5/18/04 9:53am
2 ;;5.3;Registration;**562,603**; Aug 13,1993
3 ;
4 ; This routine scans the Patient file #2 and checks military service
5 ; data for inconsistencies. The inconsistencies are stored in
6 ; ^XTMP("DSMSRPT").
7 Q
8EN ; Entry point called from ^DGMSRPT
9 ; Initialize ^XTMP global and set start date
10 S ^XTMP("DGMSRPT",0)=$$FMADD^XLFDT(DT,60)_U_DT_U_"DG MILITARY SERVICE INCONSISTENCY REPORT"
11 S $P(^XTMP("DGMSRPT","DATE"),U,1)=$$FMTE^XLFDT($$NOW^XLFDT(),"5P")
12 S:$G(ZTSK) ZTREQ="@"
13 D INIT^DGMSRPT
14 ; Loop through Patient file #2. If patient meets report criteria, check
15 ; military service data for inconsistencies.
16 N DFN
17 S DFN=0 F S DFN=$O(^DPT(DFN)) Q:'DFN I $$CHK(DFN) D MSINC(DFN)
18 ; Send message containing inconsistency counts, update stop date/time
19 S $P(^XTMP("DGMSRPT","DATE"),U,2)=$$FMTE^XLFDT($$NOW^XLFDT(),"5P")
20 D MSG^DGMSRPT(DGXTMP)
21 K ^XTMP("DGMSRPT","RUNNING"),DGXTMP
22 Q
23CHK(DFN) ; Check if patient meets criteria to include in report
24 ; OUTPUT: 1=Meets report criteria; 0=Doesn't meet report criteria
25 N CHK,ENR,ENRDT,UE,UESITE,SITE
26 S CHK=0 I '$G(DFN) Q CHK
27 ; Patient is a veteran
28 I $P($G(^DPT(DFN,"VET")),U)'="Y" Q CHK
29 ; Patient not deceased
30 I +$G(^DPT(DFN,.35)) Q CHK
31 ; Primary eligibility not 'Humanitarian Emergency', 'Sharing Agreement',
32 ; or 'Employee'
33 I "^8^9^14^"[(U_+$G(^DPT(DFN,.36))_U) Q CHK
34 ; User Enrollee of this facility
35 S UE=$P($G(^DPT(DFN,.361)),U,7) I UE="" Q CHK
36 S UESITE=$P($G(^DPT(DFN,.361)),U,8) I +UESITE=0 Q CHK
37 S SITE=$P($$SITE^VASITE,U,3),SITE=$$PSITE^EASUER(SITE)
38 I $P($G(^DIC(4,UESITE,99)),U)'=$P($G(^DIC(4,SITE,99)),U) Q CHK
39 ; Has a current enrollment record
40 I '$G(^DPT(DFN,"ENR")) Q CHK
41 ; Meets report criteria
42 S CHK=1
43 Q CHK
44MSINC(DFN) ; Check military service data for inconsistencies.
45 N DGMS,NAM,SSN
46 Q:'$G(DFN)
47 ; Get veteran's military service data
48 D GETMS(DFN,.DGMS)
49 ; Check Military Service Episodes
50 D MSECHK(DFN,.DGMS)
51 ; Check Combat and POW data
52 D CMPWCHK(DFN,.DGMS)
53 ; Check Conflict data
54 D CONFCHK(DFN,.DGMS)
55 ; If inconsistencies were found, add 0 node and x-refs
56 I $D(@DGXTMP@(DFN)) D
57 .S NAM=$P($G(^DPT(DFN,0)),U,1),SSN=$P($G(^DPT(DFN,0)),U,9)
58 .S @DGXTMP@(DFN,0)=NAM_U_SSN
59 .I NAM'="" S @DGXTMP@("NAM",NAM,DFN)=""
60 .I SSN'="" S @DGXTMP@("SSN",+$E(SSN,8,9),+$E(SSN,6,9),+SSN,DFN)=""
61 .D SETCNT("VET")
62 Q
63GETMS(DFN,DGMS) ; Build DGMS array of military service data
64 ; OUTPUT: DGMS(CATEGORY,FIELD) - array of Military Service data
65 N MS,I,CAT,FLD
66 Q:'$G(DFN)
67 F I=.32,.321,.322,.52 S MS(I)=$G(^DPT(DFN,I))
68 S CAT="MSE1^MSE2^MSE3",FLD="DIS^BOS^FDT^TDT^NUM"
69 D ARRY(CAT,FLD,.32,4,18,.MS,.DGMS)
70 I $P(MS(.32),U,19)'="Y" K DGMS("MSE2") ;Delete data for inactive MSE
71 I $P(MS(.32),U,20)'="Y" K DGMS("MSE3") ;Delete data for inactive MSE
72 S CAT="LEB^GREN^PAN^GULF",FLD="IND^FDT^TDT"
73 D ARRY(CAT,FLD,.322,1,12,.MS,.DGMS)
74 S CAT="SOM^YUG"
75 D ARRY(CAT,FLD,.322,16,21,.MS,.DGMS)
76 S CAT="VIET",FLD="IND"
77 D ARRY(CAT,FLD,.321,1,1,.MS,.DGMS)
78 S FLD="FDT^TDT"
79 D ARRY(CAT,FLD,.321,4,5,.MS,.DGMS)
80 S CAT="POW",FLD="IND^LOC^FDT^TDT"
81 D ARRY(CAT,FLD,.52,5,8,.MS,.DGMS)
82 S CAT="COM"
83 D ARRY(CAT,FLD,.52,11,14,.MS,.DGMS)
84 Q
85ARRY(CAT,FLD,SB,P1,P2,MS,DGMS) ; Set array
86 ; INPUT: CAT - MS categories (e.g. MSE1 = 1st Military Service Episode)
87 ; FLD - MS fields (e.g. FDT = From Date, TDT = To Date)
88 ; SB - MS array subscript
89 ; P1 - Starting piece in MS string
90 ; P2 - Ending piece in MS string
91 ; MS( - Array with MS data from the Patient file
92 ; OUTPUT: DGMS( - Array returned with MS data grouped by category
93 N I,J,K
94 S J=1,K=0
95 F I=P1:1:P2 D
96 .I K=$L(FLD,U) S J=J+1,K=0
97 .S K=K+1
98 .I $P(MS(SB),U,I)'="" S DGMS($P(CAT,U,J),$P(FLD,U,K))=$P(MS(SB),U,I)
99 Q
100MSECHK(DFN,DGMS) ; Check military service episodes for inconsistencies
101 N DGTXT,CAT,DG,OVR,BOS,WWIIDT,WWIIS,WWIIE
102 ; Is there MSE data for this veteran?
103 I '$D(DGMS("MSE1")),'$D(DGMS("MSE2")),'$D(DGMS("MSE3")) Q
104 F CAT="MSE1","MSE2","MSE3" K DGTXT S DG=1 I $D(DGMS(CAT)) D
105 .; Check Branch of Service (B.E.C. and Merchant Seaman)
106 .S BOS=+$G(DGMS(CAT,"BOS")),BOS=$P($G(^DIC(23,BOS,0)),U,1)
107 .I BOS="B.E.C." S DGTXT="BEC" D SETTXT(.DG,.DGTXT),SETCNT(2)
108 .I BOS="MERCHANT SEAMAN" D
109 ..S WWIIDT=$$GETCNFDT^DGRPDT("WWIIP"),WWIIS=$P(WWIIDT,U),WWIIE=$P(WWIIDT,U,2)
110 ..Q:$$WITHIN^DGRPDT(WWIIS,WWIIE,$G(DGMS(CAT,"FDT")))
111 ..Q:$$WITHIN^DGRPDT(WWIIS,WWIIE,$G(DGMS(CAT,"TDT")))
112 ..Q:$$RWITHIN^DGRPDT($G(DGMS(CAT,"FDT")),$G(DGMS(CAT,"TDT")),WWIIS,WWIIE)
113 ..S DGTXT="MERC SEA NO WWII SVC" D SETTXT(.DG,.DGTXT),SETCNT(3)
114 .; Check for missing data
115 .I $$MISS(CAT,"BOS^DIS^FDT^TDT") S DGTXT="DATA MISS" D SETTXT(.DG,.DGTXT),SETCNT(4)
116 .; Check for imprecise dates (year only)
117 .I $$IMPR(CAT,"FDT^TDT") S DGTXT="DT IMPR" D SETTXT(.DG,.DGTXT),SETCNT(5)
118 .; Check if To Date is before From Date
119 .I $G(DGMS(CAT,"FDT")),$G(DGMS(CAT,"TDT")),$$B4^DGRPDT(DGMS(CAT,"TDT"),DGMS(CAT,"FDT")) D
120 ..S DGTXT="END DT BEFORE START DT" D SETTXT(.DG,.DGTXT),SETCNT(6)
121 .; Check if dates overlap with another MSE
122 .S OVR=$$OVRLP(CAT) I OVR S DGTXT="DT OVRLP W/ "_$P(OVR,U,2) D SETTXT(.DG,.DGTXT),SETCNT(7)
123 .;If inconsistencies found, update ^XTMP("DGMSRPT","MSINC",DFN,
124 .I $D(DGTXT) D SETVET(DFN,CAT,.DGTXT)
125 Q
126CMPWCHK(DFN,DGMS) ; Check Combat and POW data for inconsistencies
127 ; INPUT: DFN - Patient file IEN
128 ; DGMS( - MS data array
129 N DGTXT,CAT,DG,LOC
130 F CAT="COM","POW" K DGTXT S DG=1 I $G(DGMS(CAT,"IND"))="Y" D
131 .; Check for missing data
132 .I $$MISS(CAT,"FDT^TDT^LOC") S DGTXT="DATA MISS" D SETTXT(.DG,.DGTXT),SETCNT($S(CAT="COM":8,1:16))
133 .; Check for imprecise dates (year only)
134 .I $$IMPR(CAT,"FDT^TDT") S DGTXT="DT IMPR" D SETTXT(.DG,.DGTXT),SETCNT($S(CAT="COM":9,1:17))
135 .; Check if dates are valid for the location
136 .I $G(DGMS(CAT,"LOC")) S LOC=$$LOC(DGMS(CAT,"LOC")) I LOC'="" D
137 ..Q:$$CNFLCTDT^DGRPDT($G(DGMS(CAT,"FDT")),$G(DGMS(CAT,"TDT")),LOC)
138 ..S DGTXT="DT INVALID FOR LOC" D SETTXT(.DG,.DGTXT),SETCNT($S(CAT="COM":10,1:18))
139 .; Check if dates are within a Military Service Episode
140 .I $G(DGMS(CAT,"FDT"))!($G(DGMS(CAT,"TDT"))) D
141 ..Q:$$OVRLPCHK^DGRPDT(DFN,$G(DGMS(CAT,"FDT")),$G(DGMS(CAT,"TDT")),-1)
142 ..S DGTXT="DT NOT W/IN MSE" D SETTXT(.DG,.DGTXT),SETCNT($S(CAT="COM":11,1:19))
143 .;If inconsistencies found, update ^XTMP("DGMSRPT","MSINC",DFN,
144 .I $D(DGTXT) D SETVET(DFN,CAT,.DGTXT)
145 Q
146CONFCHK(DFN,DGMS) ; Check Conflict data for inconsistencies
147 N DGTXT,CAT,DG
148 F CAT="VIET","LEB","GREN","PAN","GULF","SOM","YUG" K DGTXT S DG=1 I $G(DGMS(CAT,"IND"))="Y" D
149 .; Check for missing data
150 .I $$MISS(CAT,"FDT^TDT") S DGTXT="DATA MISS" D SETTXT(.DG,.DGTXT),SETCNT(12)
151 .; Check for imprecise dates (year only)
152 .I $$IMPR(CAT,"FDT^TDT") S DGTXT="DT IMPR" D SETTXT(.DG,.DGTXT),SETCNT(13)
153 .; Check if dates are valid for the location
154 .I $G(DGMS(CAT,"FDT"))!($G(DGMS(CAT,"TDT"))) D
155 ..Q:$$CNFLCTDT^DGRPDT($G(DGMS(CAT,"FDT")),$G(DGMS(CAT,"TDT")),CAT)
156 ..S DGTXT="DT INVALID FOR LOC" D SETTXT(.DG,.DGTXT),SETCNT(14)
157 .; Check if dates are within a Military Service Episode
158 .I $G(DGMS(CAT,"FDT"))!($G(DGMS(CAT,"TDT"))) D
159 ..Q:$$OVRLPCHK^DGRPDT(DFN,$G(DGMS(CAT,"FDT")),$G(DGMS(CAT,"TDT")),-1)
160 ..S DGTXT="DT NOT W/IN MSE" D SETTXT(.DG,.DGTXT),SETCNT(15)
161 .;If inconsistencies found, update ^XTMP("DGMSRPT","MSINC",DFN,
162 .I $D(DGTXT) D SETVET(DFN,CAT,.DGTXT)
163 Q
164SETTXT(DG,DGTXT) ; Set array of MS inconsistency text DGTXT(
165 ; INPUT: DG - Subscript for DGTXT array
166 Q:'$G(DG)
167 I $G(DGTXT(DG))="" S DGTXT(DG)=DGTXT Q
168 I $L(DGTXT(DG)_"; "_DGTXT)>36 S DG=DG+1,DGTXT(DG)=DGTXT Q
169 S DGTXT(DG)=DGTXT(DG)_"; "_DGTXT
170 Q
171SETVET(DFN,CAT,DGTXT) ; Update ^XTMP("DGMSRPT","MSINC",DFN, with MS inconsistencies for veteran
172 ;
173 Q:'$G(DFN) Q:'$D(CAT) Q:'$D(DGTXT)
174 N DG S DG=0
175 F S DG=$O(DGTXT(DG)) Q:'DG S @DGXTMP@(DFN,CAT,DG)=DGTXT(DG)
176 Q
177SETCNT(SUB) ; Update ^XTMP("DGMSRPT","MSINC","CNT",
178 ; INPUT: SUB - Subscript in ^("CNT") array to increment
179 Q:$G(SUB)=""
180 S $P(@DGXTMP@("CNT",SUB),U,1)=+(@DGXTMP@("CNT",SUB))+1
181 Q
182MISS(CAT,FLD) ; Check for missing data elements
183 ; INPUT: CAT - MS category, 1st subscript in DGMS array
184 ; FLD - List of fields to check for missing data
185 ; OUTPUT: 1=Missing data; 0=No missing data
186 N MISS,I,X
187 S MISS=0
188 I $G(CAT)=""!($G(FLD)="") Q MISS
189 F I=1:1 S X=$P(FLD,U,I) Q:X="" I '$D(DGMS(CAT,X)) S MISS=1 Q
190 Q MISS
191IMPR(CAT,FLD) ; Check for imprecise dates (year only)
192 ; INPUT: CAT - MS category, 1st subscript in DGMS array
193 ; FLD - List of fields to check for imprecise dates
194 ; OUTPUT: 1=Imprecise date; 0=No imprecise date
195 N IMPR,I,X
196 S IMPR=0
197 I $G(CAT)=""!($G(FLD)="") Q IMPR
198 F I=1:1 S X=$P(FLD,U,I) Q:X="" I $D(DGMS(CAT,X)),'$$MNTHYR^DGRPDT(DGMS(CAT,X)) S IMPR=1 Q
199 Q IMPR
200OVRLP(CAT) ; Check if MSE dates overlap with another MSE
201 ; INPUT: CAT - MS category, 1st subscript in DGMS array
202 ; OUTPUT: 0=No overlap; 1^X=Overlap^MSE that overlaps
203 N OVR,MSE,DGI,DGX
204 S OVR=0
205 I $G(CAT)="" Q OVR
206 S DGX=$E(CAT,4)
207 ; If MSE1, no check; if MSE2, check overlap with MSE1; if MSE3, check
208 ; overlap with MSE2 or MSE1
209 F DGI=(DGX-1):-1:1 S MSE="MSE"_DGI I $D(DGMS(MSE)) D Q:OVR
210 .S OVR=$$WITHIN^DGRPDT($G(DGMS(CAT,"FDT")),$G(DGMS(CAT,"TDT")),$G(DGMS(MSE,"FDT"))) I OVR S OVR=+OVR_U_MSE Q
211 .S OVR=$$WITHIN^DGRPDT($G(DGMS(CAT,"FDT")),$G(DGMS(CAT,"TDT")),$G(DGMS(MSE,"TDT"))) I OVR S OVR=+OVR_U_MSE Q
212 Q OVR
213LOC(LN) ; Return conflict location abbreviation to pass to $$CNFLCTDT^DGRPDT
214 ; INPUT: LN - POW Location file #22 IEN
215 ; OUTPUT: Conflict location abbreviation
216 Q:'$G(LN) ""
217 S LN=$P($G(^DIC(22,LN,0)),U,1) I LN="" Q ""
218 Q:LN="WORLD WAR I" "WWI"
219 Q:LN["EUROPE" "WWIIE"
220 Q:LN["PACIFIC" "WWIIP"
221 Q:LN["KOREA" "KOR"
222 Q:LN["VIETNAM" "VIET"
223 Q:LN="OTHER" ""
224 Q:LN["GULF" "GULF"
225 Q:LN["YUGOSLAVIA" "YUG"
226 Q ""
Note: See TracBrowser for help on using the repository browser.