- 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 Feb 18, 2025@23:06:58 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