- DGRP11 ;ALB/MRL,RTK,PHH,PWC,HM,BDB - REGISTRATION SCREEN 11/VERIFICATION INFORMATION ;3/23/06 8:10am
- ;;5.3;Registration;**327,631,709,871,987,1006**;Aug 13, 1993;Build 6
- ;
- S DGRPS=11 D H^DGRPU F I=.3,.32,.36,.361,"TYPE","VET" S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
- S (DGRPW,Z)=1 D WW^DGRPV W " Eligibility Status: " S DGRPX=DGRP(.361),X=$P(DGRPX,"^",1),Z=$S(X']"":"NOT VERIFIED",X="V":"VERIFIED",X="R":"PENDING RE-VERIFICATION",1:"PENDING VERIFICATION"),Z1=28 D WW1^DGRPV S DGRPVR=$S(X]"":1,1:0)
- W "Status Date: " S Y=$P(DGRPX,"^",2) X:Y]"" ^DD("DD") W $S(Y]"":Y,DGRPVR:DGRPU,1:DGRPNA),!?5,"Status Entered By: ",$S($D(^VA(200,+$P(DGRPX,"^",6),0)):$P(^(0),"^",1)_" (#"_+$P(DGRPX,"^",6)_")",DGRPVR:DGRPU,1:DGRPNA)
- W !?6,"Interim Response: " S Y=$P(DGRPX,"^",4) X:Y]"" ^DD("DD") W $S(Y]"":Y,1:DGRPU_" (NOT REQUIRED)"),!?9,"Verif. Method: ",$S($P(DGRPX,"^",5)]"":$P(DGRPX,"^",5),DGRPVR:DGRPU,1:DGRPNA)
- ;Added display of ELIGIBILITY VERIF. SOURCE for Ineligible Project:
- W !?9,"Verif. Source: ",$S($P(DGRPX,"^",3)="H":"HEC",$P(DGRPX,"^",3)="V":"VISTA",1:"NOT AVAILABLE")
- S Z=2 D WW^DGRPV W " Money Verified: " S Y=$P(DGRP(.3),"^",6) X:Y]"" ^DD("DD") W $S(Y]"":Y,1:"NOT VERIFIED") S Z=3 D WW^DGRPV W " Service Verified: " S Y=$P(DGRP(.32),"^",2) X:Y]"" ^DD("DD") W $S(Y]"":Y,1:"NOT VERIFIED")
- S Z=4 D WW^DGRPV W " Rated Disabilities: " I $P(DGRP("VET"),"^",1)'="Y",$S('$D(^DG(391,+DGRP("TYPE"),0)):1,$P(^(0),"^",2):0,1:1) W DGRPNA," - NOT A VETERAN" G HBP
- N DGEC,DGEFF
- S DGEC=$P($G(DGRP(.36)),U)
- I $G(DGEC) I $D(^DIC(8,DGEC)) S DGEC=$P(^DIC(8,DGEC,0),U)
- W " SC%: ",$S($G(DGEC)="NSC":"",$P($G(DGRP(.3)),U,2)="":"",1:$P($G(DGRP(.3)),U,2))
- S DGEFF=$P($G(DGRP(.3)),U,14)
- I $G(DGEFF)]"" S Y=DGEFF X ^DD("DD") S DGEFF=Y
- W " EFF. DATE OF COMBINED SC%: "_$G(DGEFF),!
- N DGQUIT
- W ?55,"Orig",?70,"Curr"
- W !?3,"Rated Disability",?46,"Extr",?55,"Eff Dt",?70,"Eff Dt"
- S I3=0
- I '$$RDIS^DGRPDB(DFN,.DGARR) W !,"NONE STATED" G HBP
- F DGC=0:0 S DGC=$O(DGARR(DGC)) Q:'DGC D
- . S I3=I3+1
- . N DGCURR,DGORIG,DG0,DG1,DG2,DG4,DG5
- . I $G(DGARR(DGC))']"" Q
- . S DGZERO=+DGARR(DGC)
- . I '$D(^DIC(31,DGZERO,0)) Q
- . S DG0=$P(^DIC(31,DGZERO,0),U,3)
- . S DG1=$P(^DIC(31,DGZERO,0),U)
- . S DG2="("_$S($P(DGARR(DGC),U,3)=1:$P(DGARR(DGC),U,2)_"% SC",$P(DGARR(DGC),U,3)]"":$P(DGARR(DGC),U,2)_"% NSC",1:"unspec")_")"
- . S DG4=$P(DGARR(DGC),U,4),DG5=$P(DGARR(DGC),U,5),DG6=$P(DGARR(DGC),U,6)
- . I DG5]"" S Y=DG5 X ^DD("DD") S DGORIG=Y
- . I DG6]"" S Y=DG6 X ^DD("DD") S DGCURR=Y
- . I $Y>(IOSL-3) D PAUSE^DGRPDB I $G(DGQUIT)=0 W @IOF
- . I $G(DGQUIT)=1 Q
- . W !,$G(DG0)_"-",DG1,DG2,?47,$G(DG4),?50," - ",?53,$G(DGORIG),?64," - ",?68,$G(DGCURR)
- W:'I3 !,"NONE STATED"
- HBP ; LINE FOR HEALTH BENEFIT PLAN (DG*53*871)
- W ! S Z=5
- W:DGRPW ! S Z="["_Z_"]"
- I DGRPCM!($E(Z)="[") W @DGVI,Z,@DGVO
- I 'DGRPCM&($E(Z)'="[") W Z
- ; D WW^DGRPV Removed to always have #5 selectable then sub screens of 11 will control edit and view capabilities
- ;W " Veteran Medical Benefit Plan (VMBP): " N CNT,PLN D ;DG*5.3*987 HM
- W " VHA Profiles (VHAP): " N CNT,PLN D ;DG*5.3*1006 BDB;DG*5.3*987 HM
- . S (CNT,PLN)=0 F S PLN=$O(^DPT(DFN,"HBP",PLN)) Q:PLN<1 S CNT=CNT+1
- W $S(CNT>0:" ("_CNT_" Profile"_$S(CNT=1:"",1:"s")_" on file)",1:" (None Specified)")
- Q G ^DGRPP
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRP11 3286 printed Feb 19, 2025@00:21:30 Page 2
- DGRP11 ;ALB/MRL,RTK,PHH,PWC,HM,BDB - REGISTRATION SCREEN 11/VERIFICATION INFORMATION ;3/23/06 8:10am
- +1 ;;5.3;Registration;**327,631,709,871,987,1006**;Aug 13, 1993;Build 6
- +2 ;
- +3 SET DGRPS=11
- DO H^DGRPU
- FOR I=.3,.32,.36,.361,"TYPE","VET"
- SET DGRP(I)=$SELECT($DATA(^DPT(DFN,I)):^(I),1:"")
- +4 SET (DGRPW,Z)=1
- DO WW^DGRPV
- WRITE " Eligibility Status: "
- SET DGRPX=DGRP(.361)
- SET X=$PIECE(DGRPX,"^",1)
- SET Z=$SELECT(X']"":"NOT VERIFIED",X="V":"VERIFIED",X="R":"PENDING RE-VERIFICATION",1:"PENDING VERIFICATION")
- SET Z1=28
- DO WW1^DGRPV
- SET DGRPVR=$SELECT(X]"":1,1:0)
- +5 WRITE "Status Date: "
- SET Y=$PIECE(DGRPX,"^",2)
- if Y]""
- XECUTE ^DD("DD")
- WRITE $SELECT(Y]"":Y,DGRPVR:DGRPU,1:DGRPNA),!?5,"Status Entered By: ",$SELECT($DATA(^VA(200,+$PIECE(DGRPX,"^",6),0)):$PIECE(^(0),"^",1)_" (#"_+$PIECE(DGRPX,"^",6)_")",DGRPVR:DGRPU,1:DGRPNA)
- +6 WRITE !?6,"Interim Response: "
- SET Y=$PIECE(DGRPX,"^",4)
- if Y]""
- XECUTE ^DD("DD")
- WRITE $SELECT(Y]"":Y,1:DGRPU_" (NOT REQUIRED)"),!?9,"Verif. Method: ",$SELECT($PIECE(DGRPX,"^",5)]"":$PIECE(DGRPX,"^",5),DGRPVR:DGRPU,1:DGRPNA)
- +7 ;Added display of ELIGIBILITY VERIF. SOURCE for Ineligible Project:
- +8 WRITE !?9,"Verif. Source: ",$SELECT($PIECE(DGRPX,"^",3)="H":"HEC",$PIECE(DGRPX,"^",3)="V":"VISTA",1:"NOT AVAILABLE")
- +9 SET Z=2
- DO WW^DGRPV
- WRITE " Money Verified: "
- SET Y=$PIECE(DGRP(.3),"^",6)
- if Y]""
- XECUTE ^DD("DD")
- WRITE $SELECT(Y]"":Y,1:"NOT VERIFIED")
- SET Z=3
- DO WW^DGRPV
- WRITE " Service Verified: "
- SET Y=$PIECE(DGRP(.32),"^",2)
- if Y]""
- XECUTE ^DD("DD")
- WRITE $SELECT(Y]"":Y,1:"NOT VERIFIED")
- +10 SET Z=4
- DO WW^DGRPV
- WRITE " Rated Disabilities: "
- IF $PIECE(DGRP("VET"),"^",1)'="Y"
- IF $SELECT('$DATA(^DG(391,+DGRP("TYPE"),0)):1,$PIECE(^(0),"^",2):0,1:1)
- WRITE DGRPNA," - NOT A VETERAN"
- GOTO HBP
- +11 NEW DGEC,DGEFF
- +12 SET DGEC=$PIECE($GET(DGRP(.36)),U)
- +13 IF $GET(DGEC)
- IF $DATA(^DIC(8,DGEC))
- SET DGEC=$PIECE(^DIC(8,DGEC,0),U)
- +14 WRITE " SC%: ",$SELECT($GET(DGEC)="NSC":"",$PIECE($GET(DGRP(.3)),U,2)="":"",1:$PIECE($GET(DGRP(.3)),U,2))
- +15 SET DGEFF=$PIECE($GET(DGRP(.3)),U,14)
- +16 IF $GET(DGEFF)]""
- SET Y=DGEFF
- XECUTE ^DD("DD")
- SET DGEFF=Y
- +17 WRITE " EFF. DATE OF COMBINED SC%: "_$GET(DGEFF),!
- +18 NEW DGQUIT
- +19 WRITE ?55,"Orig",?70,"Curr"
- +20 WRITE !?3,"Rated Disability",?46,"Extr",?55,"Eff Dt",?70,"Eff Dt"
- +21 SET I3=0
- +22 IF '$$RDIS^DGRPDB(DFN,.DGARR)
- WRITE !,"NONE STATED"
- GOTO HBP
- +23 FOR DGC=0:0
- SET DGC=$ORDER(DGARR(DGC))
- if 'DGC
- QUIT
- Begin DoDot:1
- +24 SET I3=I3+1
- +25 NEW DGCURR,DGORIG,DG0,DG1,DG2,DG4,DG5
- +26 IF $GET(DGARR(DGC))']""
- QUIT
- +27 SET DGZERO=+DGARR(DGC)
- +28 IF '$DATA(^DIC(31,DGZERO,0))
- QUIT
- +29 SET DG0=$PIECE(^DIC(31,DGZERO,0),U,3)
- +30 SET DG1=$PIECE(^DIC(31,DGZERO,0),U)
- +31 SET DG2="("_$SELECT($PIECE(DGARR(DGC),U,3)=1:$PIECE(DGARR(DGC),U,2)_"% SC",$PIECE(DGARR(DGC),U,3)]"":$PIECE(DGARR(DGC),U,2)_"% NSC",1:"unspec")_")"
- +32 SET DG4=$PIECE(DGARR(DGC),U,4)
- SET DG5=$PIECE(DGARR(DGC),U,5)
- SET DG6=$PIECE(DGARR(DGC),U,6)
- +33 IF DG5]""
- SET Y=DG5
- XECUTE ^DD("DD")
- SET DGORIG=Y
- +34 IF DG6]""
- SET Y=DG6
- XECUTE ^DD("DD")
- SET DGCURR=Y
- +35 IF $Y>(IOSL-3)
- DO PAUSE^DGRPDB
- IF $GET(DGQUIT)=0
- WRITE @IOF
- +36 IF $GET(DGQUIT)=1
- QUIT
- +37 WRITE !,$GET(DG0)_"-",DG1,DG2,?47,$GET(DG4),?50," - ",?53,$GET(DGORIG),?64," - ",?68,$GET(DGCURR)
- End DoDot:1
- +38 if 'I3
- WRITE !,"NONE STATED"
- HBP ; LINE FOR HEALTH BENEFIT PLAN (DG*53*871)
- +1 WRITE !
- SET Z=5
- +2 if DGRPW
- WRITE !
- SET Z="["_Z_"]"
- +3 IF DGRPCM!($EXTRACT(Z)="[")
- WRITE @DGVI,Z,@DGVO
- +4 IF 'DGRPCM&($EXTRACT(Z)'="[")
- WRITE Z
- +5 ; D WW^DGRPV Removed to always have #5 selectable then sub screens of 11 will control edit and view capabilities
- +6 ;W " Veteran Medical Benefit Plan (VMBP): " N CNT,PLN D ;DG*5.3*987 HM
- +7 ;DG*5.3*1006 BDB;DG*5.3*987 HM
- WRITE " VHA Profiles (VHAP): "
- NEW CNT,PLN
- Begin DoDot:1
- +8 SET (CNT,PLN)=0
- FOR
- SET PLN=$ORDER(^DPT(DFN,"HBP",PLN))
- if PLN<1
- QUIT
- SET CNT=CNT+1
- End DoDot:1
- +9 WRITE $SELECT(CNT>0:" ("_CNT_" Profile"_$SELECT(CNT=1:"",1:"s")_" on file)",1:" (None Specified)")
- Q GOTO ^DGRPP