DGBTDLT1 ;UNK/BLD - REPRINT BENEFICIARY TRAVEL DENIAL LETTER ; 1/8/24 12:37pm
;;1.0;Beneficiary Travel;**20,28,33,41**;September 25, 2001;Build 7
;
Q
;************************************************************************************************************
; THIS WILL PRINT DENIAL LETTERS
;************************************************************************************************************
;
REPRINT ;
;
Q ;DGBT*1*41 Remove functionality
D QUIT
W !
K ^UTILITY($J,"W"),^TMP("DGBT",$J)
S QUIT=0
;
;DIVISN ; if MED CTR DIV file set up (first record) and record does not exist, write warning, kill variables, and exit
S X=$G(^DG(40.8,0)) I X="" W !,"WARNING...MEDICAL CENTER DIVISION FILE IS NOT SET UP",!,"USE THE ADT PARAMETER OPTION FILE TO SET UP DIVISION" Q
; check if multi-divisional center (GL node exists and 2nd piece=1). Do lookup, if it exists-set local variables
S DGBTMD=0 I $D(^DG(43,1,"GL")),$P(^("GL"),U,2) D Q:Y'>0 ;D PATIENT
. S DIC="^DG(40.8,",DIC(0)="AEQMNZ",DIC("A")="Select DIVISION: " W !!
. D ^DIC K DIC Q:Y'>0
. S DGBTDIVI=+Y,DGBTDIV=$P(Y,U,2)
. D INSTIT S DGBTMD=1
; if not a multi-divisional center, default to institution name
I 'DGBTMD S DGBTDIVI=$O(^DG(40.8,0)),DGBTDIV=$P(^DG(40.8,DGBTDIVI,0),U) D INSTIT
;
D PATIENT Q:$G(DFN)="" ;I '$D(^DGBT(392,"ADENIED",DFN)) W !!,"THERE ARE NO DENIAL LETTERS TO PRINT FOR: ",VADM(1) K DFN D QUIT Q ;D REPRINT,QUIT Q
D LIST2 I $G(CHZFLG)="" D QUIT Q
S DGBTDLTR=$$GET1^DIQ(392,DGBTDTI,45,"I")
I 'DGBTDLTR D QUIT Q
S DGBTCMTY=$$GET1^DIQ(392,DGBTDTI,56,"I")
D DEVICE^DGBTDLT("DENIAL LETTER","LTR^DGBTDLT1") I $D(DTOUT)!($D(DUOUT)) S QUIT=1 D QUIT Q
I $G(DGBTQ) D QUIT Q
D LTR
D QUIT
Q
;
LTR ;
;
N NAME,DGBTCDT,DGBTDR,DIWL,DIWR
K ^UTILITY($J,"W")
S DGBTDR=$$GET1^DIQ(392,DGBTDTI,45.4,"I")
I $$GET1^DIQ(392.8,DGBTDR,1,,"REASON")
D DIVISN(.DGBTINST) ;this will set up the DGBTINST array containing the current VA location address
;D DEVICE("DENIAL LETTER") I $D(DTOUT)!($D(DUOUT)) S QUIT=1 Q
D HEADER(.DGBTINST) ;this will print the current VA location information
S QUIT=1
S DIWL=5 ;left margin
S DIWR=75 ;right margin
S DGBTCDT(1)=$P(DGBTDTE,"@",1) ;invoice date
S NAME=$$GET1^DIQ(392,DGBTDTI,12),DGBTCDT(2)=$P(NAME,",",2)_" "_$P(NAME,",",1) ;user name *28 modified to use who entered into the file (#12) field
S DGBTCDT(3)=$$GET1^DIQ(200,$$GET1^DIQ(392,DGBTDTI,12,"I"),8) ;user title *28 modified to use who entered into the file (#12) field
I DGBTCMTY="M" D ;for mileage claims
.I $$GET1^DIQ(392.6,1,1,,"LETTERS1")
.S LINENBR=0
.F S LINENBR=$O(LETTERS1(LINENBR)) Q:'LINENBR D D ^DIWP
..S X=LETTERS1(LINENBR)
.S NBR=0
.F S NBR=$O(REASON(NBR)) Q:'NBR D D ^DIWP
..S X=REASON(NBR)
.I $$GET1^DIQ(392.6,2,1,,"LETTERS2")
.F S LINENBR=$O(LETTERS2(LINENBR)) Q:'LINENBR D D ^DIWP
..S X=LETTERS2(LINENBR) Q:X=""
.D ^DIWW
;
K LETTERS1,KETTERS2
I DGBTCMTY="S" D ;for Special Mode Claims
.I $$GET1^DIQ(392.6,3,3,,"LETTERS1")
.S LINENBR=0
.F S LINENBR=$O(LETTERS1(LINENBR)) Q:'LINENBR D D ^DIWP
..S X=LETTERS1(LINENBR)
.S NBR=0
.F S NBR=$O(REASON(NBR)) Q:'NBR D D ^DIWP
..S X=REASON(NBR)
.I $$GET1^DIQ(392.6,4,3,,"LETTERS2")
.F S LINENBR=$O(LETTERS2(LINENBR)) Q:'LINENBR D D ^DIWP
..S X=LETTERS2(LINENBR) Q:X=""
.D ^DIWW
D:'IOST'["C-" ^%ZISC
Q
;
PATIENT ; patient lookup, quit if patient doesn't exist
N VAEL
S DGBTTOUT="",DIC="^DPT(",DIC(0)="AEQMZ",DIC("A")="Select PATIENT: "
W !! D ^DIC K DIC I +Y'>0 K DFN Q
; get patient information#, call return patient return variables routine and set whether new claim or not
S DFN=+Y D 6^VADPT,PID^VADPT
S DGBTNEW=$S($D(^DGBT(392,"C",DFN)):0,1:1)
Q
;
LIST2 ; find all previous claims, get total count in DGBTC and put those claims in utility file
N X1,YY,DGBTCDT,DGBTC,CNT
S (CNTR,DGBTCH,DGBTCH1,DGBTCDT)=0
S DGBTC=""
I $D(^DGBT(392,"ADENIED",DFN))'>1 W !!?10,"There are no entries on file for this patient",! S Y1=-1 D QUIT Q
;
F I=1:1 S DGBTC=$O(^DGBT(392,"ADENIED",DFN,DGBTC),-1) Q:'DGBTC D
.S Y=DGBTC D DD^%DT
.S CNTR=$G(CNTR)+1
.S DGBTARY(CNTR,DGBTC)=Y ;K DGBTARY(DGBTC)
;
LIST3 ; list claims (in external format) from temporary global, 5 at a time. Loop thru list until selection made.
S (CNTR,DGBTCH)=""
S DGBTC=""
W !
F S CNTR=$O(DGBTARY(CNTR)) Q:'CNTR D Q:$G(CHZFLG)!$G(DTOUT)!$G(DUOUT)
.F S DGBTC=$O(DGBTARY(CNTR,DGBTC)) Q:DGBTC="" D Q:$G(CHZFLG)
..W !?5,CNTR,".",?10,DGBTARY(CNTR,DGBTC) I CNTR#5=0!($O(DGBTARY(CNTR))="") D CHOZ I $D(DUOUT)!$D(DTOUT)!(Y>0) Q
I '$D(DTOUT)&Y="" D LIST3 Q
S DGBTDTI=$O(DGBTARY(CNTR,"")),DGBTDTE=DGBTARY(CNTR,DGBTDTI)
K DIR
Q
;
CHOZ ; select from the displayed past claims dates for claim to be edited.
N DGBTCH1,CHOICE
S CHOICE=1
W !! S (Y1,Y)=0,DGBTCH1=I,DIR(0)="FO^1:5",DIR("A")="Select CLAIM"
S DIR("A",1)="Type '^' to exit date list, or <RETURN> to display more dates"
S DIR("?")="Entering a '^' will exit the Past CLAIM list, entering <RETURN> will continue to scroll through past dates.",DIR("?",1)="Select a Past CLAIM date by number."
D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) S Y1=-1 Q
I Y="",$O(DGBTARY(CNTR))'="" Q
I X<CHOICE!(X>DGBTCH1)!(X'=+X) W !?25,*7,"INVALID ENTRY!" D CHOZ Q ; value must be between 1 and last displayed number
S CHZFLG=Y,DGBTDTI=$O(DGBTARY(Y,""))
S CNTR=$G(Y)
Q
;
DIVISN(DGBTINST) ; if MED CTR DIV file set up (first record) and record does not exist, write warning, kill variables, and exit
S DGBTDIVI=$$GET1^DIQ(392,DGBTDTI,11,"I"),DGBTDIV=$$GET1^DIQ(40.8,DGBTDIVI,.01) ; RFE DGBT*1.0*20
I ($G(DGBTDIVI)'="")&($G(DGBTDIV)'="") D INSTIT(.DGBTINST) Q ; RFE DGBT*1.0*20
S DGBTDIVI=$O(^DG(40.8,0)),DGBTDIV=$P(^DG(40.8,DGBTDIVI,0),U) D INSTIT(.DGBTINST)
Q
;
INSTIT(DGBTINST) ; check for pointer to institution file and for address information on institution
N MAILCODE,INSTADD,INSTNODE
S DGBTDIVN=$P(^DG(40.8,DGBTDIVI,0),"^",7)
I 'DGBTDIVN W !!,"INSTITUTION HAS NOT BEEN DEFINED FOR ",$P(^(0),"^"),!,"USE THE ADT PARAMETER OPTION TO UPDATE",! Q
I $D(^DIC(4,DGBTDIVN,0)),$S($D(^(1))#10=0:1,$P(^(1),"^",3)']"":1,1:0) W !!,"INSTITUTION ADDRESS NOT ENTERED. PLEASE UPDATE USING THE INSTITUTION FILE ENTER/EDIT",! Q
;
S INSTNODE=^DIC(4,DGBTDIVN,0)
S INSTADD=^DIC(4,DGBTDIVN,1)
;
S DGBTINST("ORG NAME")="DEPARTMENT OF VETERANS AFFAIRS"
S DGBTINST("INST NAME")=$$GET1^DIQ(4,DGBTDIVN,.01)
S DGBTINST("INST ADDRESS 1")=$$GET1^DIQ(4,DGBTDIVN,1.01)
S DGBTINST("INST ADDRESS 2")=$$GET1^DIQ(4,DGBTDIVN,1.02)
S DGBTINST("INST CITY")=$$GET1^DIQ(4,DGBTDIVN,1.03)
S DGBTINST("INST STATE")=$$GET1^DIQ(4,DGBTDIVN,.02)
S DGBTINST("INST ZIP CODE")=$$GET1^DIQ(4,DGBTDIVN,1.04)
S DGBTINST("FAC NUMBER")=$$GET1^DIQ(40.8,DGBTDIVI,1)
S MAILCODE=$O(^DIC(49,"B","BENEFICIARY TRAVEL",""))
S DGBTINST("MAIL CODE")=$$GET1^DIQ(49,MAILCODE,1.5)
Q
;
;
I $G(DGBTINST("ORG NAME"))="" D Q
.W !!,"INSTITUTION INFORMATION IS UNAVAILABLE. PLEASE UPDATE USING THE INSTITUTION FILE ENTER/EDIT."
N ORG,ADD1,ADD2,CITY,STATE,ZIP,INSTNAME,LOC,LOC2,DGBTDTFILED
;
S ORG=DGBTINST("ORG NAME")
S INSTNAME=DGBTINST("INST NAME")
S ADD1=DGBTINST("INST ADDRESS 1")
S ADD2=DGBTINST("INST ADDRESS 2")
S CITY=DGBTINST("INST CITY")
S STATE=DGBTINST("INST STATE")
S ZIP=DGBTINST("INST ZIP CODE")
;
D DEM^VADPT
S PATSEX=$P(VADM(5),"^",1),PATSEX=$S(PATSEX="M":"Mr",1:"Ms")_". "
S PATADD1=VAPA(1),PATADD2=VAPA(2)
S PATCITY=VAPA(4)_", ",PATST=$P(VAPA(5),"^",2)_" ",PATZIP=VAPA(6)
S PATNAME=VADM(1),PATNAME=$P(PATNAME,",",2)_" "_$P(PATNAME,",",1)
;
S LOC2=5
S LOC=80-$L(ORG) W !,?LOC/2,ORG
S LOC=80-$L(INSTNAME) W !,?LOC/2,INSTNAME
S LOC=80-$L(ADD1) W !,?LOC/2,ADD1
I $G(ADD2)'="" S LOC=80-$L(ADD2) W !,?LOC/2,ADD2
S CITYSTZIP=CITY_", "_STATE_" "_ZIP
S LOC=80-$L(CITYSTZIP) W !,?LOC/2,CITYSTZIP,!
;S LOC=80-$L(DGBTDTE) W !?LOC,$P(DGBTDTE,"@",1)
S DGBTDTFILED=$$GET1^DIQ(392,DGBTDTI,13,"E")
S DGBTDTFILED=$S(DGBTDTFILED'="":DGBTDTFILED,1:DT)
S DGBTDTFILED=$$FMTE^XLFDT(DGBTDTFILED)
S LOC=80-$L(DGBTDTFILED) W !,?LOC,DGBTDTFILED
W !,?LOC,DGBTINST("FAC NUMBER")
W ?LOC,"/"_$S(DGBTINST("MAIL CODE")'="":DGBTINST("MAIL CODE"),1:"BT"),!
W ?LOC,$E(VADM(1),1)_$E($P(VADM(2),"^",1),6,99)
W !,?LOC2,$G(PATSEX),$G(PATNAME)
W !,?LOC2,$G(PATADD1)
W:$G(PATADD2)'="" !,?LOC2,PATADD2
W !,?LOC2,PATCITY,PATST,PATZIP,!!
;
Q
;
DEVICE(DGBTRPT) N %ZIS,ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE,POP
S %ZIS="QM"
D ^%ZIS
I POP S DGBTQ=1
;
;Check for exit
I $G(DGBTQ) Q
;
S DGBTSCR=$S($E($G(IOST),1,2)="C-":1,1:0)
I $D(IO("Q")) D S DGBTQ=1
. S ZTRTN="RUN^DGBTBORP0(DGBTEXCEL,DGBTRPT,DGBTSMDET)"
. S ZTIO=ION
. S ZTSAVE("*")=""
. S ZTDESC="DGBT REPORT: "_DGBTRPT
. D ^%ZTLOAD
. W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
. D HOME^%ZIS
U IO
Q
;
QUIT ;will kill all local variables used by this routine
;
K DFN,DGBTNEW,VACNTRY,VADAT,VADM,VAERR,VAPA,Y,Z,J,DGBTINST,DGBTNEW,DGBTTOUT,DGBTDLTR,DGBTDIVN,DGBTDIVI,DGBTDIV,DGBTCMTY,DGTCH1,DGBTCH,DGBTC,DGBTMD
K ^TMP("DGBT",$J),DFN,CITYSTZIP,CHZFLG,C,QUIT
K X1,YY,DGBTCHK,^TMP("DGBT",$J),^TMP("DGBTARA",$J)
K DRIEN,REASON,LETTERS1,LETTERS2,LINENBR,NBR,DGBTDNLTR,DGBTFDA,DGBTSCR,DGBTDR,DGBTISSUED,VADM,PATSEX,PATADD1,PATADD2,PATCITY,PATST,PATZIP,PATNAME
K CNTR,DFN,DGBTARY,DGBTCH,DGBTCH1,DGBTDTE,DGBTDTI,DGBTNEW,DGBTTOUT,DGBTARY,VA,VACNTRY,VAPA,DUOUT,DTOUT,DGBTQ,DGBTQ1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGBTDLT1 9783 printed Dec 13, 2024@01:40:35 Page 2
DGBTDLT1 ;UNK/BLD - REPRINT BENEFICIARY TRAVEL DENIAL LETTER ; 1/8/24 12:37pm
+1 ;;1.0;Beneficiary Travel;**20,28,33,41**;September 25, 2001;Build 7
+2 ;
+3 QUIT
+4 ;************************************************************************************************************
+5 ; THIS WILL PRINT DENIAL LETTERS
+6 ;************************************************************************************************************
+7 ;
REPRINT ;
+1 ;
+2 ;DGBT*1*41 Remove functionality
QUIT
+3 DO QUIT
+4 WRITE !
+5 KILL ^UTILITY($JOB,"W"),^TMP("DGBT",$JOB)
+6 SET QUIT=0
+7 ;
+8 ;DIVISN ; if MED CTR DIV file set up (first record) and record does not exist, write warning, kill variables, and exit
+9 SET X=$GET(^DG(40.8,0))
IF X=""
WRITE !,"WARNING...MEDICAL CENTER DIVISION FILE IS NOT SET UP",!,"USE THE ADT PARAMETER OPTION FILE TO SET UP DIVISION"
QUIT
+10 ; check if multi-divisional center (GL node exists and 2nd piece=1). Do lookup, if it exists-set local variables
+11 ;D PATIENT
SET DGBTMD=0
IF $DATA(^DG(43,1,"GL"))
IF $PIECE(^("GL"),U,2)
Begin DoDot:1
+12 SET DIC="^DG(40.8,"
SET DIC(0)="AEQMNZ"
SET DIC("A")="Select DIVISION: "
WRITE !!
+13 DO ^DIC
KILL DIC
if Y'>0
QUIT
+14 SET DGBTDIVI=+Y
SET DGBTDIV=$PIECE(Y,U,2)
+15 DO INSTIT
SET DGBTMD=1
End DoDot:1
if Y'>0
QUIT
+16 ; if not a multi-divisional center, default to institution name
+17 IF 'DGBTMD
SET DGBTDIVI=$ORDER(^DG(40.8,0))
SET DGBTDIV=$PIECE(^DG(40.8,DGBTDIVI,0),U)
DO INSTIT
+18 ;
+19 ;I '$D(^DGBT(392,"ADENIED",DFN)) W !!,"THERE ARE NO DENIAL LETTERS TO PRINT FOR: ",VADM(1) K DFN D QUIT Q ;D REPRINT,QUIT Q
DO PATIENT
if $GET(DFN)=""
QUIT
+20 DO LIST2
IF $GET(CHZFLG)=""
DO QUIT
QUIT
+21 SET DGBTDLTR=$$GET1^DIQ(392,DGBTDTI,45,"I")
+22 IF 'DGBTDLTR
DO QUIT
QUIT
+23 SET DGBTCMTY=$$GET1^DIQ(392,DGBTDTI,56,"I")
+24 DO DEVICE^DGBTDLT("DENIAL LETTER","LTR^DGBTDLT1")
IF $DATA(DTOUT)!($DATA(DUOUT))
SET QUIT=1
DO QUIT
QUIT
+25 IF $GET(DGBTQ)
DO QUIT
QUIT
+26 DO LTR
+27 DO QUIT
+28 QUIT
+29 ;
LTR ;
+1 ;
+2 NEW NAME,DGBTCDT,DGBTDR,DIWL,DIWR
+3 KILL ^UTILITY($JOB,"W")
+4 SET DGBTDR=$$GET1^DIQ(392,DGBTDTI,45.4,"I")
+5 IF $$GET1^DIQ(392.8,DGBTDR,1,,"REASON")
+6 ;this will set up the DGBTINST array containing the current VA location address
DO DIVISN(.DGBTINST)
+7 ;D DEVICE("DENIAL LETTER") I $D(DTOUT)!($D(DUOUT)) S QUIT=1 Q
+8 ;this will print the current VA location information
DO HEADER(.DGBTINST)
+9 SET QUIT=1
+10 ;left margin
SET DIWL=5
+11 ;right margin
SET DIWR=75
+12 ;invoice date
SET DGBTCDT(1)=$PIECE(DGBTDTE,"@",1)
+13 ;user name *28 modified to use who entered into the file (#12) field
SET NAME=$$GET1^DIQ(392,DGBTDTI,12)
SET DGBTCDT(2)=$PIECE(NAME,",",2)_" "_$PIECE(NAME,",",1)
+14 ;user title *28 modified to use who entered into the file (#12) field
SET DGBTCDT(3)=$$GET1^DIQ(200,$$GET1^DIQ(392,DGBTDTI,12,"I"),8)
+15 ;for mileage claims
IF DGBTCMTY="M"
Begin DoDot:1
+16 IF $$GET1^DIQ(392.6,1,1,,"LETTERS1")
+17 SET LINENBR=0
+18 FOR
SET LINENBR=$ORDER(LETTERS1(LINENBR))
if 'LINENBR
QUIT
Begin DoDot:2
+19 SET X=LETTERS1(LINENBR)
End DoDot:2
DO ^DIWP
+20 SET NBR=0
+21 FOR
SET NBR=$ORDER(REASON(NBR))
if 'NBR
QUIT
Begin DoDot:2
+22 SET X=REASON(NBR)
End DoDot:2
DO ^DIWP
+23 IF $$GET1^DIQ(392.6,2,1,,"LETTERS2")
+24 FOR
SET LINENBR=$ORDER(LETTERS2(LINENBR))
if 'LINENBR
QUIT
Begin DoDot:2
+25 SET X=LETTERS2(LINENBR)
if X=""
QUIT
End DoDot:2
DO ^DIWP
+26 DO ^DIWW
End DoDot:1
+27 ;
+28 KILL LETTERS1,KETTERS2
+29 ;for Special Mode Claims
IF DGBTCMTY="S"
Begin DoDot:1
+30 IF $$GET1^DIQ(392.6,3,3,,"LETTERS1")
+31 SET LINENBR=0
+32 FOR
SET LINENBR=$ORDER(LETTERS1(LINENBR))
if 'LINENBR
QUIT
Begin DoDot:2
+33 SET X=LETTERS1(LINENBR)
End DoDot:2
DO ^DIWP
+34 SET NBR=0
+35 FOR
SET NBR=$ORDER(REASON(NBR))
if 'NBR
QUIT
Begin DoDot:2
+36 SET X=REASON(NBR)
End DoDot:2
DO ^DIWP
+37 IF $$GET1^DIQ(392.6,4,3,,"LETTERS2")
+38 FOR
SET LINENBR=$ORDER(LETTERS2(LINENBR))
if 'LINENBR
QUIT
Begin DoDot:2
+39 SET X=LETTERS2(LINENBR)
if X=""
QUIT
End DoDot:2
DO ^DIWP
+40 DO ^DIWW
End DoDot:1
+41 if 'IOST'["C-"
DO ^%ZISC
+42 QUIT
+43 ;
PATIENT ; patient lookup, quit if patient doesn't exist
+1 NEW VAEL
+2 SET DGBTTOUT=""
SET DIC="^DPT("
SET DIC(0)="AEQMZ"
SET DIC("A")="Select PATIENT: "
+3 WRITE !!
DO ^DIC
KILL DIC
IF +Y'>0
KILL DFN
QUIT
+4 ; get patient information#, call return patient return variables routine and set whether new claim or not
+5 SET DFN=+Y
DO 6^VADPT
DO PID^VADPT
+6 SET DGBTNEW=$SELECT($DATA(^DGBT(392,"C",DFN)):0,1:1)
+7 QUIT
+8 ;
LIST2 ; find all previous claims, get total count in DGBTC and put those claims in utility file
+1 NEW X1,YY,DGBTCDT,DGBTC,CNT
+2 SET (CNTR,DGBTCH,DGBTCH1,DGBTCDT)=0
+3 SET DGBTC=""
+4 IF $DATA(^DGBT(392,"ADENIED",DFN))'>1
WRITE !!?10,"There are no entries on file for this patient",!
SET Y1=-1
DO QUIT
QUIT
+5 ;
+6 FOR I=1:1
SET DGBTC=$ORDER(^DGBT(392,"ADENIED",DFN,DGBTC),-1)
if 'DGBTC
QUIT
Begin DoDot:1
+7 SET Y=DGBTC
DO DD^%DT
+8 SET CNTR=$GET(CNTR)+1
+9 ;K DGBTARY(DGBTC)
SET DGBTARY(CNTR,DGBTC)=Y
End DoDot:1
+10 ;
LIST3 ; list claims (in external format) from temporary global, 5 at a time. Loop thru list until selection made.
+1 SET (CNTR,DGBTCH)=""
+2 SET DGBTC=""
+3 WRITE !
+4 FOR
SET CNTR=$ORDER(DGBTARY(CNTR))
if 'CNTR
QUIT
Begin DoDot:1
+5 FOR
SET DGBTC=$ORDER(DGBTARY(CNTR,DGBTC))
if DGBTC=""
QUIT
Begin DoDot:2
+6 WRITE !?5,CNTR,".",?10,DGBTARY(CNTR,DGBTC)
IF CNTR#5=0!($ORDER(DGBTARY(CNTR))="")
DO CHOZ
IF $DATA(DUOUT)!$DATA(DTOUT)!(Y>0)
QUIT
End DoDot:2
if $GET(CHZFLG)
QUIT
End DoDot:1
if $GET(CHZFLG)!$GET(DTOUT)!$GET(DUOUT)
QUIT
+7 IF '$DATA(DTOUT)&Y=""
DO LIST3
QUIT
+8 SET DGBTDTI=$ORDER(DGBTARY(CNTR,""))
SET DGBTDTE=DGBTARY(CNTR,DGBTDTI)
+9 KILL DIR
+10 QUIT
+11 ;
CHOZ ; select from the displayed past claims dates for claim to be edited.
+1 NEW DGBTCH1,CHOICE
+2 SET CHOICE=1
+3 WRITE !!
SET (Y1,Y)=0
SET DGBTCH1=I
SET DIR(0)="FO^1:5"
SET DIR("A")="Select CLAIM"
+4 SET DIR("A",1)="Type '^' to exit date list, or <RETURN> to display more dates"
+5 SET DIR("?")="Entering a '^' will exit the Past CLAIM list, entering <RETURN> will continue to scroll through past dates."
SET DIR("?",1)="Select a Past CLAIM date by number."
+6 DO ^DIR
KILL DIR
IF $DATA(DTOUT)!($DATA(DUOUT))
SET Y1=-1
QUIT
+7 IF Y=""
IF $ORDER(DGBTARY(CNTR))'=""
QUIT
+8 ; value must be between 1 and last displayed number
IF X<CHOICE!(X>DGBTCH1)!(X'=+X)
WRITE !?25,*7,"INVALID ENTRY!"
DO CHOZ
QUIT
+9 SET CHZFLG=Y
SET DGBTDTI=$ORDER(DGBTARY(Y,""))
+10 SET CNTR=$GET(Y)
+11 QUIT
+12 ;
DIVISN(DGBTINST) ; if MED CTR DIV file set up (first record) and record does not exist, write warning, kill variables, and exit
+1 ; RFE DGBT*1.0*20
SET DGBTDIVI=$$GET1^DIQ(392,DGBTDTI,11,"I")
SET DGBTDIV=$$GET1^DIQ(40.8,DGBTDIVI,.01)
+2 ; RFE DGBT*1.0*20
IF ($GET(DGBTDIVI)'="")&($GET(DGBTDIV)'="")
DO INSTIT(.DGBTINST)
QUIT
+3 SET DGBTDIVI=$ORDER(^DG(40.8,0))
SET DGBTDIV=$PIECE(^DG(40.8,DGBTDIVI,0),U)
DO INSTIT(.DGBTINST)
+4 QUIT
+5 ;
INSTIT(DGBTINST) ; check for pointer to institution file and for address information on institution
+1 NEW MAILCODE,INSTADD,INSTNODE
+2 SET DGBTDIVN=$PIECE(^DG(40.8,DGBTDIVI,0),"^",7)
+3 IF 'DGBTDIVN
WRITE !!,"INSTITUTION HAS NOT BEEN DEFINED FOR ",$PIECE(^(0),"^"),!,"USE THE ADT PARAMETER OPTION TO UPDATE",!
QUIT
+4 IF $DATA(^DIC(4,DGBTDIVN,0))
IF $SELECT($DATA(^(1))#10=0:1,$PIECE(^(1),"^",3)']"":1,1:0)
WRITE !!,"INSTITUTION ADDRESS NOT ENTERED. PLEASE UPDATE USING THE INSTITUTION FILE ENTER/EDIT",!
QUIT
+5 ;
+6 SET INSTNODE=^DIC(4,DGBTDIVN,0)
+7 SET INSTADD=^DIC(4,DGBTDIVN,1)
+8 ;
+9 SET DGBTINST("ORG NAME")="DEPARTMENT OF VETERANS AFFAIRS"
+10 SET DGBTINST("INST NAME")=$$GET1^DIQ(4,DGBTDIVN,.01)
+11 SET DGBTINST("INST ADDRESS 1")=$$GET1^DIQ(4,DGBTDIVN,1.01)
+12 SET DGBTINST("INST ADDRESS 2")=$$GET1^DIQ(4,DGBTDIVN,1.02)
+13 SET DGBTINST("INST CITY")=$$GET1^DIQ(4,DGBTDIVN,1.03)
+14 SET DGBTINST("INST STATE")=$$GET1^DIQ(4,DGBTDIVN,.02)
+15 SET DGBTINST("INST ZIP CODE")=$$GET1^DIQ(4,DGBTDIVN,1.04)
+16 SET DGBTINST("FAC NUMBER")=$$GET1^DIQ(40.8,DGBTDIVI,1)
+17 SET MAILCODE=$ORDER(^DIC(49,"B","BENEFICIARY TRAVEL",""))
+18 SET DGBTINST("MAIL CODE")=$$GET1^DIQ(49,MAILCODE,1.5)
+19 QUIT
+20 ;
+1 ;
+2 IF $GET(DGBTINST("ORG NAME"))=""
Begin DoDot:1
+3 WRITE !!,"INSTITUTION INFORMATION IS UNAVAILABLE. PLEASE UPDATE USING THE INSTITUTION FILE ENTER/EDIT."
End DoDot:1
QUIT
+4 NEW ORG,ADD1,ADD2,CITY,STATE,ZIP,INSTNAME,LOC,LOC2,DGBTDTFILED
+5 ;
+6 SET ORG=DGBTINST("ORG NAME")
+7 SET INSTNAME=DGBTINST("INST NAME")
+8 SET ADD1=DGBTINST("INST ADDRESS 1")
+9 SET ADD2=DGBTINST("INST ADDRESS 2")
+10 SET CITY=DGBTINST("INST CITY")
+11 SET STATE=DGBTINST("INST STATE")
+12 SET ZIP=DGBTINST("INST ZIP CODE")
+13 ;
+14 DO DEM^VADPT
+15 SET PATSEX=$PIECE(VADM(5),"^",1)
SET PATSEX=$SELECT(PATSEX="M":"Mr",1:"Ms")_". "
+16 SET PATADD1=VAPA(1)
SET PATADD2=VAPA(2)
+17 SET PATCITY=VAPA(4)_", "
SET PATST=$PIECE(VAPA(5),"^",2)_" "
SET PATZIP=VAPA(6)
+18 SET PATNAME=VADM(1)
SET PATNAME=$PIECE(PATNAME,",",2)_" "_$PIECE(PATNAME,",",1)
+19 ;
+20 SET LOC2=5
+21 SET LOC=80-$LENGTH(ORG)
WRITE !,?LOC/2,ORG
+22 SET LOC=80-$LENGTH(INSTNAME)
WRITE !,?LOC/2,INSTNAME
+23 SET LOC=80-$LENGTH(ADD1)
WRITE !,?LOC/2,ADD1
+24 IF $GET(ADD2)'=""
SET LOC=80-$LENGTH(ADD2)
WRITE !,?LOC/2,ADD2
+25 SET CITYSTZIP=CITY_", "_STATE_" "_ZIP
+26 SET LOC=80-$LENGTH(CITYSTZIP)
WRITE !,?LOC/2,CITYSTZIP,!
+27 ;S LOC=80-$L(DGBTDTE) W !?LOC,$P(DGBTDTE,"@",1)
+28 SET DGBTDTFILED=$$GET1^DIQ(392,DGBTDTI,13,"E")
+29 SET DGBTDTFILED=$SELECT(DGBTDTFILED'="":DGBTDTFILED,1:DT)
+30 SET DGBTDTFILED=$$FMTE^XLFDT(DGBTDTFILED)
+31 SET LOC=80-$LENGTH(DGBTDTFILED)
WRITE !,?LOC,DGBTDTFILED
+32 WRITE !,?LOC,DGBTINST("FAC NUMBER")
+33 WRITE ?LOC,"/"_$SELECT(DGBTINST("MAIL CODE")'="":DGBTINST("MAIL CODE"),1:"BT"),!
+34 WRITE ?LOC,$EXTRACT(VADM(1),1)_$EXTRACT($PIECE(VADM(2),"^",1),6,99)
+35 WRITE !,?LOC2,$GET(PATSEX),$GET(PATNAME)
+36 WRITE !,?LOC2,$GET(PATADD1)
+37 if $GET(PATADD2)'=""
WRITE !,?LOC2,PATADD2
+38 WRITE !,?LOC2,PATCITY,PATST,PATZIP,!!
+39 ;
+40 QUIT
+41 ;
DEVICE(DGBTRPT) NEW %ZIS,ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE,POP
+1 SET %ZIS="QM"
+2 DO ^%ZIS
+3 IF POP
SET DGBTQ=1
+4 ;
+5 ;Check for exit
+6 IF $GET(DGBTQ)
QUIT
+7 ;
+8 SET DGBTSCR=$SELECT($EXTRACT($GET(IOST),1,2)="C-":1,1:0)
+9 IF $DATA(IO("Q"))
Begin DoDot:1
+10 SET ZTRTN="RUN^DGBTBORP0(DGBTEXCEL,DGBTRPT,DGBTSMDET)"
+11 SET ZTIO=ION
+12 SET ZTSAVE("*")=""
+13 SET ZTDESC="DGBT REPORT: "_DGBTRPT
+14 DO ^%ZTLOAD
+15 WRITE !,$SELECT($DATA(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
+16 DO HOME^%ZIS
End DoDot:1
SET DGBTQ=1
+17 USE IO
+18 QUIT
+19 ;
QUIT ;will kill all local variables used by this routine
+1 ;
+2 KILL DFN,DGBTNEW,VACNTRY,VADAT,VADM,VAERR,VAPA,Y,Z,J,DGBTINST,DGBTNEW,DGBTTOUT,DGBTDLTR,DGBTDIVN,DGBTDIVI,DGBTDIV,DGBTCMTY,DGTCH1,DGBTCH,DGBTC,DGBTMD
+3 KILL ^TMP("DGBT",$JOB),DFN,CITYSTZIP,CHZFLG,C,QUIT
+4 KILL X1,YY,DGBTCHK,^TMP("DGBT",$JOB),^TMP("DGBTARA",$JOB)
+5 KILL DRIEN,REASON,LETTERS1,LETTERS2,LINENBR,NBR,DGBTDNLTR,DGBTFDA,DGBTSCR,DGBTDR,DGBTISSUED,VADM,PATSEX,PATADD1,PATADD2,PATCITY,PATST,PATZIP,PATNAME
+6 KILL CNTR,DFN,DGBTARY,DGBTCH,DGBTCH1,DGBTDTE,DGBTDTI,DGBTNEW,DGBTTOUT,DGBTARY,VA,VACNTRY,VAPA,DUOUT,DTOUT,DGBTQ,DGBTQ1
+7 QUIT
