- DGRPC3 ;ALB/PJR,LBD,BAJ,TDM - CHECK CONSISTENCY OF PATIENT DATA (CONT) ; 10/20/10 3:40pm
- ;;5.3;PIMS;**451,632,673,657,1015,1016**;JUN 30, 2012;Build 20
- ;
- 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
- 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)
- F RULE=301,303,304,306:1:308 S DGLST=RULE_"^IVMZ7CD" D @DGLST I $D(FILERR(RULE)) S X=RULE D COMB
- F RULE=402,403,406,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
- S DGLST="END"
- Q
- DGRPC3 ;ALB/PJR,LBD,BAJ,TDM - CHECK CONSISTENCY OF PATIENT DATA (CONT) ; 10/20/10 3:40pm
- +1 ;;5.3;PIMS;**451,632,673,657,1015,1016**;JUN 30, 2012;Build 20
- +2 ;
- 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
- 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 FOR RULE=301,303,304,306:1:308
- SET DGLST=RULE_"^IVMZ7CD"
- DO @DGLST
- IF $DATA(FILERR(RULE))
- SET X=RULE
- DO COMB
- +3 FOR RULE=402,403,406,407
- SET DGLST=RULE_"^IVMZ7CE"
- DO @DGLST
- IF $DATA(FILERR(RULE))
- SET X=RULE
- DO COMB
- +4 FOR RULE=501:1:507,516,517
- SET DGLST=RULE_"^IVMZ7CS"
- DO @DGLST
- IF $DATA(FILERR(RULE))
- SET X=RULE
- DO COMB
- +5 SET DGLST="END"
- +6 QUIT