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 Nov 22, 2024@17:09:15 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
