DGRPC3 ;ALB/PJR,LBD,BAJ,TDM,JDB,JDB,JDB - CHECK CONSISTENCY OF PATIENT DATA (CONT) ;10/20/10 3:40pm
;;5.3;Registration;**451,632,673,657,688,754,797,867,903,952,1098,1109,1111**;Aug 13, 1993;Build 18
;Per VHA Directive 6402, this routine should not be modified.
;
; 315 subroutine added by patch DG*5.3*903 which was submitted to OSEHRA
; on 04/02/2015 by HP. This update was authored by James Harris 2014-2015
;
79 ;; MSE Dates overlap
;; Don't check if MSE Dates Incomplete or if MSE TO precedes FROM
;; or unless at least 2 ranges
S:'$G(MSECHK) MSECHK=$$MSCK^DGMSCK I MSDATERR!($L(ANYMSE)<2) D NEXT G @DGLST
;Use MSE data in DGPMSE array, if it exists (DG*5.3*797)
I $D(DGPMSE) D D NEXT G @DGLST
.N MS,MSE,OUT S MS=0 F S MS=$O(DGPMSE(MS)) Q:'MS!($G(OUT)) D
..I $P(DGPMSE(MS),U,7) Q ;Don't check MSE verified by HEC
..S MSE=$O(DGPMSE(MS,0)) Q:'MSE
..I '$$OVRLPCHK^DGRPDT(DFN,$P(DGPMSE(MS),U),$P(DGPMSE(MS),U,2),1,"","",MSE) S X=79 D COMB S (MSERR,OUT)=1 Q
;Otherwise, use MSE data in DGP(.32)
I ANYMSE[1,'$$OVRLPCHK^DGRPDT(DFN,$P(DGP(.32),"^",6),$P(DGP(.32),"^",7),1,".326^.327") S X=79 D COMB S MSERR=1 D NEXT G @DGLST
I ANYMSE'[1,'$$OVRLPCHK^DGRPDT(DFN,$P(DGP(.32),"^",11),$P(DGP(.32),"^",12),1,".3292^.3293") S X=79 D COMB S MSERR=1 D NEXT G @DGLST
D NEXT G @DGLST
80 ;; POW Dates not within MSE
;; Check turned off by EVC project (DG*5.3*688)
D NEXT G @DGLST
81 ;; Combat Dates not within MSE
I '$P(DGP(.52),"^",12) D NEXT G @DGLST ;; Don't check if no COMBAT Data
;; Don't check if COMBAT Data Incomplete or if COMBAT TO precedes FROM
I ((","_DGER_",")[(",39,"))!((","_DGER_",")[(",40,")) D NEXT G @DGLST
S:'$G(MSECHK) MSECHK=$$MSCK^DGMSCK S:'$G(MSESET) MSESET=$$MSFROMTO^DGMSCK
;; If COMBAT, but no MSE, then Range is NOT within MSE
I 'ANYMSE S X=81 D COMB D NEXT G @DGLST
I '$$RWITHIN^DGRPDT($P(MSESET,"^",1),$P(MSESET,"^",2),$P(DGP(.52),"^",13),$P(DGP(.52),"^",14)) S X=81 D COMB
D NEXT G @DGLST
82 ;; Conflict Dates not within MSE
S:'$G(CONCHK) CONCHK=$$CNCK^DGMSCK
S:'$G(MSECHK) MSECHK=$$MSCK^DGMSCK S:'$G(MSESET) MSESET=$$MSFROMTO^DGMSCK
S LOC="",I2=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 '$$RWITHIN^DGRPDT($P(MSESET,"^",1),$P(MSESET,"^",2),FROMDAT,TODAT) S X=82 D COMB:'I2 S CONARR(LOC)=2,I2=1
.Q
; Check OIF/OEF conflict dates
N DGOEIF D GET^DGENOEIF(DFN,.DGOEIF,0,"",0)
I $G(DGOEIF("COUNT")),DGER'[",82," D
. N Z
. S Z=0 F S Z=$O(DGOEIF("IEN",Z)) Q:'Z D Q:DGER[",82,"
.. S FROMDAT=$G(DGOEIF("FR",Z)),TODAT=$G(DGOEIF("TO",Z)),LOC=$G(DGOEIF("LOC",Z))
.. I '$$RWITHIN^DGRPDT($P(MSESET,"^",1),$P(MSESET,"^",2),FROMDAT,TODAT) S X=82 D COMB S I2=1
D NEXT G @DGLST
83 ;Merchant Seaman or Filipino Vet BOS requires service dates during WWII
N BOS,BOSN,MS,MSE,OUT
;Use MSE data from DGPMSE array, if it exists (DG*5.3*797)
I $D(DGPMSE) D D NEXT G @DGLST
.S MS=0 F S MS=$O(DGPMSE(MS)) Q:'MS!($G(OUT)) D
..I $P(DGPMSE(MS),U,7) Q ;Don't check MSE if verified by HEC
..S BOS=$P(DGPMSE(MS),U,3) Q:'BOS S BOSN=$P(^DIC(23,BOS,0),U)
..S MSE=$O(DGPMSE(MS,0)) Q:'MSE S MSE="MSE-"_MSE
..I $$BRANCH^DGRPMS(BOS_U_BOSN),'$$WWII^DGRPMS(DFN,"",MSE) S X=83 D COMB S OUT=1 Q
;Otherwise, get MSE data from DGP(.32)
F MS=1:1:3 D Q:$G(OUT)
.I MS=2,$P(DGP(.32),U,19)'="Y" S OUT=1 Q
.I MS=3,$P(DGP(.32),U,20)'="Y" S OUT=1 Q
.S BOS=$P(DGP(.32),U,(5*MS)) Q:'BOS S BOSN=$P($G(^DIC(23,BOS,0)),U)
.S MSE=$S(MS=1:"MSL",MS=2:"MSNTL",1:"MSNNTL")
.I $$BRANCH^DGRPMS(BOS_U_BOSN),'$$WWII^DGRPMS(DFN,"",MSE) S X=83 D COMB S OUT=1 Q
D NEXT G @DGLST
84 ;Filipino Vet BOS requires Filipino Vet Proof
N MS,BOS,OUT,MSE
;Use MSE data from DGPMSE array, if it exists (DG*5.3*797)
I $D(DGPMSE) D D NEXT G @DGLST
.S MS=0 F S MS=$O(DGPMSE(MS)) Q:'MS!($G(OUT)) D
..I $P(DGPMSE(MS),U,7) Q ;Don't check MSE if verified by HEC
..S BOS=$P(DGPMSE(MS),U,3) Q:'BOS
..I $$FV^DGRPMS(BOS)=1,$P(DGP(.321),U,14)="" S X=84 D COMB S OUT=1 Q
;Otherwise use MSE data in DGP(.32)
F MS=1:1:3 D Q:$G(OUT)
.I MS=2,$P(DGP(.32),U,19)'="Y" S OUT=1 Q
.I MS=3,$P(DGP(.32),U,20)'="Y" S OUT=1 Q
.S BOS=$P(DGP(.32),U,(5*MS))
.I $$FV^DGRPMS(BOS)=1,$P(DGP(.321),U,14)="" S X=84 D COMB S OUT=1 Q
D NEXT G @DGLST
85 ;Eligible Filipino Vet should have Veteran status = 'YES'
86 ;Ineligible Filipino Vet should have Veteran status = 'NO'
N MS,BOS,FV,FILV,NOTFV,MSE,OUT
;Use MSE data from DGPMSE array, if it exists (DG*5.3*797)
I $D(DGPMSE) D
.S MS=0 F S MS=$O(DGPMSE(MS)) Q:'MS!($G(OUT)) D
..I $P(DGPMSE(MS),U,7) Q ;Don't check MSE if verified by HEC
..S BOS=$P(DGPMSE(MS),U,3),FV=$$FV^DGRPMS(BOS) I 'FV S NOTFV="" Q
..S MSE=$O(DGPMSE(MS,0)) Q:'MSE S MSE="MSE-"_MSE
..I '$$WWII^DGRPMS(DFN,"",MSE) S FILV("I")="" Q
..I FV=2 S FILV("E")="" Q
..I $P(DGP(.321),U,14)=""!($P(DGP(.321),U,14)="NO") S FILV("I")="" Q
..S FILV("E")=""
;Otherwise, get MSE data from DGP(.32)
E F MS=1:1:3 D Q:$G(OUT)
.I MS=2,$P(DGP(.32),U,19)'="Y" S OUT=1 Q
.I MS=3,$P(DGP(.32),U,20)'="Y" S OUT=1 Q
.S BOS=$P(DGP(.32),U,(5*MS)),FV=$$FV^DGRPMS(BOS) I 'FV S NOTFV="" Q
.S MSE=$S(MS=1:"MSL",MS=2:"MSNTL",1:"MSNNTL")
.I '$$WWII^DGRPMS(DFN,"",MSE) S FILV("I")="" Q
.I FV=2 S FILV("E")="" Q
.I $P(DGP(.321),U,14)=""!($P(DGP(.321),U,14)="NO") S FILV("I")="" Q
.S FILV("E")=""
I $D(FILV) D
.I DGVT'=1,$D(FILV("E")) S X=85 D COMB Q
.I DGCHK'[(",86,") Q
.I DGVT=1,'$D(NOTFV),'$D(FILV("E")),$D(FILV("I")) S X=86 D COMB
S DGLST=86
D NEXT G @DGLST
87 ; DG*5.3*657 BAJ 11/24/2005 CC #87 added
; SC Eligibility but no rated Disability Codes
; 1. Svc Connected is answered "YES"
; 2. Eligibility code is either SC < 50% or SC 50-100%
; 3. Svc connected %-age is 0 or greater
; 4. Patient has no rated disabilities
; .. VAEL(1) $P 1 = Primary Eligibility Code $p 2 = Primary Elig External Value
; .. VAEL(3) $P 1 = SERVICE CONNECTED? $P 2 = SC %
; .. Rated Disabilities : ^DPT(DFN,.372,0) $P 4 is number of records '($P($G(^DPT(DFN,.372,0)),"^",4)) is TRUE
;
; Get Eligibility info
D ELIG^VADPT
;
; If not svc connected, don't check
I '$G(VAEL(3)) D NEXT G @DGLST
;
I +VAEL(3)=1!(+VAEL(3)=3) D
. Q:$P(VAEL(3),"^",2)<0
. Q:$P(VAEL(3),"^",2)=""
. I '($P($G(^DPT(DFN,.372,0)),"^",4)) S X=87 D COMB
D NEXT G @DGLST
;
88 ;Temporary Address check
N STR88,J,DGI,DGERR,START,END
S DGERR=0
I $P(DGP(.121),U,9)="Y" D
. ;check only if current date is within effective range
. S START=$P(DGP(.121),U,7),END=$P(DGP(.121),U,8)
. Q:START="" I END="" S END=9999999
. ; quit if current date is not within range
. I '(DT'<START&(DT'>END)) Q
. ; country is either NULL or non-numeric
. I '$P(DGP(.122),U,3) S DGERR=1 Q
. ; country is not in Country file
. I '$D(^HL(779.004,$P(DGP(.122),U,3))) S DGERR=1 Q
. S STR88="1,4,5,6" I $$FORIEN^DGADDUTL($P(DGP(.122),"^",3)) S STR88="1,4"
. F J=1:1:$L(STR88,",") S DGI=$P(STR88,",",J) Q:DGERR I $P(DGP(.121),U,DGI)="" S DGERR=1
I DGERR S X=88 D COMB
D NEXT G @DGLST
89 ;
N DGPT,DGELIG
S DGPT=$$GET1^DIQ(2,DFN_",",391),DGELIG=$$GET1^DIQ(2,DFN+",",.361)
I DGELIG="EXPANDED MH CARE NON-ENROLLEE",DGPT'="NON-VETERAN (OTHER)" S X=89 D COMB
D NEXT G @DGLST
99 ; synonymous with END
END I DGNCK S X=99 D COMB
D OVER99CK
I DGEDCN S DGCON=0 D TIME^DGRPC
K C,C1,C2,DGCD,DGD,DGD1,DGD2,DGDATE,DGDEP,DGCHK,DGFL,DGINC,DGISYR,DGLST,DGMS,DGNCK,DGP,DGPMSE,DGPTYP,DGREL,DGSCT,DGT,DGTIME,DGTOT,DGVT,I,I2,I2,J,VAIN,X,X1
G ^DGRPCF
;
COMB S DGCT=DGCT+1,DGER=DGER_X_",",DGLST=X Q
;;
NEXT S I=$F(DGCHK,(","_+DGLST_",")),DGLST=+$E(DGCHK,I,999) S:'DGLST DGLST="END"
Q
;
OVER99CK N DGP,DGSD,RULE,FILERR
D LOADPT^IVMZ07C(DFN,.DGP),LOADSD^IVMZ072(DFN,.DGSD)
;DG*5.3*1109 removed 304:GENDER INVALID from following loop
;F RULE=301,303,304,306,307,308 S DGLST=RULE_"^IVMZ7CD" D @DGLST I $D(FILERR(RULE)) S X=RULE D COMB
;DG*5.3*1111 removed 301:PERSON LASTNAME REQUIRED and 303:GENDER REQUIRED from following loop
;F RULE=301,303,306,307,308 S DGLST=RULE_"^IVMZ7CD" D @DGLST I $D(FILERR(RULE)) S X=RULE D COMB
F RULE=306,307,308 S DGLST=RULE_"^IVMZ7CD" D @DGLST I $D(FILERR(RULE)) S X=RULE D COMB
;DG*5.3*1098 removed 406:CLAIM NUMBER INVALID, from following for loop
F RULE=402,403,407 S DGLST=RULE_"^IVMZ7CE" D @DGLST I $D(FILERR(RULE)) S X=RULE D COMB
F RULE=501:1:507,516,517 S DGLST=RULE_"^IVMZ7CS" D @DGLST I $D(FILERR(RULE)) S X=RULE D COMB
F RULE=313 S DGLST=RULE_"^DGRPC3" D @DGLST I $D(FILERR(RULE)) S X=RULE D COMB
F RULE=314 S DGLST=RULE_"^DGRPC3" D @DGLST I $D(FILERR(RULE)) S X=RULE D COMB
F RULE=315 S DGLST=RULE_"^DGRPC3" D @DGLST I $D(FILERR(RULE)) S X=RULE D COMB
S DGLST="END"
Q
;
313 ; NEWBORN REQUIRES SPONSOR
N X
S DOB=$P(^DPT(DFN,0),"^",3)
D NOW^%DTC
S NOW=X
I $$FMDIFF^XLFDT(NOW,DOB,1)>365 Q ;NOT A NEWBORN
I $D(^IBA(355.81,"B",DFN)) Q ;already has a sponsor
S FILERR(RULE)=""
Q
;
314 ;NEWBORN SPONSOR MUST BE ELIGIBLE
I '$D(^IBA(355.81,"B",DFN)) Q ;Does not have a sponsor
N X
S DOB=$P(^DPT(DFN,0),"^",3)
D NOW^%DTC
S NOW=X
I $$FMDIFF^XLFDT(NOW,DOB,1)>365 Q ;NOT A NEWBORN
N RELIEN,SPNIEN,SPNDFN,ELIG
;NEED TO FIND SPONSOR IN PATIENT FILE
S RELIEN="",SPNIEN="",SPNDFN="",ELIG=""
S RELIEN=$O(^IBA(355.81,"B",DFN,RELIEN))
S SPNIEN=$$GET1^DIQ(355.81,RELIEN,.02,"I")
S SPNDFN=$$GET1^DIQ(355.8,SPNIEN,.01,"I")
S SPNDFN=$P(SPNDFN,";",1)
S ELIG=$$GET1^DIQ(2,SPNDFN,.3611,"I")
I ELIG'="" Q ;sponsor has an eligibility status
S FILERR(RULE)=""
Q
;
315 ; MHV - subroutine added by patch DG*5.3*903
Q:'$G(DFN)!'$G(DGPRFLG)
;This functionality will not be executed if "Enable MyHealtheVet Prompts?" (#1100.07
;field in MAS PARAMETERS (43) file is not set to YES (internal value 1)
Q:+$$MHVENABL^DGMHVUTL()'>0
;
N DGFLDCHK,DGMHVACT,DGMHVOUT,DGMHVQ,X,Y,DIR
Q:$$MHVOK^DGMHVAC(DFN)
; Quit if MHV ENROLLED/Registered has not been answered, and enrollment/registration
; action is pending
S DGMHVACT=$$ENQACHK^DGMHVUTL(DFN) Q:(DGMHVACT]"")&'$G(^DPT(DFN,2))
S:'$$MHVOK^DGMHVAC(DFN) FILERR(315)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRPC3 10269 printed Oct 16, 2024@18:56:29 Page 2
DGRPC3 ;ALB/PJR,LBD,BAJ,TDM,JDB,JDB,JDB - CHECK CONSISTENCY OF PATIENT DATA (CONT) ;10/20/10 3:40pm
+1 ;;5.3;Registration;**451,632,673,657,688,754,797,867,903,952,1098,1109,1111**;Aug 13, 1993;Build 18
+2 ;Per VHA Directive 6402, this routine should not be modified.
+3 ;
+4 ; 315 subroutine added by patch DG*5.3*903 which was submitted to OSEHRA
+5 ; on 04/02/2015 by HP. This update was authored by James Harris 2014-2015
+6 ;
79 ;; MSE Dates overlap
+1 ;; Don't check if MSE Dates Incomplete or if MSE TO precedes FROM
+2 ;; or unless at least 2 ranges
+3 if '$GET(MSECHK)
SET MSECHK=$$MSCK^DGMSCK
IF MSDATERR!($LENGTH(ANYMSE)<2)
DO NEXT
GOTO @DGLST
+4 ;Use MSE data in DGPMSE array, if it exists (DG*5.3*797)
+5 IF $DATA(DGPMSE)
Begin DoDot:1
+6 NEW MS,MSE,OUT
SET MS=0
FOR
SET MS=$ORDER(DGPMSE(MS))
if 'MS!($GET(OUT))
QUIT
Begin DoDot:2
+7 ;Don't check MSE verified by HEC
IF $PIECE(DGPMSE(MS),U,7)
QUIT
+8 SET MSE=$ORDER(DGPMSE(MS,0))
if 'MSE
QUIT
+9 IF '$$OVRLPCHK^DGRPDT(DFN,$PIECE(DGPMSE(MS),U),$PIECE(DGPMSE(MS),U,2),1,"","",MSE)
SET X=79
DO COMB
SET (MSERR,OUT)=1
QUIT
End DoDot:2
End DoDot:1
DO NEXT
GOTO @DGLST
+10 ;Otherwise, use MSE data in DGP(.32)
+11 IF ANYMSE[1
IF '$$OVRLPCHK^DGRPDT(DFN,$PIECE(DGP(.32),"^",6),$PIECE(DGP(.32),"^",7),1,".326^.327")
SET X=79
DO COMB
SET MSERR=1
DO NEXT
GOTO @DGLST
+12 IF ANYMSE'[1
IF '$$OVRLPCHK^DGRPDT(DFN,$PIECE(DGP(.32),"^",11),$PIECE(DGP(.32),"^",12),1,".3292^.3293")
SET X=79
DO COMB
SET MSERR=1
DO NEXT
GOTO @DGLST
+13 DO NEXT
GOTO @DGLST
80 ;; POW Dates not within MSE
+1 ;; Check turned off by EVC project (DG*5.3*688)
+2 DO NEXT
GOTO @DGLST
81 ;; Combat Dates not within MSE
+1 ;; Don't check if no COMBAT Data
IF '$PIECE(DGP(.52),"^",12)
DO NEXT
GOTO @DGLST
+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 if '$GET(MSECHK)
SET MSECHK=$$MSCK^DGMSCK
if '$GET(MSESET)
SET MSESET=$$MSFROMTO^DGMSCK
+5 ;; If COMBAT, but no MSE, then Range is NOT within MSE
+6 IF 'ANYMSE
SET X=81
DO COMB
DO NEXT
GOTO @DGLST
+7 IF '$$RWITHIN^DGRPDT($PIECE(MSESET,"^",1),$PIECE(MSESET,"^",2),$PIECE(DGP(.52),"^",13),$PIECE(DGP(.52),"^",14))
SET X=81
DO COMB
+8 DO NEXT
GOTO @DGLST
82 ;; Conflict Dates not within MSE
+1 if '$GET(CONCHK)
SET CONCHK=$$CNCK^DGMSCK
+2 if '$GET(MSECHK)
SET MSECHK=$$MSCK^DGMSCK
if '$GET(MSESET)
SET MSESET=$$MSFROMTO^DGMSCK
+3 SET LOC=""
SET I2=0
FOR I1=1:1
SET LOC=$ORDER(CONSPEC(LOC))
if LOC=""
QUIT
IF CONARR(LOC)=1
Begin DoDot:1
+4 NEW FROMDAT,FROMPC,TODAT,TOPC,NODE,DATA
+5 SET DATA=CONSPEC(LOC)
+6 SET NODE=$PIECE(DATA,",",1)
SET FROMPC=$PIECE(DATA,",",3)
SET TOPC=$PIECE(DATA,",",4)
+7 SET FROMDAT=$PIECE(DGP(NODE),"^",FROMPC)
SET TODAT=$PIECE(DGP(NODE),"^",TOPC)
+8 IF '$$RWITHIN^DGRPDT($PIECE(MSESET,"^",1),$PIECE(MSESET,"^",2),FROMDAT,TODAT)
SET X=82
if 'I2
DO COMB
SET CONARR(LOC)=2
SET I2=1
+9 QUIT
End DoDot:1
+10 ; Check OIF/OEF conflict dates
+11 NEW DGOEIF
DO GET^DGENOEIF(DFN,.DGOEIF,0,"",0)
+12 IF $GET(DGOEIF("COUNT"))
IF DGER'[",82,"
Begin DoDot:1
+13 NEW Z
+14 SET Z=0
FOR
SET Z=$ORDER(DGOEIF("IEN",Z))
if 'Z
QUIT
Begin DoDot:2
+15 SET FROMDAT=$GET(DGOEIF("FR",Z))
SET TODAT=$GET(DGOEIF("TO",Z))
SET LOC=$GET(DGOEIF("LOC",Z))
+16 IF '$$RWITHIN^DGRPDT($PIECE(MSESET,"^",1),$PIECE(MSESET,"^",2),FROMDAT,TODAT)
SET X=82
DO COMB
SET I2=1
End DoDot:2
if DGER[",82,"
QUIT
End DoDot:1
+17 DO NEXT
GOTO @DGLST
83 ;Merchant Seaman or Filipino Vet BOS requires service dates during WWII
+1 NEW BOS,BOSN,MS,MSE,OUT
+2 ;Use MSE data from DGPMSE array, if it exists (DG*5.3*797)
+3 IF $DATA(DGPMSE)
Begin DoDot:1
+4 SET MS=0
FOR
SET MS=$ORDER(DGPMSE(MS))
if 'MS!($GET(OUT))
QUIT
Begin DoDot:2
+5 ;Don't check MSE if verified by HEC
IF $PIECE(DGPMSE(MS),U,7)
QUIT
+6 SET BOS=$PIECE(DGPMSE(MS),U,3)
if 'BOS
QUIT
SET BOSN=$PIECE(^DIC(23,BOS,0),U)
+7 SET MSE=$ORDER(DGPMSE(MS,0))
if 'MSE
QUIT
SET MSE="MSE-"_MSE
+8 IF $$BRANCH^DGRPMS(BOS_U_BOSN)
IF '$$WWII^DGRPMS(DFN,"",MSE)
SET X=83
DO COMB
SET OUT=1
QUIT
End DoDot:2
End DoDot:1
DO NEXT
GOTO @DGLST
+9 ;Otherwise, get MSE data from DGP(.32)
+10 FOR MS=1:1:3
Begin DoDot:1
+11 IF MS=2
IF $PIECE(DGP(.32),U,19)'="Y"
SET OUT=1
QUIT
+12 IF MS=3
IF $PIECE(DGP(.32),U,20)'="Y"
SET OUT=1
QUIT
+13 SET BOS=$PIECE(DGP(.32),U,(5*MS))
if 'BOS
QUIT
SET BOSN=$PIECE($GET(^DIC(23,BOS,0)),U)
+14 SET MSE=$SELECT(MS=1:"MSL",MS=2:"MSNTL",1:"MSNNTL")
+15 IF $$BRANCH^DGRPMS(BOS_U_BOSN)
IF '$$WWII^DGRPMS(DFN,"",MSE)
SET X=83
DO COMB
SET OUT=1
QUIT
End DoDot:1
if $GET(OUT)
QUIT
+16 DO NEXT
GOTO @DGLST
84 ;Filipino Vet BOS requires Filipino Vet Proof
+1 NEW MS,BOS,OUT,MSE
+2 ;Use MSE data from DGPMSE array, if it exists (DG*5.3*797)
+3 IF $DATA(DGPMSE)
Begin DoDot:1
+4 SET MS=0
FOR
SET MS=$ORDER(DGPMSE(MS))
if 'MS!($GET(OUT))
QUIT
Begin DoDot:2
+5 ;Don't check MSE if verified by HEC
IF $PIECE(DGPMSE(MS),U,7)
QUIT
+6 SET BOS=$PIECE(DGPMSE(MS),U,3)
if 'BOS
QUIT
+7 IF $$FV^DGRPMS(BOS)=1
IF $PIECE(DGP(.321),U,14)=""
SET X=84
DO COMB
SET OUT=1
QUIT
End DoDot:2
End DoDot:1
DO NEXT
GOTO @DGLST
+8 ;Otherwise use MSE data in DGP(.32)
+9 FOR MS=1:1:3
Begin DoDot:1
+10 IF MS=2
IF $PIECE(DGP(.32),U,19)'="Y"
SET OUT=1
QUIT
+11 IF MS=3
IF $PIECE(DGP(.32),U,20)'="Y"
SET OUT=1
QUIT
+12 SET BOS=$PIECE(DGP(.32),U,(5*MS))
+13 IF $$FV^DGRPMS(BOS)=1
IF $PIECE(DGP(.321),U,14)=""
SET X=84
DO COMB
SET OUT=1
QUIT
End DoDot:1
if $GET(OUT)
QUIT
+14 DO NEXT
GOTO @DGLST
85 ;Eligible Filipino Vet should have Veteran status = 'YES'
86 ;Ineligible Filipino Vet should have Veteran status = 'NO'
+1 NEW MS,BOS,FV,FILV,NOTFV,MSE,OUT
+2 ;Use MSE data from DGPMSE array, if it exists (DG*5.3*797)
+3 IF $DATA(DGPMSE)
Begin DoDot:1
+4 SET MS=0
FOR
SET MS=$ORDER(DGPMSE(MS))
if 'MS!($GET(OUT))
QUIT
Begin DoDot:2
+5 ;Don't check MSE if verified by HEC
IF $PIECE(DGPMSE(MS),U,7)
QUIT
+6 SET BOS=$PIECE(DGPMSE(MS),U,3)
SET FV=$$FV^DGRPMS(BOS)
IF 'FV
SET NOTFV=""
QUIT
+7 SET MSE=$ORDER(DGPMSE(MS,0))
if 'MSE
QUIT
SET MSE="MSE-"_MSE
+8 IF '$$WWII^DGRPMS(DFN,"",MSE)
SET FILV("I")=""
QUIT
+9 IF FV=2
SET FILV("E")=""
QUIT
+10 IF $PIECE(DGP(.321),U,14)=""!($PIECE(DGP(.321),U,14)="NO")
SET FILV("I")=""
QUIT
+11 SET FILV("E")=""
End DoDot:2
End DoDot:1
+12 ;Otherwise, get MSE data from DGP(.32)
+13 IF '$TEST
FOR MS=1:1:3
Begin DoDot:1
+14 IF MS=2
IF $PIECE(DGP(.32),U,19)'="Y"
SET OUT=1
QUIT
+15 IF MS=3
IF $PIECE(DGP(.32),U,20)'="Y"
SET OUT=1
QUIT
+16 SET BOS=$PIECE(DGP(.32),U,(5*MS))
SET FV=$$FV^DGRPMS(BOS)
IF 'FV
SET NOTFV=""
QUIT
+17 SET MSE=$SELECT(MS=1:"MSL",MS=2:"MSNTL",1:"MSNNTL")
+18 IF '$$WWII^DGRPMS(DFN,"",MSE)
SET FILV("I")=""
QUIT
+19 IF FV=2
SET FILV("E")=""
QUIT
+20 IF $PIECE(DGP(.321),U,14)=""!($PIECE(DGP(.321),U,14)="NO")
SET FILV("I")=""
QUIT
+21 SET FILV("E")=""
End DoDot:1
if $GET(OUT)
QUIT
+22 IF $DATA(FILV)
Begin DoDot:1
+23 IF DGVT'=1
IF $DATA(FILV("E"))
SET X=85
DO COMB
QUIT
+24 IF DGCHK'[(",86,")
QUIT
+25 IF DGVT=1
IF '$DATA(NOTFV)
IF '$DATA(FILV("E"))
IF $DATA(FILV("I"))
SET X=86
DO COMB
End DoDot:1
+26 SET DGLST=86
+27 DO NEXT
GOTO @DGLST
87 ; DG*5.3*657 BAJ 11/24/2005 CC #87 added
+1 ; SC Eligibility but no rated Disability Codes
+2 ; 1. Svc Connected is answered "YES"
+3 ; 2. Eligibility code is either SC < 50% or SC 50-100%
+4 ; 3. Svc connected %-age is 0 or greater
+5 ; 4. Patient has no rated disabilities
+6 ; .. VAEL(1) $P 1 = Primary Eligibility Code $p 2 = Primary Elig External Value
+7 ; .. VAEL(3) $P 1 = SERVICE CONNECTED? $P 2 = SC %
+8 ; .. Rated Disabilities : ^DPT(DFN,.372,0) $P 4 is number of records '($P($G(^DPT(DFN,.372,0)),"^",4)) is TRUE
+9 ;
+10 ; Get Eligibility info
+11 DO ELIG^VADPT
+12 ;
+13 ; If not svc connected, don't check
+14 IF '$GET(VAEL(3))
DO NEXT
GOTO @DGLST
+15 ;
+16 IF +VAEL(3)=1!(+VAEL(3)=3)
Begin DoDot:1
+17 if $PIECE(VAEL(3),"^",2)<0
QUIT
+18 if $PIECE(VAEL(3),"^",2)=""
QUIT
+19 IF '($PIECE($GET(^DPT(DFN,.372,0)),"^",4))
SET X=87
DO COMB
End DoDot:1
+20 DO NEXT
GOTO @DGLST
+21 ;
88 ;Temporary Address check
+1 NEW STR88,J,DGI,DGERR,START,END
+2 SET DGERR=0
+3 IF $PIECE(DGP(.121),U,9)="Y"
Begin DoDot:1
+4 ;check only if current date is within effective range
+5 SET START=$PIECE(DGP(.121),U,7)
SET END=$PIECE(DGP(.121),U,8)
+6 if START=""
QUIT
IF END=""
SET END=9999999
+7 ; quit if current date is not within range
+8 IF '(DT'<START&(DT'>END))
QUIT
+9 ; country is either NULL or non-numeric
+10 IF '$PIECE(DGP(.122),U,3)
SET DGERR=1
QUIT
+11 ; country is not in Country file
+12 IF '$DATA(^HL(779.004,$PIECE(DGP(.122),U,3)))
SET DGERR=1
QUIT
+13 SET STR88="1,4,5,6"
IF $$FORIEN^DGADDUTL($PIECE(DGP(.122),"^",3))
SET STR88="1,4"
+14 FOR J=1:1:$LENGTH(STR88,",")
SET DGI=$PIECE(STR88,",",J)
if DGERR
QUIT
IF $PIECE(DGP(.121),U,DGI)=""
SET DGERR=1
End DoDot:1
+15 IF DGERR
SET X=88
DO COMB
+16 DO NEXT
GOTO @DGLST
89 ;
+1 NEW DGPT,DGELIG
+2 SET DGPT=$$GET1^DIQ(2,DFN_",",391)
SET DGELIG=$$GET1^DIQ(2,DFN+",",.361)
+3 IF DGELIG="EXPANDED MH CARE NON-ENROLLEE"
IF DGPT'="NON-VETERAN (OTHER)"
SET X=89
DO COMB
+4 DO NEXT
GOTO @DGLST
99 ; synonymous with END
END IF DGNCK
SET X=99
DO COMB
+1 DO OVER99CK
+2 IF DGEDCN
SET DGCON=0
DO TIME^DGRPC
+3 KILL C,C1,C2,DGCD,DGD,DGD1,DGD2,DGDATE,DGDEP,DGCHK,DGFL,DGINC,DGISYR,DGLST,DGMS,DGNCK,DGP,DGPMSE,DGPTYP,DGREL,DGSCT,DGT,DGTIME,DGTOT,DGVT,I,I2,I2,J,VAIN,X,X1
+4 GOTO ^DGRPCF
+5 ;
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
SET DGLST="END"
+1 QUIT
+2 ;
OVER99CK NEW DGP,DGSD,RULE,FILERR
+1 DO LOADPT^IVMZ07C(DFN,.DGP)
DO LOADSD^IVMZ072(DFN,.DGSD)
+2 ;DG*5.3*1109 removed 304:GENDER INVALID from following loop
+3 ;F RULE=301,303,304,306,307,308 S DGLST=RULE_"^IVMZ7CD" D @DGLST I $D(FILERR(RULE)) S X=RULE D COMB
+4 ;DG*5.3*1111 removed 301:PERSON LASTNAME REQUIRED and 303:GENDER REQUIRED from following loop
+5 ;F RULE=301,303,306,307,308 S DGLST=RULE_"^IVMZ7CD" D @DGLST I $D(FILERR(RULE)) S X=RULE D COMB
+6 FOR RULE=306,307,308
SET DGLST=RULE_"^IVMZ7CD"
DO @DGLST
IF $DATA(FILERR(RULE))
SET X=RULE
DO COMB
+7 ;DG*5.3*1098 removed 406:CLAIM NUMBER INVALID, from following for loop
+8 FOR RULE=402,403,407
SET DGLST=RULE_"^IVMZ7CE"
DO @DGLST
IF $DATA(FILERR(RULE))
SET X=RULE
DO COMB
+9 FOR RULE=501:1:507,516,517
SET DGLST=RULE_"^IVMZ7CS"
DO @DGLST
IF $DATA(FILERR(RULE))
SET X=RULE
DO COMB
+10 FOR RULE=313
SET DGLST=RULE_"^DGRPC3"
DO @DGLST
IF $DATA(FILERR(RULE))
SET X=RULE
DO COMB
+11 FOR RULE=314
SET DGLST=RULE_"^DGRPC3"
DO @DGLST
IF $DATA(FILERR(RULE))
SET X=RULE
DO COMB
+12 FOR RULE=315
SET DGLST=RULE_"^DGRPC3"
DO @DGLST
IF $DATA(FILERR(RULE))
SET X=RULE
DO COMB
+13 SET DGLST="END"
+14 QUIT
+15 ;
313 ; NEWBORN REQUIRES SPONSOR
+1 NEW X
+2 SET DOB=$PIECE(^DPT(DFN,0),"^",3)
+3 DO NOW^%DTC
+4 SET NOW=X
+5 ;NOT A NEWBORN
IF $$FMDIFF^XLFDT(NOW,DOB,1)>365
QUIT
+6 ;already has a sponsor
IF $DATA(^IBA(355.81,"B",DFN))
QUIT
+7 SET FILERR(RULE)=""
+8 QUIT
+9 ;
314 ;NEWBORN SPONSOR MUST BE ELIGIBLE
+1 ;Does not have a sponsor
IF '$DATA(^IBA(355.81,"B",DFN))
QUIT
+2 NEW X
+3 SET DOB=$PIECE(^DPT(DFN,0),"^",3)
+4 DO NOW^%DTC
+5 SET NOW=X
+6 ;NOT A NEWBORN
IF $$FMDIFF^XLFDT(NOW,DOB,1)>365
QUIT
+7 NEW RELIEN,SPNIEN,SPNDFN,ELIG
+8 ;NEED TO FIND SPONSOR IN PATIENT FILE
+9 SET RELIEN=""
SET SPNIEN=""
SET SPNDFN=""
SET ELIG=""
+10 SET RELIEN=$ORDER(^IBA(355.81,"B",DFN,RELIEN))
+11 SET SPNIEN=$$GET1^DIQ(355.81,RELIEN,.02,"I")
+12 SET SPNDFN=$$GET1^DIQ(355.8,SPNIEN,.01,"I")
+13 SET SPNDFN=$PIECE(SPNDFN,";",1)
+14 SET ELIG=$$GET1^DIQ(2,SPNDFN,.3611,"I")
+15 ;sponsor has an eligibility status
IF ELIG'=""
QUIT
+16 SET FILERR(RULE)=""
+17 QUIT
+18 ;
315 ; MHV - subroutine added by patch DG*5.3*903
+1 if '$GET(DFN)!'$GET(DGPRFLG)
QUIT
+2 ;This functionality will not be executed if "Enable MyHealtheVet Prompts?" (#1100.07
+3 ;field in MAS PARAMETERS (43) file is not set to YES (internal value 1)
+4 if +$$MHVENABL^DGMHVUTL()'>0
QUIT
+5 ;
+6 NEW DGFLDCHK,DGMHVACT,DGMHVOUT,DGMHVQ,X,Y,DIR
+7 if $$MHVOK^DGMHVAC(DFN)
QUIT
+8 ; Quit if MHV ENROLLED/Registered has not been answered, and enrollment/registration
+9 ; action is pending
+10 SET DGMHVACT=$$ENQACHK^DGMHVUTL(DFN)
if (DGMHVACT]"")&'$GET(^DPT(DFN,2))
QUIT
+11 if '$$MHVOK^DGMHVAC(DFN)
SET FILERR(315)=""
+12 QUIT
