- 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 Mar 13, 2025@22:00:39 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