DGBTCR ;ALB/SCK - BENEFICIARY TRAVEL FORM 70-3542d VARIABLES ; 6/11/93@09:30
;;1.0;Beneficiary Travel;**7,14,20,28,34,39**;September 25, 2001;Build 6
;Modification of AIVBTPRT / pmg / GRAND ISLAND ; 07 Jul 88 12:02 PM
START Q:'$D(DGBTDT)
N DGBTDIV ;dgbt*1.0*34 - new dgbtdiv rather than kill to preserve previous value
D MILE
S DGBTVAR(0)=$G(^DGBT(392,+DGBTDT,0)),DGBTACCT=$P($G(^DGBT(392.3,+$P(DGBTVAR(0),"^",6),0)),"^",5)
Q:DGBTACCT'>3
W !!,*7,"This needs to be printed at 132 columns"
S DGPGM="PRINT^DGBTCR",DGVAR="DGBTDT"
S %ZIS="PMQ" D ^%ZIS G QUIT:POP
I $D(IO("Q")) D QUE G QUIT
D PRINT
QUIT ;
D:'$D(ZTQUEUED) ^%ZISC
K DGPGM,DGVAR,VADAT,VADATE,I,X,X2,DGBTVAR,DGBTCC,DGBTDOB,DGBTINS,DGBTINS1,DGBTINS2,DGBTCNA,DGBTCSZ,DGBTCNU,DGBTTCTY,DGBTFCTY,DGBTDT,DGBTACCT,DFN,Y
K DGBTM6,DGBTM7,DGBTM8,DGBTM8A,DGBTM9,DGBTM10,DGBTM11,DGBTM12,DGBTM13,DGBTM14,DGBTM15,DGBTM16,DGBTM17,DGBTRATE,DGBTSCP,DGBTSSN,DGBTST,DTOTAL,CDAT,D
Q
PRINT ;
U IO D SET,PRINT^DGBTCR1,PRINT^DGBTCR2,KVAR^VADPT
Q
SET S DFN=$P(^DGBT(392,DGBTDT,0),"^",2) D 6^VADPT,RESADDR^DGBTUTL1(.DGBTADDR) S (DGBTFCTY,DGBTTCTY)="" ;*39 - call to resaddr to get values for address
NODES F I=0,"A","C","D","M","R","T" S DGBTVAR(I)=$S($D(^DGBT(392,DGBTDT,I)):^(I),1:"")
I $D(^DG(43.1,$O(^DG(43.1,(9999999.99999-DGBTDT))),"BT")) S DGBTRATE=^("BT"),DGBTM7=$S($P(DGBTVAR("A"),"^",3)=1:$P(DGBTRATE,"^",5),1:$P(DGBTRATE,"^",3))
I $P(DGBTVAR("D"),"^",4)]"" S DGBTCNA=$P(DGBTVAR("D"),"^",4) D CITY I DGBTCSZ[DGBTCNA D
. S DGBTCSZ=DGBTCNA_", "_$S(+$P(DGBTVAR("D"),"^",5)>0:$P(^DIC(5,$P(DGBTVAR("D"),"^",5),0),U,2),1:"")_" "
. S Y=$P(DGBTVAR("D"),U,6),Y=$E(Y,1,5)_$S($E(Y,6,9)]"":"-"_$E(Y,6,9),1:""),DGBTCSZ=DGBTCSZ_Y,DGBTFCTY=DGBTCSZ
S $P(DGBTVAR("T"),U,6)=$$GET1^DIQ(392,DGBTDT,28.2) ;dgbt*1.0*28 - use fileman to set external zip code value
I $P(DGBTVAR("T"),"^",4)]"" S DGBTCNA=$P(DGBTVAR("T"),U,4) D CITY^DGBTCR S:DGBTCSZ[DGBTCNA DGBTCSZ=DGBTCNA_", "_$S(+$P(DGBTVAR("T"),"^",5)>0:$P(^DIC(5,$P(DGBTVAR("T"),"^",5),0),U,2),1:"")_" "_$P(DGBTVAR("T"),U,6) S DGBTTCTY=DGBTCSZ
DIV S DGBTDIV=$P(DGBTVAR(0),"^",11) I +DGBTDIV S DGBTDIV=$P(^DG(40.8,DGBTDIV,0),"^",7) S (DGBTCC,DGBTST)=""
I $D(^DIC(4,+DGBTDIV,0)) S DGBTINS=^(0),DGBTINS1=$S($D(^DIC(4,DGBTDIV,1)):^(1),1:""),DGBTINS2=$S(DGBTINS1]"":$P(DGBTINS1,"^",3)_",",1:"UNSPECIFIED")_" "_$S($D(^DIC(5,+$P(DGBTINS,U,2),0)):$P(^(0),U,2),1:"")_" "_$P(DGBTINS1,"^",4)
I DGBTADDR(5)&(DGBTADDR(7)) S DGBTCC=$S($D(^DIC(5,+DGBTADDR(5),1,+DGBTADDR(7),0)):$P(^(0),"^",3),1:""),DGBTST=$P(^DIC(5,+DGBTADDR(5),0),"^",2) ;*39 - updated to use residential address
D PID^VADPT6 S DGBTSSN=VA("PID"),DGBTDOB=$E(VADM(3),4,7)_($E(VADM(3),1,3)+1700)
S DGBTSCP=$S($L($P(VAEL(3),"^",2)<3):"0",1:"")_$P(VAEL(3),"^",2)
MILES S DGBTM6=$P(DGBTVAR("M"),"^")*$P(DGBTVAR("M"),"^",2)
N X3
S X2="2$",X=DGBTM6*DGBTM7 D COMMA^%DTC S DGBTM8=X
S X=$P(DGBTVAR("C"),"^",2) D COMMA^%DTC S DGBTM8A=X
S X=$P(DGBTVAR("M"),"^",4) D COMMA^%DTC S DGBTM9=X
S X=$P(DGBTVAR("M"),"^",5) D COMMA^%DTC S DGBTM10=X
S X=DGBTM6*DGBTM7+$P(DGBTM8A,"$",2)+$P(DGBTVAR("M"),"^",4)+$P(DGBTVAR("M"),"^",5) D COMMA^%DTC S DGBTM11=X
S X2="3$",X=DGBTM7 D COMMA^%DTC S DGBTM7=X
S X2="2$" ;Reset edit mask to 2 decimal positions for rest of report
S X=$P(DGBTVAR(0),"^",8) D COMMA^%DTC S DGBTM12=X
S X=$P(DGBTVAR("M"),"^",4)+$P(DGBTVAR(0),"^",8) D COMMA^%DTC S DGBTM13=X
S X=$P(DGBTVAR(0),"^",10) D COMMA^%DTC S DGBTM14=X
S X=$P(DGBTVAR(0),"^",9) D COMMA^%DTC S $P(DGBTM14,"^",2)=X
CERT S VADAT("W")=DGBTDT D ^VADATE S DGBTM15=VADATE("E")
S X=$S($P(^DG(43,1,"BT"),"^")'="":$P(^DG(43,1,"BT"),"^"),1:DUZ),DGBTM16=$P($P(^VA(200,X,0),",",2),"^")_" "_$P(^VA(200,X,0),",")_$S($P(^DG(43,1,"BT"),"^")'="":"",1:", DESIGNEE OF CERTIFYING OFFICIAL") K X
S DGBTM17=$P($P(DGBTVAR("A"),"^",2),",",2)_" "_$P($P(DGBTVAR("A"),"^",2),",")
Q
CITY S DGBTCSZ=DGBTCNA
D RESADDR^DGBTUTL1(.DGBTADDR) ;*39 - call to resaddr to get values for address
S:DGBTADDR(5)'="" DGBTCNU=$O(^DGBT(392.1,"ACS",DGBTCNA,+DGBTADDR(5),0)) ;*39 - updated to use residential address
I $D(DGBTCNU),(DGBTCNU'="") S DGBTCSZ=$P(^DGBT(392.1,DGBTCNU,0),"^")_", "_($P(^DIC(5,+DGBTADDR(5),0),"^",2))_" "_($P(^DGBT(392.1,DGBTCNU,0),"^",4)) ;*39 - updated to use residential address
Q
QUE ;
N I
S ZTRTN="PRINT^DGBTCR",ZTDESC="VA FORM 70-3542d"
F I="DFN","DGBTDT","DGBTFCTY","DGBTTCTY","ONEWAY","RTRIP","DTOTAL" S ZTSAVE(I)=""
D ^%ZTLOAD W:$D(ZTSK) !,"TASK #",ZTSK
D HOME^%ZIS K IO("Q")
Q
;
MILE ; one way, round trip and total amount deductible
I $D(MONTOT) D Q
.S ONEWAY=$P(MONTOT,U,2),RTRIP=$P(MONTOT,U,3),DTOTAL=$P(MONTOT,U,4)
K CDAT,SDATE,EDATE,PDATA,DEDUCT,EMONTH,MDATA,DGBTRIP
S (DEDUCT,DTOTAL,ONEWAY,RTRIP,CDAT,SDATE,EDATE)=0
S EMONTH=0
;
S SDATE=$P(DGBTDT,".",1)
S SDATE=$E(SDATE,1,5)_"01" ;_.0001
S EDATE=$E(DGBTDT,1,5)
S EMONTH=$E(DGBTDT,4,5) S EMONTH=EMONTH+1
S:$L(EMONTH)=1 EMONTH="0"_EMONTH
S EDATE=$E(DGBTDT,1,3)_EMONTH_"00"
;
F S CDAT=$O(^DGBT(392,"C",DFN,CDAT)) Q:'CDAT D
.Q:$$GET1^DIQ(392,CDAT,45.2,"I") ;DENIED CLAIM, DON'T COUNT
.Q:$P(^DGBT(392,CDAT,0),"^",16)'=""
.Q:$D(^DGBT(392,CDAT,"SP"))
.Q:CDAT<SDATE!(CDAT>EDATE)
.Q:'$D(^DGBT(392,CDAT,0))
.Q:$D(DGBTRIP("ONEWAY",$P(CDAT,".",1)))
.S PDATA=$G(^DGBT(392,CDAT,0))
.S DEDUCT=$P(PDATA,"^",9)
.S DTOTAL=DTOTAL+DEDUCT
.;
.S MDATA=$G(^DGBT(392,CDAT,"M"))
.Q:$P(MDATA,"^",1)=""
.I $P(MDATA,"^",1)=1,'$D(DGBTRIP("ONEWAY",$P(CDAT,".",1))) S ONEWAY=ONEWAY+1
.I $P(MDATA,"^",1)=2,'$D(DGBTRIP("RTRIP",$P(CDAT,".",1))) S RTRIP=RTRIP+1
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGBTCR 5559 printed Apr 09, 2024@20:46:09 Page 2
DGBTCR ;ALB/SCK - BENEFICIARY TRAVEL FORM 70-3542d VARIABLES ; 6/11/93@09:30
+1 ;;1.0;Beneficiary Travel;**7,14,20,28,34,39**;September 25, 2001;Build 6
+2 ;Modification of AIVBTPRT / pmg / GRAND ISLAND ; 07 Jul 88 12:02 PM
START if '$DATA(DGBTDT)
QUIT
+1 ;dgbt*1.0*34 - new dgbtdiv rather than kill to preserve previous value
NEW DGBTDIV
+2 DO MILE
+3 SET DGBTVAR(0)=$GET(^DGBT(392,+DGBTDT,0))
SET DGBTACCT=$PIECE($GET(^DGBT(392.3,+$PIECE(DGBTVAR(0),"^",6),0)),"^",5)
+4 if DGBTACCT'>3
QUIT
+5 WRITE !!,*7,"This needs to be printed at 132 columns"
+6 SET DGPGM="PRINT^DGBTCR"
SET DGVAR="DGBTDT"
+7 SET %ZIS="PMQ"
DO ^%ZIS
if POP
GOTO QUIT
+8 IF $DATA(IO("Q"))
DO QUE
GOTO QUIT
+9 DO PRINT
QUIT ;
+1 if '$DATA(ZTQUEUED)
DO ^%ZISC
+2 KILL DGPGM,DGVAR,VADAT,VADATE,I,X,X2,DGBTVAR,DGBTCC,DGBTDOB,DGBTINS,DGBTINS1,DGBTINS2,DGBTCNA,DGBTCSZ,DGBTCNU,DGBTTCTY,DGBTFCTY,DGBTDT,DGBTACCT,DFN,Y
+3 KILL DGBTM6,DGBTM7,DGBTM8,DGBTM8A,DGBTM9,DGBTM10,DGBTM11,DGBTM12,DGBTM13,DGBTM14,DGBTM15,DGBTM16,DGBTM17,DGBTRATE,DGBTSCP,DGBTSSN,DGBTST,DTOTAL,CDAT,D
+4 QUIT
PRINT ;
+1 USE IO
DO SET
DO PRINT^DGBTCR1
DO PRINT^DGBTCR2
DO KVAR^VADPT
+2 QUIT
SET ;*39 - call to resaddr to get values for address
SET DFN=$PIECE(^DGBT(392,DGBTDT,0),"^",2)
DO 6^VADPT
DO RESADDR^DGBTUTL1(.DGBTADDR)
SET (DGBTFCTY,DGBTTCTY)=""
NODES FOR I=0,"A","C","D","M","R","T"
SET DGBTVAR(I)=$SELECT($DATA(^DGBT(392,DGBTDT,I)):^(I),1:"")
+1 IF $DATA(^DG(43.1,$ORDER(^DG(43.1,(9999999.99999-DGBTDT))),"BT"))
SET DGBTRATE=^("BT")
SET DGBTM7=$SELECT($PIECE(DGBTVAR("A"),"^",3)=1:$PIECE(DGBTRATE,"^",5),1:$PIECE(DGBTRATE,"^",3))
+2 IF $PIECE(DGBTVAR("D"),"^",4)]""
SET DGBTCNA=$PIECE(DGBTVAR("D"),"^",4)
DO CITY
IF DGBTCSZ[DGBTCNA
Begin DoDot:1
+3 SET DGBTCSZ=DGBTCNA_", "_$SELECT(+$PIECE(DGBTVAR("D"),"^",5)>0:$PIECE(^DIC(5,$PIECE(DGBTVAR("D"),"^",5),0),U,2),1:"")_" "
+4 SET Y=$PIECE(DGBTVAR("D"),U,6)
SET Y=$EXTRACT(Y,1,5)_$SELECT($EXTRACT(Y,6,9)]"":"-"_$EXTRACT(Y,6,9),1:"")
SET DGBTCSZ=DGBTCSZ_Y
SET DGBTFCTY=DGBTCSZ
End DoDot:1
+5 ;dgbt*1.0*28 - use fileman to set external zip code value
SET $PIECE(DGBTVAR("T"),U,6)=$$GET1^DIQ(392,DGBTDT,28.2)
+6 IF $PIECE(DGBTVAR("T"),"^",4)]""
SET DGBTCNA=$PIECE(DGBTVAR("T"),U,4)
DO CITY^DGBTCR
if DGBTCSZ[DGBTCNA
SET DGBTCSZ=DGBTCNA_", "_$SELECT(+$PIECE(DGBTVAR("T"),"^",5)>0:$PIECE(^DIC(5,$PIECE(DGBTVAR("T"),"^",5),0),U,2),1:"")_" "_$PIECE(DGBTVAR("T"),U,6)
SET DGBTTCTY=DGBTCSZ
DIV SET DGBTDIV=$PIECE(DGBTVAR(0),"^",11)
IF +DGBTDIV
SET DGBTDIV=$PIECE(^DG(40.8,DGBTDIV,0),"^",7)
SET (DGBTCC,DGBTST)=""
+1 IF $DATA(^DIC(4,+DGBTDIV,0))
SET DGBTINS=^(0)
SET DGBTINS1=$SELECT($DATA(^DIC(4,DGBTDIV,1)):^(1),1:"")
SET DGBTINS2=$SELECT(DGBTINS1]"":$PIECE(DGBTINS1,"^",3)_",",1:"UNSPECIFIED")_" "_$SELECT($DATA(^DIC(5,+$PIECE(DGBTINS,U,2),0)):$PIECE(^(0),U,2),1:"")_" "_$PIECE(DGBTINS1,"^",4)
+2 ;*39 - updated to use residential address
IF DGBTADDR(5)&(DGBTADDR(7))
SET DGBTCC=$SELECT($DATA(^DIC(5,+DGBTADDR(5),1,+DGBTADDR(7),0)):$PIECE(^(0),"^",3),1:"")
SET DGBTST=$PIECE(^DIC(5,+DGBTADDR(5),0),"^",2)
+3 DO PID^VADPT6
SET DGBTSSN=VA("PID")
SET DGBTDOB=$EXTRACT(VADM(3),4,7)_($EXTRACT(VADM(3),1,3)+1700)
+4 SET DGBTSCP=$SELECT($LENGTH($PIECE(VAEL(3),"^",2)<3):"0",1:"")_$PIECE(VAEL(3),"^",2)
MILES SET DGBTM6=$PIECE(DGBTVAR("M"),"^")*$PIECE(DGBTVAR("M"),"^",2)
+1 NEW X3
+2 SET X2="2$"
SET X=DGBTM6*DGBTM7
DO COMMA^%DTC
SET DGBTM8=X
+3 SET X=$PIECE(DGBTVAR("C"),"^",2)
DO COMMA^%DTC
SET DGBTM8A=X
+4 SET X=$PIECE(DGBTVAR("M"),"^",4)
DO COMMA^%DTC
SET DGBTM9=X
+5 SET X=$PIECE(DGBTVAR("M"),"^",5)
DO COMMA^%DTC
SET DGBTM10=X
+6 SET X=DGBTM6*DGBTM7+$PIECE(DGBTM8A,"$",2)+$PIECE(DGBTVAR("M"),"^",4)+$PIECE(DGBTVAR("M"),"^",5)
DO COMMA^%DTC
SET DGBTM11=X
+7 SET X2="3$"
SET X=DGBTM7
DO COMMA^%DTC
SET DGBTM7=X
+8 ;Reset edit mask to 2 decimal positions for rest of report
SET X2="2$"
+9 SET X=$PIECE(DGBTVAR(0),"^",8)
DO COMMA^%DTC
SET DGBTM12=X
+10 SET X=$PIECE(DGBTVAR("M"),"^",4)+$PIECE(DGBTVAR(0),"^",8)
DO COMMA^%DTC
SET DGBTM13=X
+11 SET X=$PIECE(DGBTVAR(0),"^",10)
DO COMMA^%DTC
SET DGBTM14=X
+12 SET X=$PIECE(DGBTVAR(0),"^",9)
DO COMMA^%DTC
SET $PIECE(DGBTM14,"^",2)=X
CERT SET VADAT("W")=DGBTDT
DO ^VADATE
SET DGBTM15=VADATE("E")
+1 SET X=$SELECT($PIECE(^DG(43,1,"BT"),"^")'="":$PIECE(^DG(43,1,"BT"),"^"),1:DUZ)
SET DGBTM16=$PIECE($PIECE(^VA(200,X,0),",",2),"^")_" "_$PIECE(^VA(200,X,0),",")_$SELECT($PIECE(^DG(43,1,"BT"),"^")'="":"",1:", DESIGNEE OF CERTIFYING OFFICIAL")
KILL X
+2 SET DGBTM17=$PIECE($PIECE(DGBTVAR("A"),"^",2),",",2)_" "_$PIECE($PIECE(DGBTVAR("A"),"^",2),",")
+3 QUIT
CITY SET DGBTCSZ=DGBTCNA
+1 ;*39 - call to resaddr to get values for address
DO RESADDR^DGBTUTL1(.DGBTADDR)
+2 ;*39 - updated to use residential address
if DGBTADDR(5)'=""
SET DGBTCNU=$ORDER(^DGBT(392.1,"ACS",DGBTCNA,+DGBTADDR(5),0))
+3 ;*39 - updated to use residential address
IF $DATA(DGBTCNU)
IF (DGBTCNU'="")
SET DGBTCSZ=$PIECE(^DGBT(392.1,DGBTCNU,0),"^")_", "_($PIECE(^DIC(5,+DGBTADDR(5),0),"^",2))_" "_($PIECE(^DGBT(392.1,DGBTCNU,0),"^",4))
+4 QUIT
QUE ;
+1 NEW I
+2 SET ZTRTN="PRINT^DGBTCR"
SET ZTDESC="VA FORM 70-3542d"
+3 FOR I="DFN","DGBTDT","DGBTFCTY","DGBTTCTY","ONEWAY","RTRIP","DTOTAL"
SET ZTSAVE(I)=""
+4 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"TASK #",ZTSK
+5 DO HOME^%ZIS
KILL IO("Q")
+6 QUIT
+7 ;
MILE ; one way, round trip and total amount deductible
+1 IF $DATA(MONTOT)
Begin DoDot:1
+2 SET ONEWAY=$PIECE(MONTOT,U,2)
SET RTRIP=$PIECE(MONTOT,U,3)
SET DTOTAL=$PIECE(MONTOT,U,4)
End DoDot:1
QUIT
+3 KILL CDAT,SDATE,EDATE,PDATA,DEDUCT,EMONTH,MDATA,DGBTRIP
+4 SET (DEDUCT,DTOTAL,ONEWAY,RTRIP,CDAT,SDATE,EDATE)=0
+5 SET EMONTH=0
+6 ;
+7 SET SDATE=$PIECE(DGBTDT,".",1)
+8 ;_.0001
SET SDATE=$EXTRACT(SDATE,1,5)_"01"
+9 SET EDATE=$EXTRACT(DGBTDT,1,5)
+10 SET EMONTH=$EXTRACT(DGBTDT,4,5)
SET EMONTH=EMONTH+1
+11 if $LENGTH(EMONTH)=1
SET EMONTH="0"_EMONTH
+12 SET EDATE=$EXTRACT(DGBTDT,1,3)_EMONTH_"00"
+13 ;
+14 FOR
SET CDAT=$ORDER(^DGBT(392,"C",DFN,CDAT))
if 'CDAT
QUIT
Begin DoDot:1
+15 ;DENIED CLAIM, DON'T COUNT
if $$GET1^DIQ(392,CDAT,45.2,"I")
QUIT
+16 if $PIECE(^DGBT(392,CDAT,0),"^",16)'=""
QUIT
+17 if $DATA(^DGBT(392,CDAT,"SP"))
QUIT
+18 if CDAT<SDATE!(CDAT>EDATE)
QUIT
+19 if '$DATA(^DGBT(392,CDAT,0))
QUIT
+20 if $DATA(DGBTRIP("ONEWAY",$PIECE(CDAT,".",1)))
QUIT
+21 SET PDATA=$GET(^DGBT(392,CDAT,0))
+22 SET DEDUCT=$PIECE(PDATA,"^",9)
+23 SET DTOTAL=DTOTAL+DEDUCT
+24 ;
+25 SET MDATA=$GET(^DGBT(392,CDAT,"M"))
+26 if $PIECE(MDATA,"^",1)=""
QUIT
+27 IF $PIECE(MDATA,"^",1)=1
IF '$DATA(DGBTRIP("ONEWAY",$PIECE(CDAT,".",1)))
SET ONEWAY=ONEWAY+1
+28 IF $PIECE(MDATA,"^",1)=2
IF '$DATA(DGBTRIP("RTRIP",$PIECE(CDAT,".",1)))
SET RTRIP=RTRIP+1
End DoDot:1
+29 ;
+30 QUIT
