- 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 Feb 19, 2025@00:21:56 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)