DGBTCR.m

DGBTCR ;ALB/SCK - BENEFICIARY TRAVEL FORM 70-3542d VARIABLES; 2/7/88@08:00 ;6/11/93@09:30

 ;;5.3;Registration;**78,119,167,1015**;Aug 13, 1993;Build 21

 ;Modification of AIVBTPRT / pmg / GRAND ISLAND ; 07 Jul 88 12:02 PM

START Q:'$D(DGBTDT)

 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,DGBTDIV,DGBTDOB,DGBTINS,DGBTINS1,DGBTINS2,DGBTCNA,DGBTCSZ,DGBTCNU,DGBTTCTY,DGBTFCTY,DGBTDT,DGBTACCT,DFN,Y

 K DGBTM6,DGBTM7,DGBTM8,DGBTM9,DGBTM10,DGBTM11,DGBTM12,DGBTM13,DGBTM14,DGBTM15,DGBTM16,DGBTM17,DGBTRATE,DGBTSCP,DGBTSSN,DGBTST

 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 S (DGBTFCTY,DGBTTCTY)=""

NODES F I=0,"A","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

 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 VAPA(5)&(VAPA(7)) S DGBTCC=$S($D(^DIC(5,+VAPA(5),1,+VAPA(7),0)):$P(^(0),"^",3),1:""),DGBTST=$P(^DIC(5,+VAPA(5),0),"^",2)

 ;S DGBTSSN=$P($P(VADM(2),"^",2),"-")_" "_$P($P(VADM(2),"^",2),"-",2)_" "_$P($P(VADM(2),"^",2),"-",3),DGBTDOB=$E(VADM(3),4,7)_$E(VADM(3),2,3)

 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)

 S X2="2$",X=DGBTM6*DGBTM7 D COMMA^%DTC S DGBTM8=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(DGBTVAR("M"),"^",4)+$P(DGBTVAR("M"),"^",5) D COMMA^%DTC S DGBTM11=X

 S X=DGBTM7 D COMMA^%DTC S DGBTM7=X

 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 CHIEF, MEDICAL ADMINISTRATION SERVICE") K X

 S DGBTM17=$P($P(DGBTVAR("A"),"^",2),",",2)_" "_$P($P(DGBTVAR("A"),"^",2),",")

 Q

