DVBHCG ; GENERATED FROM 'DVBHINQ PAT-HINQ COMP' PRINT TEMPLATE (#513) ; 03/29/12 ; (FILE 2, MARGIN=80)
G BEGIN
N W !
T W:$X ! I '$D(DIOT(2)),DN,$D(IOSL),$S('$D(DIWF):1,$P(DIWF,"B",2):$P(DIWF,"B",2),1:1)+$Y'<IOSL,$D(^UTILITY($J,1))#2,^(1)?1U1P1E.E X ^(1)
S DISTP=DISTP+1,DILCT=DILCT+1 D:'(DISTP#100) CSTP^DIO2
Q
DT I $G(DUZ("LANG"))>1,Y W $$OUT^DIALOGU(Y,"DD") Q
I Y W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" " W:Y#100 $J(Y#100\1,2)_"," W Y\10000+1700 W:Y#1 " "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12) Q
W Y Q
M D @DIXX
Q
BEGIN ;
S:'$D(DN) DN=1 S DISTP=$G(DISTP),DILCT=$G(DILCT)
I $D(DXS)<9 M DXS=^DIPT(513,"DXS")
S I(0)="^DPT(",J(0)=2
W ?0 W @$S('$D(IOF):"#",IOF="":"#",1:IOF) K DIP K:DN Y
X DXS(1,9) K DIP K:DN Y
D N:$X>0 Q:'DN W ?0 W "Name:"
S X=$G(^DPT(D0,0)) D N:$X>19 Q:'DN W ?19,$E($P(X,U,1),1,30)
W ?51 I $D(DVBADR(1)) W ?56,DVBADR(1) K DIP K:DN Y
W ?62 I '$D(DVBADR(1)),$D(DVBNAME) W ?56,DVBNAME K DIP K:DN Y
D N:$X>0 Q:'DN W ?0 W "Address:"
S X=$G(^DPT(D0,.11)) D N:$X>19 Q:'DN W ?19,$E($P(X,U,1),1,35)
W ?56 I $D(DVBADR(1)) W ?56,DVBADR(1) K DIP K:DN Y
S X=$G(^DPT(D0,.11)) D N:$X>19 Q:'DN W ?19,$E($P(X,U,2),1,30)
W ?51 I $D(DVBADR(2)) W ?56,DVBADR(2) K DIP K:DN Y
S X=$G(^DPT(D0,.11)) D N:$X>19 Q:'DN W ?19,$E($P(X,U,3),1,30)
W ?51 I $D(DVBADR(3)) W ?56,DVBADR(3) K DIP K:DN Y
D N:$X>0 Q:'DN W ?0 W "SSN:"
S X=$G(^DPT(D0,0)) D N:$X>19 Q:'DN W ?19,$E($P(X,U,9),1,10)
W ?31 I $D(DVBSSN) W ?50,DVBSSN K DIP K:DN Y
D N:$X>0 Q:'DN W ?0 W "Claim number:"
S X=$G(^DPT(D0,.31)) D N:$X>19 Q:'DN W ?19 S Y=$P(X,U,3) S Y(0)=Y S Y=$E(Y,1,10) W $E(Y,1,9)
I $D(DVBCN),DVBCN>0 W ?50,DVBCN K DIP K:DN Y
D N:$X>0 Q:'DN W ?0 W "Date of Birth:"
S X=$G(^DPT(D0,0)) D N:$X>19 Q:'DN W ?19 S Y=$P(X,U,3) S Y(0)=Y S X=Y(0) S:X X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3)) S Y=X W $E(Y,1,30)
W ?19 X DXS(2,9) K DIP K:DN Y
D N:$X>0 Q:'DN W ?0 W "Date of Death:"
S X=$G(^DPT(D0,.35)) D N:$X>19 Q:'DN W ?19 S Y=$P(X,U,1) D DT
W ?19 X DXS(3,9) K DIP K:DN Y
D N:$X>0 Q:'DN W ?0 W "Rated Incompetent:"
S X=$G(^DPT(D0,.29)) D N:$X>19 Q:'DN W ?19 S Y=$P(X,U,12) W:Y]"" $S($D(DXS(10,Y)):DXS(10,Y),1:Y)
W ?19 X DXS(4,9) K DIP K:DN Y
D N:$X>0 Q:'DN W ?0 W "POW"
S X=$G(^DPT(D0,.52)) D N:$X>19 Q:'DN W ?19 S Y=$P(X,U,5) W:Y]"" $S($D(DXS(11,Y)):DXS(11,Y),1:Y)
W ?19 X DXS(5,9) K DIP K:DN Y
D N:$X>0 Q:'DN W ?0 W "Folder Location:"
S X=$G(^DPT(D0,.31)) D N:$X>19 Q:'DN W ?19 S Y=$P(X,U,4) S Y=$S(Y="":Y,$D(^DIC(4,Y,0))#2:$P(^(0),U),1:Y) W $E(Y,1,27)
W ?19 I $D(DVBFL) W ?50,$E(DVBFL,1,27) K DIP K:DN Y
D N:$X>0 Q:'DN W ?0 W "Verified SVC:"
S X=$G(^DPT(D0,.32)) D N:$X>19 Q:'DN W ?19 S Y=$P(X,U,2) D DT
W ?19 I $P(DVBP(6),U,8)'[" " W ?50 W:$P(DVBP(6),U,8)="Y" "YES" W:$P(DVBP(6),U,8)="N" "NO" K DIP K:DN Y
D N:$X>0 Q:'DN W ?0 W "Vietnam Service:"
S X=$G(^DPT(D0,.321)) D N:$X>19 Q:'DN W ?19 S Y=$P(X,U,1) W:Y]"" $S($D(DXS(12,Y)):DXS(12,Y),1:Y)
W ?19 I $P(DVBP(6),U,4)'[" " W ?50 W:$P(DVBP(6),U,4)="Y" "YES" W:$P(DVBP(6),U,4)="N" "NO" K DIP K:DN Y
W ?30 X DXS(6,9) K DIP K:DN Y
D T Q:'DN D N D N:$X>0 Q:'DN W ?0 W "Rated Disab. (Patient file)"
W ?29 D LSTR^DVBHQUP K DIP K:DN Y
W ?40 X DXS(7,9) K DIP K:DN Y
W ?51 I $D(DVBDXNO),DVBDXNO'=0 D S1^DVBHQZ6 K DIP K:DN Y
W !,?34,"HINQ Data" K DIP K:DN Y
W !,?6,"EOD",?20,"RAD",?34,"Bran. Ser.",?48,"Char. Ser.",?62,"Ser Num." K DIP K:DN Y
W ?62 W !,"--------------------------------------------------------------------------------" K DIP K:DN Y
D T Q:'DN W ?2 I +$G(DVBEOD(2))>0 K DVBEOD(1) K DIP K:DN Y
W ?13 I +$G(DVBRAD(2))>0 K DVBRAD(1) K DIP K:DN Y
W ?24 I $G(DVBCSVC(2))]"" K DVBCSVC(1) K DIP K:DN Y
W ?35 I $G(DVBSN(2))]"" K DVBSN(1) K DIP K:DN Y
W ?46 I $G(DVBBOS(2))]"" K DVBBOS(1) K DIP K:DN Y
X DXS(8,9) K DIP K:DN Y
X DXS(9,9) K DIP K:DN Y
I $D(DVBBOS(1)) S Y=DVBBOS(1) D XBOS^DVBHQM12 W ?34,$E(Y,1,16) K Y K DIP K:DN Y
I $D(DVBCSVC(1)) S I=1,Y=DVBCSVC(1) D DISCHG^DVBHQM1 W ?48,Y K Y K DIP K:DN Y
I $D(DVBSN(1)) W ?62,DVBSN(1) K DIP K:DN Y
W ! I $D(DVBEOD(2)),DVBEOD(2)?7N S Y=DVBEOD(2) X ^DD("DD") W ?1,Y K Y K DIP K:DN Y
I $D(DVBRAD(2)),DVBRAD(2)?7N S Y=DVBRAD(2) X ^DD("DD") W ?15,Y K Y K DIP K:DN Y
I $D(DVBBOS(2)) W ?34,DVBBOS(2) K DIP K:DN Y
I $D(DVBCSVC(2)) W ?48,DVBCSVC(2) K DIP K:DN Y
I $D(DVBSN(2)) W ?62,DVBSN(2) K DIP K:DN Y
W ! I $D(DVBEOD(3)),DVBEOD(3)?7N S Y=DVBEOD(3) X ^DD("DD") W ?1,Y K Y K DIP K:DN Y
I $D(DVBRAD(3)),DVBRAD(3)?7N S Y=DVBRAD(3) X ^DD("DD") W ?15,Y K Y K DIP K:DN Y
I $D(DVBBOS(3)) W ?34,DVBBOS(3) K DIP K:DN Y
I $D(DVBCSVC(3)) W ?48,DVBCSVC(3) K DIP K:DN Y
I $D(DVBSN(3)) W ?62,DVBSN(3) K DIP K:DN Y
W ! I $D(DVBEOD(4)),DVBEOD(4)?7N S Y=DVBEOD(4) X ^DD("DD") W ?1,Y K Y K DIP K:DN Y
I $D(DVBRAD(4)),DVBRAD(4)?7N S Y=DVBRAD(4) X ^DD("DD") W ?15,Y K Y K DIP K:DN Y
I $D(DVBBOS(4)) W ?34,DVBBOS(4) K DIP K:DN Y
I $D(DVBCSVC(4)) W ?48,DVBCSVC(4) K DIP K:DN Y
I $D(DVBSN(4)) W ?62,DVBSN(4) K DIP K:DN Y
W !!,?34,"Patient File" K DIP K:DN Y
W ?57 W !,"-------------------------------------------------------------------------------" K DIP K:DN Y
W ?68 D DISP^DVBHQZ6(DFN) K DIP K:DN Y
K Y
Q
HEAD ;
W !,"--------------------------------------------------------------------------------",!!
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBHCG 5282 printed Dec 13, 2024@01:58:17 Page 2
DVBHCG ; GENERATED FROM 'DVBHINQ PAT-HINQ COMP' PRINT TEMPLATE (#513) ; 03/29/12 ; (FILE 2, MARGIN=80)
+1 GOTO BEGIN
N WRITE !
T if $X
WRITE !
IF '$DATA(DIOT(2))
IF DN
IF $DATA(IOSL)
IF $SELECT('$DATA(DIWF):1,$PIECE(DIWF,"B",2):$PIECE(DIWF,"B",2),1:1)+$Y'<IOSL
IF $DATA(^UTILITY($JOB,1))#2
IF ^(1)?1U1P1E.E
XECUTE ^(1)
+1 SET DISTP=DISTP+1
SET DILCT=DILCT+1
if '(DISTP#100)
DO CSTP^DIO2
+2 QUIT
DT IF $GET(DUZ("LANG"))>1
IF Y
WRITE $$OUT^DIALOGU(Y,"DD")
QUIT
+1 IF Y
WRITE $PIECE("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$EXTRACT(Y,4,5))_" "
if Y#100
WRITE $JUSTIFY(Y#100\1,2)_","
WRITE Y\10000+1700
if Y#1
WRITE " "_$EXTRACT(Y_0,9,10)_":"_$EXTRACT(Y_"000",11,12)
QUIT
+2 WRITE Y
QUIT
M DO @DIXX
+1 QUIT
BEGIN ;
+1 if '$DATA(DN)
SET DN=1
SET DISTP=$GET(DISTP)
SET DILCT=$GET(DILCT)
+2 IF $DATA(DXS)<9
MERGE DXS=^DIPT(513,"DXS")
+3 SET I(0)="^DPT("
SET J(0)=2
+4 WRITE ?0
WRITE @$SELECT('$DATA(IOF):"#",IOF="":"#",1:IOF)
KILL DIP
if DN
KILL Y
+5 XECUTE DXS(1,9)
KILL DIP
if DN
KILL Y
+6 if $X>0
DO N
if 'DN
QUIT
WRITE ?0
WRITE "Name:"
+7 SET X=$GET(^DPT(D0,0))
if $X>19
DO N
if 'DN
QUIT
WRITE ?19,$EXTRACT($PIECE(X,U,1),1,30)
+8 WRITE ?51
IF $DATA(DVBADR(1))
WRITE ?56,DVBADR(1)
KILL DIP
if DN
KILL Y
+9 WRITE ?62
IF '$DATA(DVBADR(1))
IF $DATA(DVBNAME)
WRITE ?56,DVBNAME
KILL DIP
if DN
KILL Y
+10 if $X>0
DO N
if 'DN
QUIT
WRITE ?0
WRITE "Address:"
+11 SET X=$GET(^DPT(D0,.11))
if $X>19
DO N
if 'DN
QUIT
WRITE ?19,$EXTRACT($PIECE(X,U,1),1,35)
+12 WRITE ?56
IF $DATA(DVBADR(1))
WRITE ?56,DVBADR(1)
KILL DIP
if DN
KILL Y
+13 SET X=$GET(^DPT(D0,.11))
if $X>19
DO N
if 'DN
QUIT
WRITE ?19,$EXTRACT($PIECE(X,U,2),1,30)
+14 WRITE ?51
IF $DATA(DVBADR(2))
WRITE ?56,DVBADR(2)
KILL DIP
if DN
KILL Y
+15 SET X=$GET(^DPT(D0,.11))
if $X>19
DO N
if 'DN
QUIT
WRITE ?19,$EXTRACT($PIECE(X,U,3),1,30)
+16 WRITE ?51
IF $DATA(DVBADR(3))
WRITE ?56,DVBADR(3)
KILL DIP
if DN
KILL Y
+17 if $X>0
DO N
if 'DN
QUIT
WRITE ?0
WRITE "SSN:"
+18 SET X=$GET(^DPT(D0,0))
if $X>19
DO N
if 'DN
QUIT
WRITE ?19,$EXTRACT($PIECE(X,U,9),1,10)
+19 WRITE ?31
IF $DATA(DVBSSN)
WRITE ?50,DVBSSN
KILL DIP
if DN
KILL Y
+20 if $X>0
DO N
if 'DN
QUIT
WRITE ?0
WRITE "Claim number:"
+21 SET X=$GET(^DPT(D0,.31))
if $X>19
DO N
if 'DN
QUIT
WRITE ?19
SET Y=$PIECE(X,U,3)
SET Y(0)=Y
SET Y=$EXTRACT(Y,1,10)
WRITE $EXTRACT(Y,1,9)
+22 IF $DATA(DVBCN)
IF DVBCN>0
WRITE ?50,DVBCN
KILL DIP
if DN
KILL Y
+23 if $X>0
DO N
if 'DN
QUIT
WRITE ?0
WRITE "Date of Birth:"
+24 SET X=$GET(^DPT(D0,0))
if $X>19
DO N
if 'DN
QUIT
WRITE ?19
SET Y=$PIECE(X,U,3)
SET Y(0)=Y
SET X=Y(0)
if X
SET X=$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_(1700+$EXTRACT(X,1,3))
SET Y=X
WRITE $EXTRACT(Y,1,30)
+25 WRITE ?19
XECUTE DXS(2,9)
KILL DIP
if DN
KILL Y
+26 if $X>0
DO N
if 'DN
QUIT
WRITE ?0
WRITE "Date of Death:"
+27 SET X=$GET(^DPT(D0,.35))
if $X>19
DO N
if 'DN
QUIT
WRITE ?19
SET Y=$PIECE(X,U,1)
DO DT
+28 WRITE ?19
XECUTE DXS(3,9)
KILL DIP
if DN
KILL Y
+29 if $X>0
DO N
if 'DN
QUIT
WRITE ?0
WRITE "Rated Incompetent:"
+30 SET X=$GET(^DPT(D0,.29))
if $X>19
DO N
if 'DN
QUIT
WRITE ?19
SET Y=$PIECE(X,U,12)
if Y]""
WRITE $SELECT($DATA(DXS(10,Y)):DXS(10,Y),1:Y)
+31 WRITE ?19
XECUTE DXS(4,9)
KILL DIP
if DN
KILL Y
+32 if $X>0
DO N
if 'DN
QUIT
WRITE ?0
WRITE "POW"
+33 SET X=$GET(^DPT(D0,.52))
if $X>19
DO N
if 'DN
QUIT
WRITE ?19
SET Y=$PIECE(X,U,5)
if Y]""
WRITE $SELECT($DATA(DXS(11,Y)):DXS(11,Y),1:Y)
+34 WRITE ?19
XECUTE DXS(5,9)
KILL DIP
if DN
KILL Y
+35 if $X>0
DO N
if 'DN
QUIT
WRITE ?0
WRITE "Folder Location:"
+36 SET X=$GET(^DPT(D0,.31))
if $X>19
DO N
if 'DN
QUIT
WRITE ?19
SET Y=$PIECE(X,U,4)
SET Y=$SELECT(Y="":Y,$DATA(^DIC(4,Y,0))#2:$PIECE(^(0),U),1:Y)
WRITE $EXTRACT(Y,1,27)
+37 WRITE ?19
IF $DATA(DVBFL)
WRITE ?50,$EXTRACT(DVBFL,1,27)
KILL DIP
if DN
KILL Y
+38 if $X>0
DO N
if 'DN
QUIT
WRITE ?0
WRITE "Verified SVC:"
+39 SET X=$GET(^DPT(D0,.32))
if $X>19
DO N
if 'DN
QUIT
WRITE ?19
SET Y=$PIECE(X,U,2)
DO DT
+40 WRITE ?19
IF $PIECE(DVBP(6),U,8)'[" "
WRITE ?50
if $PIECE(DVBP(6),U,8)="Y"
WRITE "YES"
if $PIECE(DVBP(6),U,8)="N"
WRITE "NO"
KILL DIP
if DN
KILL Y
+41 if $X>0
DO N
if 'DN
QUIT
WRITE ?0
WRITE "Vietnam Service:"
+42 SET X=$GET(^DPT(D0,.321))
if $X>19
DO N
if 'DN
QUIT
WRITE ?19
SET Y=$PIECE(X,U,1)
if Y]""
WRITE $SELECT($DATA(DXS(12,Y)):DXS(12,Y),1:Y)
+43 WRITE ?19
IF $PIECE(DVBP(6),U,4)'[" "
WRITE ?50
if $PIECE(DVBP(6),U,4)="Y"
WRITE "YES"
if $PIECE(DVBP(6),U,4)="N"
WRITE "NO"
KILL DIP
if DN
KILL Y
+44 WRITE ?30
XECUTE DXS(6,9)
KILL DIP
if DN
KILL Y
+45 DO T
if 'DN
QUIT
DO N
if $X>0
DO N
if 'DN
QUIT
WRITE ?0
WRITE "Rated Disab. (Patient file)"
+46 WRITE ?29
DO LSTR^DVBHQUP
KILL DIP
if DN
KILL Y
+47 WRITE ?40
XECUTE DXS(7,9)
KILL DIP
if DN
KILL Y
+48 WRITE ?51
IF $DATA(DVBDXNO)
IF DVBDXNO'=0
DO S1^DVBHQZ6
KILL DIP
if DN
KILL Y
+49 WRITE !,?34,"HINQ Data"
KILL DIP
if DN
KILL Y
+50 WRITE !,?6,"EOD",?20,"RAD",?34,"Bran. Ser.",?48,"Char. Ser.",?62,"Ser Num."
KILL DIP
if DN
KILL Y
+51 WRITE ?62
WRITE !,"--------------------------------------------------------------------------------"
KILL DIP
if DN
KILL Y
+52 DO T
if 'DN
QUIT
WRITE ?2
IF +$GET(DVBEOD(2))>0
KILL DVBEOD(1)
KILL DIP
if DN
KILL Y
+53 WRITE ?13
IF +$GET(DVBRAD(2))>0
KILL DVBRAD(1)
KILL DIP
if DN
KILL Y
+54 WRITE ?24
IF $GET(DVBCSVC(2))]""
KILL DVBCSVC(1)
KILL DIP
if DN
KILL Y
+55 WRITE ?35
IF $GET(DVBSN(2))]""
KILL DVBSN(1)
KILL DIP
if DN
KILL Y
+56 WRITE ?46
IF $GET(DVBBOS(2))]""
KILL DVBBOS(1)
KILL DIP
if DN
KILL Y
+57 XECUTE DXS(8,9)
KILL DIP
if DN
KILL Y
+58 XECUTE DXS(9,9)
KILL DIP
if DN
KILL Y
+59 IF $DATA(DVBBOS(1))
SET Y=DVBBOS(1)
DO XBOS^DVBHQM12
WRITE ?34,$EXTRACT(Y,1,16)
KILL Y
KILL DIP
if DN
KILL Y
+60 IF $DATA(DVBCSVC(1))
SET I=1
SET Y=DVBCSVC(1)
DO DISCHG^DVBHQM1
WRITE ?48,Y
KILL Y
KILL DIP
if DN
KILL Y
+61 IF $DATA(DVBSN(1))
WRITE ?62,DVBSN(1)
KILL DIP
if DN
KILL Y
+62 WRITE !
IF $DATA(DVBEOD(2))
IF DVBEOD(2)?7N
SET Y=DVBEOD(2)
XECUTE ^DD("DD")
WRITE ?1,Y
KILL Y
KILL DIP
if DN
KILL Y
+63 IF $DATA(DVBRAD(2))
IF DVBRAD(2)?7N
SET Y=DVBRAD(2)
XECUTE ^DD("DD")
WRITE ?15,Y
KILL Y
KILL DIP
if DN
KILL Y
+64 IF $DATA(DVBBOS(2))
WRITE ?34,DVBBOS(2)
KILL DIP
if DN
KILL Y
+65 IF $DATA(DVBCSVC(2))
WRITE ?48,DVBCSVC(2)
KILL DIP
if DN
KILL Y
+66 IF $DATA(DVBSN(2))
WRITE ?62,DVBSN(2)
KILL DIP
if DN
KILL Y
+67 WRITE !
IF $DATA(DVBEOD(3))
IF DVBEOD(3)?7N
SET Y=DVBEOD(3)
XECUTE ^DD("DD")
WRITE ?1,Y
KILL Y
KILL DIP
if DN
KILL Y
+68 IF $DATA(DVBRAD(3))
IF DVBRAD(3)?7N
SET Y=DVBRAD(3)
XECUTE ^DD("DD")
WRITE ?15,Y
KILL Y
KILL DIP
if DN
KILL Y
+69 IF $DATA(DVBBOS(3))
WRITE ?34,DVBBOS(3)
KILL DIP
if DN
KILL Y
+70 IF $DATA(DVBCSVC(3))
WRITE ?48,DVBCSVC(3)
KILL DIP
if DN
KILL Y
+71 IF $DATA(DVBSN(3))
WRITE ?62,DVBSN(3)
KILL DIP
if DN
KILL Y
+72 WRITE !
IF $DATA(DVBEOD(4))
IF DVBEOD(4)?7N
SET Y=DVBEOD(4)
XECUTE ^DD("DD")
WRITE ?1,Y
KILL Y
KILL DIP
if DN
KILL Y
+73 IF $DATA(DVBRAD(4))
IF DVBRAD(4)?7N
SET Y=DVBRAD(4)
XECUTE ^DD("DD")
WRITE ?15,Y
KILL Y
KILL DIP
if DN
KILL Y
+74 IF $DATA(DVBBOS(4))
WRITE ?34,DVBBOS(4)
KILL DIP
if DN
KILL Y
+75 IF $DATA(DVBCSVC(4))
WRITE ?48,DVBCSVC(4)
KILL DIP
if DN
KILL Y
+76 IF $DATA(DVBSN(4))
WRITE ?62,DVBSN(4)
KILL DIP
if DN
KILL Y
+77 WRITE !!,?34,"Patient File"
KILL DIP
if DN
KILL Y
+78 WRITE ?57
WRITE !,"-------------------------------------------------------------------------------"
KILL DIP
if DN
KILL Y
+79 WRITE ?68
DO DISP^DVBHQZ6(DFN)
KILL DIP
if DN
KILL Y
+80 KILL Y
+81 QUIT
HEAD ;
+1 WRITE !,"--------------------------------------------------------------------------------",!!
