- DVBHS3 ; ALB/JLU;Routine for HINQ screen 3 ; 8/22/05 9:46pm
- ;;4.0;HINQ;**49**;03/25/92
- ;
- K DVBX(1)
- F LP2=.322,.32101 S X="DVBDIQ(2,"_DFN_","_LP2_")" K @X
- K DVBDIQ(2.04)
- I $D(X(1)) S DVBX(1)=X(1)
- S DIC="^DPT(",DA=DFN,DIQ(0)="E",DIQ="DVBDIQ("
- S DR=".302;.3014;.322;.32101;.361"
- D EN^DIQ1
- S DR=".3721",DR(2.04)=".01;2:6",DIQ(0)="IE"
- F LP=0:0 S LP=$O(^DPT(DFN,.372,LP)) Q:'LP S DA(2.04)=LP D EN^DIQ1
- I $D(DVBX(1)) S X(1)=DVBX(1) K DVBX(1)
- S DVBSCRN=3 D SCRHD^DVBHUTIL
- S DVBJS=35
- ;
- ;DVB*4*49 - Combat Disability removed - Combined % Disability okay
- ;W !?11,"Comb. % Disab.: "
- ;I $D(DVBDXPCT) W +DVBDXPCT
- W !,"Act. Duty Training: "
- I $D(DVBBIR) W $S($P(DVBBIR,U,24)["Y":"YES",$P(DVBBIR,U,24)["N":"NO",1:"")
- ;as of DVB*4*49 Additional Service is no longer being sent by VBA
- ;
- W ?24,"Tot. Act. Ser.: "
- I $D(DVBTOTAS) W ?40,DVBTOTAS
- ;
- W ?63,"Perm. & Tot.: "
- ;DVB*4*49 - P&T now being sent by VBA. 3=yes,2=no, else null
- I $D(DVBPTI) W ?56,$S(DVBPTI=2:"No",DVBPTI=3:"Yes",1:"")
- ;
- W !,DVBON,"[1]",DVBOFF X DVBLIT1
- W ?4,"Ver. SVC data: "
- W ?21,DVBDIQ(2,DFN,.322,"E")
- I $D(DVBP(6)) W ?49,$S($P(DVBP(6),U,8)["Y":"YES",$P(DVBP(6),U,8)["N":"NO",1:"")
- ;
- W !,DVBON,"[2]",DVBOFF X DVBLIT1
- W ?4,"Vietnam Ser.:"
- W ?21,DVBDIQ(2,DFN,.32101,"E")
- I $D(DVBP(6)) W ?49,$S($P(DVBP(6),U,4)["Y":"YES",$P(DVBP(6),U,4)["N":"NO",1:"")
- ;
- W !,DVBON,"[3]",DVBOFF X DVBLIT1
- W ?4,"Rated Disab.(Pat. File)-Comb. SC%: "
- I DVBDIQ(2,DFN,.361,"E")'="NSC" W ?37,$S(DVBDIQ(2,DFN,.302,"E")]"":+DVBDIQ(2,DFN,.302,"E"),1:"")
- ;W ?37,+DVBDIQ(2,DFN,.302,"E")
- W ?42,"Eff. Date Comb. Eval.: "_DVBDIQ(2,DFN,.3014,"E")
- I $P($G(^DPT(DFN,.372,0)),U,3)>0 D LABELS
- I $D(DVBDIQ(2.04)) F LP=0:0 S LP=$O(DVBDIQ(2.04,LP)) Q:'LP D
- . I ($Y+5)>IOSL,$E(IOST,1,2)="C-" D PAUSE
- . W !,$E(DVBDIQ(2.04,LP,.01,"E"),1,40),?42,DVBDIQ(2.04,LP,2,"E")
- . W ?50,$G(DVBDIQ(2.04,LP,4,"I")),?55,$G(DVBDIQ(2.04,LP,5,"E"))
- . W ?68,$G(DVBDIQ(2.04,LP,6,"E"))
- N DVBEDT
- I +$G(DVBEFF)>0 S M=$E(DVBEFF,1,2) D MM^DVBHQM11 S DVBEDT=M_" "_$E(DVBEFF,3,4)_","_$E(DVBEFF,5,8)
- W !,?4,"Rated Disab. (HINQ)- Comb. SC%: "
- W ?39,$S($G(DVBDXPCT)]"":+DVBDXPCT,1:"")
- W ?44,"Eff. Date Comb. Eval.: "_$G(DVBEDT)
- I $D(DVBDX)>9 D S1^DVBHQZ6
- Q
- PAUSE ;
- N DIR
- S DIR(0)="E" D ^DIR
- I ('(+Y))!$D(DIRUT) S QUIT=1
- W @IOF,!
- Q
- CHKDIS ;check to see if any of the disabilities comng from VBA are absent
- ;from the VistA DISABILITY CONDITION file (#31)
- Q
- N DVBC,DVBERR
- S (DVBC,DVBERR)=0
- F S DVBC=$O(DVBDX(DVBC)) Q:DVBC'>0 D
- . N DVBDIS,DVBDISAB
- . S DVBDISAB=$P(DVBDX(DVBC),U)
- . S DVBDIS=$O(^DIC(31,"C",DVBDISAB,""))
- . I $G(DVBDIS)']"" W !,"Disability code "_DVBDISAB_" is missing from this site's DISABILITY",!,"CONDITIONS file (#13). "_DVBDISAB_" not updated to VistA. Check with ADPAC." S DVBERR=1
- I $G(DVBERR)=0 Q
- N DVBANS
- R !,"Hit any key to continue: ",DVBANS:DTIME
- Q
- CHKEFF(DVBDT) ;
- Q:$G(DVBDT)']""
- F DVBE=1:1:4 I $E(DVBDT,1)=" " S DVBDT=$E(DVBDT,2,8)
- I DVBDT'?1.8N S DVBDT="" Q
- D
- . S DVBOFFST="00000000"
- . S DVBDT=$E(DVBOFFST,1,8-$L(DVBDT))_DVBDT
- . I +DVBDT?5.6N S DVBDT=$E(DVBDT,3,4)_"00"_$E(DVBDT,5,8)
- S DVBDT=($E(DVBDT,5,8)-1700)_$E(DVBDT,1,2)_$E(DVBDT,3,4)
- Q
- LABELS ;
- W !?55,"Original",?68,"Current"
- W !?3,"Disability",?43,"%",?49,"Extr.",?54,"Eff. Date",?67,"Eff. Date"
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBHS3 3350 printed Feb 18, 2025@23:25:28 Page 2
- DVBHS3 ; ALB/JLU;Routine for HINQ screen 3 ; 8/22/05 9:46pm
- +1 ;;4.0;HINQ;**49**;03/25/92
- +2 ;
- +3 KILL DVBX(1)
- +4 FOR LP2=.322,.32101
- SET X="DVBDIQ(2,"_DFN_","_LP2_")"
- KILL @X
- +5 KILL DVBDIQ(2.04)
- +6 IF $DATA(X(1))
- SET DVBX(1)=X(1)
- +7 SET DIC="^DPT("
- SET DA=DFN
- SET DIQ(0)="E"
- SET DIQ="DVBDIQ("
- +8 SET DR=".302;.3014;.322;.32101;.361"
- +9 DO EN^DIQ1
- +10 SET DR=".3721"
- SET DR(2.04)=".01;2:6"
- SET DIQ(0)="IE"
- +11 FOR LP=0:0
- SET LP=$ORDER(^DPT(DFN,.372,LP))
- if 'LP
- QUIT
- SET DA(2.04)=LP
- DO EN^DIQ1
- +12 IF $DATA(DVBX(1))
- SET X(1)=DVBX(1)
- KILL DVBX(1)
- +13 SET DVBSCRN=3
- DO SCRHD^DVBHUTIL
- +14 SET DVBJS=35
- +15 ;
- +16 ;DVB*4*49 - Combat Disability removed - Combined % Disability okay
- +17 ;W !?11,"Comb. % Disab.: "
- +18 ;I $D(DVBDXPCT) W +DVBDXPCT
- +19 WRITE !,"Act. Duty Training: "
- +20 IF $DATA(DVBBIR)
- WRITE $SELECT($PIECE(DVBBIR,U,24)["Y":"YES",$PIECE(DVBBIR,U,24)["N":"NO",1:"")
- +21 ;as of DVB*4*49 Additional Service is no longer being sent by VBA
- +22 ;
- +23 WRITE ?24,"Tot. Act. Ser.: "
- +24 IF $DATA(DVBTOTAS)
- WRITE ?40,DVBTOTAS
- +25 ;
- +26 WRITE ?63,"Perm. & Tot.: "
- +27 ;DVB*4*49 - P&T now being sent by VBA. 3=yes,2=no, else null
- +28 IF $DATA(DVBPTI)
- WRITE ?56,$SELECT(DVBPTI=2:"No",DVBPTI=3:"Yes",1:"")
- +29 ;
- +30 WRITE !,DVBON,"[1]",DVBOFF
- XECUTE DVBLIT1
- +31 WRITE ?4,"Ver. SVC data: "
- +32 WRITE ?21,DVBDIQ(2,DFN,.322,"E")
- +33 IF $DATA(DVBP(6))
- WRITE ?49,$SELECT($PIECE(DVBP(6),U,8)["Y":"YES",$PIECE(DVBP(6),U,8)["N":"NO",1:"")
- +34 ;
- +35 WRITE !,DVBON,"[2]",DVBOFF
- XECUTE DVBLIT1
- +36 WRITE ?4,"Vietnam Ser.:"
- +37 WRITE ?21,DVBDIQ(2,DFN,.32101,"E")
- +38 IF $DATA(DVBP(6))
- WRITE ?49,$SELECT($PIECE(DVBP(6),U,4)["Y":"YES",$PIECE(DVBP(6),U,4)["N":"NO",1:"")
- +39 ;
- +40 WRITE !,DVBON,"[3]",DVBOFF
- XECUTE DVBLIT1
- +41 WRITE ?4,"Rated Disab.(Pat. File)-Comb. SC%: "
- +42 IF DVBDIQ(2,DFN,.361,"E")'="NSC"
- WRITE ?37,$SELECT(DVBDIQ(2,DFN,.302,"E")]"":+DVBDIQ(2,DFN,.302,"E"),1:"")
- +43 ;W ?37,+DVBDIQ(2,DFN,.302,"E")
- +44 WRITE ?42,"Eff. Date Comb. Eval.: "_DVBDIQ(2,DFN,.3014,"E")
- +45 IF $PIECE($GET(^DPT(DFN,.372,0)),U,3)>0
- DO LABELS
- +46 IF $DATA(DVBDIQ(2.04))
- FOR LP=0:0
- SET LP=$ORDER(DVBDIQ(2.04,LP))
- if 'LP
- QUIT
- Begin DoDot:1
- +47 IF ($Y+5)>IOSL
- IF $EXTRACT(IOST,1,2)="C-"
- DO PAUSE
- +48 WRITE !,$EXTRACT(DVBDIQ(2.04,LP,.01,"E"),1,40),?42,DVBDIQ(2.04,LP,2,"E")
- +49 WRITE ?50,$GET(DVBDIQ(2.04,LP,4,"I")),?55,$GET(DVBDIQ(2.04,LP,5,"E"))
- +50 WRITE ?68,$GET(DVBDIQ(2.04,LP,6,"E"))
- End DoDot:1
- +51 NEW DVBEDT
- +52 IF +$GET(DVBEFF)>0
- SET M=$EXTRACT(DVBEFF,1,2)
- DO MM^DVBHQM11
- SET DVBEDT=M_" "_$EXTRACT(DVBEFF,3,4)_","_$EXTRACT(DVBEFF,5,8)
- +53 WRITE !,?4,"Rated Disab. (HINQ)- Comb. SC%: "
- +54 WRITE ?39,$SELECT($GET(DVBDXPCT)]"":+DVBDXPCT,1:"")
- +55 WRITE ?44,"Eff. Date Comb. Eval.: "_$GET(DVBEDT)
- +56 IF $DATA(DVBDX)>9
- DO S1^DVBHQZ6
- +57 QUIT
- PAUSE ;
- +1 NEW DIR
- +2 SET DIR(0)="E"
- DO ^DIR
- +3 IF ('(+Y))!$DATA(DIRUT)
- SET QUIT=1
- +4 WRITE @IOF,!
- +5 QUIT
- CHKDIS ;check to see if any of the disabilities comng from VBA are absent
- +1 ;from the VistA DISABILITY CONDITION file (#31)
- +2 QUIT
- +3 NEW DVBC,DVBERR
- +4 SET (DVBC,DVBERR)=0
- +5 FOR
- SET DVBC=$ORDER(DVBDX(DVBC))
- if DVBC'>0
- QUIT
- Begin DoDot:1
- +6 NEW DVBDIS,DVBDISAB
- +7 SET DVBDISAB=$PIECE(DVBDX(DVBC),U)
- +8 SET DVBDIS=$ORDER(^DIC(31,"C",DVBDISAB,""))
- +9 IF $GET(DVBDIS)']""
- WRITE !,"Disability code "_DVBDISAB_" is missing from this site's DISABILITY",!,"CONDITIONS file (#13). "_DVBDISAB_" not updated to VistA. Check with ADPAC."
- SET DVBERR=1
- End DoDot:1
- +10 IF $GET(DVBERR)=0
- QUIT
- +11 NEW DVBANS
- +12 READ !,"Hit any key to continue: ",DVBANS:DTIME
- +13 QUIT
- CHKEFF(DVBDT) ;
- +1 if $GET(DVBDT)']""
- QUIT
- +2 FOR DVBE=1:1:4
- IF $EXTRACT(DVBDT,1)=" "
- SET DVBDT=$EXTRACT(DVBDT,2,8)
- +3 IF DVBDT'?1.8N
- SET DVBDT=""
- QUIT
- +4 Begin DoDot:1
- +5 SET DVBOFFST="00000000"
- +6 SET DVBDT=$EXTRACT(DVBOFFST,1,8-$LENGTH(DVBDT))_DVBDT
- +7 IF +DVBDT?5.6N
- SET DVBDT=$EXTRACT(DVBDT,3,4)_"00"_$EXTRACT(DVBDT,5,8)
- End DoDot:1
- +8 SET DVBDT=($EXTRACT(DVBDT,5,8)-1700)_$EXTRACT(DVBDT,1,2)_$EXTRACT(DVBDT,3,4)
- +9 QUIT
- LABELS ;
- +1 WRITE !?55,"Original",?68,"Current"
- +2 WRITE !?3,"Disability",?43,"%",?49,"Extr.",?54,"Eff. Date",?67,"Eff. Date"
- +3 QUIT