DVBHQM2 ;ISC-ALBANY/PKE - MAIL DELIVERY PROGRAM;6/10/09 6:01pm
;;4.0;HINQ;**49,63,65**;03/25/92;Build 19
G EN
LIN S CT=CT+1,A1=A_CT_",0)",@A1=T1 Q
DD S:Y Y=$S($E(Y,4,5):$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+$E(Y,4,5))_" ",1:"")_$S($E(Y,6,7):+$E(Y,6,7)_",",1:"")_($E(Y,1,3)+1700)_$P("@"_$E(Y_0,9,10)_":"_$E(Y_"000",11,12),"^",Y[".") Q
;
EN ;P&T now sent by VBA, 2=no, 3=yes, else null
I $D(DVBPTI),((DVBPTI=2)!(DVBPTI=3)) S DVBPTI=$S(DVBPTI=2:"No",DVBPTI=3:"Yes",1:""),T1=" Perm.,Total Disability = "_DVBPTI D LIN
;DVB*4*65
I $D(DVBPTI),($G(DVBPTIDT)>0) S M=$E(DVBPTIDT,1,2) D MM^DVBHQM11 S T1=" Perm.,Total Disability Eff Date = "_M_" "_$S(+$E(DVBPTIDT,3,4)>0:$E(DVBPTIDT,3,4)_", ",1:" ")_$E(DVBPTIDT,5,8) D LIN
I $D(DVBAAHB),((DVBAAHB="A")!(DVBAAHB="H")) S Y=DVBAAHB S Y=$S(Y="A":"A&A Paid",Y="H":"Housebound Paid",1:"") S T1=" AID & ATTEND = "_Y D LIN
I $D(DVBFIDUC),(DVBFIDUC>0) S T1="Chief Attorney, fiduciary = "_DVBFIDUC D LIN
;;;I $D(DVBFIDUC),DVBFIDUC,$D(^DIC(4,DVBFIDUC,0)) S DVBFIDUC=$P(^(0),U),T1="Chief Attorney, fiduciary = "_DVBFIDUC D LIN
;VBA field is Unemployable, codes will Y=Unemploy, N=Employ DVB*4*49
I $D(DVBEI),((DVBEI="N")!(DVBEI="Y")) S DVBEI=$S(DVBEI="N":"Employable or not an issue",DVBEI="Y":"Unemployable",1:""),T1=" Employable indicator = "_DVBEI D LIN
;new VBA codes, I=incompetent or C=competent DVB*4*49
I $D(DVBCI),((DVBCI'=" ")) S DVBCI=$S(DVBCI=1!(DVBCI="C"):"Competent, or not an issue",DVBCI="I"!(DVBCI="2"):"Incompetent",1:DVBCI),T1=" Competency indicator = "_DVBCI D LIN
;Severence Recoup, PFOP, Competency Pay Status and Consol Payment will
;no longer be sent by VBA - DVB*4*49
;DVB*4*65
I $D(DVBDENTI),((DVBDENTI'=" ")) S DVBDENTI=$S(DVBDENTI="Y":" Dental Treatment provided at discharge",DVBDENTI="N":" No dental treatment at discharge",1:DVBDENTI),T1=DVBDENTI D LIN
;
I $D(DVBP(2)) D P2^DVBHQM11
PNX I $D(DVBSPNAM),DVBSPNAM'?10" " S T1=" " D LIN S T1="Spouse name = "_DVBSPNAM D SDB,LIN
S T1="" D LIN
S T1=" "
;CHAMPVA no longer sent by VBA - DVB*4*49
K C I $D(DVBBAS(1)) F N=32:1:35 I $P(DVBBAS(1),U,N) D SHDR Q
I $D(C) D COUNT ;DVB*4*49 - some fields for C not sent by VBA any more
;so calculate from Child Status field
I $D(C) D LIN S T1="",$P(T1,"-",80)="" D LIN S T1="School = "_$P(C,U,3)_" Helpless School = "_$P(C,U,4)_" Depend. total = "_$$DEP($P(C,U,1))_" This Award = "_$$DEP($P(C,U,2)) D LIN
I '$D(C),T1'["Not" S T1=$E(T1,1,23) D LIN
K C
I $D(DVBCHILD) S T1="" D LIN S T1="Child name DOB Child Status" D LIN
I $D(DVBCHILD) F DVBC=0:0 S DVBC=$O(DVBCHILD(DVBC)) Q:'DVBC S DVBDOB=$P(DVBCHILD(DVBC),U,3),V=$P(DVBCHILD(DVBC),U),T1=$P(DVBCHILD(DVBC),U,2) D CDATE,CHILD D
. F DVBB=$L(T1):1:10 S T1=T1_" "
. S T1=T1_" "_$E(Y_" ",1,11)_" "_V D LIN
K DVBPSNAM,DVBSPDOB,DVBCHILD,DVBDOB,V
;
;-8
;with DVB*4*49 Hardship Exp no longer sent by VBA, so removed from line
S T1=" " D LIN
S T1="Check Amount= ''' Net Award= '''"
I $D(DVBBAS(1)) S $P(T1,"'",5,6)="$"_$P(DVBBAS(1),U,20)
I $D(DVBCHECK) S $P(T1,"'",2,3)="$"_DVBCHECK
;I $P(^DIC(8,$P(^DPT(DFN,.36),U),0),U)'="NSC" D LIN
D LIN
K DVBCAP
;
RINC ;
I $G(DVBINC)]"" I +$P(DVBINC,U,15)>0 S T1=" Income for VA Purposes= '$"_$P(DVBINC,U,15)_".00'" D LIN
;
EX ;
K C,T2,T1,DVBDXPCT,DVBPT,DVBPTI,DVBPTIDT,DVBDENTI,DVBAAHB,DVBFIDUC,DVBEI,DVBCI,DVBCPS,DVBSPNAM,DVBSPDOB,DVBCHILD,DVBDOB,V,DVBCHECK,Y
D ADD^DVBHQM31
G ERR^DVBHQM3 ;with DVB*4*49 no call made to EN^DVBHQM3
;
SHDR S T1=T1_" Number of CHILDREN"
I N>31 S C=$P(DVBBAS(1),U,32,35) Q
;
RHDR S T1="" D LIN
S T1="last date previously INCOME REPORTED amount, type" D LIN
S T1="Reported Reported This Year For VA purposes Medical or Last Expense" D LIN
S T1="",$P(T1,"-",80)="" D LIN Q
;
FILLER S T1="" F N=14,12,13,15,16,17 I N'=16 S T2=$S(N'=14:"$",1:"")_+$P(DVBINC,U,N),T1=T1_$J(T2,6) S:N<16 T1=T1_" " I N=17 S T2=$P(DVBINC,U,16) D RTYP S T1=T1_" "_T2 D LIN S T1="" D LIN
Q
;
RTYP S T2=$S(T2=" ":T2,T2="B":"SS/Other",T2="C":"Unusual Med.Exp.",T2="O":"Other",T2="R":"10%Ret.Pay excl.",T2="S":"Social Security",1:"") Q
;
AAA S V=Y S:Y>3&(Y<8) V=Y-4 S V=$S(V=0:"HB and/or A&A TERM",V=1:"HOSPITALIZED, HB,A&A PAY",V=2:"PAY A&A",V=3:"HB ONLY ",V=" ":"HB and/or A&A NOT GRANTED",1:"") I +Y,Y>3&(Y<8) S Y=V_", INCREMENT FOR SPOUSE" Q
S Y=V Q
;
CHILD Q:$G(V)'?1U S V=$S(V="H":"Helpless Child",V="M":"Minor Child",V="N":"Not an award dep.",V="S":"School Child",V="U":"Unclaimed DIC Child",1:"")
Q
;
CPS S Y=$S(Y=1:"Competent,or not an issue,Pay direct",Y=2:"Incompetent by VA, Court .. pay fiduciary",Y=3:"Incompetent by Court, .. pay fiduciary",Y=4:"Competent by Court, Incompetent by VA .. pay direct",Y=5:"Supervised direct pay",1:Y) Q
;
SDB I $D(DVBSPDOB),DVBSPDOB I DVBSPDOB?8N S M=$E(DVBSPDOB,1,2) D MM^DVBHQM11 S T1=T1_" DOB = "_M_" "_$S(+$E(DVBSPDOB,3,4)>0:$E(DVBSPDOB,3,4)_", ",1:" ")_$E(DVBSPDOB,5,8) K M
Q
;
CDATE I DVBDOB'?8N S Y="" Q
;change CDATE to receive date as MMDDYYYY - DVB*4*49
;change to take in an eight digit date - DVB*4*63
S M=$E(DVBDOB,1,2) D MM^DVBHQM11
S Y=M_" "_$S(+$E(DVBDOB,3,4)>0:$E(DVBDOB,3,4)_",",1:" ")_$E(DVBDOB,5,8)
Q
DEP(X) ;;V-S^V-S-F^V-S-M^V-S-2P^V-F^V-M^V-2P^V^
;Dependency codes
Q:X>89 X Q:X'?2N X
I X="00" S X="V" Q X
I X="80" S X="V-C" Q X
I $E(X,2)=0 S X=$P($P($T(DEP),";;",2),"^",$E(X,1)) Q X
I X?2N S X=$P($P($T(DEP),";;",2),"^",$E(X,1))_"-"_$E(X,2)_"C" Q X
Q X
COUNT ;loop through the DVBCHILD array and count the total, helpless and
;school children
N DVBC,DVBH,DVBS,DVBT
S (DVBC,DVBH,DVBS,DVBT)=0
F S DVBC=$O(DVBCHILD(DVBC)) Q:DVBC'>0 D
. I $P(DVBCHILD(DVBC),U)="H" S DVBH=DVBH+1
. I $P(DVBCHILD(DVBC),U)="S" S DVBS=DVBS+1
. S DVBT=DVBT+1
S C=DVBT_"^"_+$P(C,U,2)_"^"_DVBS_"^"_DVBH
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBHQM2 5932 printed Oct 16, 2024@17:59:34 Page 2
DVBHQM2 ;ISC-ALBANY/PKE - MAIL DELIVERY PROGRAM;6/10/09 6:01pm
+1 ;;4.0;HINQ;**49,63,65**;03/25/92;Build 19
+2 GOTO EN
LIN SET CT=CT+1
SET A1=A_CT_",0)"
SET @A1=T1
QUIT
DD if Y
SET Y=$SELECT($EXTRACT(Y,4,5):$PIECE("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+$EXTRACT(Y,4,5))_" ",1:"")_$SELECT($EXTRACT(Y,6,7):+$EXTRACT(Y,6,7)_",",1:"")_($EXTRACT(Y,1,3)+1700)_$PIECE("@"_$EXTRACT(Y_0,9,10)_":"_...
... $EXTRACT(Y_"000",11,12),"^",Y[".")
QUIT
+1 ;
EN ;P&T now sent by VBA, 2=no, 3=yes, else null
+1 IF $DATA(DVBPTI)
IF ((DVBPTI=2)!(DVBPTI=3))
SET DVBPTI=$SELECT(DVBPTI=2:"No",DVBPTI=3:"Yes",1:"")
SET T1=" Perm.,Total Disability = "_DVBPTI
DO LIN
+2 ;DVB*4*65
+3 IF $DATA(DVBPTI)
IF ($GET(DVBPTIDT)>0)
SET M=$EXTRACT(DVBPTIDT,1,2)
DO MM^DVBHQM11
SET T1=" Perm.,Total Disability Eff Date = "_M_" "_$SELECT(+$EXTRACT(DVBPTIDT,3,4)>0:$EXTRACT(DVBPTIDT,3,4)_", ",1:" ")_$EXTRACT(DVBPTIDT,5,8)
DO LIN
+4 IF $DATA(DVBAAHB)
IF ((DVBAAHB="A")!(DVBAAHB="H"))
SET Y=DVBAAHB
SET Y=$SELECT(Y="A":"A&A Paid",Y="H":"Housebound Paid",1:"")
SET T1=" AID & ATTEND = "_Y
DO LIN
+5 IF $DATA(DVBFIDUC)
IF (DVBFIDUC>0)
SET T1="Chief Attorney, fiduciary = "_DVBFIDUC
DO LIN
+6 ;;;I $D(DVBFIDUC),DVBFIDUC,$D(^DIC(4,DVBFIDUC,0)) S DVBFIDUC=$P(^(0),U),T1="Chief Attorney, fiduciary = "_DVBFIDUC D LIN
+7 ;VBA field is Unemployable, codes will Y=Unemploy, N=Employ DVB*4*49
+8 IF $DATA(DVBEI)
IF ((DVBEI="N")!(DVBEI="Y"))
SET DVBEI=$SELECT(DVBEI="N":"Employable or not an issue",DVBEI="Y":"Unemployable",1:"")
SET T1=" Employable indicator = "_DVBEI
DO LIN
+9 ;new VBA codes, I=incompetent or C=competent DVB*4*49
+10 IF $DATA(DVBCI)
IF ((DVBCI'=" "))
SET DVBCI=$SELECT(DVBCI=1!(DVBCI="C"):"Competent, or not an issue",DVBCI="I"!(DVBCI="2"):"Incompetent",1:DVBCI)
SET T1=" Competency indicator = "_DVBCI
DO LIN
+11 ;Severence Recoup, PFOP, Competency Pay Status and Consol Payment will
+12 ;no longer be sent by VBA - DVB*4*49
+13 ;DVB*4*65
+14 IF $DATA(DVBDENTI)
IF ((DVBDENTI'=" "))
SET DVBDENTI=$SELECT(DVBDENTI="Y":" Dental Treatment provided at discharge",DVBDENTI="N":" No dental treatment at discharge",1:DVBDENTI)
SET T1=DVBDENTI
DO LIN
+15 ;
+16 IF $DATA(DVBP(2))
DO P2^DVBHQM11
PNX IF $DATA(DVBSPNAM)
IF DVBSPNAM'?10" "
SET T1=" "
DO LIN
SET T1="Spouse name = "_DVBSPNAM
DO SDB
DO LIN
+1 SET T1=""
DO LIN
+2 SET T1=" "
+3 ;CHAMPVA no longer sent by VBA - DVB*4*49
+4 KILL C
IF $DATA(DVBBAS(1))
FOR N=32:1:35
IF $PIECE(DVBBAS(1),U,N)
DO SHDR
QUIT
+5 ;DVB*4*49 - some fields for C not sent by VBA any more
IF $DATA(C)
DO COUNT
+6 ;so calculate from Child Status field
+7 IF $DATA(C)
DO LIN
SET T1=""
SET $PIECE(T1,"-",80)=""
DO LIN
SET T1="School = "_$PIECE(C,U,3)_" Helpless School = "_$PIECE(C,U,4)_" Depend. total = "_$$DEP">DEP($PIECE(C,U,1))_" This Award = "_$$DEP">DEP($PIECE(C,U,2))
DO LIN
+8 IF '$DATA(C)
IF T1'["Not"
SET T1=$EXTRACT(T1,1,23)
DO LIN
+9 KILL C
+10 IF $DATA(DVBCHILD)
SET T1=""
DO LIN
SET T1="Child name DOB Child Status"
DO LIN
+11 IF $DATA(DVBCHILD)
FOR DVBC=0:0
SET DVBC=$ORDER(DVBCHILD(DVBC))
if 'DVBC
QUIT
SET DVBDOB=$PIECE(DVBCHILD(DVBC),U,3)
SET V=$PIECE(DVBCHILD(DVBC),U)
SET T1=$PIECE(DVBCHILD(DVBC),U,2)
DO CDATE
DO CHILD
Begin DoDot:1
+12 FOR DVBB=$LENGTH(T1):1:10
SET T1=T1_" "
+13 SET T1=T1_" "_$EXTRACT(Y_" ",1,11)_" "_V
DO LIN
End DoDot:1
+14 KILL DVBPSNAM,DVBSPDOB,DVBCHILD,DVBDOB,V
+15 ;
+16 ;-8
+17 ;with DVB*4*49 Hardship Exp no longer sent by VBA, so removed from line
+18 SET T1=" "
DO LIN
+19 SET T1="Check Amount= ''' Net Award= '''"
+20 IF $DATA(DVBBAS(1))
SET $PIECE(T1,"'",5,6)="$"_$PIECE(DVBBAS(1),U,20)
+21 IF $DATA(DVBCHECK)
SET $PIECE(T1,"'",2,3)="$"_DVBCHECK
+22 ;I $P(^DIC(8,$P(^DPT(DFN,.36),U),0),U)'="NSC" D LIN
+23 DO LIN
+24 KILL DVBCAP
+25 ;
RINC ;
+1 IF $GET(DVBINC)]""
IF +$PIECE(DVBINC,U,15)>0
SET T1=" Income for VA Purposes= '$"_$PIECE(DVBINC,U,15)_".00'"
DO LIN
+2 ;
EX ;
+1 KILL C,T2,T1,DVBDXPCT,DVBPT,DVBPTI,DVBPTIDT,DVBDENTI,DVBAAHB,DVBFIDUC,DVBEI,DVBCI,DVBCPS,DVBSPNAM,DVBSPDOB,DVBCHILD,DVBDOB,V,DVBCHECK,Y
+2 DO ADD^DVBHQM31
+3 ;with DVB*4*49 no call made to EN^DVBHQM3
GOTO ERR^DVBHQM3
+4 ;
SHDR SET T1=T1_" Number of CHILDREN"
+1 IF N>31
SET C=$PIECE(DVBBAS(1),U,32,35)
QUIT
+2 ;
RHDR SET T1=""
DO LIN
+1 SET T1="last date previously INCOME REPORTED amount, type"
DO LIN
+2 SET T1="Reported Reported This Year For VA purposes Medical or Last Expense"
DO LIN
+3 SET T1=""
SET $PIECE(T1,"-",80)=""
DO LIN
QUIT
+4 ;
FILLER SET T1=""
FOR N=14,12,13,15,16,17
IF N'=16
SET T2=$SELECT(N'=14:"$",1:"")_+$PIECE(DVBINC,U,N)
SET T1=T1_$JUSTIFY(T2,6)
if N<16
SET T1=T1_" "
IF N=17
SET T2=$PIECE(DVBINC,U,16)
DO RTYP
SET T1=T1_" "_T2
DO LIN
SET T1=""
DO LIN
+1 QUIT
+2 ;
RTYP SET T2=$SELECT(T2=" ":T2,T2="B":"SS/Other",T2="C":"Unusual Med.Exp.",T2="O":"Other",T2="R":"10%Ret.Pay excl.",T2="S":"Social Security",1:"")
QUIT
+1 ;
AAA SET V=Y
if Y>3&(Y<8)
SET V=Y-4
SET V=$SELECT(V=0:"HB and/or A&A TERM",V=1:"HOSPITALIZED, HB,A&A PAY",V=2:"PAY A&A",V=3:"HB ONLY ",V=" ":"HB and/or A&A NOT GRANTED",1:"")
IF +Y
IF Y>3&(Y<8)
SET Y=V_", INCREMENT FOR SPOUSE"
QUIT
+1 SET Y=V
QUIT
+2 ;
CHILD if $GET(V)'?1U
QUIT
SET V=$SELECT(V="H":"Helpless Child",V="M":"Minor Child",V="N":"Not an award dep.",V="S":"School Child",V="U":"Unclaimed DIC Child",1:"")
+1 QUIT
+2 ;
CPS SET Y=$SELECT(Y=1:"Competent,or not an issue,Pay direct",Y=2:"Incompetent by VA, Court .. pay fiduciary",Y=3:"Incompetent by Court, .. pay fiduciary",Y=4:"Competent by Court, Incompetent by VA .. pay direct",Y=5:"Supervised direct pay",1:Y)
QUIT
+1 ;
SDB IF $DATA(DVBSPDOB)
IF DVBSPDOB
IF DVBSPDOB?8N
SET M=$EXTRACT(DVBSPDOB,1,2)
DO MM^DVBHQM11
SET T1=T1_" DOB = "_M_" "_$SELECT(+$EXTRACT(DVBSPDOB,3,4)>0:$EXTRACT(DVBSPDOB,3,4)_", ",1:" ")_$EXTRACT(DVBSPDOB,5,8)
KILL M
+1 QUIT
+2 ;
CDATE IF DVBDOB'?8N
SET Y=""
QUIT
+1 ;change CDATE to receive date as MMDDYYYY - DVB*4*49
+2 ;change to take in an eight digit date - DVB*4*63
+3 SET M=$EXTRACT(DVBDOB,1,2)
DO MM^DVBHQM11
+4 SET Y=M_" "_$SELECT(+$EXTRACT(DVBDOB,3,4)>0:$EXTRACT(DVBDOB,3,4)_",",1:" ")_$EXTRACT(DVBDOB,5,8)
+5 QUIT
DEP(X) ;;V-S^V-S-F^V-S-M^V-S-2P^V-F^V-M^V-2P^V^
+1 ;Dependency codes
+2 if X>89
QUIT X
if X'?2N
QUIT X
+3 IF X="00"
SET X="V"
QUIT X
+4 IF X="80"
SET X="V-C"
QUIT X
+5 IF $EXTRACT(X,2)=0
SET X=$PIECE($PIECE($TEXT(DEP),";;",2),"^",$EXTRACT(X,1))
QUIT X
+6 IF X?2N
SET X=$PIECE($PIECE($TEXT(DEP),";;",2),"^",$EXTRACT(X,1))_"-"_$EXTRACT(X,2)_"C"
QUIT X
+7 QUIT X
COUNT ;loop through the DVBCHILD array and count the total, helpless and
+1 ;school children
+2 NEW DVBC,DVBH,DVBS,DVBT
+3 SET (DVBC,DVBH,DVBS,DVBT)=0
+4 FOR
SET DVBC=$ORDER(DVBCHILD(DVBC))
if DVBC'>0
QUIT
Begin DoDot:1
+5 IF $PIECE(DVBCHILD(DVBC),U)="H"
SET DVBH=DVBH+1
+6 IF $PIECE(DVBCHILD(DVBC),U)="S"
SET DVBS=DVBS+1
+7 SET DVBT=DVBT+1
End DoDot:1
+8 SET C=DVBT_"^"_+$PIECE(C,U,2)_"^"_DVBS_"^"_DVBH
+9 QUIT
