- 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 Jan 18, 2025@02:41:51 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