DGBTCE ;ALB/SCK/BLD,LAB - BENEFICIARY TRAVEL CLAIM RE-ENTER/EDIT ;03/20/2019
;;1.0;Beneficiary Travel;**2,14,17,20,30,37**;September 25, 2001;Build 1
Q
SCREEN ;
D QUIT^DGBTCE1
S DGBTTOUT=""
D SCREEN^DGBTEE1 Q:'$D(^DGBT(392,DGBTDT,0)) I DGBTTOUT=-1 S DGBTTOUT=1 Q
I $D(DGBTOACT) I DGBTOACT'=DGBTACCT S DGBTVAR(0)=^DGBT(392,DGBTDT,0) D FILE
S (DGBTMAL,DGBTFAB,DGBTME,DGBTCP,DGBTFLAG,DGBTDE,DGBTDCV,DGBTDCM,DGBTDPV,DGBTDPM)=0
S:$G(DGBTACCT)'>0 DGBTACCT=$P($G(DGBTVAR(0)),U,6)
I DGBTACCT=4!(DGBTACCT=5) I $$ABP^DGBTUTL(DFN) W !!,"*ALERT: Patient has an active bus pass, which expires on ",$$FMTE^XLFDT($$ABP^DGBTUTL(DFN)),".",! S DIR("A")="Press RETURN to continue",DIR(0)="E" D ^DIR K DIR ;20
S DGBTAP=VADM(1),DIE="^DGBT(392,",DA=DGBTDT,DR=$S(DGBTACCT=4:"42//"_DGBTAP,DGBTACCT=5:"43;S DGBTCP=X;42//"_DGBTAP,1:"44")
D ^DIE K DIE,DQ,DR I $D(DTOUT)!($D(Y)) S DGBTTOUT=1 Q
I DGBTACCT=4!(DGBTACCT=5) S:$D(DGBTVAR("M")) DGBTWAY=$P(DGBTVAR("M"),"^"),DGBTMILE=$P(DGBTVAR("M"),"^",2) S:$D(DGBTVAR("D")) DGBTCITY=$P(DGBTVAR("D"),"^",4),DGBTSTAT=$P(DGBTVAR("D"),"^",5)
S DGBTDIV=$P($G(^DGBT(392,DA,0)),U,11),DGBTRMK=$S($D(DGBTREC):$$DICLKUP^DGBTUTL(DGBTREC,DGBTDIV,4),1:"")
S DIE="^DGBT(392,",DA=DGBTDT
;DGBT*1.0*37 replace 4 slashes 3///' the ' allows for the internal value of a pointer to be validated and pushed
S DR="3///`"_DGBTELIG_";6///`"_DGBTACTN_";21;I X="""" S Y=24;22;I X="""" S Y=24;23;24;24.1;24.2;25;I X="""" S Y=28;26;I X="""" S Y=28;27;28;28.1;28.2"
D ^DIE K DIE I $D(DTOUT)!($D(Y)) S DGBTTOUT=1 Q
W:DGBTRMK]"" !!,*7,"MILEAGE REMARKS: ",DGBTRMK,!
I DGBTACCT=4!(DGBTACCT=5) D Q:$G(DGBTTOUT)
.I $G(MONTOT)'="" N OTRIPTYP S OTRIPTYP=$$GET1^DIQ(392,DGBTDT,31,"I")
. S DR="31//;S DGBTOWRT=X;32//;S DGBTML=X"
. I DGBTACCT=5&(DGBTCP=1) S DGBTMR=DGBTMR1
. S DIE="^DGBT(392,",DA=DGBTDT
. D ^DIE K DIE,DQ,DR I $D(DTOUT)!($D(Y)) S DGBTTOUT=1
.I ($G(MONTOT)'="")&($G(OTRIPTYP)'=$$GET1^DIQ(392,DGBTDT,31,"I")) D
..N NTRIPTYP S NTRIPTYP=$$GET1^DIQ(392,DGBTDT,31,"I")
..I (OTRIPTYP=1)&(NTRIPTYP=2) D Q
...S $P(MONTOT,U)=$P(MONTOT,U)+1
...S $P(MONTOT,U,2)=$P(MONTOT,U,2)-1
...S $P(MONTOT,U,3)=$P(MONTOT,U,3)+1
..I (OTRIPTYP=2)&(NTRIPTYP=1) D Q
...S $P(MONTOT,U)=$P(MONTOT,U)-1
...S $P(MONTOT,U,2)=$P(MONTOT,U,2)+1
...S $P(MONTOT,U,3)=$P(MONTOT,U,3)-1
. N MODE S DIR(0)="Y",DIR("B")=$S($D(^DGBT(392,DGBTDT,"C")):"YES",1:"NO"),DIR("A")="COMMON CARRIER USED" D ^DIR K DIR S MODE=Y I $D(DIRUT),$G(DUOUT) S DGBTTOUT=-1 Q ;20
. I 'MODE,$D(^DGBT(392,DGBTDT,"C")) S $P(^DGBT(392,DGBTDT,"A"),"^",4)="" F I="B","C" K ^DGBT(392,DGBTDT,I)
. I $$GET1^DIQ(392,DGBTDT,44)'=""!($G(MODE)) S DIE="^DGBT(392,",DA=DGBTDT,DR="44COMMON CARRIER MODE" D ^DIE I $D(Y) S DGBTTOUT=1 Q ;20
. S DIE="^DGBT(392,",DA=DGBTDT I $$UP^XLFSTR($$GET1^DIQ(392,DGBTDT,44))["BUS" S DR="52R;I X'=""P"" S Y="""";53R" D ^DIE I $D(Y) S DGBTTOUT=1 Q ;20
. I $$GET1^DIQ(392,DGBTDT,44)'="" S DIE="^DGBT(392,",DA=DGBTDT,DR="54;55;55.1" D ^DIE I $D(Y) S DGBTTOUT=1 Q ;20
DIE1 ;
S DGBTMLT=$S($D(DGBTVAR("M"))&((DGBTACCT=4)!(DGBTACCT=5)):$J((DGBTOWRT*DGBTML*DGBTMR),0,2),1:""),$P(^DGBT(392,DGBTDT,"M"),"^",3)=DGBTMLT,$P(DGBTVAR("M"),"^",3)=DGBTMLT
;
S DIE="^DGBT(392,",DA=DGBTDT
I 'DGBTCORE D
. S DR="I DGBTACCT=4!(DGBTACCT=5) S Y=""@1"";41;7;@1;I DGBTMLFB=0 S Y=""@2"";34//;S DGBTMAL=X;35//;S DGBTFAB=X;@2;8//;S DGBTME=X"
I DGBTCORE S DR="" D
. S DR(1,392,1)="I DGBTACCT=4!(DGBTACCT=5) S Y=""@1"";41;@3;14;S DGBTCSL=$$AFTER^DGBTCSL(392,D0,X,$G(DGBTPRV)) S:DGBTCSL<1 Y=""@3"" W:DGBTCSL<1 "" Required"" K DGBTPRV,DGBTCSL;"
. S DR(1,392,2)="@1;I DGBTMLFB=0 S Y=""@2"";34//;S DGBTMAL=X;35//;S DGBTFAB=X;@2;8//;S DGBTME=X"
DIE3 ;
D ^DIE K DIE,DQ,DR I $D(DTOUT)!($D(Y)) S DGBTTOUT=1 Q
;
TCOST ;CALCULATE TOTAL COST AND MONTHLY CUM. DEDUCTIBLE
MLFB ;
S DGBTMAF=$S(DGBTMLFB:DGBTMAL+DGBTFAB,1:0),DGBTMETC=DGBTME+$S($D(DGBTMAL):DGBTMAL,1:0)
I DGBTACCT'=4&(DGBTACCT'=5) S DGBTPA=DGBTMAF+DGBTME G CONT
I $D(DGBTMLT) S DGBTTC=$S(DGBTMLT+DGBTMAF'>DGBTMETC:DGBTMLT+DGBTMAF,DGBTMLT+DGBTMAF>DGBTMETC&(DGBTME>0):DGBTMETC,DGBTME'>0:DGBTMLT+DGBTMAF,1:DGBTMETC)
I DGBTACCT=5 S DGBTDE=0 S DGBTPA=$S((DGBTMLT+DGBTMAF)'=0:DGBTTC,1:DGBTMETC) G CONT
DED ;
I $G(MONTOT)'="" N ODED S ODED=$$GET1^DIQ(392,DGBTDT,9)
F I=$E(DGBTDT,1,5)_"00.2399":0 S I=$O(^DGBT(392,"C",DFN,I)) Q:'I!($E(I,1,5)>$E(DGBTDT,1,5)) I I'=DGBTDT S DGBTDCM=DGBTDCM+($P(^DGBT(392,I,0),"^",9))
I $D(^DG(43.1,$O(^DG(43.1,(9999999.99999-DGBTDT))),"BT")) S DGBTRATE=^("BT"),DGBTDPV=$P(DGBTRATE,"^"),DGBTDPM=$P(DGBTRATE,"^",2),DGBTMR=$P(DGBTRATE,"^",3)
I $D(^DGBT(392,DGBTDT,"M")) S:$P(^("M"),"^")=1 DGBTDPV=DGBTDPV/2 I DGBTWAY'=$P(^("M"),"^")!(DGBTMILE'=$P(^("M"),"^",2)) I $D(^DGBT(392,DGBTDT,0)) S $P(^(0),"^",9)="" K ^DGBT(392,"AD",$P(^(0),"^",2),$E(DGBTDT,2,5),DGBTDT)
S DGBTDRM=DGBTDPM-DGBTDCM
I DGBTDRM<0 S DGBTDRM=0
I DGBTDE<0 S DGBTDE=0
S DGBTDCV=$S(DGBTDCM'<DGBTDPM:0,DGBTDRM'<DGBTDPV&(DGBTTC'<DGBTDPV):DGBTDPV,DGBTDRM'<DGBTDPV&(DGBTTC'>DGBTDPV):DGBTTC,DGBTDRM'>DGBTDPV&(DGBTTC'>DGBTDRM):DGBTTC,DGBTDRM'>DGBTDPV&(DGBTTC'<DGBTDRM):DGBTDRM,1:0)
I $P(MONTOT,"^",5)="YES"&('$G(CHZFLG)) S DGBTDCV=0 ;*30 modified to preserve waiver status of existing claims
DED1 ;
S DR="I $P(^DGBT(392,DGBTDT,0),""^"",9)]"""" S Y=""@9"";9///"_DGBTDCV_";@9;9;S DGBTDE=X S:DGBTDE>DGBTTC DGBTDE=DGBTTC,DGBTFLAG=2 S:DGBTDE>DGBTDRM DGBTDE=DGBTDRM,DGBTFLAG=1"
DIE4 ;
I $G(^DGBT(392,DGBTDT,0))'="" D
.I $P(^DGBT(392,DGBTDT,0),U,9)="" S $P(^DGBT(392,DGBTDT,0),U,9)=+$G(DGBTDCV)
S DIE="^DGBT(392,",DA=DGBTDT D ^DIE K DIE,DQ,DR I $D(DTOUT)!($D(Y)) S DGBTTOUT=1 Q
I ($G(MONTOT)'="")&($G(ODED)'=DGBTDE) D
.S $P(MONTOT,U,4)=$P(MONTOT,U,4)+DGBTDE
.S $P(MONTOT,U,4)=$P(MONTOT,U,4)-ODED
CONT ;
D CONT^DGBTCE1
Q
FILE ; Reset values if account changes
S DGBTVAR(0)=$P(DGBTVAR(0),"^",1,6)_"^^0^^"_$S($L(DGBTVAR(0),"^")>10:$P(DGBTVAR(0),"^",10,$L(DGBTVAR(0),"^")),1:""),DGBTVAR("A")="^"_$P(DGBTVAR("A"),"^",2)_"^^^"_$S($L(DGBTVAR("A"),"^")>4:$P(DGBTVAR("A"),"^",5,$L(DGBTVAR("A"),"^")),1:"")
I DGBTACCT<4 S DGBTVAR("M")="^^^"_$S($L(DGBTVAR("M"),"^")>3:$P(DGBTVAR("M"),"^",4,$L(DGBTVAR("M"),"^")),1:"")
S ^DGBT(392,DGBTDT,0)=DGBTVAR(0),^("A")=DGBTVAR("A") S:DGBTACCT<4 ^("M")=DGBTVAR("M") S DA=DGBTDT,DIK="^DGBT(392," D IX^DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGBTCE 6250 printed Apr 09, 2024@20:45:24 Page 2
DGBTCE ;ALB/SCK/BLD,LAB - BENEFICIARY TRAVEL CLAIM RE-ENTER/EDIT ;03/20/2019
+1 ;;1.0;Beneficiary Travel;**2,14,17,20,30,37**;September 25, 2001;Build 1
+2 QUIT
SCREEN ;
+1 DO QUIT^DGBTCE1
+2 SET DGBTTOUT=""
+3 DO SCREEN^DGBTEE1
if '$DATA(^DGBT(392,DGBTDT,0))
QUIT
IF DGBTTOUT=-1
SET DGBTTOUT=1
QUIT
+4 IF $DATA(DGBTOACT)
IF DGBTOACT'=DGBTACCT
SET DGBTVAR(0)=^DGBT(392,DGBTDT,0)
DO FILE
+5 SET (DGBTMAL,DGBTFAB,DGBTME,DGBTCP,DGBTFLAG,DGBTDE,DGBTDCV,DGBTDCM,DGBTDPV,DGBTDPM)=0
+6 if $GET(DGBTACCT)'>0
SET DGBTACCT=$PIECE($GET(DGBTVAR(0)),U,6)
+7 ;20
IF DGBTACCT=4!(DGBTACCT=5)
IF $$ABP^DGBTUTL(DFN)
WRITE !!,"*ALERT: Patient has an active bus pass, which expires on ",$$FMTE^XLFDT($$ABP^DGBTUTL(DFN)),".",!
SET DIR("A")="Press RETURN to continue"
SET DIR(0)="E"
DO ^DIR
KILL DIR
+8 SET DGBTAP=VADM(1)
SET DIE="^DGBT(392,"
SET DA=DGBTDT
SET DR=$SELECT(DGBTACCT=4:"42//"_DGBTAP,DGBTACCT=5:"43;S DGBTCP=X;42//"_DGBTAP,1:"44")
+9 DO ^DIE
KILL DIE,DQ,DR
IF $DATA(DTOUT)!($DATA(Y))
SET DGBTTOUT=1
QUIT
+10 IF DGBTACCT=4!(DGBTACCT=5)
if $DATA(DGBTVAR("M"))
SET DGBTWAY=$PIECE(DGBTVAR("M"),"^")
SET DGBTMILE=$PIECE(DGBTVAR("M"),"^",2)
if $DATA(DGBTVAR("D"))
SET DGBTCITY=$PIECE(DGBTVAR("D"),"^",4)
SET DGBTSTAT=$PIECE(DGBTVAR("D"),"^",5)
+11 SET DGBTDIV=$PIECE($GET(^DGBT(392,DA,0)),U,11)
SET DGBTRMK=$SELECT($DATA(DGBTREC):$$DICLKUP^DGBTUTL(DGBTREC,DGBTDIV,4),1:"")
+12 SET DIE="^DGBT(392,"
SET DA=DGBTDT
+13 ;DGBT*1.0*37 replace 4 slashes 3///' the ' allows for the internal value of a pointer to be validated and pushed
+14 SET DR="3///`"_DGBTELIG_";6///`"_DGBTACTN_";21;I X="""" S Y=24;22;I X="""" S Y=24;23;24;24.1;24.2;25;I X="""" S Y=28;26;I X="""" S Y=28;27;28;28.1;28.2"
+15 DO ^DIE
KILL DIE
IF $DATA(DTOUT)!($DATA(Y))
SET DGBTTOUT=1
QUIT
+16 if DGBTRMK]""
WRITE !!,*7,"MILEAGE REMARKS: ",DGBTRMK,!
+17 IF DGBTACCT=4!(DGBTACCT=5)
Begin DoDot:1
+18 IF $GET(MONTOT)'=""
NEW OTRIPTYP
SET OTRIPTYP=$$GET1^DIQ(392,DGBTDT,31,"I")
+19 SET DR="31//;S DGBTOWRT=X;32//;S DGBTML=X"
+20 IF DGBTACCT=5&(DGBTCP=1)
SET DGBTMR=DGBTMR1
+21 SET DIE="^DGBT(392,"
SET DA=DGBTDT
+22 DO ^DIE
KILL DIE,DQ,DR
IF $DATA(DTOUT)!($DATA(Y))
SET DGBTTOUT=1
+23 IF ($GET(MONTOT)'="")&($GET(OTRIPTYP)'=$$GET1^DIQ(392,DGBTDT,31,"I"))
Begin DoDot:2
+24 NEW NTRIPTYP
SET NTRIPTYP=$$GET1^DIQ(392,DGBTDT,31,"I")
+25 IF (OTRIPTYP=1)&(NTRIPTYP=2)
Begin DoDot:3
+26 SET $PIECE(MONTOT,U)=$PIECE(MONTOT,U)+1
+27 SET $PIECE(MONTOT,U,2)=$PIECE(MONTOT,U,2)-1
+28 SET $PIECE(MONTOT,U,3)=$PIECE(MONTOT,U,3)+1
End DoDot:3
QUIT
+29 IF (OTRIPTYP=2)&(NTRIPTYP=1)
Begin DoDot:3
+30 SET $PIECE(MONTOT,U)=$PIECE(MONTOT,U)-1
+31 SET $PIECE(MONTOT,U,2)=$PIECE(MONTOT,U,2)+1
+32 SET $PIECE(MONTOT,U,3)=$PIECE(MONTOT,U,3)-1
End DoDot:3
QUIT
End DoDot:2
+33 ;20
NEW MODE
SET DIR(0)="Y"
SET DIR("B")=$SELECT($DATA(^DGBT(392,DGBTDT,"C")):"YES",1:"NO")
SET DIR("A")="COMMON CARRIER USED"
DO ^DIR
KILL DIR
SET MODE=Y
IF $DATA(DIRUT)
IF $GET(DUOUT)
SET DGBTTOUT=-1
QUIT
+34 IF 'MODE
IF $DATA(^DGBT(392,DGBTDT,"C"))
SET $PIECE(^DGBT(392,DGBTDT,"A"),"^",4)=""
FOR I="B","C"
KILL ^DGBT(392,DGBTDT,I)
+35 ;20
IF $$GET1^DIQ(392,DGBTDT,44)'=""!($GET(MODE))
SET DIE="^DGBT(392,"
SET DA=DGBTDT
SET DR="44COMMON CARRIER MODE"
DO ^DIE
IF $DATA(Y)
SET DGBTTOUT=1
QUIT
+36 ;20
SET DIE="^DGBT(392,"
SET DA=DGBTDT
IF $$UP^XLFSTR($$GET1^DIQ(392,DGBTDT,44))["BUS"
SET DR="52R;I X'=""P"" S Y="""";53R"
DO ^DIE
IF $DATA(Y)
SET DGBTTOUT=1
QUIT
+37 ;20
IF $$GET1^DIQ(392,DGBTDT,44)'=""
SET DIE="^DGBT(392,"
SET DA=DGBTDT
SET DR="54;55;55.1"
DO ^DIE
IF $DATA(Y)
SET DGBTTOUT=1
QUIT
End DoDot:1
if $GET(DGBTTOUT)
QUIT
DIE1 ;
+1 SET DGBTMLT=$SELECT($DATA(DGBTVAR("M"))&((DGBTACCT=4)!(DGBTACCT=5)):$JUSTIFY((DGBTOWRT*DGBTML*DGBTMR),0,2),1:"")
SET $PIECE(^DGBT(392,DGBTDT,"M"),"^",3)=DGBTMLT
SET $PIECE(DGBTVAR("M"),"^",3)=DGBTMLT
+2 ;
+3 SET DIE="^DGBT(392,"
SET DA=DGBTDT
+4 IF 'DGBTCORE
Begin DoDot:1
+5 SET DR="I DGBTACCT=4!(DGBTACCT=5) S Y=""@1"";41;7;@1;I DGBTMLFB=0 S Y=""@2"";34//;S DGBTMAL=X;35//;S DGBTFAB=X;@2;8//;S DGBTME=X"
End DoDot:1
+6 IF DGBTCORE
SET DR=""
Begin DoDot:1
+7 SET DR(1,392,1)="I DGBTACCT=4!(DGBTACCT=5) S Y=""@1"";41;@3;14;S DGBTCSL=$$AFTER^DGBTCSL(392,D0,X,$G(DGBTPRV)) S:DGBTCSL<1 Y=""@3"" W:DGBTCSL<1 "" Required"" K DGBTPRV,DGBTCSL;"
+8 SET DR(1,392,2)="@1;I DGBTMLFB=0 S Y=""@2"";34//;S DGBTMAL=X;35//;S DGBTFAB=X;@2;8//;S DGBTME=X"
End DoDot:1
DIE3 ;
+1 DO ^DIE
KILL DIE,DQ,DR
IF $DATA(DTOUT)!($DATA(Y))
SET DGBTTOUT=1
QUIT
+2 ;
TCOST ;CALCULATE TOTAL COST AND MONTHLY CUM. DEDUCTIBLE
MLFB ;
+1 SET DGBTMAF=$SELECT(DGBTMLFB:DGBTMAL+DGBTFAB,1:0)
SET DGBTMETC=DGBTME+$SELECT($DATA(DGBTMAL):DGBTMAL,1:0)
+2 IF DGBTACCT'=4&(DGBTACCT'=5)
SET DGBTPA=DGBTMAF+DGBTME
GOTO CONT
+3 IF $DATA(DGBTMLT)
SET DGBTTC=$SELECT(DGBTMLT+DGBTMAF'>DGBTMETC:DGBTMLT+DGBTMAF,DGBTMLT+DGBTMAF>DGBTMETC&(DGBTME>0):DGBTMETC,DGBTME'>0:DGBTMLT+DGBTMAF,1:DGBTMETC)
+4 IF DGBTACCT=5
SET DGBTDE=0
SET DGBTPA=$SELECT((DGBTMLT+DGBTMAF)'=0:DGBTTC,1:DGBTMETC)
GOTO CONT
DED ;
+1 IF $GET(MONTOT)'=""
NEW ODED
SET ODED=$$GET1^DIQ(392,DGBTDT,9)
+2 FOR I=$EXTRACT(DGBTDT,1,5)_"00.2399":0
SET I=$ORDER(^DGBT(392,"C",DFN,I))
if 'I!($EXTRACT(I,1,5)>$EXTRACT(DGBTDT,1,5))
QUIT
IF I'=DGBTDT
SET DGBTDCM=DGBTDCM+($PIECE(^DGBT(392,I,0),"^",9))
+3 IF $DATA(^DG(43.1,$ORDER(^DG(43.1,(9999999.99999-DGBTDT))),"BT"))
SET DGBTRATE=^("BT")
SET DGBTDPV=$PIECE(DGBTRATE,"^")
SET DGBTDPM=$PIECE(DGBTRATE,"^",2)
SET DGBTMR=$PIECE(DGBTRATE,"^",3)
+4 IF $DATA(^DGBT(392,DGBTDT,"M"))
if $PIECE(^("M"),"^")=1
SET DGBTDPV=DGBTDPV/2
IF DGBTWAY'=$PIECE(^("M"),"^")!(DGBTMILE'=$PIECE(^("M"),"^",2))
IF $DATA(^DGBT(392,DGBTDT,0))
SET $PIECE(^(0),"^",9)=""
KILL ^DGBT(392,"AD",$PIECE(^(0),"^",2),$EXTRACT(DGBTDT,2,5),DGBTDT)
+5 SET DGBTDRM=DGBTDPM-DGBTDCM
+6 IF DGBTDRM<0
SET DGBTDRM=0
+7 IF DGBTDE<0
SET DGBTDE=0
+8 SET DGBTDCV=$SELECT(DGBTDCM'<DGBTDPM:0,DGBTDRM'<DGBTDPV&(DGBTTC'<DGBTDPV):DGBTDPV,DGBTDRM'<DGBTDPV&(DGBTTC'>DGBTDPV):DGBTTC,DGBTDRM'>DGBTDPV&(DGBTTC'>DGBTDRM):DGBTTC,DGBTDRM'>DGBTDPV&(DGBTTC'<DGBTDRM):DGBTDRM,1:0)
+9 ;*30 modified to preserve waiver status of existing claims
IF $PIECE(MONTOT,"^",5)="YES"&('$GET(CHZFLG))
SET DGBTDCV=0
DED1 ;
+1 SET DR="I $P(^DGBT(392,DGBTDT,0),""^"",9)]"""" S Y=""@9"";9///"_DGBTDCV_";@9;9;S DGBTDE=X S:DGBTDE>DGBTTC DGBTDE=DGBTTC,DGBTFLAG=2 S:DGBTDE>DGBTDRM DGBTDE=DGBTDRM,DGBTFLAG=1"
DIE4 ;
+1 IF $GET(^DGBT(392,DGBTDT,0))'=""
Begin DoDot:1
+2 IF $PIECE(^DGBT(392,DGBTDT,0),U,9)=""
SET $PIECE(^DGBT(392,DGBTDT,0),U,9)=+$GET(DGBTDCV)
End DoDot:1
+3 SET DIE="^DGBT(392,"
SET DA=DGBTDT
DO ^DIE
KILL DIE,DQ,DR
IF $DATA(DTOUT)!($DATA(Y))
SET DGBTTOUT=1
QUIT
+4 IF ($GET(MONTOT)'="")&($GET(ODED)'=DGBTDE)
Begin DoDot:1
+5 SET $PIECE(MONTOT,U,4)=$PIECE(MONTOT,U,4)+DGBTDE
+6 SET $PIECE(MONTOT,U,4)=$PIECE(MONTOT,U,4)-ODED
End DoDot:1
CONT ;
+1 DO CONT^DGBTCE1
+2 QUIT
FILE ; Reset values if account changes
+1 SET DGBTVAR(0)=$PIECE(DGBTVAR(0),"^",1,6)_"^^0^^"_$SELECT($LENGTH(DGBTVAR(0),"^")>10:$PIECE(DGBTVAR(0),"^",10,$LENGTH(DGBTVAR(0),"^")),1:"")
SET DGBTVAR("A")="^"_$PIECE(DGBTVAR("A"),"^",2)_"^^^"_$SELECT($LENGTH(DGBTVAR("A"),"^")>4:$PIECE(DGBTVAR("A"),"^",5,$LENGTH(DGBTVAR("A"),"^")),1:"")
+2 IF DGBTACCT<4
SET DGBTVAR("M")="^^^"_$SELECT($LENGTH(DGBTVAR("M"),"^")>3:$PIECE(DGBTVAR("M"),"^",4,$LENGTH(DGBTVAR("M"),"^")),1:"")
+3 SET ^DGBT(392,DGBTDT,0)=DGBTVAR(0)
SET ^("A")=DGBTVAR("A")
if DGBTACCT<4
SET ^("M")=DGBTVAR("M")
SET DA=DGBTDT
SET DIK="^DGBT(392,"
DO IX^DIK
+4 QUIT
