- DGBTEE1 ;ALB/SCK - BENEFICIARY TRAVEL ENTER/EDIT CHECK; 12/7/92 3/19/93 ;11/10/11 13:16
- ;;1.0;Beneficiary Travel;**14,20**;September 25, 2001;Build 185
- Q
- SCREEN ; called by dgbtee,dgbtce
- Q:'$D(^DGBT(392,DGBTDT,0))!($G(DGBTSP("CLAIM TYPE"))="S")
- K DGBTVAR F I=0,"A","C","D","M","R","T" S DGBTVAR(I)=$S($D(^DGBT(392,DGBTDT,I)):^(I),1:"") ; ref file #392, claims
- W @IOF S DGBTFLAG=0
- I '$D(^DG(43,1,"BT"))!('$D(^DG(43.1,$O(^DG(43.1,(9999999.99999-DGBTDT))),"BT"))) W !!,"Module has not been properly initialized - to continue you should first complete",!,"the parameters" Q
- W !?16,"Beneficiary Travel Claim Information <Enter/Edit>"
- D PID^VADPT6
- W !!?8,"Name: ",VADM(1),?40,"PT ID: ",VA("PID"),?64,"DOB: ",$P(VADM(3),"^",2),!
- START ; ask date/time, and division
- K DIC,^TMP("DGBT",$J),X
- S DIE="^DGBT(392,",DIE("NO^")="OUTOK"
- S DR=".01;S (DGBTDT,VADAT(""W""))=X D ^VADATE S DGBTDTI=VADATE(""I""),DGBTDTE=VADATE(""E"") K VADAT,VADATE I '$D(DGBTMD) S Y=""@1"";11;@1"
- ;
- S DIDEL=392 ; allows users to delete BT claims
- D ^DIE K DIE,DIDEL,DQ,DR I $D(DTOUT)!$G(DUOUT)!($D(Y)) S DGBTTOUT=-1,%=-1 Q ;PAVEL
- K X
- I '$D(^DGBT(392,DGBTDT,0)) Q
- I $D(^DGBT(392,DGBTDT,0)) L +^DGBT(392,DGBTDT):2 I '$T W !?5,"Another user is editing this entry.",*7 S DGBTTOUT=1 G QUIT
- ; set rates and build eligibilities in DGBTEE2
- D RATES^DGBTEE2
- ELIG1 ; select eligibility from those available in TMP list
- I '$O(VAEL(1,0)) S DGBTELIG=+VAEL(1) G ESET1
- S DIR("A")="Select ELIGIBILITY",DIR("B")=$S($P(^DGBT(392,DGBTDT,0),"^",3):$P(^DIC(8,$P(^DGBT(392,DGBTDT,0),"^",3),0),"^"),VAEL(1):$P(VAEL(1),"^",2),1:"")
- S DIR(0)="F",DIR("?")="^D ELIST^DGBTEE2"
- D ^DIR K DIR I $D(DUOUT) W !?3,"SORRY, '^' NOT ALLOWED!!" G ELIG1
- I $D(DTOUT) S DGBTTOUT=-1 Q
- S:Y="" DGBTELIG=$S($P(^DGBT(392,DGBTDT,0),"^",3):$P(^(0),"^",3),1:+VAEL(1)) ; ref file #392, claims
- I X["@" W !,"ELIGIBILITY REQUIRED." G ELIG1
- I Y?1A.E F I=0:0 S I=$O(^TMP("DGBT",$J,I)) Q:'I I $E($P(^(I),"^",2),1,$L(X))=X S XX=Y,Y=I G ESET ; ref ^TMP file for eligibility
- I +Y?1N.N S Y=+Y F I=0:0 S I=$O(^TMP("DGBT",$J,I)) Q:'I I +$P(^(I),"^")=Y S XX=Y,Y=I G ESET ; ref ^TMP file for eligibility
- ECHOZ ;
- W !!,"Choose by NUMBER the primary eligibility or other entitled eligibilities",!
- I DGBTCT>1 F I=0:0 S I=$O(^TMP("DGBT",$J,I)) Q:'I W !?5,I,?10,$P(^TMP("DGBT",$J,I),"^",2)
- K DIR,X S DIR("A")="Choose 1-"_DGBTCT,DIR(0)="NO^1:"_DGBTCT,DIR("?")="Enter choice from those displayed"
- D ^DIR K DIR G:$D(DIRUT) ELIG1 S XX=Y
- I '$D(^TMP("DGBT",$J,Y)) W " ?? ",!,"Select ELIGIBILITY: " G ECHOZ
- ESET ;
- S:$D(Y) DGBTELIG=$S($D(^TMP("DGBT",$J,Y)):+^TMP("DGBT",$J,Y),'$D(XX):Y,1:+VAEL(1))
- W:Y]"" ?30,$E($P(^DIC(8,+DGBTELIG,0),"^"),$S($D(XX):($L(XX)+1),1:1),99)
- ESET1 ;
- S DGBTSCP=$S($P(^DIC(8,DGBTELIG,0),"^",9)=1&(+VAEL(3)):$P(VAEL(3),"^",2),$P(^DIC(8,DGBTELIG,0),"^",9)=3&(+VAEL(3)):$P(VAEL(3),"^",2),1:"")
- CERT ; stuff of certification date if appropriate
- ; naked global ref file #392.2, certification file.
- I $P(VAEL(3),"^") S DGBTCD="" I VAEL(3)&($P(VAEL(3),"^",2)'>29) S DGBTIDT=9999999.99999-DGBTDT F I=0:0 S I=$O(^DGBT(392.2,"C",DFN,I)) Q:'I I I'>DGBTIDT&($P(^DGBT(392.2,I,0),"^",3)) S DGBTCD=$P(^(0),"^")
- ACCT ; allowed to select only valid active accounts
- ;I DGBTDTI>PATCHDT S DGBTOACT=$S('$D(^DGBT(392.3,+$P(DGBTVAR(0),"^",6),0)):0,1:+$P(^DGBT(392.3,$P(DGBTVAR(0),"^",6),0),"^",5))
- S DGBTOACT=$S('$D(^DGBT(392.3,+$P(DGBTVAR(0),"^",6),0)):0,1:+$P(^DGBT(392.3,$P(DGBTVAR(0),"^",6),0),"^",5))
- K X S (DIC("B"),X)=$S(+$P(DGBTVAR(0),"^",6):$P(^DGBT(392.3,$P(DGBTVAR(0),"^",6),0),"^"),1:$$DEFLT1()) S DIC("A")="Select ACCOUNT: "
- S DIC="^DGBT(392.3,",DIC(0)="AEQMZ"
- S DIC("S")="I $$ACCTHELP^DGBTEE1"
- D ^DIC K DIC I $D(DTOUT) S DGBTTOUT=-1 K DTOUT Q
- I Y'>0 W !,"ACCOUNT IS REQUIRED!!" G ACCT
- S DGBTACTN=$P(Y,"^"),DGBTACCT=$P(Y(0),"^",5)
- ; if account is ALL OTHER - stuff in mileage info
- I $D(DGBTVAR("M")) S DGBTML=$P(DGBTVAR("M"),"^",2),DGBTOWRT=$P(DGBTVAR("M"),"^"),DGBTMLT=$J((DGBTML*DGBTOWRT*DGBTMR),0,2)
- QUIT ;
- K A,C,I,IA,J,X,XX,^TMP("DGBT",$J),DGBTIDT,DGBTCT
- Q
- ;
- DEFLT1() ;
- N REC,Y
- I $P(DGBTDTI,".",1)'=DT Q ""
- S REC="0" F S REC=$O(^DGBT(392.3,REC)) Q:'REC D Q:$D(Y)
- . S:$P(^DGBT(392.3,REC,0),U,5)=4&($P(^(0),U,3)'>DGBTDT&('$P(^(0),U,4)!($P(^(0),U,4)'<DGBTDT))) Y=$P(^(0),U,1)
- Q $G(Y)
- ACCTHELP() ;
- N DATUM
- S DATUM=$G(^DGBT(392.3,Y,0))
- I $P(DATUM,U,3)>DGBTDT Q 0
- I ($P(DATUM,U,4)<DGBTDT)&(+$P(DATUM,U,4)>0) Q 0
- Q $E(DATUM,5,16)'="SPECIAL MODE"
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGBTEE1 4496 printed Feb 18, 2025@23:07:05 Page 2
- DGBTEE1 ;ALB/SCK - BENEFICIARY TRAVEL ENTER/EDIT CHECK; 12/7/92 3/19/93 ;11/10/11 13:16
- +1 ;;1.0;Beneficiary Travel;**14,20**;September 25, 2001;Build 185
- +2 QUIT
- SCREEN ; called by dgbtee,dgbtce
- +1 if '$DATA(^DGBT(392,DGBTDT,0))!($GET(DGBTSP("CLAIM TYPE"))="S")
- QUIT
- +2 ; ref file #392, claims
- KILL DGBTVAR
- FOR I=0,"A","C","D","M","R","T"
- SET DGBTVAR(I)=$SELECT($DATA(^DGBT(392,DGBTDT,I)):^(I),1:"")
- +3 WRITE @IOF
- SET DGBTFLAG=0
- +4 IF '$DATA(^DG(43,1,"BT"))!('$DATA(^DG(43.1,$ORDER(^DG(43.1,(9999999.99999-DGBTDT))),"BT")))
- WRITE !!,"Module has not been properly initialized - to continue you should first complete",!,"the parameters"
- QUIT
- +5 WRITE !?16,"Beneficiary Travel Claim Information <Enter/Edit>"
- +6 DO PID^VADPT6
- +7 WRITE !!?8,"Name: ",VADM(1),?40,"PT ID: ",VA("PID"),?64,"DOB: ",$PIECE(VADM(3),"^",2),!
- START ; ask date/time, and division
- +1 KILL DIC,^TMP("DGBT",$JOB),X
- +2 SET DIE="^DGBT(392,"
- SET DIE("NO^")="OUTOK"
- +3 SET DR=".01;S (DGBTDT,VADAT(""W""))=X D ^VADATE S DGBTDTI=VADATE(""I""),DGBTDTE=VADATE(""E"") K VADAT,VADATE I '$D(DGBTMD) S Y=""@1"";11;@1"
- +4 ;
- +5 ; allows users to delete BT claims
- SET DIDEL=392
- +6 ;PAVEL
- DO ^DIE
- KILL DIE,DIDEL,DQ,DR
- IF $DATA(DTOUT)!$GET(DUOUT)!($DATA(Y))
- SET DGBTTOUT=-1
- SET %=-1
- QUIT
- +7 KILL X
- +8 IF '$DATA(^DGBT(392,DGBTDT,0))
- QUIT
- +9 IF $DATA(^DGBT(392,DGBTDT,0))
- LOCK +^DGBT(392,DGBTDT):2
- IF '$TEST
- WRITE !?5,"Another user is editing this entry.",*7
- SET DGBTTOUT=1
- GOTO QUIT
- +10 ; set rates and build eligibilities in DGBTEE2
- +11 DO RATES^DGBTEE2
- ELIG1 ; select eligibility from those available in TMP list
- +1 IF '$ORDER(VAEL(1,0))
- SET DGBTELIG=+VAEL(1)
- GOTO ESET1
- +2 SET DIR("A")="Select ELIGIBILITY"
- SET DIR("B")=$SELECT($PIECE(^DGBT(392,DGBTDT,0),"^",3):$PIECE(^DIC(8,$PIECE(^DGBT(392,DGBTDT,0),"^",3),0),"^"),VAEL(1):$PIECE(VAEL(1),"^",2),1:"")
- +3 SET DIR(0)="F"
- SET DIR("?")="^D ELIST^DGBTEE2"
- +4 DO ^DIR
- KILL DIR
- IF $DATA(DUOUT)
- WRITE !?3,"SORRY, '^' NOT ALLOWED!!"
- GOTO ELIG1
- +5 IF $DATA(DTOUT)
- SET DGBTTOUT=-1
- QUIT
- +6 ; ref file #392, claims
- if Y=""
- SET DGBTELIG=$SELECT($PIECE(^DGBT(392,DGBTDT,0),"^",3):$PIECE(^(0),"^",3),1:+VAEL(1))
- +7 IF X["@"
- WRITE !,"ELIGIBILITY REQUIRED."
- GOTO ELIG1
- +8 ; ref ^TMP file for eligibility
- IF Y?1A.E
- FOR I=0:0
- SET I=$ORDER(^TMP("DGBT",$JOB,I))
- if 'I
- QUIT
- IF $EXTRACT($PIECE(^(I),"^",2),1,$LENGTH(X))=X
- SET XX=Y
- SET Y=I
- GOTO ESET
- +9 ; ref ^TMP file for eligibility
- IF +Y?1N.N
- SET Y=+Y
- FOR I=0:0
- SET I=$ORDER(^TMP("DGBT",$JOB,I))
- if 'I
- QUIT
- IF +$PIECE(^(I),"^")=Y
- SET XX=Y
- SET Y=I
- GOTO ESET
- ECHOZ ;
- +1 WRITE !!,"Choose by NUMBER the primary eligibility or other entitled eligibilities",!
- +2 IF DGBTCT>1
- FOR I=0:0
- SET I=$ORDER(^TMP("DGBT",$JOB,I))
- if 'I
- QUIT
- WRITE !?5,I,?10,$PIECE(^TMP("DGBT",$JOB,I),"^",2)
- +3 KILL DIR,X
- SET DIR("A")="Choose 1-"_DGBTCT
- SET DIR(0)="NO^1:"_DGBTCT
- SET DIR("?")="Enter choice from those displayed"
- +4 DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- GOTO ELIG1
- SET XX=Y
- +5 IF '$DATA(^TMP("DGBT",$JOB,Y))
- WRITE " ?? ",!,"Select ELIGIBILITY: "
- GOTO ECHOZ
- ESET ;
- +1 if $DATA(Y)
- SET DGBTELIG=$SELECT($DATA(^TMP("DGBT",$JOB,Y)):+^TMP("DGBT",$JOB,Y),'$DATA(XX):Y,1:+VAEL(1))
- +2 if Y]""
- WRITE ?30,$EXTRACT($PIECE(^DIC(8,+DGBTELIG,0),"^"),$SELECT($DATA(XX):($LENGTH(XX)+1),1:1),99)
- ESET1 ;
- +1 SET DGBTSCP=$SELECT($PIECE(^DIC(8,DGBTELIG,0),"^",9)=1&(+VAEL(3)):$PIECE(VAEL(3),"^",2),$PIECE(^DIC(8,DGBTELIG,0),"^",9)=3&(+VAEL(3)):$PIECE(VAEL(3),"^",2),1:"")
- CERT ; stuff of certification date if appropriate
- +1 ; naked global ref file #392.2, certification file.
- +2 IF $PIECE(VAEL(3),"^")
- SET DGBTCD=""
- IF VAEL(3)&($PIECE(VAEL(3),"^",2)'>29)
- SET DGBTIDT=9999999.99999-DGBTDT
- FOR I=0:0
- SET I=$ORDER(^DGBT(392.2,"C",DFN,I))
- if 'I
- QUIT
- IF I'>DGBTIDT&($PIECE(^DGBT(392.2,I,0),"^",3))
- SET DGBTCD=$PIECE(^(0),"^")
- ACCT ; allowed to select only valid active accounts
- +1 ;I DGBTDTI>PATCHDT S DGBTOACT=$S('$D(^DGBT(392.3,+$P(DGBTVAR(0),"^",6),0)):0,1:+$P(^DGBT(392.3,$P(DGBTVAR(0),"^",6),0),"^",5))
- +2 SET DGBTOACT=$SELECT('$DATA(^DGBT(392.3,+$PIECE(DGBTVAR(0),"^",6),0)):0,1:+$PIECE(^DGBT(392.3,$PIECE(DGBTVAR(0),"^",6),0),"^",5))
- +3 KILL X
- SET (DIC("B"),X)=$SELECT(+$PIECE(DGBTVAR(0),"^",6):$PIECE(^DGBT(392.3,$PIECE(DGBTVAR(0),"^",6),0),"^"),1:$$DEFLT1())
- SET DIC("A")="Select ACCOUNT: "
- +4 SET DIC="^DGBT(392.3,"
- SET DIC(0)="AEQMZ"
- +5 SET DIC("S")="I $$ACCTHELP^DGBTEE1"
- +6 DO ^DIC
- KILL DIC
- IF $DATA(DTOUT)
- SET DGBTTOUT=-1
- KILL DTOUT
- QUIT
- +7 IF Y'>0
- WRITE !,"ACCOUNT IS REQUIRED!!"
- GOTO ACCT
- +8 SET DGBTACTN=$PIECE(Y,"^")
- SET DGBTACCT=$PIECE(Y(0),"^",5)
- +9 ; if account is ALL OTHER - stuff in mileage info
- +10 IF $DATA(DGBTVAR("M"))
- SET DGBTML=$PIECE(DGBTVAR("M"),"^",2)
- SET DGBTOWRT=$PIECE(DGBTVAR("M"),"^")
- SET DGBTMLT=$JUSTIFY((DGBTML*DGBTOWRT*DGBTMR),0,2)
- QUIT ;
- +1 KILL A,C,I,IA,J,X,XX,^TMP("DGBT",$JOB),DGBTIDT,DGBTCT
- +2 QUIT
- +3 ;
- DEFLT1() ;
- +1 NEW REC,Y
- +2 IF $PIECE(DGBTDTI,".",1)'=DT
- QUIT ""
- +3 SET REC="0"
- FOR
- SET REC=$ORDER(^DGBT(392.3,REC))
- if 'REC
- QUIT
- Begin DoDot:1
- +4 if $PIECE(^DGBT(392.3,REC,0),U,5)=4&($PIECE(^(0),U,3)'>DGBTDT&('$PIECE(^(0),U,4)!($PIECE(^(0),U,4)'<DGBTDT)))
- SET Y=$PIECE(^(0),U,1)
- End DoDot:1
- if $DATA(Y)
- QUIT
- +5 QUIT $GET(Y)
- ACCTHELP() ;
- +1 NEW DATUM
- +2 SET DATUM=$GET(^DGBT(392.3,Y,0))
- +3 IF $PIECE(DATUM,U,3)>DGBTDT
- QUIT 0
- +4 IF ($PIECE(DATUM,U,4)<DGBTDT)&(+$PIECE(DATUM,U,4)>0)
- QUIT 0
- +5 QUIT $EXTRACT(DATUM,5,16)'="SPECIAL MODE"