source: WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CR.m

Last change on this file was 623, checked in by George Lilly, 15 years ago

revised back to 6/30/08 version

File size: 9.3 KB
Line 
1IVMZ7CR ;BAJ - HL7 Z07 CONSISTENCY CHECKER -- REGISTRATION SUBROUTINE ; 12/7/05 12:24pm
2 ;;2.0;INCOME VERIFICATION MATCH;**105**;JUL 8,1996;Build 2
3 ;
4 ; Registration Consistency Checks
5 Q ; Entry point must be specified
6EN(DFN,DGP,DGSD) ;Entry point
7 ; input: DFN - Patient IEN
8 ; DGP - Patient data array
9 ; DGSD - Spouse and Dependent data array
10 ; output: ^TMP($J,DFN,RULE) global
11 ; DFN - Patient IEN
12 ; RULE - Consistency rule #
13 ;initialize variables
14 N RULE,Y,X,FILERR,SPDEP
15 S SPDEP=$D(DGSD("DEP"))
16 ; we do not count through all numbers to save routine space
17 F RULE=4,7,9,11,13,15,16,19,24,29:1:31,34,60,72,74,78,81,83,85,86 I $D(^DGIN(38.6,RULE)) D
18 . I $$ON(RULE) D @RULE
19 I $D(FILERR) M ^TMP($J,DFN)=FILERR
20 Q
214 ; DOB UNSPECIFIED
22 ; Note: RULE #302 in IVMZ7CD is a duplicate of this rule
23 N RIEN
24 I $P($G(DGP("PAT",0)),U,3)="" S FILERR(RULE)=""
25 I 'SPDEP Q
26 S RIEN=0 F S RIEN=$O(DGSD("DEP",RIEN)) Q:RIEN="" D
27 . I $P(DGSD("DEP",RIEN,0),U,3)="" S FILERR(RULE)=""
28 Q
297 ; SSN UNSPECIFIED
30 ; Note: RULE #305 in IVMZ7CD is a duplicate of this rule
31 I $P($G(DGP("PAT",0)),U,9)="" S FILERR(RULE)=""
32 Q
339 ; VETERAN STATUS UNSPECIFIED
34 I $P($G(DGP("PAT","VET")),U)="" S FILERR(RULE)=""
35 Q
3611 ; SC PROMPT INCONSISTENT
37 N VET,SC,PTYPE
38 ; If VET Status is not specified (RULE 9) no need for this test
39 Q:$P($G(DGP("PAT","VET")),U)=""
40 S VET=$P(DGP("PAT","VET"),U,1)="Y",SC=$P(DGP("PAT",.3),U,1)="Y"
41 I 'VET,SC S FILERR(RULE)=""
42 Q
4313 ; POS UNSPECIFIED
44 ; Note: Rule #413 IN IVMZ7CE is a duplicate of this rule
45 Q:$P($G(DGP("PAT","VET")),U,1)'="Y"
46 ; Make sure that the value in the field is valid -- DGRPC does this as well
47 I '$D(^DIC(21,+$P(DGP("PAT",.32),U,3),0)) S FILERR(RULE)=""
48 Q
4915 ; INEL REASON UNSPECIFIED
50 ; Note: Rule #404 IN IVMZ7CE is a duplicate of this rule
51 I $P(DGP("PAT",.15),U,2),$P($G(DGP("PAT",.3)),U,7)="" S FILERR(RULE)=""
52 Q
5316 ; DATE OF DEATH IN FUTURE
54 ; Note: Rule #308 IN IVMZ7CD is a duplicate of this rule
55 S X=$P($G(DGP("PAT",.35)),U) I X']"" Q
56 ; Compare DOD to right now
57 I X>$$DT^XLFDT S FILERR(RULE)=""
58 Q
5919 ; ELIG/NONVET STAT INCONSISTENT
60 ; Note: Rule #405 in IVMZ7CE is a duplicate of this rule
61 N VET,ELIG,FILE8,FILE81,MPTR,MTYPE,PTYPE
62 ; Patient's VET status
63 S VET=$P($G(DGP("PAT","VET")),U,1) I VET="" S FILERR(RULE)="" Q
64 ; do this check for NON-VET status only
65 Q:VET="Y"
66 ; Check PT type to see if we skip VET checks
67 S PTYPE=$P($G(DGP("PAT","TYPE")),U,1)
68 I PTYPE]"",$P(^DG(391,PTYPE,0),U,2) Q
69 ; Eligibility Code
70 S ELIG=$P($G(DGP("PAT",.36)),U,1) I ELIG="" S FILERR(RULE)="" Q
71 ;start in File #8
72 S FILE8=$G(^DIC(8,ELIG,0)) I FILE8="" S FILERR(RULE)="" Q
73 ;using the pointer value in field #8 (node 0; piece 9)
74 S MPTR=$P(FILE8,U,9)
75 ;find the record in File #8.1
76 S FILE81=$G(^DIC(8.1,MPTR,0)) I FILE81="" S FILERR(RULE)="" Q
77 ;check the Type field #4 (node 0; piece 5).
78 S MTYPE=$P(FILE81,U,5)
79 ; Pt's VET status must match NON-VET Status of Eligibility Code
80 I VET'=MTYPE S FILERR(RULE)=""
81 Q
8224 ; POS/ELIG CODE INCONSISTENT
83 ; Note: Rule #412 in IVMZ7CE is a duplicate of this rule
84 I '$D(^DIC(21,+$P(DGP("PAT",.32),U,3),"E",+$P(DGP("PAT",.36),U,1))) S FILERR(RULE)=""
85 Q
8629 ; A&A CLAIMED, NONVET
87 I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.362)),U,12)="Y" S FILERR(RULE)=""
88 Q
8930 ; HOUSEBOUND CLAIMED, NONVET
90 I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.362)),U,13)="Y" S FILERR(RULE)=""
91 Q
9231 ; VA PENSION CLAIMED, NONVET
93 I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.362)),U,14)="Y" S FILERR(RULE)=""
94 Q
9534 ; POW CLAIMED, NONVET
96 I $P(DGP("PAT","VET"),U,1)'="Y",$P($G(^DPT(DFN,.52)),U,5)="Y" S FILERR(RULE)=""
97 Q
9860 ; AGENT ORANGE EXP LOC MISSING
99 ; Note: Rule #512 in IVMZ7CS is a duplicate of this rule.
100 I $P(DGP("PAT",.321),U,2)="Y",$P(DGP("PAT",.321),U,13)="" S FILERR(RULE)=""
101 Q
10272 ; MSE DATA MISSING/INCOMPLETE
103 ; Note: Rule #513 in IVMZ7CS is a duplicate of this rule.
104 N I,X
105 S X=DGP("PAT",.32)
106 F I=4,5,8 I $P(X,U,I)'="",'$$YY^IVMZ7CS($P(X,U,6)) S FILERR(RULE)="" Q ;LAST
107 F I=9,10,13 I $P(X,U,I)'="",'$$YY^IVMZ7CS($P(X,U,11)) S FILERR(RULE)="" Q ;NTL
108 F I=14,15,18 I $P(X,U,I)'="",'$$YY^IVMZ7CS($P(X,U,11)) S FILERR(RULE)="" ;NNTL
109 Q
110 ;
11174 ; CONFLICT DT MISSING/INCOMPLETE
112 ; Note: Rule #515 in IVMZ7CS is a duplicate of this rule.
113 ; ALSO # 75 CONFLICT TO DT BEFORE FROM DT
114 ; # 76 INACCURATE CONFLICT DATE
115 ;
116 N I,T,FROM,TO,RULE1,RULE2,NODE,PCE,PCEFR,PCETO,CONFL,RANGE,RFR,RTO,RNGE,ERR,COM,ON75,ON76
117 S RULE1=75,RULE2=76
118 S ON75=$$ON(75),ON76=$$ON(76)
119 S I=$$RANGE^DGMSCK() ; load range table
120 F I=1:1 S CONFL=$P($T(CONLIST+I),";;",3) Q:CONFL="QUIT" D
121 . ;we have to have a flag ERR because we don't want multiple
122 . ;inconsistencies on a single conflict but we do want to
123 . ;flag a single inconsistency on multiple conflicts
124 . S ERR=0
125 . S NODE=$P(CONFL,U,1),PCE=$P(CONFL,U,2),PCEFR=$P(CONFL,U,3),PCETO=$P(CONFL,U,4)
126 . S RNGE=$P(CONFL,U,5)
127 . Q:$P(DGP("PAT",NODE),U,PCE)'="Y"
128 . S FROM=$P(DGP("PAT",NODE),U,PCEFR),TO=$P(DGP("PAT",NODE),U,PCETO)
129 . ; check rule 74 CONFLICT DT MISSING/INCOMPLETE
130 . F T=FROM,TO I '$$YM^IVMZ7CS(T) S FILERR(RULE)="",ERR=1
131 . Q:ERR
132 . ; check rule 75 CONFLICT TO DT BEFORE CONFLICT FROM DT
133 . I ON75,FROM>TO S FILERR(RULE1)="",ERR=1
134 . Q:ERR
135 . ; check rule 76 INACCURATE CONFLICT DATE
136 . Q:ERR
137 . Q:'$D(RANGE(RNGE)) ; can't calculate if range table is missing
138 . ; determine whether dates are withing conflict range
139 . S RFR=$P(RANGE(RNGE),U,1),RTO=$P(RANGE(RNGE),U,2)
140 . I ON76 D
141 . . I '((RFR'>FROM)&((RTO'<TO))) S FILERR(RULE2)=""
142 Q
14378 ; INACCURATE COMBAT DT/LOC
144 N I,T,FROM,TO,RULE,NODE,PCE,PCEFR,PCETO,CONFL,RANGE,RFR,RTO,RNGE,ERR,COM,ON78,LOC
145 ; This tag checks COMBAT status and verifies that valid FROM & TO dates are found
146 S RULE=78
147 I '$$ON(RULE) Q
148 S I=$$RANGE^DGMSCK() ; load range table
149 F I=1:1 S CONFL=$P($T(COMLIST+I),";;",3) Q:CONFL="QUIT" D
150 . S NODE=$P(CONFL,U,1),PCE=$P(CONFL,U,2),PCEFR=$P(CONFL,U,3),PCETO=$P(CONFL,U,4)
151 . S RNGE=$P(CONFL,U,5)
152 . ; if we have COMBAT data, get Service Location info, it comes under a different rule
153 . Q:$P(DGP("PAT",NODE),U,PCE)'="Y"
154 . S RNGE=$$COMPOW^DGRPMS($P(DGP("PAT",.52),U,12)) I $G(RNGE)="" S FILERR(RULE)="" Q
155 . S FROM=$P(DGP("PAT",NODE),U,PCEFR),TO=$P(DGP("PAT",NODE),U,PCETO)
156 . ; determine whether Pt dates are within conflict range for specified location
157 . S RFR=$P(RANGE(RNGE),U,1),RTO=$P(RANGE(RNGE),U,2)
158 . I '(RFR'>FROM&((FROM'>RTO)&((RTO'<TO)&((TO'<RFR))))) S FILERR(RULE)=""
159 Q
16081 ; COMBAT DT NOT WITHIN MSE
161 ; this code is copied from DGRP3
162 ; MSFROMTO^DGMSCK creates a block for a continual MSE
163 N MSE,MSECHK,MSESET,ANYMSE,DGP81
164 I '$P($G(DGP("PAT",.52)),U,12) Q
165 ;
166 ; we're calling into DG Legacy code so we have to modify some arrays
167 M DGP81=DGP K DGP
168 M DGP=DGP81("PAT")
169 ; set up the check
170 S:'$G(MSECHK) MSECHK=$$MSCK^DGMSCK S:'$G(MSESET) MSESET=$$MSFROMTO^DGMSCK
171 ; If COMBAT, but no MSE, then Range is NOT within MSE
172 I '$G(ANYMSE) D Q
173 . S FILERR(RULE)=""
174 . K DGP M DGP=DGP81
175 I '$$RWITHIN^DGRPDT($P(MSESET,U,1),$P(MSESET,U,2),$P($G(DGP81("PAT",.52)),U,13),$P($G(DGP81("PAT",.52)),U,14)) S FILERR(RULE)=""
176 K DGP M DGP=DGP81
177 Q
178 ;
17983 ; BOS REQUIRES DATE W/IN WWII
180 ; this code is copied from DGRP3
181 N BOS,BOSN,MS,MSE,DGP83
182 Q:'$D(DGP("PAT",.32))
183 ; we're calling into DG Legacy code so we have to modify some arrays
184 M DGP83=DGP K DGP
185 M DGP=DGP83("PAT")
186 F MS=1:1:3 D
187 . I MS=2,$P(DGP83("PAT",.32),U,19)'="Y" Q
188 . I MS=3,$P(DGP83("PAT",.32),U,20)'="Y" Q
189 . S BOS=$P(DGP83("PAT",.32),U,(5*MS)) Q:'BOS S BOSN=$P($G(^DIC(23,BOS,0)),U)
190 . S MSE=$P("MSL^MSNTL^MSNNTL",U,MS)
191 . I $$BRANCH^DGRPMS(BOS_U_BOSN),'$$WWII^DGRPMS(DFN,"",MSE) S FILERR(RULE)=""
192 ; fix the arrays before we leave
193 K DGP M DGP=DGP83
194 Q
19585 ; FILIPINO VET SHOULD BE VET='Y'
196 ; this code is copied from DGRP3
197 N MS,BOS,FV,FILV,NOTFV,MSE,RULE2,DGVT,DGP85
198 Q:'$D(DGP("PAT",.32))
199 ; we're calling into DG Legacy code so we have to modify some arrays
200 S DGVT=$P($G(DGP("PAT","VET")),U)="Y"
201 M DGP85=DGP K DGP
202 M DGP=DGP85("PAT")
203 S RULE2=86 ; will also check RULE #86 INEL FIL VET SHOULD BE VET='N'
204 F MS=1:1:3 D
205 . I MS=2,$P(DGP85("PAT",.32),U,19)'="Y" Q
206 . I MS=3,$P(DGP85("PAT",.32),U,20)'="Y" Q
207 . S BOS=$P(DGP85("PAT",.32),U,(5*MS)),FV=$$FV^DGRPMS(BOS) I 'FV S NOTFV="" Q
208 . S MSE=$P("MSL^MSNTL^MSNNTL",U,MS)
209 . I '$$WWII^DGRPMS(DFN,"",MSE) S FILV("I")="" Q
210 . I FV=2 S FILV("E")="" Q
211 . I $P(DGP85("PAT",.321),U,14)=""!($P(DGP85("PAT",.321),U,14)="NO") S FILV("I")="" Q
212 . S FILV("E")=""
213 I $D(FILV) D
214 . I DGVT'=1,$D(FILV("E")) S FILERR(RULE)=""
215 . I DGVT=1,'$D(NOTFV),'$D(FILV("E")),$D(FILV("I")) S FILERR(RULE2)=""
216 ; fix the arrays before we leave
217 K DGP M DGP=DGP85
218 Q
21986 ; INEL FIL VET SHOULD BE VET='N'
220 ; This rule is satisfied in #85 above
221 Q
222ON(RULE) ;verify RULE is turned on
223 N ON,Y
224 S ON=0
225 S Y=^DGIN(38.6,RULE,0)
226 I '$P(Y,U,5),$P(Y,U,6) S ON=1
227 Q ON
228CONLIST ;;CONFLICT;;NODE^PIECE^FROM^TO^RANGE -- offset list, do not add comments
229 ;;VIETNAM;;.321^1^4^5^VIET
230 ;;LEBANON;;.322^1^2^3^LEB
231 ;;GRENADA;;.322^4^5^6^GREN
232 ;;PANAMA;;.322^7^8^9^PAN
233 ;;PERSIAN GULF;;.322^10^11^12^GULF
234 ;;SOMALIA;;.322^16^17^18^SOM
235 ;;YUGOSLAVIA;;.322^19^20^21^YUG
236 ;;QUIT;;QUIT
237COMLIST ;;COMBAT;;NODE^PIECE^FROM^TO^RANGE -- offset list, do not add comments
238 ;;WWI;;.52^11^13^14^WWI
239 ;;WWIIE;;.52^11^13^14^WWIIE
240 ;;WWIIP;;.52^11^13^14^WWIIP
241 ;;KOREA;;.52^11^13^14^KOR
242 ;;OTHER;;.52^11^13^14^OTHER
243 ;;VIETNAM;;.52^11^13^14^VIET
244 ;;LEBANON;;.52^11^13^14^LEB
245 ;;GRENADA;;.52^11^13^14^GREN
246 ;;PANAMA;;.52^11^13^14^PAN
247 ;;PERSIAN GULF;;.52^11^13^14^GULF
248 ;;SOMALIA;;.52^11^13^14^SOM
249 ;;YUGOSLAVIA;;.52^11^13^14^YUG
250 ;;QUIT;;QUIT
Note: See TracBrowser for help on using the repository browser.