CITY S DGBTCSZ=DGBTCNA

 S:VAPA(5)'="" DGBTCNU=$O(^DGBT(392.1,"ACS",DGBTCNA,+VAPA(5),0))

 I $D(DGBTCNU),(DGBTCNU'="") S DGBTCSZ=$P(^DGBT(392.1,DGBTCNU,0),"^")_", "_($P(^DIC(5,+VAPA(5),0),"^",2))_"  "_($P(^DGBT(392.1,DGBTCNU,0),"^",4))

 Q

QUE ;

 N I

 S ZTRTN="PRINT^DGBTCR",ZTDESC="VA FORM 70-3542d"

 F I="DFN","DGBTDT","DGBTFCTY","DGBTTCTY" S ZTSAVE(I)=""

 D ^%ZTLOAD W:$D(ZTSK) !,"TASK #",ZTSK

 D HOME^%ZIS K IO("Q")

 Q

DGBTCR    ;ALB/SCK - BENEFICIARY TRAVEL FORM 70-3542d VARIABLES; 2/7/88@08:00 ;6/11/93@09:30

 +1       ;;5.3;Registration;**78,119,167,1015**;Aug 13, 1993;Build 21

 +2       ;Modification of AIVBTPRT / pmg / GRAND ISLAND ; 07 Jul 88 12:02 PM

START      IF '$DATA(DGBTDT)

               QUIT 

 +1        SET DGBTVAR(0)=$GET(^DGBT(392,+DGBTDT,0))

           SET DGBTACCT=$PIECE($GET(^DGBT(392.3,+$PIECE(DGBTVAR(0),"^",6),0)),"^",5)

 +2        IF DGBTACCT'>3

               QUIT 

 +3        WRITE !!,*7,"This needs to be printed at 132 columns"

 +4        SET DGPGM="PRINT^DGBTCR"

           SET DGVAR="DGBTDT"

 +5        SET %ZIS="PMQ"

           DO ^%ZIS

           IF POP

               GOTO QUIT

 +6        IF $DATA(IO("Q"))

               DO QUE

               GOTO QUIT

 +7        DO PRINT

QUIT      ;

 +1        IF '$DATA(ZTQUEUED)

               DO ^%ZISC

 +2        KILL DGPGM,DGVAR,VADAT,VADATE,I,X,X2,DGBTVAR,DGBTCC,DGBTDIV,DGBTDOB,DGBTINS,DGBTINS1,DGBTINS2,DGBTCNA,DGBTCSZ,DGBTCNU,DGBTTCTY,DGBTFCTY,DGBTDT,DGBTACCT,DFN,Y

 +3        KILL DGBTM6,DGBTM7,DGBTM8,DGBTM9,DGBTM10,DGBTM11,DGBTM12,DGBTM13,DGBTM14,DGBTM15,DGBTM16,DGBTM17,DGBTRATE,DGBTSCP,DGBTSSN,DGBTST

 +4        QUIT 

PRINT     ;

 +1        USE IO

           DO SET

           DO PRINT^DGBTCR1

           DO PRINT^DGBTCR2

           DO KVAR^VADPT

 +2        QUIT 

SET        SET DFN=$PIECE(^DGBT(392,DGBTDT,0),"^",2)

           DO 6^VADPT

           SET (DGBTFCTY,DGBTTCTY)=""

NODES      FOR I=0,"A","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        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        IF VAPA(5)&(VAPA(7))

               SET DGBTCC=$SELECT($DATA(^DIC(5,+VAPA(5),1,+VAPA(7),0)):$PIECE(^(0),"^",3),1:"")

               SET DGBTST=$PIECE(^DIC(5,+VAPA(5),0),"^",2)

 +3       ;S DGBTSSN=$P($P(VADM(2),"^",2),"-")_" "_$P($P(VADM(2),"^",2),"-",2)_" "_$P($P(VADM(2),"^",2),"-",3),DGBTDOB=$E(VADM(3),4,7)_$E(VADM(3),2,3)

 +4        DO PID^VADPT6

           SET DGBTSSN=VA("PID")

           SET DGBTDOB=$EXTRACT(VADM(3),4,7)_($EXTRACT(VADM(3),1,3)+1700)

 +5        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        SET X2="2$"

           SET X=DGBTM6*DGBTM7

           DO COMMA^%DTC

           SET DGBTM8=X

 +2        SET X=$PIECE(DGBTVAR("M"),"^",4)

           DO COMMA^%DTC

           SET DGBTM9=X

 +3        SET X=$PIECE(DGBTVAR("M"),"^",5)

           DO COMMA^%DTC

           SET DGBTM10=X

 +4        SET X=DGBTM6*DGBTM7+$PIECE(DGBTVAR("M"),"^",4)+$PIECE(DGBTVAR("M"),"^",5)

           DO COMMA^%DTC

           SET DGBTM11=X

 +5        SET X=DGBTM7

           DO COMMA^%DTC

           SET DGBTM7=X

 +6        SET X=$PIECE(DGBTVAR(0),"^",8)

           DO COMMA^%DTC

           SET DGBTM12=X

 +7        SET X=$PIECE(DGBTVAR("M"),"^",4)+$PIECE(DGBTVAR(0),"^",8)

           DO COMMA^%DTC

           SET DGBTM13=X

 +8        SET X=$PIECE(DGBTVAR(0),"^",10)

           DO COMMA^%DTC

           SET DGBTM14=X

 +9        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 CHIEF, MEDICAL ADMINISTRATION SERVICE")

           KILL X

 +2        SET DGBTM17=$PIECE($PIECE(DGBTVAR("A"),"^",2),",",2)_" "_$PIECE($PIECE(DGBTVAR("A"),"^",2),",")

 +3        QUIT 

CITY       SET DGBTCSZ=DGBTCNA

 +1        IF VAPA(5)'=""

               SET DGBTCNU=$ORDER(^DGBT(392.1,"ACS",DGBTCNA,+VAPA(5),0))

 +2        IF $DATA(DGBTCNU)

               IF (DGBTCNU'="")

                   SET DGBTCSZ=$PIECE(^DGBT(392.1,DGBTCNU,0),"^")_", "_($PIECE(^DIC(5,+VAPA(5),0),"^",2))_"  "_($PIECE(^DGBT(392.1,DGBTCNU,0),"^",4))

 +3        QUIT 

QUE       ;

 +1        NEW I

 +2        SET ZTRTN="PRINT^DGBTCR"

           SET ZTDESC="VA FORM 70-3542d"

 +3        FOR I="DFN","DGBTDT","DGBTFCTY","DGBTTCTY"

               SET ZTSAVE(I)=""

 +4        DO ^%ZTLOAD

           IF $DATA(ZTSK)

               WRITE !,"TASK #",ZTSK

 +5        DO HOME^%ZIS

           KILL IO("Q")

 +6        QUIT