DGBTDW ;ALB/RFE - DEDUCTIBLE WAIVER SETUP/MAIN ENTRY CALLUP; 01/19/12
;;1.0;Beneficiary Travel;**20**;November 11, 2011;Build 185
Q
EN ; Entry point
N %,%H,%I,%Y,ANS,C,DELRAY,DFN,DGBTDTI,DGBTDW,DGBTFDA,DGBTFDA1,DGBTIENS,DGBTNEW,DGBTOK,DGBTTOUT,DGENR,DGRETV,DISPLAY,DTSUB,ERRMSG,PENSION,THISYR,I,X,Y
N VAEL,VAERR,DELETRAY,DGBTERR
D CLEAN^DILF
F D ENTRQ Q:'$D(DFN)
D QUIT
Q
ENTRQ ; Keep prompting until we don't get a DFN
D PATIENT Q:'$D(DFN)
K VAEL D ELIG^VADPT ;
I '+VAEL(1) W !!,"Eligibility is missing from registration and is required to continue.",*7 D QUIT Q
S DGBTNEW='$D(^DGBT(392.7,"C",DFN))
D DATE
I ($D(DIRUT))!($D(DUOUT))!($D(DIROUT))!($D(DTOUT))!(Y=-1)!('$D(DGBTDTI)) D QUIT Q
W !
S DGBTNEW='$D(^DGBT(392.7,"C",DFN,DGBTDTI))
S (DGBTOK,DISPLAY)=0
S DGBTOK=1
I 'DGBTNEW D OLDREQ
I DISPLAY D DISPLAY,QUIT Q
I 'DGBTOK D QUIT Q
I 'DGBTNEW W !,$$GET1^DIQ(2,DFN,.01)," ",DGBTDW("REQDT")
D AUTH
I 'DGBTOK D QUIT Q
D GRANT
I 'DGBTOK D QUIT Q
D APPDT
I 'DGBTOK D QUIT Q
D RMRK
I 'DGBTOK D QUIT Q
W !,"NAME: ",$$GET1^DIQ(2,DFN,.01)," DEDUCTIBLE WAIVER REQUEST DATE: ",DGBTDW("REQDT")
W !,$S(DGBTDW("AUTH")="YES":"GRANT",1:"DENI"),"ED BY: ",$$GET1^DIQ(200,DGBTDW("GRANT"),.01)," ON DATE: ",DGBTDW("APPDT")
;
I '$$YESNO^DGBTUTL("Complete waiver request") W !,"Not completed" D QUIT Q ;changed by bld
;
D UPDATE
D QUIT
Q
PATIENT ;
K DIC,DFN
S DGBTTOUT="",DIC="^DPT(",DIC(0)="AEQMZ",DIC("A")="Select PATIENT: "
W !! D ^DIC K DIC Q:Y'>0
S (DFN,DGBTDW("NAME"))=+Y
S PENSION=$$PENSION
Q
PENSION() ;
N HIT,VAEL,VAERR
D ELIG^VADPT
I $P(VAEL(1),"^",2)["PENSION" Q 1
I $P(VAEL(1),"^",2)="AID & ATTENDANCE" Q 1
I $P(VAEL(1),"^",2)="HOUSEBOUND" Q 1
S (HIT,I)=""
F S I=$O(VAEL(1,I)) Q:I="" D Q:HIT
.I VAEL(1,I)["PENSION" S HIT=1 Q
.I $P(VAEL(1,I),"^",2)="AID & ATTENDANCE" S HIT=1 Q
.I $P(VAEL(1,I),"^",2)="HOUSEBOUND" S HIT=1
Q HIT
UPDATE ;
K ERRMSG
I DGBTNEW D
.S DGBTFDA(392.7,"+1,",.01)=DGBTDW("REQDT")
.S DGBTFDA(392.7,"+1,",3)=DGBTDW("AUTH")
.S DGBTFDA(392.7,"+1,",5)=DGBTDW("APPDT")
.I $G(DGBTDW("REMARK"))'="" S DGBTFDA(392.7,"+1,",7)=DGBTDW("REMARK")
.S DGBTFDA(392.7,"+1,",9)=$$FMTE^XLFDT(DT)
.D UPDATE^DIE("E","DGBTFDA",,"ERRMSG")
.I $D(ERRMSG) Q
.;
.S DGBTFDA1(392.7,DGBTDTI_",",2)=DGBTDW("NAME")
.S DGBTFDA1(392.7,DGBTDTI_",",4)=DGBTDW("GRANT")
.S DGBTFDA1(392.7,DGBTDTI_",",6)=DUZ
.S DGBTFDA1(392.7,DGBTDTI_",",8)=$$EXP
.D FILE^DIE("S","DGBTFDA1","ERRMSG")
;
I '$G(DGBTNEW) D
.S DGBTFDA(392.7,DGBTDTI_",",3)=DGBTDW("AUTH")
.S DGBTFDA(392.7,DGBTDTI_",",5)=DGBTDW("APPDT")
.I $G(DGBTDW("REMARK"))'="" S DGBTFDA(392.7,DGBTDTI_",",7)=DGBTDW("REMARK")
.S DGBTFDA(392.7,DGBTDTI_",",9)=$$FMTE^XLFDT(DT)
.D FILE^DIE("E","DGBTFDA","ERRMSG")
.I $D(ERRMSG) Q
.S DGBTFDA(392.7,DGBTDTI_",",4)=DGBTDW("GRANT")
.S DGBTFDA(392.7,DGBTDTI_",",6)=DUZ
.S DGBTFDA(392.7,DGBTDTI_",",8)=$$EXP
.D FILE^DIE(,"DGBTFDA","ERRMSG")
I '$D(ERRMSG) D FILDLT Q
F I=1:1 Q:'$D(ERRMSG("DIERR","1","TEXT",I)) W !,ERRMSG("DIERR",1,"TEXT",I)
Q
FILDLT ;
Q:'$D(DELETRAY)
S I=$O(DELETRAY("")) Q:I=""
K ERR
S DGBTFDA(392.7,I_",",97)=DELETRAY(I,"DATE")
S DGBTFDA(392.7,I_",",98)=DELETRAY(I,"DUZ")
S DGBTFDA(392.7,I_",",99)=DELETRAY(I,"REMARK")
D FILE^DIE(,"DGBTFDA","ERR")
Q
DATE ;
Q:$$PENSDT
K DGBTDTI,DELETRAY
N PASTDT,PASTYR,DEL
D DEL
I 'DGBTNEW N DGBTC D OLD S:'DGBTC DGBTNEW=1
F D DATE1 Q:DONE
K DONE
Q
DATE1 ;
S DONE=1
K DIR
I 'DGBTNEW S DIR("A",2)="Enter 'P' for past requests"
S (DIR("A",1),DIR("A",3))="",DIR("A")="DEDUCTIBLE WAIVER REQUEST DATE AND TIME",DIR("?")="^D DHELP^DGBTDW"
S DIR(0)="F",DIR("B")="NOW" D ^DIR K DIR
I ($D(DIRUT))!($D(DUOUT)) Q
S %DT="EXR",DTSUB=$S($$UP^XLFSTR(Y)="P":"PASTRQ",1:"OTHR") D @DTSUB K DTSUB,%DT
Q
; Date-requested subroutines
OTHR ; date/time entry for manually entered date
S %DT(0)="-NOW" D ^%DT I Y<0 S DONE=0 Q
I Y<$$FMADD^XLFDT(DT,-30) W !,"Date cannot precede ",$$FMTE^XLFDT($$FMADD^XLFDT(DT,-30)) S DONE=0 Q
I $D(DEL($E(Y,1,3))),('$D(PASTYR($E(Y,1,3)))) D I 'ANS S Y=-1 Q
.S THISYR=DEL($E(Y,1,3))
.W !,"Request already on file and has been deleted on ",$$UP^XLFSTR($$FMTE^XLFDT(THISYR)),!
.N RQDT S RQDT=Y
.S ANS=$$YESNO^DGBTUTL("Do you wish to enter a new manual waiver request")
.S Y=RQDT
.I ($D(DIRUT))!($D(DIROUT))!($D(DTOUT))!($D(DUOUT)) S ANS=0
I $D(PASTYR($E(Y,1,3))),'$D(^DGBT(392.7,"C",DFN,Y)) N RQDT D DELETE S Y=RQDT I 'ANS Q
I ($D(DIRUT))!($D(DIROUT))!($D(DTOUT))!($D(DUOUT)) Q
I $D(^DGBT(392.7,"C",DFN,Y)) S (DGBTDTI,DGBTIENS)=Y,DGBTDW("REQDT")=$$FMTE^XLFDT(DGBTDTI) Q
S DGBTDTI=$$LOCKNEW(Y,0) I DGBTDTI=-1 W !,"Please enter another date/time" K DGBTDTI Q
S DGBTDW("REQDT")=$$FMTE^XLFDT(DGBTDTI)
Q
LOCKNEW(DGBTDTI,DONE) ;
F D Q:DONE
.L +^DGBT(392.7,DGBTDTI):1
.I ($T),('$D(^DGBT(392.7,DGBTDTI))) S DONE=1 Q
.L S DGBTDTI=DGBTDTI+.000001
.I ($L(DGBTDTI)=13),$E(DGBTDTI,13)=6 S DONE=1,DGBTDTI=-1 Q
.I $E(DGBTDTI,13,14)>59 S DONE=1,DGBTDTI=-1 Q
Q DGBTDTI
PASTRQ ;
I DGBTNEW W !,"No past dates on file, please enter a valid date/time" S DONE=0 Q
N DGBTCH
S DGBTCH=1
F D LIST Q:DONE1
K DONE1
I ('$D(DTOUT)),(Y'>0) S DONE=0
Q
DELETE ;
S RQDT=Y
W !!,"Request already on file for this year: "
S THISYR=PASTYR($E(Y,1,3))
W $$UP^XLFSTR($$FMTE^XLFDT(THISYR)),!
D
.N X,Y
.S ANS=$$YESNO^DGBTUTL("Do you wish to delete the request for "_$$UP^XLFSTR($$FMTE^XLFDT(THISYR)))
I ($D(DIRUT))!($D(DIROUT))!($D(DTOUT))!($D(DUOUT)) Q
I 'ANS S Y=THISYR Q
D
.N X,Y
.S ANS=$$YESNO^DGBTUTL("Are you sure you wish to delete this request?")
I ($D(DIRUT))!($D(DIROUT))!($D(DTOUT))!($D(DUOUT)) Q
I 'ANS S Y=THISYR Q
S DELETRAY(THISYR,"DATE")=DT
S DELETRAY(THISYR,"DUZ")=DUZ
F D Q:DONE
.S DONE=1
.N X,Y
.K DIR S DIR("A")="Enter reason for deletion",DIR(0)="FO^1:100" D ^DIR K DIR
.I ($D(DUOUT))!($D(DIROUT))!($D(DTOUT)) Q
.S ANS=$TR(Y,U," ")
.I $L($TR(ANS," ",""))=0 S DONE=0
I ($D(DUOUT))!($D(DIROUT))!($D(DTOUT)) K DELETRAY Q
S DELETRAY(THISYR,"REMARK")=ANS
S ANS=$$YESNO^DGBTUTL("Do you wish to enter a deductible waiver request for "_$$UP^XLFSTR($$FMTE^XLFDT(Y)))
I ($D(DIRUT))!($D(DIROUT))!($D(DTOUT))!($D(DUOUT)) Q
I ANS Q
D FILDLT K DELETRAY
Q
OLD ; Previously entered waiver request dates
S DGBTC=0,I=""
F S I=$O(^DGBT(392.7,"C",DFN,I),-1) Q:'I D
.Q:$$GET1^DIQ(392.7,I,97,"I") ;deleted
.S DGBTC=DGBTC+1
.S PASTYR($E(I,1,3))=I
.S PASTDT(DGBTC)=$$FMTE^XLFDT(I)_"^"_I
Q
DEL ; Deleted waivers on file
S I=""
F S I=$O(^DGBT(392.7,"C",DFN,I),-1) Q:'I D
.Q:'$$GET1^DIQ(392.7,I,97,"I") ;deleted
.S DEL($E(I,1,3))=I
Q
LIST ;
S DONE1=1
F I=DGBTCH:1:DGBTC W !?5,I,". ",$P(PASTDT(I),"^") I (I#5=0)!(I=DGBTC) D Q:($D(DTOUT))!($D(DIRUT))!(Y>0)
.N DONE
.F D CHOZ Q:DONE
I ('$D(DTOUT))&(Y="")&(I=DGBTC) S Y=-1 Q
S:('$D(DTOUT))&(Y="") DONE1=0,DGBTCH=I+1 Q
I Y=-1 Q
Q
DHELP ;
S %DT="EXR" D ^%DT K %DT
W ! I 'DGBTNEW W !,"If there is more than one waiver request, select by number to edit."
W !,"You cannot enter a future date/time."
W !,"The date you enter cannot precede ",$$FMTE^XLFDT($$FMADD^XLFDT(DT,-30)),"."
Q
PENSDT() ;
I 'PENSION Q 0
S DGBTDTI=$O(^DGBT(392.7,"C",DFN,""),-1) I 'DGBTDTI Q 0
I $$GET1^DIQ(392.7,DGBTDTI,8)'="PENSION" Q 0
S (DGBTIENS,Y)=DGBTDTI,DGBTDW("REQDT")=$$FMTE^XLFDT(DGBTDTI)
W !,$$UP^XLFSTR(DGBTDW("REQDT"))
Q 1
CHOZ ; select from the displayed past claims dates for claim to be edited.
S DONE=1
K DIR
W !! S Y=0,DIR(0)="FO^1:5",DIR("A")="Select DEDUCTIBLE WAIVER REQUEST"
I I<DGBTC S DIR("A",1)="Type '^' to exit date list, or <RETURN> to display more dates"
I I=DGBTC S DIR("A",1)="Type <RETURN> or '^' to exit date list"
S DIR("?")="Entering a '^' will exit the Past REQUEST list, entering <RETURN> will continue to scroll through past dates.",DIR("?",1)="Select a Past CLAIM date by number, or enter 'T' for TODAY."
D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) S Y=-1 Q
Q:Y=""
I (X<1)!(X>I)!(X'=+X) W !?25,*7,"INVALID ENTRY" S DONE=0 Q
S (DGBTDTI,DGBTIENS)=$P(PASTDT(Y),"^",2),DGBTDW("REQDT")=$P(PASTDT(Y),"^") W !,$$GET1^DIQ(392.7,DGBTDTI,2)," ",$$GET1^DIQ(392.7,DGBTDTI,.01)
Q
AUTH ; Deductible waiver authorized Y/N
I PENSION W !,"DEDUCTIBLE WAIVER AUTHORIZED YES" S DGBTDW("AUTH")="YES" Q
K DIR
S DIR("A")="DEDUCTIBLE WAIVER AUTHORIZED Y/N",DIR(0)="Y"
S DIR("B")=$S(DGBTNEW:"YES",1:$$GET1^DIQ(392.7,DGBTIENS,3))
D ^DIR K DIR
I ($D(DTOUT))!($D(DIRUT)) S DGBTOK=0 Q
S DGBTDW("AUTH")=Y(0)
Q
RMRK ; Remarks
K DGBTDW("REMARK"),DIR
S DIR("A")="DEDUCTIBLE WAIVER REMARKS"
I 'DGBTNEW S DIR("B")=$$GET1^DIQ(392.7,DGBTIENS,7)
S DIR(0)="FO^1:235"
D ^DIR K DIR
I (Y=""),('$D(DTOUT)) Q
I ($E(Y,1)="^")!($D(DIRUT))!($D(DTOUT)) S DGBTOK=0 D QUIT Q
S DGBTDW("REMARK")=Y
Q
APPDT ; Waiver Approval Date
F D Q:DONE
.S DONE=1
.K DIR
.S DIR("A")=$S(DGBTDW("AUTH")="YES":"WAIVER APPROVAL DATE: ",1:"WAIVER DENIAL DATE: ")
.S DIR(0)="DA^2991231:NOW:EX",DIR("B")=$S(DGBTNEW:"TODAY",1:$$GET1^DIQ(392.7,DGBTIENS,5)) D ^DIR K DIR
.I ($D(DIRUT))!($D(DIROUT)) Q
.I Y<$P(DGBTDTI,".") W !,"Cannot be before request date" S DONE=0 Q
K DONE
I ($D(DIRUT))!($D(DIROUT))!(Y=-1) S DGBTOK=0 Q
S DGBTDW("APPDT")=Y(0)
Q
GRANT ; Waiver granted by:
K DIC
F D Q:DONE
.S DONE=1
.S DIC="^VA(200,",DIC(0)="AEQMZ",DIC("A")=$S(DGBTDW("AUTH")="YES":"DEDUCTIBLE WAIVER GRANTED BY: ",1:"DEDUCTIBLE WAIVER DENIED BY: ")
.I 'DGBTNEW S DIC("B")=$$GET1^DIQ(392.7,DGBTIENS,4)
.D ^DIC K DIC
.I ($D(DTOUT))!($D(DUOUT)) Q
.I +Y<0 S DONE=0
K DONE
I ($D(DTOUT))!($D(DUOUT))!(+Y'>0) S DGBTOK=0 Q
S DGBTDW("GRANT")=+Y
Q
EXP() ; Expiration date
I PENSION Q "PENSION"
I $G(DGBTDW("AUTH"))'="YES" Q ""
N DGBTINCA,EXPDT
D GA^DGBTUTL(DFN,"DGBTINCA",DGBTDTI)
S EXPDT=$$EXPDT
I EXPDT<DGBTDTI Q $E(DGBTDTI,1,3)_1231 ;BLD changed exp to expdt
N DGARRAY,DGBTDATA,DGBTRET,DGMTST,DGMTYPT1,FIELDS,FILE,FLAGS,INCOM,LOWINC,MTDATA,MTIEN,MTT,NETINC,THRESHLD
I +$$LI^DGBTUTL(DFN,DGBTDTI,$$DEP^VAFMON(DFN,DGBTDTI),,DGBTINCA) Q EXPDT ;
Q $E(DGBTDTI,1,3)_1231 ;BLD add $g around DGBTDW("APPR")
EXPDT() ;
I +$G(DGBTINCA) Q $P(DGBTINCA,U,5)
N TESTDATE
S TESTDATE=$P($$LST^DGMTCOU1(DFN,DGBTDTI,3),"^",2)
I +TESTDATE=0 Q 0
Q ($E(TESTDATE,1,3)+1)_$E(TESTDATE,4,7)
OLDREQ ;
K DIR
;I $$EDITOLD S DIR("A")="<E>dit Request, <D>isplay Request, or <Q>uit ",DIR(0)="SA^Q:Quit;E:Edit;D:Display"
;E S DIR("A")="<D>isplay Request, or <Q>uit ",DIR(0)="SA^Q:Quit;D:Display"
I $$EDITOLD S DIR("A")="<E>dit Request, <D>isplay Request, <DEL>ete Request, or <Q>uit ",DIR(0)="SA^Q:Quit;E:Edit;D:Display;DEL:Delete"
E S DIR("A")="<D>isplay Request, <DEL>ete Request, or <Q>uit ",DIR(0)="SA^Q:Quit;D:Display;DEL:Delete"
S DIR("B")="Quit"
D ^DIR K DIR
;S X=$E($$UP^XLFSTR(X),1)
S X=$$UP^XLFSTR(X)
I ($E(X,1)="Q")!($D(DIRUT))!($D(DUOUT)) S DGBTOK=0 Q
I $E(X,1,3)="DEL" D Q
.I $G(DGBTIENS)="" S DGBTIENS=$G(PASTYR($E(Y,1,3)))
.I DGBTIENS="" Q
.S DELETRAY(DGBTIENS,"DATE")=DT
.S DELETRAY(DGBTIENS,"DUZ")=DUZ
.F D Q:DONE
..S DONE=1
..N X,Y
..K DIR S DIR("A")="Enter reason for deletion",DIR(0)="FO^1:100" D ^DIR K DIR
..I ($D(DUOUT))!($D(DIROUT))!($D(DTOUT)) Q
..S ANS=$TR(Y,U," ")
..I $L($TR(ANS," ",""))=0 S DONE=0
.I ($D(DUOUT))!($D(DIROUT))!($D(DTOUT)) K DELETRAY Q
.S DELETRAY(DGBTIENS,"REMARK")=ANS
.I ($D(DIRUT))!($D(DIROUT))!($D(DTOUT))!($D(DUOUT)) Q
.D FILDLT K DELETRAY
.S DGBTOK=0
S DGBTOK=1
I $E(X,1)="D" S DISPLAY=1
Q
EDITOLD() ;
N EXPDT
S EXPDT=$$GET1^DIQ(392.7,DGBTIENS_",",8,"I")
I EXPDT="PENSION" Q 1
Q EXPDT'<DT
DISPLAY ;
I $G(DGBTIENS)="" S DGBTIENS=$G(PASTYR($E(Y,1,3)))
I DGBTIENS="" Q
N AUTH,DENYDT
S AUTH=$$GET1^DIQ(392.7,DGBTIENS,3)
W !,"PATIENT: ",$$GET1^DIQ(392.7,DGBTIENS,2)
W !,"DEDUCTIBLE WAIVER REQUEST DATE: ",$$GET1^DIQ(392.7,DGBTIENS,.01)
W !,"DEDUCTIBLE WAIVER AUTHORIZED?: ",AUTH
W !,"DEDUCTIBLE WAIVER "
W $S(AUTH="YES":"GRANT",1:"DENI"),"ED BY: ",$$GET1^DIQ(392.7,DGBTIENS,4)
W !,"DEDUCTIBLE WAIVER "
W $S(AUTH="YES":"APPROV",1:"DENI"),"AL DATE: ",$$GET1^DIQ(392.7,DGBTIENS,5)
W !,"DEDUCTIBLE WAIVER ENTERED BY: ",$$GET1^DIQ(392.7,DGBTIENS,6)
W !,"DEDUCTIBLE WAIVER ENTRY DATE: ",$$GET1^DIQ(392.7,DGBTIENS,9)
W !,"DEDUCTIBLE WAIVER EXPIRATION DATE: "
S I=$$GET1^DIQ(392.7,DGBTIENS,8)
W $S(I?7N:$$UP^XLFSTR($$FMTE^XLFDT(I)),1:I)
W !,"DEDUCTIBLE WAIVER REMARKS: ",$$GET1^DIQ(392.7,DGBTIENS,7)
S DENYDT=$$GET1^DIQ(392.7,DGBTIENS,97)
I DENYDT'="" W !,"DEDUCTIBLE WAIVER DELETION DATE: ",DENYDT
D CLEAN^DILF
Q
QUIT ;
D CLEAN^DILF
L
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGBTDW 12695 printed Nov 22, 2024@16:50:49 Page 2
DGBTDW ;ALB/RFE - DEDUCTIBLE WAIVER SETUP/MAIN ENTRY CALLUP; 01/19/12
+1 ;;1.0;Beneficiary Travel;**20**;November 11, 2011;Build 185
+2 QUIT
EN ; Entry point
+1 NEW %,%H,%I,%Y,ANS,C,DELRAY,DFN,DGBTDTI,DGBTDW,DGBTFDA,DGBTFDA1,DGBTIENS,DGBTNEW,DGBTOK,DGBTTOUT,DGENR,DGRETV,DISPLAY,DTSUB,ERRMSG,PENSION,THISYR,I,X,Y
+2 NEW VAEL,VAERR,DELETRAY,DGBTERR
+3 DO CLEAN^DILF
+4 FOR
DO ENTRQ
if '$DATA(DFN)
QUIT
+5 DO QUIT
+6 QUIT
ENTRQ ; Keep prompting until we don't get a DFN
+1 DO PATIENT
if '$DATA(DFN)
QUIT
+2 ;
KILL VAEL
DO ELIG^VADPT
+3 IF '+VAEL(1)
WRITE !!,"Eligibility is missing from registration and is required to continue.",*7
DO QUIT
QUIT
+4 SET DGBTNEW='$DATA(^DGBT(392.7,"C",DFN))
+5 DO DATE
+6 IF ($DATA(DIRUT))!($DATA(DUOUT))!($DATA(DIROUT))!($DATA(DTOUT))!(Y=-1)!('$DATA(DGBTDTI))
DO QUIT
QUIT
+7 WRITE !
+8 SET DGBTNEW='$DATA(^DGBT(392.7,"C",DFN,DGBTDTI))
+9 SET (DGBTOK,DISPLAY)=0
+10 SET DGBTOK=1
+11 IF 'DGBTNEW
DO OLDREQ
+12 IF DISPLAY
DO DISPLAY
DO QUIT
QUIT
+13 IF 'DGBTOK
DO QUIT
QUIT
+14 IF 'DGBTNEW
WRITE !,$$GET1^DIQ(2,DFN,.01)," ",DGBTDW("REQDT")
+15 DO AUTH
+16 IF 'DGBTOK
DO QUIT
QUIT
+17 DO GRANT
+18 IF 'DGBTOK
DO QUIT
QUIT
+19 DO APPDT
+20 IF 'DGBTOK
DO QUIT
QUIT
+21 DO RMRK
+22 IF 'DGBTOK
DO QUIT
QUIT
+23 WRITE !,"NAME: ",$$GET1^DIQ(2,DFN,.01)," DEDUCTIBLE WAIVER REQUEST DATE: ",DGBTDW("REQDT")
+24 WRITE !,$SELECT(DGBTDW("AUTH")="YES":"GRANT",1:"DENI"),"ED BY: ",$$GET1^DIQ(200,DGBTDW("GRANT"),.01)," ON DATE: ",DGBTDW("APPDT")
+25 ;
+26 ;changed by bld
IF '$$YESNO^DGBTUTL("Complete waiver request")
WRITE !,"Not completed"
DO QUIT
QUIT
+27 ;
+28 DO UPDATE
+29 DO QUIT
+30 QUIT
PATIENT ;
+1 KILL DIC,DFN
+2 SET DGBTTOUT=""
SET DIC="^DPT("
SET DIC(0)="AEQMZ"
SET DIC("A")="Select PATIENT: "
+3 WRITE !!
DO ^DIC
KILL DIC
if Y'>0
QUIT
+4 SET (DFN,DGBTDW("NAME"))=+Y
+5 SET PENSION=$$PENSION
+6 QUIT
PENSION() ;
+1 NEW HIT,VAEL,VAERR
+2 DO ELIG^VADPT
+3 IF $PIECE(VAEL(1),"^",2)["PENSION"
QUIT 1
+4 IF $PIECE(VAEL(1),"^",2)="AID & ATTENDANCE"
QUIT 1
+5 IF $PIECE(VAEL(1),"^",2)="HOUSEBOUND"
QUIT 1
+6 SET (HIT,I)=""
+7 FOR
SET I=$ORDER(VAEL(1,I))
if I=""
QUIT
Begin DoDot:1
+8 IF VAEL(1,I)["PENSION"
SET HIT=1
QUIT
+9 IF $PIECE(VAEL(1,I),"^",2)="AID & ATTENDANCE"
SET HIT=1
QUIT
+10 IF $PIECE(VAEL(1,I),"^",2)="HOUSEBOUND"
SET HIT=1
End DoDot:1
if HIT
QUIT
+11 QUIT HIT
UPDATE ;
+1 KILL ERRMSG
+2 IF DGBTNEW
Begin DoDot:1
+3 SET DGBTFDA(392.7,"+1,",.01)=DGBTDW("REQDT")
+4 SET DGBTFDA(392.7,"+1,",3)=DGBTDW("AUTH")
+5 SET DGBTFDA(392.7,"+1,",5)=DGBTDW("APPDT")
+6 IF $GET(DGBTDW("REMARK"))'=""
SET DGBTFDA(392.7,"+1,",7)=DGBTDW("REMARK")
+7 SET DGBTFDA(392.7,"+1,",9)=$$FMTE^XLFDT(DT)
+8 DO UPDATE^DIE("E","DGBTFDA",,"ERRMSG")
+9 IF $DATA(ERRMSG)
QUIT
+10 ;
+11 SET DGBTFDA1(392.7,DGBTDTI_",",2)=DGBTDW("NAME")
+12 SET DGBTFDA1(392.7,DGBTDTI_",",4)=DGBTDW("GRANT")
+13 SET DGBTFDA1(392.7,DGBTDTI_",",6)=DUZ
+14 SET DGBTFDA1(392.7,DGBTDTI_",",8)=$$EXP
+15 DO FILE^DIE("S","DGBTFDA1","ERRMSG")
End DoDot:1
+16 ;
+17 IF '$GET(DGBTNEW)
Begin DoDot:1
+18 SET DGBTFDA(392.7,DGBTDTI_",",3)=DGBTDW("AUTH")
+19 SET DGBTFDA(392.7,DGBTDTI_",",5)=DGBTDW("APPDT")
+20 IF $GET(DGBTDW("REMARK"))'=""
SET DGBTFDA(392.7,DGBTDTI_",",7)=DGBTDW("REMARK")
+21 SET DGBTFDA(392.7,DGBTDTI_",",9)=$$FMTE^XLFDT(DT)
+22 DO FILE^DIE("E","DGBTFDA","ERRMSG")
+23 IF $DATA(ERRMSG)
QUIT
+24 SET DGBTFDA(392.7,DGBTDTI_",",4)=DGBTDW("GRANT")
+25 SET DGBTFDA(392.7,DGBTDTI_",",6)=DUZ
+26 SET DGBTFDA(392.7,DGBTDTI_",",8)=$$EXP
+27 DO FILE^DIE(,"DGBTFDA","ERRMSG")
End DoDot:1
+28 IF '$DATA(ERRMSG)
DO FILDLT
QUIT
+29 FOR I=1:1
if '$DATA(ERRMSG("DIERR","1","TEXT",I))
QUIT
WRITE !,ERRMSG("DIERR",1,"TEXT",I)
+30 QUIT
FILDLT ;
+1 if '$DATA(DELETRAY)
QUIT
+2 SET I=$ORDER(DELETRAY(""))
if I=""
QUIT
+3 KILL ERR
+4 SET DGBTFDA(392.7,I_",",97)=DELETRAY(I,"DATE")
+5 SET DGBTFDA(392.7,I_",",98)=DELETRAY(I,"DUZ")
+6 SET DGBTFDA(392.7,I_",",99)=DELETRAY(I,"REMARK")
+7 DO FILE^DIE(,"DGBTFDA","ERR")
+8 QUIT
DATE ;
+1 if $$PENSDT
QUIT
+2 KILL DGBTDTI,DELETRAY
+3 NEW PASTDT,PASTYR,DEL
+4 DO DEL
+5 IF 'DGBTNEW
NEW DGBTC
DO OLD
if 'DGBTC
SET DGBTNEW=1
+6 FOR
DO DATE1
if DONE
QUIT
+7 KILL DONE
+8 QUIT
DATE1 ;
+1 SET DONE=1
+2 KILL DIR
+3 IF 'DGBTNEW
SET DIR("A",2)="Enter 'P' for past requests"
+4 SET (DIR("A",1),DIR("A",3))=""
SET DIR("A")="DEDUCTIBLE WAIVER REQUEST DATE AND TIME"
SET DIR("?")="^D DHELP^DGBTDW"
+5 SET DIR(0)="F"
SET DIR("B")="NOW"
DO ^DIR
KILL DIR
+6 IF ($DATA(DIRUT))!($DATA(DUOUT))
QUIT
+7 SET %DT="EXR"
SET DTSUB=$SELECT($$UP^XLFSTR(Y)="P":"PASTRQ",1:"OTHR")
DO @DTSUB
KILL DTSUB,%DT
+8 QUIT
+9 ; Date-requested subroutines
OTHR ; date/time entry for manually entered date
+1 SET %DT(0)="-NOW"
DO ^%DT
IF Y<0
SET DONE=0
QUIT
+2 IF Y<$$FMADD^XLFDT(DT,-30)
WRITE !,"Date cannot precede ",$$FMTE^XLFDT($$FMADD^XLFDT(DT,-30))
SET DONE=0
QUIT
+3 IF $DATA(DEL($EXTRACT(Y,1,3)))
IF ('$DATA(PASTYR($EXTRACT(Y,1,3))))
Begin DoDot:1
+4 SET THISYR=DEL($EXTRACT(Y,1,3))
+5 WRITE !,"Request already on file and has been deleted on ",$$UP^XLFSTR($$FMTE^XLFDT(THISYR)),!
+6 NEW RQDT
SET RQDT=Y
+7 SET ANS=$$YESNO^DGBTUTL("Do you wish to enter a new manual waiver request")
+8 SET Y=RQDT
+9 IF ($DATA(DIRUT))!($DATA(DIROUT))!($DATA(DTOUT))!($DATA(DUOUT))
SET ANS=0
End DoDot:1
IF 'ANS
SET Y=-1
QUIT
+10 IF $DATA(PASTYR($EXTRACT(Y,1,3)))
IF '$DATA(^DGBT(392.7,"C",DFN,Y))
NEW RQDT
DO DELETE
SET Y=RQDT
IF 'ANS
QUIT
+11 IF ($DATA(DIRUT))!($DATA(DIROUT))!($DATA(DTOUT))!($DATA(DUOUT))
QUIT
+12 IF $DATA(^DGBT(392.7,"C",DFN,Y))
SET (DGBTDTI,DGBTIENS)=Y
SET DGBTDW("REQDT")=$$FMTE^XLFDT(DGBTDTI)
QUIT
+13 SET DGBTDTI=$$LOCKNEW(Y,0)
IF DGBTDTI=-1
WRITE !,"Please enter another date/time"
KILL DGBTDTI
QUIT
+14 SET DGBTDW("REQDT")=$$FMTE^XLFDT(DGBTDTI)
+15 QUIT
LOCKNEW(DGBTDTI,DONE) ;
+1 FOR
Begin DoDot:1
+2 LOCK +^DGBT(392.7,DGBTDTI):1
+3 IF ($TEST)
IF ('$DATA(^DGBT(392.7,DGBTDTI)))
SET DONE=1
QUIT
+4 LOCK
SET DGBTDTI=DGBTDTI+.000001
+5 IF ($LENGTH(DGBTDTI)=13)
IF $EXTRACT(DGBTDTI,13)=6
SET DONE=1
SET DGBTDTI=-1
QUIT
+6 IF $EXTRACT(DGBTDTI,13,14)>59
SET DONE=1
SET DGBTDTI=-1
QUIT
End DoDot:1
if DONE
QUIT
+7 QUIT DGBTDTI
PASTRQ ;
+1 IF DGBTNEW
WRITE !,"No past dates on file, please enter a valid date/time"
SET DONE=0
QUIT
+2 NEW DGBTCH
+3 SET DGBTCH=1
+4 FOR
DO LIST
if DONE1
QUIT
+5 KILL DONE1
+6 IF ('$DATA(DTOUT))
IF (Y'>0)
SET DONE=0
+7 QUIT
DELETE ;
+1 SET RQDT=Y
+2 WRITE !!,"Request already on file for this year: "
+3 SET THISYR=PASTYR($EXTRACT(Y,1,3))
+4 WRITE $$UP^XLFSTR($$FMTE^XLFDT(THISYR)),!
+5 Begin DoDot:1
+6 NEW X,Y
+7 SET ANS=$$YESNO^DGBTUTL("Do you wish to delete the request for "_$$UP^XLFSTR($$FMTE^XLFDT(THISYR)))
End DoDot:1
+8 IF ($DATA(DIRUT))!($DATA(DIROUT))!($DATA(DTOUT))!($DATA(DUOUT))
QUIT
+9 IF 'ANS
SET Y=THISYR
QUIT
+10 Begin DoDot:1
+11 NEW X,Y
+12 SET ANS=$$YESNO^DGBTUTL("Are you sure you wish to delete this request?")
End DoDot:1
+13 IF ($DATA(DIRUT))!($DATA(DIROUT))!($DATA(DTOUT))!($DATA(DUOUT))
QUIT
+14 IF 'ANS
SET Y=THISYR
QUIT
+15 SET DELETRAY(THISYR,"DATE")=DT
+16 SET DELETRAY(THISYR,"DUZ")=DUZ
+17 FOR
Begin DoDot:1
+18 SET DONE=1
+19 NEW X,Y
+20 KILL DIR
SET DIR("A")="Enter reason for deletion"
SET DIR(0)="FO^1:100"
DO ^DIR
KILL DIR
+21 IF ($DATA(DUOUT))!($DATA(DIROUT))!($DATA(DTOUT))
QUIT
+22 SET ANS=$TRANSLATE(Y,U," ")
+23 IF $LENGTH($TRANSLATE(ANS," ",""))=0
SET DONE=0
End DoDot:1
if DONE
QUIT
+24 IF ($DATA(DUOUT))!($DATA(DIROUT))!($DATA(DTOUT))
KILL DELETRAY
QUIT
+25 SET DELETRAY(THISYR,"REMARK")=ANS
+26 SET ANS=$$YESNO^DGBTUTL("Do you wish to enter a deductible waiver request for "_$$UP^XLFSTR($$FMTE^XLFDT(Y)))
+27 IF ($DATA(DIRUT))!($DATA(DIROUT))!($DATA(DTOUT))!($DATA(DUOUT))
QUIT
+28 IF ANS
QUIT
+29 DO FILDLT
KILL DELETRAY
+30 QUIT
OLD ; Previously entered waiver request dates
+1 SET DGBTC=0
SET I=""
+2 FOR
SET I=$ORDER(^DGBT(392.7,"C",DFN,I),-1)
if 'I
QUIT
Begin DoDot:1
+3 ;deleted
if $$GET1^DIQ(392.7,I,97,"I")
QUIT
+4 SET DGBTC=DGBTC+1
+5 SET PASTYR($EXTRACT(I,1,3))=I
+6 SET PASTDT(DGBTC)=$$FMTE^XLFDT(I)_"^"_I
End DoDot:1
+7 QUIT
DEL ; Deleted waivers on file
+1 SET I=""
+2 FOR
SET I=$ORDER(^DGBT(392.7,"C",DFN,I),-1)
if 'I
QUIT
Begin DoDot:1
+3 ;deleted
if '$$GET1^DIQ(392.7,I,97,"I")
QUIT
+4 SET DEL($EXTRACT(I,1,3))=I
End DoDot:1
+5 QUIT
LIST ;
+1 SET DONE1=1
+2 FOR I=DGBTCH:1:DGBTC
WRITE !?5,I,". ",$PIECE(PASTDT(I),"^")
IF (I#5=0)!(I=DGBTC)
Begin DoDot:1
+3 NEW DONE
+4 FOR
DO CHOZ
if DONE
QUIT
End DoDot:1
if ($DATA(DTOUT))!($DATA(DIRUT))!(Y>0)
QUIT
+5 IF ('$DATA(DTOUT))&(Y="")&(I=DGBTC)
SET Y=-1
QUIT
+6 if ('$DATA(DTOUT))&(Y="")
SET DONE1=0
SET DGBTCH=I+1
QUIT
+7 IF Y=-1
QUIT
+8 QUIT
DHELP ;
+1 SET %DT="EXR"
DO ^%DT
KILL %DT
+2 WRITE !
IF 'DGBTNEW
WRITE !,"If there is more than one waiver request, select by number to edit."
+3 WRITE !,"You cannot enter a future date/time."
+4 WRITE !,"The date you enter cannot precede ",$$FMTE^XLFDT($$FMADD^XLFDT(DT,-30)),"."
+5 QUIT
PENSDT() ;
+1 IF 'PENSION
QUIT 0
+2 SET DGBTDTI=$ORDER(^DGBT(392.7,"C",DFN,""),-1)
IF 'DGBTDTI
QUIT 0
+3 IF $$GET1^DIQ(392.7,DGBTDTI,8)'="PENSION"
QUIT 0
+4 SET (DGBTIENS,Y)=DGBTDTI
SET DGBTDW("REQDT")=$$FMTE^XLFDT(DGBTDTI)
+5 WRITE !,$$UP^XLFSTR(DGBTDW("REQDT"))
+6 QUIT 1
CHOZ ; select from the displayed past claims dates for claim to be edited.
+1 SET DONE=1
+2 KILL DIR
+3 WRITE !!
SET Y=0
SET DIR(0)="FO^1:5"
SET DIR("A")="Select DEDUCTIBLE WAIVER REQUEST"
+4 IF I<DGBTC
SET DIR("A",1)="Type '^' to exit date list, or <RETURN> to display more dates"
+5 IF I=DGBTC
SET DIR("A",1)="Type <RETURN> or '^' to exit date list"
+6 SET DIR("?")="Entering a '^' will exit the Past REQUEST list, entering <RETURN> will continue to scroll through past dates."
SET DIR("?",1)="Select a Past CLAIM date by number, or enter 'T' for TODAY."
+7 DO ^DIR
KILL DIR
IF $DATA(DTOUT)!($DATA(DUOUT))
SET Y=-1
QUIT
+8 if Y=""
QUIT
+9 IF (X<1)!(X>I)!(X'=+X)
WRITE !?25,*7,"INVALID ENTRY"
SET DONE=0
QUIT
+10 SET (DGBTDTI,DGBTIENS)=$PIECE(PASTDT(Y),"^",2)
SET DGBTDW("REQDT")=$PIECE(PASTDT(Y),"^")
WRITE !,$$GET1^DIQ(392.7,DGBTDTI,2)," ",$$GET1^DIQ(392.7,DGBTDTI,.01)
+11 QUIT
AUTH ; Deductible waiver authorized Y/N
+1 IF PENSION
WRITE !,"DEDUCTIBLE WAIVER AUTHORIZED YES"
SET DGBTDW("AUTH")="YES"
QUIT
+2 KILL DIR
+3 SET DIR("A")="DEDUCTIBLE WAIVER AUTHORIZED Y/N"
SET DIR(0)="Y"
+4 SET DIR("B")=$SELECT(DGBTNEW:"YES",1:$$GET1^DIQ(392.7,DGBTIENS,3))
+5 DO ^DIR
KILL DIR
+6 IF ($DATA(DTOUT))!($DATA(DIRUT))
SET DGBTOK=0
QUIT
+7 SET DGBTDW("AUTH")=Y(0)
+8 QUIT
RMRK ; Remarks
+1 KILL DGBTDW("REMARK"),DIR
+2 SET DIR("A")="DEDUCTIBLE WAIVER REMARKS"
+3 IF 'DGBTNEW
SET DIR("B")=$$GET1^DIQ(392.7,DGBTIENS,7)
+4 SET DIR(0)="FO^1:235"
+5 DO ^DIR
KILL DIR
+6 IF (Y="")
IF ('$DATA(DTOUT))
QUIT
+7 IF ($EXTRACT(Y,1)="^")!($DATA(DIRUT))!($DATA(DTOUT))
SET DGBTOK=0
DO QUIT
QUIT
+8 SET DGBTDW("REMARK")=Y
+9 QUIT
APPDT ; Waiver Approval Date
+1 FOR
Begin DoDot:1
+2 SET DONE=1
+3 KILL DIR
+4 SET DIR("A")=$SELECT(DGBTDW("AUTH")="YES":"WAIVER APPROVAL DATE: ",1:"WAIVER DENIAL DATE: ")
+5 SET DIR(0)="DA^2991231:NOW:EX"
SET DIR("B")=$SELECT(DGBTNEW:"TODAY",1:$$GET1^DIQ(392.7,DGBTIENS,5))
DO ^DIR
KILL DIR
+6 IF ($DATA(DIRUT))!($DATA(DIROUT))
QUIT
+7 IF Y<$PIECE(DGBTDTI,".")
WRITE !,"Cannot be before request date"
SET DONE=0
QUIT
End DoDot:1
if DONE
QUIT
+8 KILL DONE
+9 IF ($DATA(DIRUT))!($DATA(DIROUT))!(Y=-1)
SET DGBTOK=0
QUIT
+10 SET DGBTDW("APPDT")=Y(0)
+11 QUIT
GRANT ; Waiver granted by:
+1 KILL DIC
+2 FOR
Begin DoDot:1
+3 SET DONE=1
+4 SET DIC="^VA(200,"
SET DIC(0)="AEQMZ"
SET DIC("A")=$SELECT(DGBTDW("AUTH")="YES":"DEDUCTIBLE WAIVER GRANTED BY: ",1:"DEDUCTIBLE WAIVER DENIED BY: ")
+5 IF 'DGBTNEW
SET DIC("B")=$$GET1^DIQ(392.7,DGBTIENS,4)
+6 DO ^DIC
KILL DIC
+7 IF ($DATA(DTOUT))!($DATA(DUOUT))
QUIT
+8 IF +Y<0
SET DONE=0
End DoDot:1
if DONE
QUIT
+9 KILL DONE
+10 IF ($DATA(DTOUT))!($DATA(DUOUT))!(+Y'>0)
SET DGBTOK=0
QUIT
+11 SET DGBTDW("GRANT")=+Y
+12 QUIT
EXP() ; Expiration date
+1 IF PENSION
QUIT "PENSION"
+2 IF $GET(DGBTDW("AUTH"))'="YES"
QUIT ""
+3 NEW DGBTINCA,EXPDT
+4 DO GA^DGBTUTL(DFN,"DGBTINCA",DGBTDTI)
+5 SET EXPDT=$$EXPDT
+6 ;BLD changed exp to expdt
IF EXPDT<DGBTDTI
QUIT $EXTRACT(DGBTDTI,1,3)_1231
+7 NEW DGARRAY,DGBTDATA,DGBTRET,DGMTST,DGMTYPT1,FIELDS,FILE,FLAGS,INCOM,LOWINC,MTDATA,MTIEN,MTT,NETINC,THRESHLD
+8 ;
IF +$$LI^DGBTUTL(DFN,DGBTDTI,$$DEP^VAFMON(DFN,DGBTDTI),,DGBTINCA)
QUIT EXPDT
+9 ;BLD add $g around DGBTDW("APPR")
QUIT $EXTRACT(DGBTDTI,1,3)_1231
EXPDT() ;
+1 IF +$GET(DGBTINCA)
QUIT $PIECE(DGBTINCA,U,5)
+2 NEW TESTDATE
+3 SET TESTDATE=$PIECE($$LST^DGMTCOU1(DFN,DGBTDTI,3),"^",2)
+4 IF +TESTDATE=0
QUIT 0
+5 QUIT ($EXTRACT(TESTDATE,1,3)+1)_$EXTRACT(TESTDATE,4,7)
OLDREQ ;
+1 KILL DIR
+2 ;I $$EDITOLD S DIR("A")="<E>dit Request, <D>isplay Request, or <Q>uit ",DIR(0)="SA^Q:Quit;E:Edit;D:Display"
+3 ;E S DIR("A")="<D>isplay Request, or <Q>uit ",DIR(0)="SA^Q:Quit;D:Display"
+4 IF $$EDITOLD
SET DIR("A")="<E>dit Request, <D>isplay Request, <DEL>ete Request, or <Q>uit "
SET DIR(0)="SA^Q:Quit;E:Edit;D:Display;DEL:Delete"
+5 IF '$TEST
SET DIR("A")="<D>isplay Request, <DEL>ete Request, or <Q>uit "
SET DIR(0)="SA^Q:Quit;D:Display;DEL:Delete"
+6 SET DIR("B")="Quit"
+7 DO ^DIR
KILL DIR
+8 ;S X=$E($$UP^XLFSTR(X),1)
+9 SET X=$$UP^XLFSTR(X)
+10 IF ($EXTRACT(X,1)="Q")!($DATA(DIRUT))!($DATA(DUOUT))
SET DGBTOK=0
QUIT
+11 IF $EXTRACT(X,1,3)="DEL"
Begin DoDot:1
+12 IF $GET(DGBTIENS)=""
SET DGBTIENS=$GET(PASTYR($EXTRACT(Y,1,3)))
+13 IF DGBTIENS=""
QUIT
+14 SET DELETRAY(DGBTIENS,"DATE")=DT
+15 SET DELETRAY(DGBTIENS,"DUZ")=DUZ
+16 FOR
Begin DoDot:2
+17 SET DONE=1
+18 NEW X,Y
+19 KILL DIR
SET DIR("A")="Enter reason for deletion"
SET DIR(0)="FO^1:100"
DO ^DIR
KILL DIR
+20 IF ($DATA(DUOUT))!($DATA(DIROUT))!($DATA(DTOUT))
QUIT
+21 SET ANS=$TRANSLATE(Y,U," ")
+22 IF $LENGTH($TRANSLATE(ANS," ",""))=0
SET DONE=0
End DoDot:2
if DONE
QUIT
+23 IF ($DATA(DUOUT))!($DATA(DIROUT))!($DATA(DTOUT))
KILL DELETRAY
QUIT
+24 SET DELETRAY(DGBTIENS,"REMARK")=ANS
+25 IF ($DATA(DIRUT))!($DATA(DIROUT))!($DATA(DTOUT))!($DATA(DUOUT))
QUIT
+26 DO FILDLT
KILL DELETRAY
+27 SET DGBTOK=0
End DoDot:1
QUIT
+28 SET DGBTOK=1
+29 IF $EXTRACT(X,1)="D"
SET DISPLAY=1
+30 QUIT
EDITOLD() ;
+1 NEW EXPDT
+2 SET EXPDT=$$GET1^DIQ(392.7,DGBTIENS_",",8,"I")
+3 IF EXPDT="PENSION"
QUIT 1
+4 QUIT EXPDT'<DT
DISPLAY ;
+1 IF $GET(DGBTIENS)=""
SET DGBTIENS=$GET(PASTYR($EXTRACT(Y,1,3)))
+2 IF DGBTIENS=""
QUIT
+3 NEW AUTH,DENYDT
+4 SET AUTH=$$GET1^DIQ(392.7,DGBTIENS,3)
+5 WRITE !,"PATIENT: ",$$GET1^DIQ(392.7,DGBTIENS,2)
+6 WRITE !,"DEDUCTIBLE WAIVER REQUEST DATE: ",$$GET1^DIQ(392.7,DGBTIENS,.01)
+7 WRITE !,"DEDUCTIBLE WAIVER AUTHORIZED?: ",AUTH
+8 WRITE !,"DEDUCTIBLE WAIVER "
+9 WRITE $SELECT(AUTH="YES":"GRANT",1:"DENI"),"ED BY: ",$$GET1^DIQ(392.7,DGBTIENS,4)
+10 WRITE !,"DEDUCTIBLE WAIVER "
+11 WRITE $SELECT(AUTH="YES":"APPROV",1:"DENI"),"AL DATE: ",$$GET1^DIQ(392.7,DGBTIENS,5)
+12 WRITE !,"DEDUCTIBLE WAIVER ENTERED BY: ",$$GET1^DIQ(392.7,DGBTIENS,6)
+13 WRITE !,"DEDUCTIBLE WAIVER ENTRY DATE: ",$$GET1^DIQ(392.7,DGBTIENS,9)
+14 WRITE !,"DEDUCTIBLE WAIVER EXPIRATION DATE: "
+15 SET I=$$GET1^DIQ(392.7,DGBTIENS,8)
+16 WRITE $SELECT(I?7N:$$UP^XLFSTR($$FMTE^XLFDT(I)),1:I)
+17 WRITE !,"DEDUCTIBLE WAIVER REMARKS: ",$$GET1^DIQ(392.7,DGBTIENS,7)
+18 SET DENYDT=$$GET1^DIQ(392.7,DGBTIENS,97)
+19 IF DENYDT'=""
WRITE !,"DEDUCTIBLE WAIVER DELETION DATE: ",DENYDT
+20 DO CLEAN^DILF
+21 QUIT
QUIT ;
+1 DO CLEAN^DILF
+2 LOCK
+3 QUIT
