DGRPC2 ;ALB/MRL/SCK/PJR/BAJ/LBD/BDB - CHECK CONSISTENCY OF PATIENT DATA (CONT) ; 10/14/10 9:56am
;;5.3;Registration;**45,69,108,121,205,218,342,387,470,467,489,505,507,528,451,564,570,657,688,780,797,858,895,993,1027**;Aug 13, 1993;Build 70
;
43 ;off
44 ;off
45 ;off
46 ;off
47 ;off
S DGLST=$S(DGCHK[",47,":47,DGCHK[",46,":46,DGCHK[",45,":45,DGCHK[",44,":44,1:DGLST)
D NEXT G @DGLST
48 I DGVT S DGD=DGP(.362) I DGCHK[(",48,"),($P(DGD,"^",17)="Y"),($P(DGD,"^",6)="") S X=48 D COMB
D NEXT G @DGLST
49 ;
50 ; insurance checks
I DGCHK[",49,"!(DGCHK[",50,") D S DGLST=$S(DGCHK["50":50,1:49)
. N COV,INS,X
. S X=0,COV=$S($P(DGP(.31),"^",11)="Y":1,1:0)
. S INS=$$INSUR^IBBAPI(DFN,DT,"R")
. I COV,'INS S X=49 ; yes, but none
. I 'COV,INS S X=50 ; not yes, but some
. I DGCHK[(","_X_",") D COMB
D NEXT G @DGLST
51 D NEXT G @DGLST ; 51 disabled
S X=$S($D(^DIC(21,+$P(DGP(.32),"^",3),0)):$P(^(0),"^",3),1:"")
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
;
52 I $P(DGP(.31),"^",11)']"" S X=52 D COMB ;automatically on
D NEXT G @DGLST
53 I $P(DGP(.311),"^",15)']"" S X=53 D COMB ;automatically on
D NEXT G @DGLST
54 ;
55 ;BELOW IS USED BY BOTH 54 & 55
N DGMT
S DGLST=$S(DGCHK["55":55,1:54)
I $G(^DPT(DFN,.35)),(^(.35)<+($E(DT,1,3)_"0000")) D NEXT G @DGLST ; patient died before current year
N DGE S DGE=+$O(^DIC(8.1,"B","SERVICE CONNECTED 50% to 100%",0))
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
;Begin DG*5.3*993 Registration Only or enroll before patch does not require Income Analysis
N DGQUIT,DRGFLG S DGQUIT=0 I DGLST=55 D I DGQUIT D NEXT G @DGLST
. I ($G(DGENRYN)=0) S DRGFLG=1 S DGQUIT=1
. I '$D(DGENRYN)!($G(DGENRYN)="") D Q:DGQUIT
. . N DGEXST S DGEXST=$$PREEXIST^DGREG(DFN) I DGEXST=1 S DGQUIT=1
. . N STATUS S STATUS=$$STATUS^DGENA($G(DFN)) I STATUS=25 S DGQUIT=1
;End changes for for DG*5.3*993
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
; If current/not outdated means test exits, pass to income retrieval
; Patch 780
S DGMT=$$LST^DGMTU(DFN)
;DG*5.3*858 MT less than 1 year old as of "VFA Start Date" and point forward do not expire
I DGMT,$$OLDMTPF^DGMTU4($P(DGMT,U,2)) S DGMT=""
D ALL^DGMTU21(DFN,"VSD",$S(DGMT:$P(DGMT,U,2),1:DT),"IP",$S(DGMT:DGMT,1:""))
I '$P(DGPTYP,"^",8)!(DGCHK'["54") G JUST55 ; screen 8 off OR JUST 55 IN CHK ; 1027 !NOTVETCHANGED
; I VETCHANGED G 56 ; screen 8 off OR JUST 55 IN CHK ; 1027
S DGFL=0 I $D(DGREL("S")),($$SSN^DGMTU1(+DGREL("S"))']"") S DGFL=1
I 'DGFL F I=0:0 S I=$O(DGREL("D",I)) Q:'I I $$SSN^DGMTU1(+DGREL("D",I))']"" S DGFL=1 Q
I DGFL S X=54 D COMB
JUST55 I DGCHK'["55" D NEXT G @DGLST
S DGLST=55
I '$P(DGPTYP,"^",9) D NEXT G @DGLST ; screen 9 off
D TOT^DGRP9(.DGINC) S DGFL=0
F DGD="V","S","D" I $D(DGTOT(DGD)) F I=8:1:17 I $P(DGTOT(DGD),"^",I)]"" S DGFL=1 Q
I 'DGFL N DGAPD,DG55 D I 'DGAPD&('DG55) S X=55 D COMB
. S DGAPD=+$$LST^DGMTU(DFN),DGAPD=+$P($G(^DGMT(408.31,+DGAPD,0)),U,11)
. S DG55=$$CHECK55(DFN) ; **507, Additional Income Checks
D NEXT G @DGLST
56 I DGVT S DGD=DGP(.3) I DGCHK[(",56,"),($P(DGD,"^",11)="Y"),($P(DGP(.362),"^",20)="") S X=56 D COMB
D NEXT G END^DGRPC3:$S('+DGLST:1,+DGLST=99:1,1:0) G @DGLST
57 I $P(DGP(.38),U,1) D
.N X1,X2
.S X1=$P(DGP(.38),U,2)
.S X=$P($G(^DG(43,1,0)),U,46) S X2=$S(X:X,1:365) D C^%DTC
.I X<DT S X=57 D COMB
D NEXT G @DGLST
58 ;58 - EC Claim - No Gulf/Som Svc
;off
;DG*5.3*688 changed the wording of Environmental Contaminants
;so if this cc is ever activated the text in ^DGIN(38.6,58
;needs to be changed to Southwest Asia Conditions.
D NEXT G @DGLST
59 ;59 - incomplete Catastrophic Disability info
I $$HASCAT^DGENCDA(DFN) D
.I '$P(DGP(.39),"^",2) S X=59 D COMB
D NEXT G @DGLST
60 ;60 - Location of agent orange exposure unanswered
I DGVT,$P(DGP(.321),"^",2)="Y",$P(DGP(.321),"^",13)="" S X=60 D COMB
D NEXT G @DGLST
61 ;61 - Incomplete Phone Number
; DG*5.3*657 BAJ Phone number check modified
; Home phone check is disabled
; Work phone is required only if pt is employed
N EMPST
S EMPST=","_$P($G(^DPT(DFN,.311)),U,15)_","
I ",1,2,4,"[EMPST,($P(DGP(.13),"^",2)="") S X=61 D COMB
D NEXT G @DGLST
62 ;62 - Missing Emergency Contact Name
I $P(DGP(.33),"^")="" S X=62 D COMB
D NEXT G @DGLST
63 ;Confidential Address check
N STR63,J,DGI,DGERR
S DGERR=0
I $P(DGP(.141),U,9)="Y",$P($$CAACT^DGRPCADD(DFN),U) D
. ; country is either NULL or non-numeric
. I '$P(DGP(.141),U,16) S DGERR=1 Q
. ; country is not in Country file
. I '$D(^HL(779.004,$P(DGP(.141),"^",16))) S DGERR=1 Q
. S STR63="1,4,5,6" I $$FORIEN^DGADDUTL($P(DGP(.141),"^",16)) S STR63="1,4"
. F J=1:1:$L(STR63,",") S DGI=$P(STR63,",",J) Q:DGERR I $P(DGP(.141),U,DGI)="" S DGERR=1
I DGERR S X=63 D COMB
D NEXT G @DGLST
64 ;64 - Place of Birth City/State Missing ;**505
I $P(DGP(0),"^",11)=""!($P(DGP(0),"^",12)="") S X=64 D COMB
D NEXT G @DGLST
65 ;65 - Mother's Maiden Name Missing ;**505
I $P(DGP(.24),"^",3)="" S X=65 D COMB
D NEXT G @DGLST
66 ;66 - Pseudo SSN in use ;**505
; DG*5.3*657 BAJ 11/20/2005 Removed from CC. Pseudo notice appears in Patient List
;I $P(DGP(0),"^",9)["P" S X=66 D COMB
; off
D NEXT G @DGLST
67 ;67 - Serv Sep Date [Last] missing or imprecise, patch 528
N DGG
S DGG=$$CVELIG^DGCV(DFN)
I $G(DGG)["A"!($G(DGG)["F") S X=67 D COMB
D NEXT G @DGLST
68 ;used for 68-71, for Combat Vet, DG*5.3*528
69 ;
70 ;
71 ;
;68 - Combat To Date missing or imprecise, patch 528
;69 - Yugoslavia To Date missing or imprecise, patch 528
;70 - Somalia To Date missing or imprecise, patch 528
;71 - Persian Gulf To Date missing or imprecise, patch 528
N DGG
S DGG=$$CVELIG^DGCV(DFN)
I DGG["B"!(DGG["G") S X=68 D COMB
I DGG["C"!(DGG["H") S X=69 D COMB
I DGG["D"!(DGG["I") S X=70 D COMB
I DGG["E"!(DGG["J") S X=71 D COMB
S DGLST=71
D NEXT G @DGLST
72 ;; MSE - Required Fields
S:'$G(MSECHK) MSECHK=$$MSCK^DGMSCK I MSERR S X=72 D COMB
D NEXT G @DGLST
73 ;; An MSE FROM date precedes an MSE TO date
S:'$G(MSECHK) MSECHK=$$MSCK^DGMSCK I MSDATERR D NEXT G @DGLST
N I1
;Use MSE data in DGPMSE array, if it exists (DG*5.3*797)
I $D(DGPMSE) D D NEXT G @DGLST
.N OUT S I1=0 F S I1=$O(DGPMSE(I1)) Q:'I1!($G(OUT)) D
..I $P(DGPMSE(I1),U,7) Q ;Don't check MSE verified by HEC
..I '$$B4^DGRPDT($P(DGPMSE(I1),U),$P(DGPMSE(I1),U,2),1) S X=73 D COMB S (MSERR,MSDATERR,OUT)=1 Q
;Otherwise, use MSE data in DGP(.32)
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
D NEXT G @DGLST
74 ;; Conflict Date Missing or Incomplete
S:'$G(CONCHK) CONCHK=$$CNCK^DGMSCK I CONERR S X=74 D COMB
D NEXT G @DGLST
75 ;; Conflict TO date precedes FROM date
76 ;; Conflict Date out of range for conflict
S:'$G(CONCHK) CONCHK=$$CNCK^DGMSCK
S LOC="",(I5,I6)=0 F I1=1:1 S LOC=$O(CONSPEC(LOC)) Q:LOC="" I CONARR(LOC)=1 D
.N FROMDAT,FROMPC,TODAT,TOPC,NODE,DATA
.S DATA=CONSPEC(LOC)
.S NODE=$P(DATA,",",1),FROMPC=$P(DATA,",",3),TOPC=$P(DATA,",",4)
.S FROMDAT=$P(DGP(NODE),"^",FROMPC),TODAT=$P(DGP(NODE),"^",TOPC)
.I '$$B4^DGRPDT(FROMDAT,TODAT,1) S X=75 D COMB:'I5&(DGCHK[(",75,")) S CONARR(LOC)=2,I5=1 Q
.I DGCHK'[(",76,") Q
.S:'$G(RANSET) RANSET=$$RANGE^DGMSCK
.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
.Q
S DGLST=76 D NEXT G @DGLST
77 ;; Date out of range for POW Location
;; Check turned off by EVC project (DG*5.3*688)
D NEXT G @DGLST
78 ;; Date out of range for Combat Location
S:'$G(RANSET) RANSET=$$RANGE^DGMSCK
;; Don't check if Combat Data Incomplete or if Combat TO precedes FROM
I ((","_DGER_",")[(",39,"))!((","_DGER_",")[(",40,")) D NEXT G @DGLST
I $P(DGP(.52),"^",11)'="Y" D NEXT G @DGLST ;; Don't check if no COMBAT
S LOC=$$COMPOW^DGRPMS($P(DGP(.52),"^",12)) I LOC="" D NEXT G @DGLST
I '$$RWITHIN^DGRPDT($P(RANGE(LOC),"^",1),$P(RANGE(LOC),"^",2),$P(DGP(.52),"^",13),$P(DGP(.52),"^",14)) S X=78 D COMB
D NEXT G @DGLST
COMB S DGCT=DGCT+1,DGER=DGER_X_",",DGLST=X Q
;
NEXT S I=$F(DGCHK,(","_+DGLST_",")),DGLST=+$E(DGCHK,I,999) I +DGLST,+DGLST<79 Q
S:'DGLST DGLST="END^DGRPC3" I +DGLST S DGLST=DGLST_"^DGRPC3"
Q
FIND F I=DGLST:1:99 I DGCHK[(","_I_",") Q
I DGNCK,(I>17),(I<36) S DGLST=36 G FIND
I I,I<99 S DGLST=I G @(DGLST_$S(DGLST>78:"^DGRPC3",DGLST>42:"",DGLST>17:"^DGRPC1",1:"^DGRPC"))
G END^DGRPC3
;
CHECK55(DFN) ;Business rules for additional 55-INCOME DATA MISSING checks
; Modeled from DGMTR checks.
; Input DFN - IEN from PATIENT File #2
;
; Output 1 - If Income check passes additional business rules
; 0 - If Income check fails additional business rules
;
N VAMB,VASV,VA,VADMVT,VAEL,VAINDT,DGRTN,DGMED,DG,DG1,DGWARD,DGSRVC,DGCOPAY
;
S DGRTN=0
D MB^VADPT I +VAMB(7) S DGRTN=1 G Q55 ; Check if receiving VA Disability
D SVC^VADPT I +VASV(4) S DGRTN=1 G Q55 ; check if POW status indicated
I +VASV(9),(+VASV(9,1)=3) S DGRTN=1 G Q55 ; Check if Purple Heart Status is Confirmed
D GETS^DIQ(2,DFN_",",".381:.383","I","DGMED")
I $G(DGMED(2,DFN_",",.381,"I")) S DGRTN=1 G Q55 ; Check if eligible for Medicaid
D ADM^VADPT2 ; Check for current admission to DOM ward
I +$G(VADMVT) D G:DGRTN Q55
. Q:'$$GET1^DIQ(43,1,16,"I") ; Has Dom wards?
. S DGWARD=$$GET1^DIQ(405,VADMVT,.06,"I") ; Get ward location
. S DGSRVC=$$GET1^DIQ(42,DGWARD,.03,"I") ; Get ward service
. S:DGSRVC="D" DGRTN=1 ; If ward service is 'D', then return 1
;
; Additional checks for 0% SC
D ELIG^VADPT
I +VAEL(3),'$P(VAEL(3),U,2) D ; Check if service connected with % of zero
. I +VAMB(4) S DGRTN=1 Q ; Check if receiving a VA pension
. S DG=0 ; Check for secondary eligibilities
. F S DG=$O(VAEL(1,DG)) Q:'DG D Q:DGRTN
. . F DG1=2,4,15,16,17,18 I DG=DG1 S DGRTN=1 Q
; DG*5.3*657 BAJ
; Additional business rules
; Do NOT file inconsistency for the following:
; 1. Service Connected = YES, Eligibility Code is "SC LESS THAN 50%", SC % is 10-49, A&A = "YES"
; 2. Service Connected = YES, Eligibility Code is "SC LESS THAN 50%", SC % is 10-49, VA Pension = "YES"
; 3. Patient Type is "NSC Veteran" and A&A = "YES"
; 4. Patient Type is "NSC Veteran" and VA Pension = "YES"
; Arrays elements used:
; .. VAEL(3) $P 1 = SERVICE CONNECTED? $P 2 = SC %
; .. VAEL(6) $P 2 = PATIENT TYPE, "B" INDEX VALUE
; .. VAMB(1) $P 1 = RECEIVING A&A
; .. VAMB(4) $P 1 = RECEIVING VA PENSION
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)
; DG*5.3*895 Check if service connected between 0% & 50% and copay exempt
S DGCOPAY=$O(^DGMT(408.31,"C",DFN,""))
I DGCOPAY I $G(PCNT)>0,$G(PCNT)'>50,$P($G(^DGMT(408.31,DGCOPAY,2)),U,3)=8 S DGRTN=1
I $P($G(VAEL(6)),"^",2)="NSC VETERAN" S DGRTN=$S(+VAMB(1):1,VAMB(4):1,1:DGRTN)
;
Q55 D KVAR^VADPT
Q $G(DGRTN)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRPC2 11185 printed Oct 16, 2024@18:56:28 Page 2
DGRPC2 ;ALB/MRL/SCK/PJR/BAJ/LBD/BDB - CHECK CONSISTENCY OF PATIENT DATA (CONT) ; 10/14/10 9:56am
+1 ;;5.3;Registration;**45,69,108,121,205,218,342,387,470,467,489,505,507,528,451,564,570,657,688,780,797,858,895,993,1027**;Aug 13, 1993;Build 70
+2 ;
43 ;off
44 ;off
45 ;off
46 ;off
47 ;off
+1 SET DGLST=$SELECT(DGCHK[",47,":47,DGCHK[",46,":46,DGCHK[",45,":45,DGCHK[",44,":44,1:DGLST)
+2 DO NEXT
GOTO @DGLST
48 IF DGVT
SET DGD=DGP(.362)
IF DGCHK[(",48,")
IF ($PIECE(DGD,"^",17)="Y")
IF ($PIECE(DGD,"^",6)="")
SET X=48
DO COMB
+1 DO NEXT
GOTO @DGLST
49 ;
50 ; insurance checks
+1 IF DGCHK[",49,"!(DGCHK[",50,")
Begin DoDot:1
+2 NEW COV,INS,X
+3 SET X=0
SET COV=$SELECT($PIECE(DGP(.31),"^",11)="Y":1,1:0)
+4 SET INS=$$INSUR^IBBAPI(DFN,DT,"R")
+5 ; yes, but none
IF COV
IF 'INS
SET X=49
+6 ; not yes, but some
IF 'COV
IF INS
SET X=50
+7 IF DGCHK[(","_X_",")
DO COMB
End DoDot:1
SET DGLST=$SELECT(DGCHK["50":50,1:49)
+8 DO NEXT
GOTO @DGLST
51 ; 51 disabled
DO NEXT
GOTO @DGLST
+1 SET X=$SELECT($DATA(^DIC(21,+$PIECE(DGP(.32),"^",3),0)):$PIECE(^(0),"^",3),1:"")
+2 IF X="Z"&($PIECE(DGP(.32),"^",5)'=7)&($PIECE(DGP(.32),"^",10)'=7)&($PIECE(DGP(.32),"^",15)'=7)!($PIECE(DGP(.32),"^",5)=7&(X'="Z"))
SET X=51
DO COMB
+3 ;
52 ;automatically on
IF $PIECE(DGP(.31),"^",11)']""
SET X=52
DO COMB
+1 DO NEXT
GOTO @DGLST
53 ;automatically on
IF $PIECE(DGP(.311),"^",15)']""
SET X=53
DO COMB
+1 DO NEXT
GOTO @DGLST
54 ;
55 ;BELOW IS USED BY BOTH 54 & 55
+1 NEW DGMT
+2 SET DGLST=$SELECT(DGCHK["55":55,1:54)
+3 ; patient died before current year
IF $GET(^DPT(DFN,.35))
IF (^(.35)<+($EXTRACT(DT,1,3)_"0000"))
DO NEXT
GOTO @DGLST
+4 NEW DGE
SET DGE=+$ORDER(^DIC(8.1,"B","SERVICE CONNECTED 50% to 100%",0))
+5 ;50-100% SC
IF $PIECE($GET(^DPT(DFN,.3)),U,2)'<50!($PIECE($GET(^DIC(8,+$GET(^DPT(DFN,.36)),0)),U,9)=DGE)
DO NEXT
GOTO @DGLST
+6 ;Begin DG*5.3*993 Registration Only or enroll before patch does not require Income Analysis
+7 NEW DGQUIT,DRGFLG
SET DGQUIT=0
IF DGLST=55
Begin DoDot:1
+8 IF ($GET(DGENRYN)=0)
SET DRGFLG=1
SET DGQUIT=1
+9 IF '$DATA(DGENRYN)!($GET(DGENRYN)="")
Begin DoDot:2
+10 NEW DGEXST
SET DGEXST=$$PREEXIST^DGREG(DFN)
IF DGEXST=1
SET DGQUIT=1
+11 NEW STATUS
SET STATUS=$$STATUS^DGENA($GET(DFN))
IF STATUS=25
SET DGQUIT=1
End DoDot:2
if DGQUIT
QUIT
End DoDot:1
IF DGQUIT
DO NEXT
GOTO @DGLST
+12 ;End changes for for DG*5.3*993
+13 ; screens 8 and 9 off
SET DGPTYP=$GET(^DG(391,+DGP("TYPE"),"S"))
SET DGISYR=$EXTRACT(DT,1,3)-1_"0000"
IF '$PIECE(DGPTYP,"^",8)&('$PIECE(DGPTYP,"^",9))
KILL DGPTYP,DGISYR
DO NEXT
GOTO @DGLST
+14 ; If current/not outdated means test exits, pass to income retrieval
+15 ; Patch 780
+16 SET DGMT=$$LST^DGMTU(DFN)
+17 ;DG*5.3*858 MT less than 1 year old as of "VFA Start Date" and point forward do not expire
+18 IF DGMT
IF $$OLDMTPF^DGMTU4($PIECE(DGMT,U,2))
SET DGMT=""
+19 DO ALL^DGMTU21(DFN,"VSD",$SELECT(DGMT:$PIECE(DGMT,U,2),1:DT),"IP",$SELECT(DGMT:DGMT,1:""))
+20 ; screen 8 off OR JUST 55 IN CHK ; 1027 !NOTVETCHANGED
IF '$PIECE(DGPTYP,"^",8)!(DGCHK'["54")
GOTO JUST55
+21 ; I VETCHANGED G 56 ; screen 8 off OR JUST 55 IN CHK ; 1027
+22 SET DGFL=0
IF $DATA(DGREL("S"))
IF ($$SSN^DGMTU1(+DGREL("S"))']"")
SET DGFL=1
+23 IF 'DGFL
FOR I=0:0
SET I=$ORDER(DGREL("D",I))
if 'I
QUIT
IF $$SSN^DGMTU1(+DGREL("D",I))']""
SET DGFL=1
QUIT
+24 IF DGFL
SET X=54
DO COMB
JUST55 IF DGCHK'["55"
DO NEXT
GOTO @DGLST
+1 SET DGLST=55
+2 ; screen 9 off
IF '$PIECE(DGPTYP,"^",9)
DO NEXT
GOTO @DGLST
+3 DO TOT^DGRP9(.DGINC)
SET DGFL=0
+4 FOR DGD="V","S","D"
IF $DATA(DGTOT(DGD))
FOR I=8:1:17
IF $PIECE(DGTOT(DGD),"^",I)]""
SET DGFL=1
QUIT
+5 IF 'DGFL
NEW DGAPD,DG55
Begin DoDot:1
+6 SET DGAPD=+$$LST^DGMTU(DFN)
SET DGAPD=+$PIECE($GET(^DGMT(408.31,+DGAPD,0)),U,11)
+7 ; **507, Additional Income Checks
SET DG55=$$CHECK55(DFN)
End DoDot:1
IF 'DGAPD&('DG55)
SET X=55
DO COMB
+8 DO NEXT
GOTO @DGLST
56 IF DGVT
SET DGD=DGP(.3)
IF DGCHK[(",56,")
IF ($PIECE(DGD,"^",11)="Y")
IF ($PIECE(DGP(.362),"^",20)="")
SET X=56
DO COMB
+1 DO NEXT
if $SELECT('+DGLST:1,+DGLST=99:1,1:0)
GOTO END^DGRPC3
GOTO @DGLST
57 IF $PIECE(DGP(.38),U,1)
Begin DoDot:1
+1 NEW X1,X2
+2 SET X1=$PIECE(DGP(.38),U,2)
+3 SET X=$PIECE($GET(^DG(43,1,0)),U,46)
SET X2=$SELECT(X:X,1:365)
DO C^%DTC
+4 IF X<DT
SET X=57
DO COMB
End DoDot:1
+5 DO NEXT
GOTO @DGLST
58 ;58 - EC Claim - No Gulf/Som Svc
+1 ;off
+2 ;DG*5.3*688 changed the wording of Environmental Contaminants
+3 ;so if this cc is ever activated the text in ^DGIN(38.6,58
+4 ;needs to be changed to Southwest Asia Conditions.
+5 DO NEXT
GOTO @DGLST
59 ;59 - incomplete Catastrophic Disability info
+1 IF $$HASCAT^DGENCDA(DFN)
Begin DoDot:1
+2 IF '$PIECE(DGP(.39),"^",2)
SET X=59
DO COMB
End DoDot:1
+3 DO NEXT
GOTO @DGLST
60 ;60 - Location of agent orange exposure unanswered
+1 IF DGVT
IF $PIECE(DGP(.321),"^",2)="Y"
IF $PIECE(DGP(.321),"^",13)=""
SET X=60
DO COMB
+2 DO NEXT
GOTO @DGLST
61 ;61 - Incomplete Phone Number
+1 ; DG*5.3*657 BAJ Phone number check modified
+2 ; Home phone check is disabled
+3 ; Work phone is required only if pt is employed
+4 NEW EMPST
+5 SET EMPST=","_$PIECE($GET(^DPT(DFN,.311)),U,15)_","
+6 IF ",1,2,4,"[EMPST
IF ($PIECE(DGP(.13),"^",2)="")
SET X=61
DO COMB
+7 DO NEXT
GOTO @DGLST
62 ;62 - Missing Emergency Contact Name
+1 IF $PIECE(DGP(.33),"^")=""
SET X=62
DO COMB
+2 DO NEXT
GOTO @DGLST
63 ;Confidential Address check
+1 NEW STR63,J,DGI,DGERR
+2 SET DGERR=0
+3 IF $PIECE(DGP(.141),U,9)="Y"
IF $PIECE($$CAACT^DGRPCADD(DFN),U)
Begin DoDot:1
+4 ; country is either NULL or non-numeric
+5 IF '$PIECE(DGP(.141),U,16)
SET DGERR=1
QUIT
+6 ; country is not in Country file
+7 IF '$DATA(^HL(779.004,$PIECE(DGP(.141),"^",16)))
SET DGERR=1
QUIT
+8 SET STR63="1,4,5,6"
IF $$FORIEN^DGADDUTL($PIECE(DGP(.141),"^",16))
SET STR63="1,4"
+9 FOR J=1:1:$LENGTH(STR63,",")
SET DGI=$PIECE(STR63,",",J)
if DGERR
QUIT
IF $PIECE(DGP(.141),U,DGI)=""
SET DGERR=1
End DoDot:1
+10 IF DGERR
SET X=63
DO COMB
+11 DO NEXT
GOTO @DGLST
64 ;64 - Place of Birth City/State Missing ;**505
+1 IF $PIECE(DGP(0),"^",11)=""!($PIECE(DGP(0),"^",12)="")
SET X=64
DO COMB
+2 DO NEXT
GOTO @DGLST
65 ;65 - Mother's Maiden Name Missing ;**505
+1 IF $PIECE(DGP(.24),"^",3)=""
SET X=65
DO COMB
+2 DO NEXT
GOTO @DGLST
66 ;66 - Pseudo SSN in use ;**505
+1 ; DG*5.3*657 BAJ 11/20/2005 Removed from CC. Pseudo notice appears in Patient List
+2 ;I $P(DGP(0),"^",9)["P" S X=66 D COMB
+3 ; off
+4 DO NEXT
GOTO @DGLST
67 ;67 - Serv Sep Date [Last] missing or imprecise, patch 528
+1 NEW DGG
+2 SET DGG=$$CVELIG^DGCV(DFN)
+3 IF $GET(DGG)["A"!($GET(DGG)["F")
SET X=67
DO COMB
+4 DO NEXT
GOTO @DGLST
68 ;used for 68-71, for Combat Vet, DG*5.3*528
69 ;
70 ;
71 ;
+1 ;68 - Combat To Date missing or imprecise, patch 528
+2 ;69 - Yugoslavia To Date missing or imprecise, patch 528
+3 ;70 - Somalia To Date missing or imprecise, patch 528
+4 ;71 - Persian Gulf To Date missing or imprecise, patch 528
+5 NEW DGG
+6 SET DGG=$$CVELIG^DGCV(DFN)
+7 IF DGG["B"!(DGG["G")
SET X=68
DO COMB
+8 IF DGG["C"!(DGG["H")
SET X=69
DO COMB
+9 IF DGG["D"!(DGG["I")
SET X=70
DO COMB
+10 IF DGG["E"!(DGG["J")
SET X=71
DO COMB
+11 SET DGLST=71
+12 DO NEXT
GOTO @DGLST
72 ;; MSE - Required Fields
+1 if '$GET(MSECHK)
SET MSECHK=$$MSCK^DGMSCK
IF MSERR
SET X=72
DO COMB
+2 DO NEXT
GOTO @DGLST
73 ;; An MSE FROM date precedes an MSE TO date
+1 if '$GET(MSECHK)
SET MSECHK=$$MSCK^DGMSCK
IF MSDATERR
DO NEXT
GOTO @DGLST
+2 NEW I1
+3 ;Use MSE data in DGPMSE array, if it exists (DG*5.3*797)
+4 IF $DATA(DGPMSE)
Begin DoDot:1
+5 NEW OUT
SET I1=0
FOR
SET I1=$ORDER(DGPMSE(I1))
if 'I1!($GET(OUT))
QUIT
Begin DoDot:2
+6 ;Don't check MSE verified by HEC
IF $PIECE(DGPMSE(I1),U,7)
QUIT
+7 IF '$$B4^DGRPDT($PIECE(DGPMSE(I1),U),$PIECE(DGPMSE(I1),U,2),1)
SET X=73
DO COMB
SET (MSERR,MSDATERR,OUT)=1
QUIT
End DoDot:2
End DoDot:1
DO NEXT
GOTO @DGLST
+8 ;Otherwise, use MSE data in DGP(.32)
+9 FOR I1=6,11,16
IF '$$B4^DGRPDT($PIECE(DGP(.32),"^",I1),$PIECE(DGP(.32),"^",I1+1),1)
SET X=73
DO COMB
SET (MSERR,MSDATERR)=1
QUIT
+10 DO NEXT
GOTO @DGLST
74 ;; Conflict Date Missing or Incomplete
+1 if '$GET(CONCHK)
SET CONCHK=$$CNCK^DGMSCK
IF CONERR
SET X=74
DO COMB
+2 DO NEXT
GOTO @DGLST
75 ;; Conflict TO date precedes FROM date
76 ;; Conflict Date out of range for conflict
+1 if '$GET(CONCHK)
SET CONCHK=$$CNCK^DGMSCK
+2 SET LOC=""
SET (I5,I6)=0
FOR I1=1:1
SET LOC=$ORDER(CONSPEC(LOC))
if LOC=""
QUIT
IF CONARR(LOC)=1
Begin DoDot:1
+3 NEW FROMDAT,FROMPC,TODAT,TOPC,NODE,DATA
+4 SET DATA=CONSPEC(LOC)
+5 SET NODE=$PIECE(DATA,",",1)
SET FROMPC=$PIECE(DATA,",",3)
SET TOPC=$PIECE(DATA,",",4)
+6 SET FROMDAT=$PIECE(DGP(NODE),"^",FROMPC)
SET TODAT=$PIECE(DGP(NODE),"^",TOPC)
+7 IF '$$B4^DGRPDT(FROMDAT,TODAT,1)
SET X=75
if 'I5&(DGCHK[(",75,"))
DO COMB
SET CONARR(LOC)=2
SET I5=1
QUIT
+8 IF DGCHK'[(",76,")
QUIT
+9 if '$GET(RANSET)
SET RANSET=$$RANGE^DGMSCK
+10 IF '$$RWITHIN^DGRPDT($PIECE(RANGE(LOC),"^",1),$PIECE(RANGE(LOC),"^",2),FROMDAT,TODAT)
SET X=76
if 'I6
DO COMB
SET CONARR(LOC)=2
SET I6=1
+11 QUIT
End DoDot:1
+12 SET DGLST=76
DO NEXT
GOTO @DGLST
77 ;; Date out of range for POW Location
+1 ;; Check turned off by EVC project (DG*5.3*688)
+2 DO NEXT
GOTO @DGLST
78 ;; Date out of range for Combat Location
+1 if '$GET(RANSET)
SET RANSET=$$RANGE^DGMSCK
+2 ;; Don't check if Combat Data Incomplete or if Combat TO precedes FROM
+3 IF ((","_DGER_",")[(",39,"))!((","_DGER_",")[(",40,"))
DO NEXT
GOTO @DGLST
+4 ;; Don't check if no COMBAT
IF $PIECE(DGP(.52),"^",11)'="Y"
DO NEXT
GOTO @DGLST
+5 SET LOC=$$COMPOW^DGRPMS($PIECE(DGP(.52),"^",12))
IF LOC=""
DO NEXT
GOTO @DGLST
+6 IF '$$RWITHIN^DGRPDT($PIECE(RANGE(LOC),"^",1),$PIECE(RANGE(LOC),"^",2),$PIECE(DGP(.52),"^",13),$PIECE(DGP(.52),"^",14))
SET X=78
DO COMB
+7 DO NEXT
GOTO @DGLST
COMB SET DGCT=DGCT+1
SET DGER=DGER_X_","
SET DGLST=X
QUIT
+1 ;
NEXT SET I=$FIND(DGCHK,(","_+DGLST_","))
SET DGLST=+$EXTRACT(DGCHK,I,999)
IF +DGLST
IF +DGLST<79
QUIT
+1 if 'DGLST
SET DGLST="END^DGRPC3"
IF +DGLST
SET DGLST=DGLST_"^DGRPC3"
+2 QUIT
FIND FOR I=DGLST:1:99
IF DGCHK[(","_I_",")
QUIT
+1 IF DGNCK
IF (I>17)
IF (I<36)
SET DGLST=36
GOTO FIND
+2 IF I
IF I<99
SET DGLST=I
GOTO @(DGLST_$SELECT(DGLST>78:"^DGRPC3",DGLST>42:"",DGLST>17:"^DGRPC1",1:"^DGRPC"))
+3 GOTO END^DGRPC3
+4 ;
CHECK55(DFN) ;Business rules for additional 55-INCOME DATA MISSING checks
+1 ; Modeled from DGMTR checks.
+2 ; Input DFN - IEN from PATIENT File #2
+3 ;
+4 ; Output 1 - If Income check passes additional business rules
+5 ; 0 - If Income check fails additional business rules
+6 ;
+7 NEW VAMB,VASV,VA,VADMVT,VAEL,VAINDT,DGRTN,DGMED,DG,DG1,DGWARD,DGSRVC,DGCOPAY
+8 ;
+9 SET DGRTN=0
+10 ; Check if receiving VA Disability
DO MB^VADPT
IF +VAMB(7)
SET DGRTN=1
GOTO Q55
+11 ; check if POW status indicated
DO SVC^VADPT
IF +VASV(4)
SET DGRTN=1
GOTO Q55
+12 ; Check if Purple Heart Status is Confirmed
IF +VASV(9)
IF (+VASV(9,1)=3)
SET DGRTN=1
GOTO Q55
+13 DO GETS^DIQ(2,DFN_",",".381:.383","I","DGMED")
+14 ; Check if eligible for Medicaid
IF $GET(DGMED(2,DFN_",",.381,"I"))
SET DGRTN=1
GOTO Q55
+15 ; Check for current admission to DOM ward
DO ADM^VADPT2
+16 IF +$GET(VADMVT)
Begin DoDot:1
+17 ; Has Dom wards?
if '$$GET1^DIQ(43,1,16,"I")
QUIT
+18 ; Get ward location
SET DGWARD=$$GET1^DIQ(405,VADMVT,.06,"I")
+19 ; Get ward service
SET DGSRVC=$$GET1^DIQ(42,DGWARD,.03,"I")
+20 ; If ward service is 'D', then return 1
if DGSRVC="D"
SET DGRTN=1
End DoDot:1
if DGRTN
GOTO Q55
+21 ;
+22 ; Additional checks for 0% SC
+23 DO ELIG^VADPT
+24 ; Check if service connected with % of zero
IF +VAEL(3)
IF '$PIECE(VAEL(3),U,2)
Begin DoDot:1
+25 ; Check if receiving a VA pension
IF +VAMB(4)
SET DGRTN=1
QUIT
+26 ; Check for secondary eligibilities
SET DG=0
+27 FOR
SET DG=$ORDER(VAEL(1,DG))
if 'DG
QUIT
Begin DoDot:2
+28 FOR DG1=2,4,15,16,17,18
IF DG=DG1
SET DGRTN=1
QUIT
End DoDot:2
if DGRTN
QUIT
End DoDot:1
+29 ; DG*5.3*657 BAJ
+30 ; Additional business rules
+31 ; Do NOT file inconsistency for the following:
+32 ; 1. Service Connected = YES, Eligibility Code is "SC LESS THAN 50%", SC % is 10-49, A&A = "YES"
+33 ; 2. Service Connected = YES, Eligibility Code is "SC LESS THAN 50%", SC % is 10-49, VA Pension = "YES"
+34 ; 3. Patient Type is "NSC Veteran" and A&A = "YES"
+35 ; 4. Patient Type is "NSC Veteran" and VA Pension = "YES"
+36 ; Arrays elements used:
+37 ; .. VAEL(3) $P 1 = SERVICE CONNECTED? $P 2 = SC %
+38 ; .. VAEL(6) $P 2 = PATIENT TYPE, "B" INDEX VALUE
+39 ; .. VAMB(1) $P 1 = RECEIVING A&A
+40 ; .. VAMB(4) $P 1 = RECEIVING VA PENSION
+41 IF $PIECE(VAEL(1),"^",2)="SC LESS THAN 50%"
IF +VAEL(3)
SET PCNT=$PIECE(VAEL(3),"^",2)
IF PCNT'<10
IF PCNT'>50
SET DGRTN=$SELECT(+VAMB(1):1,VAMB(4):1,1:DGRTN)
+42 ; DG*5.3*895 Check if service connected between 0% & 50% and copay exempt
+43 SET DGCOPAY=$ORDER(^DGMT(408.31,"C",DFN,""))
+44 IF DGCOPAY
IF $GET(PCNT)>0
IF $GET(PCNT)'>50
IF $PIECE($GET(^DGMT(408.31,DGCOPAY,2)),U,3)=8
SET DGRTN=1
+45 IF $PIECE($GET(VAEL(6)),"^",2)="NSC VETERAN"
SET DGRTN=$SELECT(+VAMB(1):1,VAMB(4):1,1:DGRTN)
+46 ;
Q55 DO KVAR^VADPT
+1 QUIT $GET(DGRTN)
