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

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

initial load of WorldVistAEHR
File size: 9.2 KB
Line 
1DGRPC2 ;ALB/MRL/SCK/PJR,BAJ - CHECK CONSISTENCY OF PATIENT DATA (CONT) ; 11/20/2005
2 ;;5.3;Registration;**45,69,108,121,205,218,342,387,470,467,489,505,507,528,451,564,570,657**;Aug 13, 1993;Build 19
3 ;
443 ;off
544 ;off
645 ;off
746 ;off
847 ;off
9 S DGLST=$S(DGCHK[",47,":47,DGCHK[",46,":46,DGCHK[",45,":45,DGCHK[",44,":44,1:DGLST)
10 D NEXT G @DGLST
1148 I DGVT S DGD=DGP(.362) I DGCHK[(",48,"),($P(DGD,"^",17)="Y"),($P(DGD,"^",6)="") S X=48 D COMB
12 D NEXT G @DGLST
1349 ;
1450 ; insurance checks
15 I DGCHK[",49,"!(DGCHK[",50,") D S DGLST=$S(DGCHK["50":50,1:49)
16 . N COV,INS,X
17 . S X=0,COV=$S($P(DGP(.31),"^",11)="Y":1,1:0)
18 . S INS=$$INSUR^IBBAPI(DFN,DT,"R")
19 . I COV,'INS S X=49 ; yes, but none
20 . I 'COV,INS S X=50 ; not yes, but some
21 . I DGCHK[(","_X_",") D COMB
22 D NEXT G @DGLST
2351 D NEXT G @DGLST ; 51 disabled
24 S X=$S($D(^DIC(21,+$P(DGP(.32),"^",3),0)):$P(^(0),"^",3),1:"")
25 I X="Z"&($P(DGP(.32),"^",5)'=7)&($P(DGP(.32),"^",10)'=7)&($P(DGP(.32),"^",15)'=7)!($P(DGP(.32),"^",5)=7&(X'="Z")) S X=51 D COMB
26 ;
2752 I $P(DGP(.31),"^",11)']"" S X=52 D COMB ;automatically on
28 D NEXT G @DGLST
2953 I $P(DGP(.311),"^",15)']"" S X=53 D COMB ;automatically on
30 D NEXT G @DGLST
3154 ;
3255 ;BELOW IS USED BY BOTH 54 & 55
33 S DGLST=$S(DGCHK["55":55,1:54)
34 I $G(^DPT(DFN,.35)),(^(.35)<+($E(DT,1,3)_"0000")) D NEXT G @DGLST ; patient died before current year
35 N DGE S DGE=+$O(^DIC(8.1,"B","SERVICE CONNECTED 50% to 100%",0))
36 I $P($G(^DPT(DFN,.3)),U,2)'<50!($P($G(^DIC(8,+$G(^DPT(DFN,.36)),0)),U,9)=DGE) D NEXT G @DGLST ;50-100% SC
37 S DGPTYP=$G(^DG(391,+DGP("TYPE"),"S")),DGISYR=$E(DT,1,3)-1_"0000" I '$P(DGPTYP,"^",8)&('$P(DGPTYP,"^",9)) K DGPTYP,DGISYR D NEXT G @DGLST ; screens 8 and 9 off
38 D ALL^DGMTU21(DFN,"VSD",DT,"IP")
39 I '$P(DGPTYP,"^",8)!(DGCHK'["54") G JUST55 ; screen 8 off OR JUST 55 IN CHK
40 S DGFL=0 I $D(DGREL("S")),($$SSN^DGMTU1(+DGREL("S"))']"") S DGFL=1
41 I 'DGFL F I=0:0 S I=$O(DGREL("D",I)) Q:'I I $$SSN^DGMTU1(+DGREL("D",I))']"" S DGFL=1 Q
42 I DGFL S X=54 D COMB
43JUST55 I DGCHK'["55" D NEXT G @DGLST
44 S DGLST=55
45 I '$P(DGPTYP,"^",9) D NEXT G @DGLST ; screen 9 off
46 D TOT^DGRP9(.DGINC) S DGFL=0
47 F DGD="V","S","D" I $D(DGTOT(DGD)) F I=8:1:17 I $P(DGTOT(DGD),"^",I)]"" S DGFL=1 Q
48 I 'DGFL N DGAPD,DG55 D I 'DGAPD&('DG55) S X=55 D COMB
49 . S DGAPD=+$$LST^DGMTU(DFN),DGAPD=+$P($G(^DGMT(408.31,+DGAPD,0)),U,11)
50 . S DG55=$$CHECK55(DFN) ; **507, Additional Income Checks
51 D NEXT G @DGLST
5256 I DGVT S DGD=DGP(.3) I DGCHK[(",56,"),($P(DGD,"^",11)="Y"),($P(DGP(.362),"^",20)="") S X=56 D COMB
53 D NEXT G END^DGRPC3:$S('+DGLST:1,+DGLST=99:1,1:0) G @DGLST
5457 I $P(DGP(.38),U,1) D
55 .N X1,X2
56 .S X1=$P(DGP(.38),U,2)
57 .S X=$P($G(^DG(43,1,0)),U,46) S X2=$S(X:X,1:365) D C^%DTC
58 .I X<DT S X=57 D COMB
59 D NEXT G @DGLST
6058 ;58 - EC Claim - No Gulf/Som Svc
61 ;off
62 D NEXT G @DGLST
6359 ;59 - incomplete Catastrophic Disability info
64 I $$HASCAT^DGENCDA(DFN) D
65 .I '$P(DGP(.39),"^",2) S X=59 D COMB
66 D NEXT G @DGLST
6760 ;60 - Location of agent orange exposure unanswered
68 I DGVT,$P(DGP(.321),"^",2)="Y",$P(DGP(.321),"^",13)="" S X=60 D COMB
69 D NEXT G @DGLST
7061 ;61 - Incomplete Phone Number
71 ; DG*5.3*657 BAJ Phone number check modified
72 ; Home phone check is disabled
73 ; Work phone is required only if pt is employed
74 N EMPST
75 S EMPST=","_$P($G(^DPT(DFN,.311)),U,15)_","
76 I ",1,2,4,"[EMPST,($P(DGP(.13),"^",2)="") S X=61 D COMB
77 D NEXT G @DGLST
7862 ;62 - Missing Emergency Contact Name
79 I $P(DGP(.33),"^")="" S X=62 D COMB
80 D NEXT G @DGLST
8163 ;Confidential Address check
82 I $P($$CAACT^DGRPCADD(DFN),U) D
83 .N DGI,DGERR
84 .S DGERR=0
85 .F DGI=1,4,5,6 Q:DGERR I $P(DGP(.141),U,DGI)="" S DGERR=1
86 .I DGERR S X=63 D COMB
87 D NEXT G @DGLST
8864 ;64 - Place of Birth City/State Missing ;**505
89 I $P(DGP(0),"^",11)=""!($P(DGP(0),"^",12)="") S X=64 D COMB
90 D NEXT G @DGLST
9165 ;65 - Mother's Maiden Name Missing ;**505
92 I $P(DGP(.24),"^",3)="" S X=65 D COMB
93 D NEXT G @DGLST
9466 ;66 - Pseudo SSN in use ;**505
95 ; DG*5.3*657 BAJ 11/20/2005 Removed from CC. Pseudo notice appears in Patient List
96 ;I $P(DGP(0),"^",9)["P" S X=66 D COMB
97 ; off
98 D NEXT G @DGLST
9967 ;67 - Serv Sep Date [Last] missing or imprecise, patch 528
100 N DGG
101 S DGG=$$CVELIG^DGCV(DFN)
102 I $G(DGG)["A"!($G(DGG)["F") S X=67 D COMB
103 D NEXT G @DGLST
10468 ;used for 68-71, for Combat Vet, DG*5.3*528
10569 ;
10670 ;
10771 ;
108 ;68 - Combat To Date missing or imprecise, patch 528
109 ;69 - Yugoslavia To Date missing or imprecise, patch 528
110 ;70 - Somalia To Date missing or imprecise, patch 528
111 ;71 - Persian Gulf To Date missing or imprecise, patch 528
112 N DGG
113 S DGG=$$CVELIG^DGCV(DFN)
114 I DGG["B"!(DGG["G") S X=68 D COMB
115 I DGG["C"!(DGG["H") S X=69 D COMB
116 I DGG["D"!(DGG["I") S X=70 D COMB
117 I DGG["E"!(DGG["J") S X=71 D COMB
118 S DGLST=71
119 D NEXT G @DGLST
12072 ;; MSE - Required Fields
121 S:'$G(MSECHK) MSECHK=$$MSCK^DGMSCK I MSERR S X=72 D COMB
122 D NEXT G @DGLST
12373 ;; An MSE FROM date precedes an MSE TO date
124 S:'$G(MSECHK) MSECHK=$$MSCK^DGMSCK I MSDATERR D NEXT G @DGLST
125 F I1=6,11,16 I '$$B4^DGRPDT($P(DGP(.32),"^",I1),$P(DGP(.32),"^",I1+1),1) S X=73 D COMB S (MSERR,MSDATERR)=1 Q
126 D NEXT G @DGLST
12774 ;; Conflict Date Missing or Incomplete
128 S:'$G(CONCHK) CONCHK=$$CNCK^DGMSCK I CONERR S X=74 D COMB
129 D NEXT G @DGLST
13075 ;; Conflict TO date precedes FROM date
13176 ;; Conflict Date out of range for conflict
132 S:'$G(CONCHK) CONCHK=$$CNCK^DGMSCK
133 S LOC="",(I5,I6)=0 F I1=1:1 S LOC=$O(CONSPEC(LOC)) Q:LOC="" I CONARR(LOC)=1 D
134 .N FROMDAT,FROMPC,TODAT,TOPC,NODE,DATA
135 .S DATA=CONSPEC(LOC)
136 .S NODE=$P(DATA,",",1),FROMPC=$P(DATA,",",3),TOPC=$P(DATA,",",4)
137 .S FROMDAT=$P(DGP(NODE),"^",FROMPC),TODAT=$P(DGP(NODE),"^",TOPC)
138 .I '$$B4^DGRPDT(FROMDAT,TODAT,1) S X=75 D COMB:'I5&(DGCHK[(",75,")) S CONARR(LOC)=2,I5=1 Q
139 .I DGCHK'[(",76,") Q
140 .S:'$G(RANSET) RANSET=$$RANGE^DGMSCK
141 .I '$$RWITHIN^DGRPDT($P(RANGE(LOC),"^",1),$P(RANGE(LOC),"^",2),FROMDAT,TODAT) S X=76 D COMB:'I6 S CONARR(LOC)=2,I6=1
142 .Q
143 S DGLST=76 D NEXT G @DGLST
14477 ;; Date out of range for POW Location
145 S:'$G(RANSET) RANSET=$$RANGE^DGMSCK
146 ;; Don't check if POW Data Incomplete or if POW TO precedes FROM
147 I ((","_DGER_",")[(",37,"))!((","_DGER_",")[(",38,")) D NEXT G @DGLST
148 I $P(DGP(.52),"^",5)'="Y" D NEXT G @DGLST ;; Don't check if no POW
149 S LOC=$$COMPOW^DGRPMS($P(DGP(.52),"^",6)) I LOC="" D NEXT G @DGLST
150 I '$$RWITHIN^DGRPDT($P(RANGE(LOC),"^",1),$P(RANGE(LOC),"^",2),$P(DGP(.52),"^",7),$P(DGP(.52),"^",8)) S X=77 D COMB
151 D NEXT G @DGLST
15278 ;; Date out of range for Combat Location
153 S:'$G(RANSET) RANSET=$$RANGE^DGMSCK
154 ;; Don't check if Combat Data Incomplete or if Combat TO precedes FROM
155 I ((","_DGER_",")[(",39,"))!((","_DGER_",")[(",40,")) D NEXT G @DGLST
156 I $P(DGP(.52),"^",11)'="Y" D NEXT G @DGLST ;; Don't check if no COMBAT
157 S LOC=$$COMPOW^DGRPMS($P(DGP(.52),"^",12)) I LOC="" D NEXT G @DGLST
158 I '$$RWITHIN^DGRPDT($P(RANGE(LOC),"^",1),$P(RANGE(LOC),"^",2),$P(DGP(.52),"^",13),$P(DGP(.52),"^",14)) S X=78 D COMB
159 D NEXT G @DGLST
160COMB S DGCT=DGCT+1,DGER=DGER_X_",",DGLST=X Q
161 ;
162NEXT S I=$F(DGCHK,(","_+DGLST_",")),DGLST=+$E(DGCHK,I,999) I +DGLST,+DGLST<79 Q
163 S:'DGLST DGLST="END^DGRPC3" I +DGLST S DGLST=DGLST_"^DGRPC3"
164 Q
165FIND F I=DGLST:1:99 I DGCHK[(","_I_",") Q
166 I DGNCK,(I>17),(I<36) S DGLST=36 G FIND
167 I I,I<99 S DGLST=I G @(DGLST_$S(DGLST>78:"^DGRPC3",DGLST>42:"",DGLST>17:"^DGRPC1",1:"^DGRPC"))
168 G END^DGRPC3
169 ;
170CHECK55(DFN) ;Buisness rules for additional 55-INCOME DATA MISSING checks
171 ; Modeled from DGMTR checks.
172 ; Input DFN - IEN from PATIENT File #2
173 ;
174 ; Output 1 - If Income check passes additional buisness rules
175 ; 0 - If Income check fails additional buisness rules
176 ;
177 N VAMB,VASV,VA,VADMVT,VAEL,VAINDT,DGRTN,DGMED,DG,DG1,DGWARD,DGSRVC
178 N PCNT
179 ;
180 S DGRTN=0
181 D MB^VADPT I +VAMB(7) S DGRTN=1 G Q55 ; Check if receiving VA Disability
182 D SVC^VADPT I +VASV(4) S DGRTN=1 G Q55 ; check if POW status indicated
183 I +VASV(9),(+VASV(9,1)=3) S DGRTN=1 G Q55 ; Check if Purple Heart Status is Confirmed
184 D GETS^DIQ(2,DFN_",",".381:.383","I","DGMED")
185 I $G(DGMED(2,DFN_",",.381,"I")) S DGRTN=1 G Q55 ; Check if eligible for Medicaid
186 D ADM^VADPT2 ; Check for current admission to DOM ward
187 I +$G(VADMVT) D G:DGRTN Q55
188 . Q:'$$GET1^DIQ(43,1,16,"I") ; Has Dom wards?
189 . S DGWARD=$$GET1^DIQ(405,VADMVT,.06,"I") ; Get ward location
190 . S DGSRVC=$$GET1^DIQ(42,DGWARD,.03,"I") ; Get ward service
191 . S:DGSRVC="D" DGRTN=1 ; If ward service is 'D', then return 1
192 ;
193 ; Additional checks for 0% SC
194 D ELIG^VADPT
195 I +VAEL(3),'$P(VAEL(3),U,2) D ; Check if service connected with % of zero
196 . I +VAMB(4) S DGRTN=1 Q ; Check if receiving a VA pension
197 . S DG=0 ; Check for secondary eligibilities
198 . F S DG=$O(VAEL(1,DG)) Q:'DG D Q:DGRTN
199 . . F DG1=2,4,15,16,17,18 I DG=DG1 S DGRTN=1 Q
200 ; DG*5.3*657 BAJ
201 ; Additional business rules
202 ; Do NOT file inconsistency for the following:
203 ; 1. Service Connected = YES, Eligibility Code is "SC LESS THAN 50%", SC % is 10-49, A&A = "YES"
204 ; 2. Service Connected = YES, Eligibility Code is "SC LESS THAN 50%", SC % is 10-49, VA Pension = "YES"
205 ; 3. Patient Type is "NSC Veteran" and A&A = "YES"
206 ; 4. Patient Type is "NSC Veteran" and VA Pension = "YES"
207 ; Arrays elements used:
208 ; .. VAEL(3) $P 1 = SERVICE CONNECTED? $P 2 = SC %
209 ; .. VAEL(6) $P 2 = PATIENT TYPE, "B" INDEX VALUE
210 ; .. VAMB(1) $P 1 = RECEIVING A&A
211 ; .. VAMB(4) $P 1 = RECEIVING VA PENSION
212 I $P(VAEL(1),"^",2)="SC LESS THAN 50%",+VAEL(3) S PCNT=$P(VAEL(3),"^",2) I PCNT'<10,PCNT'>50 S DGRTN=$S(+VAMB(1):1,VAMB(4):1,1:DGRTN)
213 I $P($G(VAEL(6)),"^",2)="NSC VETERAN" S DGRTN=$S(+VAMB(1):1,VAMB(4):1,1:DGRTN)
214Q55 D KVAR^VADPT
215 Q $G(DGRTN)
Note: See TracBrowser for help on using the repository browser.