DGBTUTL ;ALB/SCK - BENEFICIARY/TRAVEL UTILITY ROUTINES;11/14/11
;;1.0;Beneficiary Travel;**20,24**;September 25, 2001;Build 13
START ;
Q
MILES(DGBTRN,DGBTDX) ;
; DGBTRN holds the record no., and DGBTDX holds the division pointer passed in during the function call
N DGBTML,XX,DGBTCHK
S XX="",(DGBTML,DGBTDEF)=0
F XX=0:0 S XX=$O(^DGBT(392.1,DGBTRN,1,XX)) Q:+XX'>0!(DGBTML>0) D
. S DGBTCHK=$P($G(^DGBT(392.1,DGBTRN,1,XX,0)),U,1) I DGBTDX=DGBTCHK S DGBTML=$P($G(^(0)),U,2)
I DGBTML'>0 S DGBTML=$P($G(^DGBT(392.1,DGBTRN,0)),U,3),DGBTDEF=1
K DGBTRN,DGBTDX
Q DGBTML
DICLKUP(DGBTRN,DGBTDX,DGBTP) ;
N RETURN,XX
S DIC="^DGBT(392.1,DGBTRN,1,",DIC(0)="MZX",X=DGBTDX,RETURN=""
D ^DIC
I +Y>0 D
. I DGBTP=4 S RETURN=$S(+$P($G(Y(0)),U,4)>0:$P($G(Y(0)),U,5),1:"")
. I DGBTP=3 S RETURN=$S(+$P($G(Y(0)),U,3)>0:$P(^(0),U,3),1:0)
Q RETURN
DEPCTY(ZIPCDE) ;
N RETURN
S DIC="^DGBT(392.1,",DIC(0)="MZ",X=$S($L(ZIPCDE)>5:$E(ZIPCDE,1,5),1:ZIPCDE) D ^DIC S RETURN=Y K DIC
K ZIPCDE
Q RETURN
;
DWAIVER(DFN,DGBTDCV,CLIEN) ;Get Deductible Waiver ***PAVEL
;DFN - Patient IEN
;DGBTDCV - Deductible amount
;CLIEN - Ien of current BT Claim
N VAEL,DGBTMW,EXIT,DGBTRDV
S EXIT=0
;added by bld to correct problem with manual waiver's
I $D(DGBTRET(0)),$P(DGBTRET(0),"^",6)="MAN" Q "0^Manual Waiver"
I $D(^DGBT(392.7,"C",DFN)) D Q:EXIT "0^Manual Waiver"
.S EXIT=0,DGBTMW=CLIEN+0.00001
.F S DGBTMW=$O(^DGBT(392.7,"C",DFN,DGBTMW),-1) Q:'DGBTMW!EXIT D
..Q:$P(^DGBT(392.7,DGBTMW,0),"^",3)'=1 ;Waiver not Authorized
..Q:$D(^DGBT(392.7,DGBTMW,"DEL")) ;Waiver deleted
..I $P(^DGBT(392.7,DGBTMW,0),"^",7)="PENSION" S EXIT=1 Q ;Waiver never expire
..Q:$P(CLIEN,".",1)>$P(^DGBT(392.7,DGBTMW,0),"^",7) ;Waiver expired
..S EXIT=1 ;Waiver found.
.Q
D ELIG^VADPT
I $$WVELG^DGBT1 Q "0^VA Pension"
I $P(DGBTINC,U,2)="H" Q "0^Alt Income Hardship"
I $P(DGBTINC,U,2)="P" Q "0^Alt Income POW"
I $G(DAYFLG)&('$G(DGBTREF))&(DGBTNSC)&($P($G(DGBTINC),"^",1)'="")&(+$TR($P(DGBTINC,U),"$,","")<DGBTRXTH) Q "0^NSC Low Income"
I $G(DGBTREF)&(DGBTNSC) Q "0^Patient refuse to provide financial information"
I '$G(DAYFLG) Q "0^Patient has expired Means Test or Co-Pay Test"
;Output:
;VAEL(4) If the VETERAN (Y/N)? field is YES, a "1" will be returned; otherwise, a "0" will be returned. (e.g., 1)
I 'VAEL(4) Q "0^NO Veteran"
N INCOME,X0,X1,X2,XX,MTEST
N VAMB D MB^VADPT
N LI
;Output:
;VAMB(1) A&A BENEFITS? field is YES, a "1" will be returned in the first piece; otherwise, a "0".
; If receiving A&A benefits, the TOTAL ANNUAL VA CHECK AMOUNT will be returned in the second piece. (e.g., 1^1000)
;VAMB(2) HOUSEBOUND BENEFITS? field is YES, a "1" will be returned in the first piece; otherwise, a "0".
; If receiving housebound benefits, the TOTAL ANNUAL VA CHECK AMOUNT will be returned in the second piece.
;(e.g., 1^0) ;VAMB(4) VA PENSION? field is YES, a "1" will be returned in the first piece; otherwise, a "0" .
; If receiving a VA pension, the TOTAL ANNUAL VA CHECK AMOUNT will be returned in the second piece. (e.g., 1^563.23)
I VAMB(4),VAMB(1) Q "0^VA Pension and A&A"
I VAMB(4),VAMB(2) Q "0^VA Pension and HB"
I VAMB(4) Q "0^VA Pension"
;Is the mode of transportation :Common Carrier ?
S LI=0
I '$G(DGBTREF) S XX=$$LI(DFN,DGBTDTI,DGBTDEP,,DGBTINCA) ;Get Low Income + Hardship
I $G(DGBTMLT)=0 S XX=0
I '$G(XX),$G(DGBTCCMODE)'="",$G(DGBTCCREQ),$G(DGBTMLT) Q "0^Mode of transportation is Common Carrier/With Mileage"
I '$G(XX),$G(DGBTCCMODE)'="",$G(DGBTCCREQ) Q "0^Mode of transportation is Common Carrier"
Q $S(+$G(XX):"0^"_$P($G(XX),U,2),1:DGBTDCV)
;
GA(DFN,AA,DGBTDTI,AB) ;Get Alternate Income on file
;@AA= 0^ = no Valid Alternate Income
;@AA= 1^Alt Income^Date Alt. Income Entered^Reason: Hardship or POW^Expiration date
;@AB(I)=1^Alt Income^Date Alt. Income Entered^Reason: Hardship or POW^Expiration date - Expire income
;Example: @AA=1^7777.7^3120501.203728^H^3121231
;FDA(392.9,"7171872,",.01,"I")="7171872"
;FDA(392.91,"3120423.211054,7171872,",.01,"I")=3120423.211054
;FDA(392.91,"3120423.211054,7171872,",1,"I")=12345.67
;FDA(392.91,"3120423.211054,7171872,",2,"I")="H"
;FDA(392.91,"3120423.211054,7171872,",3,"I")=3121231
N FDA,X0,X,Y,I,FDD,AC
S @AA="0^" ;S XX(3)="0^"
D GETS^DIQ(392.9,DFN_",","**","I","FDA","DGBTERR")
S X0=$G(FDA(392.9,DFN_",",.01,"I"))
Q:'$L(X0)!'$G(DGBTDTI)
S X0="" F S X0=$O(FDA(392.91,X0)) Q:'$L(X0) S X=$P(X0,",",1) M FDD(392.91,X)=FDA(392.91,X0)
S X0=DGBTDTI+0.000001
F S X0=$O(FDD(392.91,X0),-1) Q:'X0 D Q:+@AA ;Quit If Alternate income found
.Q:DGBTDTI>$G(FDD(392.91,X0,3,"I")) ;Alternate Income Expired continue search
.S @AA="1^"_$G(FDD(392.91,X0,1,"I"))_U_X0_U_$G(FDD(392.91,X0,2,"I"))_U_$G(FDD(392.91,X0,3,"I"))
.K FDD(392.91,X0)
I $D(FDD),$L($G(AB)) D
.S AB=$S($E(AB,$L(AB))=")":$E(AB,1,$L(AB)-1)_",",1:AB_"(")
.S X0=0 F I=1:1 S X0=$O(FDD(392.91,X0)) Q:'X0 S AC=AB_I_")",@AC="1^"_$G(FDD(392.91,X0,1,"I"))_U_X0_U_$G(FDD(392.91,X0,2,"I"))_U_$G(FDD(392.91,X0,3,"I"))
Q
LI(DFN,DGBTDTI,DGBTDEP,FLAG,DGBTINCA) ;Low Income
;DGBTDEP = # of Dependence
;FLAG = 1 Indication if printable Income value returned in DGBTINC and Income Type Type in DGBTIFL
;DGBTINCA = Possible Alternate income set for the VA Patient
; 1^alt income^date^alt. income reason POW or HARDSHIP^expiration date
;DGBTRET = RETURN VALUE:
; 0^
; 1^Low Income Copay
; 2^Low Income M Test
; 3^Alt. Income POW
; 4^Alt. Income Hardship
N INCOME,X,X0,X2,X3,Y,MTEST,DGBTRET
S DGBTRET="0^"
I $G(DGBTREF) Q DGBTRET
I '$G(DAYFLG) Q DGBTRET
I '$G(FLAG) N DGBTINC,DGBTIFL
S DGBTINCA=$G(DGBTINCA,"0^")
S (Y,INCOME)=$$INCOME^VAFMON(DFN,DGBTDTI,1)
I '$G(DGBTDYFL) S (Y,INCOME)="0^"
S:DGBTINCA (Y,INCOME)=$P(DGBTINCA,U,2)_U_$E($P(DGBTINCA,U,4))
S X=$P(Y,U),DGBTIFL=$P(Y,U,2) ; returns income & source.
I DGBTIFL["I^V" S (DGBTINC,DGBTIFL,X,Y)="" Q DGBTRET ;Ignore if Income type is I or V
I X?1N.E!(X<0) D
.I X<0 S X=0
.S X2="0$",X3=8 D COMMA^%DTC
S DGBTINC=X_U_$G(DGBTIFL)
I $G(DGBTINCA) Q $S($P(DGBTINCA,U,4)="P":"3^Alt. Income POW",1:"4^Alt. Income Hardship")
I $P(INCOME,U,2)="C" D Q:$G(DGBTRET) $G(DGBTRET) ;Copay income
.S INCOME=+$G(INCOME)
.I $G(DGBTRXTH),'($G(INCOME)>$G(DGBTRXTH)) S DGBTRET="1^Low Income Copay"
;Get the patient Means Test for corresponding data and see if patient is M-test Low Income.
S MTEST=+$$LST^DGMTU(DFN,DGBTDTI,1) Q:'MTEST DGBTRET ;Get last Means test
I $G(DGBTRXTH),'($G(INCOME)>$G(DGBTRXTH)) Q "2^Low Income M Test" ;change by bld 10/9/2012@2346
Q $G(DGBTRET)
;
EXIT ;
Q
TEST ;
W !,"DATE/TIME REQUIRED.."
S X="OLD",DTOUT=1
Q
;
ABP(DGBTU) ;Function returns date if patient has an active bus pass. Function added in patch 20
N DATE,IEN,EXPDT
S DATE=0,IEN=0,EXPDT=0
F S DATE=$O(^DGBT(392,"AI",DGBTU,DATE)) Q:'+DATE S IEN=^DGBT(392,"AI",DGBTU,DATE) I $D(^DGBT(392,IEN,"B"))&($P($G(^DGBT(392,IEN,"B")),U,2)'<DT) S EXPDT=$P(^("B"),U,2) Q
Q EXPDT
;
MHELP ;help text for Mileage/One Way field. Field 32 file 392.
;
;
W !,?5,"If patient used a common carrier, then the mileage entered here would be"
W !,?5,"only the mileage needed to get to the common carrier pick up point.",!
Q
;
PAUSE(EXCEL) ;
;
N DIR,PROMPT,PROMPT1,PROMPT2,PROMPT3
K Y
S EXCEL=$G(EXCEL)
S PROMPT1="REPORT HAS FINISHED, "
I IOST'["C-" S DGBTQ=1 W !!!,PROMPT1 Q "" ;quit if sent to a printer
S PROMPT2="TURN OFF CAPTURE, THEN "
S PROMPT3="PRESS RETURN TO CONTINUE OR '^' TO STOP...."
I EXCEL S PROMPT=PROMPT1_PROMPT2_PROMPT3
I 'EXCEL S PROMPT=PROMPT3
W !
S DIR("A")=PROMPT,DIR(0)="FAO" D ^DIR
Q Y
;
YESNO(PROMPT) ;
;
K DTOUT,DUOUT,DIRUT,DIROUT
S DIR(0)="Y",DIR("B")="YES",DIR("?")="ENTER Y(ES) OR N(O)"
I $G(PROMPT)'="" S DIR("A")=PROMPT
D ^DIR K DIR I $D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) Q 0
Q Y
;
DEVICE(RPTNAM,ROUTINE,DGBTEXCEL,COLWID) ;common device call for DGBT reports
;
N %ZIS,ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE,POP,ZTQUEUED
; RPTNAM = NAME OF DGBT REPORT BEING RUN
; ROUTINE = "TAG^ROUTINE"
;
S DGBTQ1=0
S %ZIS="PQM"
D ^%ZIS
I POP S DGBTQ=1 Q
I IOST["C-" D Q ;
.N X I IOM=255,$D(^%ZOSF("RM")) S (X,IOM)=512 X ^%ZOSF("RM")
;Check for exit
I $G(IO("Q")) D S DGBTQ=1
.S ZTRTN=ROUTINE
.S ZTDESC="BT REPORT: "_RPTNAM
.S ZTSAVE("*")=""
.D ^%ZTLOAD
.W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
.D HOME^%ZIS K IO("Q")
Q
;
SELEXCEL() ; - Returns whether to capture data for Excel report.
; Output: EXCEL = 1 - YES (capture data) / 0 - NO (DO NOT capture data)
;
N EXCEL,DIR,DIRUT,DTOUT,DUOUT,DIROUT
;
S DIR(0)="Y",DIR("B")="NO",DIR("T")=DTIME W !
S DIR("A")="Do you want to capture report data for an Excel document"
S DIR("?")="^D HEXC^DGBTUTL"
D ^DIR K DIR I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) Q "^"
K DIROUT,DTOUT,DUOUT,DIRUT
S EXCEL=0 I Y S EXCEL=1
;
;Display Excel display message
I EXCEL=1 D EXMSG
;
Q EXCEL
;
HEXC ; - 'Do you want to capture data...' prompt
W !!," Enter: 'Y' - To capture detail report data to transfer"
W !," to an Excel document"
W !," '<CR>' - To skip this option"
W !," '^' - To quit this option"
Q
;
PRINTMSG ;common help message if user selects a printer
;
W !!,"WARNING - THIS REPORT REQUIRES THAT A DEVICE WITH ",COLWID," COLUMN WIDTH BE USED."
W !,"IT WILL NOT DISPLAY CORRECTLY USING 80 COLUMN WIDTH DEVICES",!
Q
;
EXMSG ;common help message if user selects Excel option
W !!?5,"Before continuing, please set up your terminal to capture the"
W !?5,"detail report data. On some terminals, this can be done by"
W !?5,"clicking on the 'Tools' menu above, then click on 'Capture"
W !?5,"Incoming Data' to save to Desktop. This report may take a"
W !?5,"while to run."
W !!?5,"Note: To avoid undesired wrapping of the data saved to the"
W !?5," file, please enter '0;512;999' at the 'DEVICE:' prompt.",!
Q
;
RDV(DGBTRDV,DGBTDTI) ;this will process the remote sites for visits during current month.
;
q
N DGBTIEN,CURDATE,LASTVISIT
S DGBTIEN=0
S CLMMONTH=$E(DGBTDTI,1,5)
F S DGBTIEN=$O(DGBTRDV(DGBTIEN)) Q:DGBTIEN="" D
.S VISITDATA=DGBTRDV(DGBTIEN)
.S LASTVISIT=$E($P(VISITDATA,"^",3),1,5)
.Q:LASTVISIT'=CLMMONTH
;
Q
NMRNG(PATNAME,SNAME,ENAME,RESULT) ;
I (SNAME="AAA"),(ENAME="ZZZ") Q 1
N DONE,I,LEN1,LEN2,PNAM
S PNAM=$$UP^XLFSTR(PATNAME)
I '$$SNAM(PNAM,$$UP^XLFSTR(SNAME)) Q 0
Q $$ENAM(PNAM,$$UP^XLFSTR(ENAME))
SNAM(PNAM,SNAM) ;
I SNAM="AAA" Q 1
S LEN1=$L(PNAM),LEN2=$L(SNAM),DONE=0
F I=1:1:$S(LEN1<LEN2:LEN1,1:LEN2) D Q:DONE
.I $E(PNAM,I)]$E(SNAM,I) S DONE=1 Q
.I $E(PNAM,I)=$E(SNAM,I) Q
.S RESULT=0,DONE=1
Q RESULT
ENAM(PNAM,ENAM) ;
I ENAM="ZZZ" Q 1
S LEN1=$L(PNAM),LEN2=$L(ENAM),DONE=0
F I=1:1:$S(LEN1<LEN2:LEN1,1:LEN2) D Q:DONE
.I $E(ENAM,I)]$E(PNAM,I) S DONE=1 Q
.I $E(ENAM,I)=$E(PNAM,I) Q
.S RESULT=0,DONE=1
Q RESULT
;
DRDV(DFN,DGBTDCV,DGBTDTI,DLM) ;Used in remote data view to get local Deductible
N I,DGBTDCM
S DLM=$G(DLM,";") ;Output Delimiter
S DGBTDCM=0 ;Cumulative of Deductible
;Get Ded. paid.
S I=$E(DGBTDTI,1,5)_"00.2399"
F S I=$O(^DGBT(392,"C",DFN,I)) Q:'I!($E(I,1,5)>$E(DGBTDT,1,5)) S:$P($G(^DGBT(392,I,1)),U,2)'=15 DGBTDCM=DGBTDCM+($P(^DGBT(392,I,0),"^",9))
S I=$$DWAIVER(DFN,DGBTDCV,DGBTDTI)
;Q Site;Ded paid;0 if ded reset to 0; Why deductible reset to 0
Q $G(DUZ(2))_DLM_DGBTDCM_DLM_$P(I,U,1)_DLM_$P(I,U,2)
Q
;
NSC() ;
I VAEL(1)["NSC" Q 1
N HIT
S (HIT,I)=""
F S I=$O(VAEL(1,I)) Q:I="" D Q:HIT
.I VAEL(1,I)["NSC" S HIT=1
Q HIT
;
DAYFLAG() ; See if we have a valid income test
;Modified for patch 24
N MTIEN,STATUS,RESULT,VFADT
S VFADT=+$$GET1^DIQ(43,"1,",1205,"I",,"ERR")
;S MTIEN=$O(^DGMT(408.31,"C",DFN,""),-1) ; Removed so MT associated with claim date can be retrieved
S MTIEN=+$$LST^DGMTCOU1(DFN,$P(DGBTDTI,"."),3)
I MTIEN="" Q 0
S STATUS=$P($$MTS^DGMTU(DFN,$$GET1^DIQ(408.31,MTIEN,.03,"I")),U,2)
I (STATUS?1A)&("LN"[STATUS) Q 0
;
I DGBTDTI'>VFADT D
. S RESULT=$$FMDIFF^XLFDT($P(DGBTDTI,"."),$$GET1^DIQ(408.31,MTIEN,.01,"I"))'>365
E D
. I $$GET1^DIQ(408.31,MTIEN,.019)["MEANS TEST" D
. . S RESULT=$$MTCHK^DGBTUTL1(DFN,$P(DGBTDTI,"."))
. E D
. . S RESULT=$$FMDIFF^XLFDT($P(DGBTDTI,"."),$$GET1^DIQ(408.31,MTIEN,.01,"I"))'>365
Q +$G(RESULT)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGBTUTL 12620 printed Oct 16, 2024@17:42 Page 2
DGBTUTL ;ALB/SCK - BENEFICIARY/TRAVEL UTILITY ROUTINES;11/14/11
+1 ;;1.0;Beneficiary Travel;**20,24**;September 25, 2001;Build 13
START ;
+1 QUIT
MILES(DGBTRN,DGBTDX) ;
+1 ; DGBTRN holds the record no., and DGBTDX holds the division pointer passed in during the function call
+2 NEW DGBTML,XX,DGBTCHK
+3 SET XX=""
SET (DGBTML,DGBTDEF)=0
+4 FOR XX=0:0
SET XX=$ORDER(^DGBT(392.1,DGBTRN,1,XX))
if +XX'>0!(DGBTML>0)
QUIT
Begin DoDot:1
+5 SET DGBTCHK=$PIECE($GET(^DGBT(392.1,DGBTRN,1,XX,0)),U,1)
IF DGBTDX=DGBTCHK
SET DGBTML=$PIECE($GET(^(0)),U,2)
End DoDot:1
+6 IF DGBTML'>0
SET DGBTML=$PIECE($GET(^DGBT(392.1,DGBTRN,0)),U,3)
SET DGBTDEF=1
+7 KILL DGBTRN,DGBTDX
+8 QUIT DGBTML
DICLKUP(DGBTRN,DGBTDX,DGBTP) ;
+1 NEW RETURN,XX
+2 SET DIC="^DGBT(392.1,DGBTRN,1,"
SET DIC(0)="MZX"
SET X=DGBTDX
SET RETURN=""
+3 DO ^DIC
+4 IF +Y>0
Begin DoDot:1
+5 IF DGBTP=4
SET RETURN=$SELECT(+$PIECE($GET(Y(0)),U,4)>0:$PIECE($GET(Y(0)),U,5),1:"")
+6 IF DGBTP=3
SET RETURN=$SELECT(+$PIECE($GET(Y(0)),U,3)>0:$PIECE(^(0),U,3),1:0)
End DoDot:1
+7 QUIT RETURN
DEPCTY(ZIPCDE) ;
+1 NEW RETURN
+2 SET DIC="^DGBT(392.1,"
SET DIC(0)="MZ"
SET X=$SELECT($LENGTH(ZIPCDE)>5:$EXTRACT(ZIPCDE,1,5),1:ZIPCDE)
DO ^DIC
SET RETURN=Y
KILL DIC
+3 KILL ZIPCDE
+4 QUIT RETURN
+5 ;
DWAIVER(DFN,DGBTDCV,CLIEN) ;Get Deductible Waiver ***PAVEL
+1 ;DFN - Patient IEN
+2 ;DGBTDCV - Deductible amount
+3 ;CLIEN - Ien of current BT Claim
+4 NEW VAEL,DGBTMW,EXIT,DGBTRDV
+5 SET EXIT=0
+6 ;added by bld to correct problem with manual waiver's
+7 IF $DATA(DGBTRET(0))
IF $PIECE(DGBTRET(0),"^",6)="MAN"
QUIT "0^Manual Waiver"
+8 IF $DATA(^DGBT(392.7,"C",DFN))
Begin DoDot:1
+9 SET EXIT=0
SET DGBTMW=CLIEN+0.00001
+10 FOR
SET DGBTMW=$ORDER(^DGBT(392.7,"C",DFN,DGBTMW),-1)
if 'DGBTMW!EXIT
QUIT
Begin DoDot:2
+11 ;Waiver not Authorized
if $PIECE(^DGBT(392.7,DGBTMW,0),"^",3)'=1
QUIT
+12 ;Waiver deleted
if $DATA(^DGBT(392.7,DGBTMW,"DEL"))
QUIT
+13 ;Waiver never expire
IF $PIECE(^DGBT(392.7,DGBTMW,0),"^",7)="PENSION"
SET EXIT=1
QUIT
+14 ;Waiver expired
if $PIECE(CLIEN,".",1)>$PIECE(^DGBT(392.7,DGBTMW,0),"^",7)
QUIT
+15 ;Waiver found.
SET EXIT=1
End DoDot:2
+16 QUIT
End DoDot:1
if EXIT
QUIT "0^Manual Waiver"
+17 DO ELIG^VADPT
+18 IF $$WVELG^DGBT1
QUIT "0^VA Pension"
+19 IF $PIECE(DGBTINC,U,2)="H"
QUIT "0^Alt Income Hardship"
+20 IF $PIECE(DGBTINC,U,2)="P"
QUIT "0^Alt Income POW"
+21 IF $GET(DAYFLG)&('$GET(DGBTREF))&(DGBTNSC)&($PIECE($GET(DGBTINC),"^",1)'="")&(+$TRANSLATE($PIECE(DGBTINC,U),"$,","")<DGBTRXTH)
QUIT "0^NSC Low Income"
+22 IF $GET(DGBTREF)&(DGBTNSC)
QUIT "0^Patient refuse to provide financial information"
+23 IF '$GET(DAYFLG)
QUIT "0^Patient has expired Means Test or Co-Pay Test"
+24 ;Output:
+25 ;VAEL(4) If the VETERAN (Y/N)? field is YES, a "1" will be returned; otherwise, a "0" will be returned. (e.g., 1)
+26 IF 'VAEL(4)
QUIT "0^NO Veteran"
+27 NEW INCOME,X0,X1,X2,XX,MTEST
+28 NEW VAMB
DO MB^VADPT
+29 NEW LI
+30 ;Output:
+31 ;VAMB(1) A&A BENEFITS? field is YES, a "1" will be returned in the first piece; otherwise, a "0".
+32 ; If receiving A&A benefits, the TOTAL ANNUAL VA CHECK AMOUNT will be returned in the second piece. (e.g., 1^1000)
+33 ;VAMB(2) HOUSEBOUND BENEFITS? field is YES, a "1" will be returned in the first piece; otherwise, a "0".
+34 ; If receiving housebound benefits, the TOTAL ANNUAL VA CHECK AMOUNT will be returned in the second piece.
+35 ;(e.g., 1^0) ;VAMB(4) VA PENSION? field is YES, a "1" will be returned in the first piece; otherwise, a "0" .
+36 ; If receiving a VA pension, the TOTAL ANNUAL VA CHECK AMOUNT will be returned in the second piece. (e.g., 1^563.23)
+37 IF VAMB(4)
IF VAMB(1)
QUIT "0^VA Pension and A&A"
+38 IF VAMB(4)
IF VAMB(2)
QUIT "0^VA Pension and HB"
+39 IF VAMB(4)
QUIT "0^VA Pension"
+40 ;Is the mode of transportation :Common Carrier ?
+41 SET LI=0
+42 ;Get Low Income + Hardship
IF '$GET(DGBTREF)
SET XX=$$LI(DFN,DGBTDTI,DGBTDEP,,DGBTINCA)
+43 IF $GET(DGBTMLT)=0
SET XX=0
+44 IF '$GET(XX)
IF $GET(DGBTCCMODE)'=""
IF $GET(DGBTCCREQ)
IF $GET(DGBTMLT)
QUIT "0^Mode of transportation is Common Carrier/With Mileage"
+45 IF '$GET(XX)
IF $GET(DGBTCCMODE)'=""
IF $GET(DGBTCCREQ)
QUIT "0^Mode of transportation is Common Carrier"
+46 QUIT $SELECT(+$GET(XX):"0^"_$PIECE($GET(XX),U,2),1:DGBTDCV)
+47 ;
GA(DFN,AA,DGBTDTI,AB) ;Get Alternate Income on file
+1 ;@AA= 0^ = no Valid Alternate Income
+2 ;@AA= 1^Alt Income^Date Alt. Income Entered^Reason: Hardship or POW^Expiration date
+3 ;@AB(I)=1^Alt Income^Date Alt. Income Entered^Reason: Hardship or POW^Expiration date - Expire income
+4 ;Example: @AA=1^7777.7^3120501.203728^H^3121231
+5 ;FDA(392.9,"7171872,",.01,"I")="7171872"
+6 ;FDA(392.91,"3120423.211054,7171872,",.01,"I")=3120423.211054
+7 ;FDA(392.91,"3120423.211054,7171872,",1,"I")=12345.67
+8 ;FDA(392.91,"3120423.211054,7171872,",2,"I")="H"
+9 ;FDA(392.91,"3120423.211054,7171872,",3,"I")=3121231
+10 NEW FDA,X0,X,Y,I,FDD,AC
+11 ;S XX(3)="0^"
SET @AA="0^"
+12 DO GETS^DIQ(392.9,DFN_",","**","I","FDA","DGBTERR")
+13 SET X0=$GET(FDA(392.9,DFN_",",.01,"I"))
+14 if '$LENGTH(X0)!'$GET(DGBTDTI)
QUIT
+15 SET X0=""
FOR
SET X0=$ORDER(FDA(392.91,X0))
if '$LENGTH(X0)
QUIT
SET X=$PIECE(X0,",",1)
MERGE FDD(392.91,X)=FDA(392.91,X0)
+16 SET X0=DGBTDTI+0.000001
+17 ;Quit If Alternate income found
FOR
SET X0=$ORDER(FDD(392.91,X0),-1)
if 'X0
QUIT
Begin DoDot:1
+18 ;Alternate Income Expired continue search
if DGBTDTI>$GET(FDD(392.91,X0,3,"I"))
QUIT
+19 SET @AA="1^"_$GET(FDD(392.91,X0,1,"I"))_U_X0_U_$GET(FDD(392.91,X0,2,"I"))_U_$GET(FDD(392.91,X0,3,"I"))
+20 KILL FDD(392.91,X0)
End DoDot:1
if +@AA
QUIT
+21 IF $DATA(FDD)
IF $LENGTH($GET(AB))
Begin DoDot:1
+22 SET AB=$SELECT($EXTRACT(AB,$LENGTH(AB))=")":$EXTRACT(AB,1,$LENGTH(AB)-1)_",",1:AB_"(")
+23 SET X0=0
FOR I=1:1
SET X0=$ORDER(FDD(392.91,X0))
if 'X0
QUIT
SET AC=AB_I_")"
SET @AC="1^"_$GET(FDD(392.91,X0,1,"I"))_U_X0_U_$GET(FDD(392.91,X0,2,"I"))_U_$GET(FDD(392.91,X0,3,"I"))
End DoDot:1
+24 QUIT
LI(DFN,DGBTDTI,DGBTDEP,FLAG,DGBTINCA) ;Low Income
+1 ;DGBTDEP = # of Dependence
+2 ;FLAG = 1 Indication if printable Income value returned in DGBTINC and Income Type Type in DGBTIFL
+3 ;DGBTINCA = Possible Alternate income set for the VA Patient
+4 ; 1^alt income^date^alt. income reason POW or HARDSHIP^expiration date
+5 ;DGBTRET = RETURN VALUE:
+6 ; 0^
+7 ; 1^Low Income Copay
+8 ; 2^Low Income M Test
+9 ; 3^Alt. Income POW
+10 ; 4^Alt. Income Hardship
+11 NEW INCOME,X,X0,X2,X3,Y,MTEST,DGBTRET
+12 SET DGBTRET="0^"
+13 IF $GET(DGBTREF)
QUIT DGBTRET
+14 IF '$GET(DAYFLG)
QUIT DGBTRET
+15 IF '$GET(FLAG)
NEW DGBTINC,DGBTIFL
+16 SET DGBTINCA=$GET(DGBTINCA,"0^")
+17 SET (Y,INCOME)=$$INCOME^VAFMON(DFN,DGBTDTI,1)
+18 IF '$GET(DGBTDYFL)
SET (Y,INCOME)="0^"
+19 if DGBTINCA
SET (Y,INCOME)=$PIECE(DGBTINCA,U,2)_U_$EXTRACT($PIECE(DGBTINCA,U,4))
+20 ; returns income & source.
SET X=$PIECE(Y,U)
SET DGBTIFL=$PIECE(Y,U,2)
+21 ;Ignore if Income type is I or V
IF DGBTIFL["I^V"
SET (DGBTINC,DGBTIFL,X,Y)=""
QUIT DGBTRET
+22 IF X?1N.E!(X<0)
Begin DoDot:1
+23 IF X<0
SET X=0
+24 SET X2="0$"
SET X3=8
DO COMMA^%DTC
End DoDot:1
+25 SET DGBTINC=X_U_$GET(DGBTIFL)
+26 IF $GET(DGBTINCA)
QUIT $SELECT($PIECE(DGBTINCA,U,4)="P":"3^Alt. Income POW",1:"4^Alt. Income Hardship")
+27 ;Copay income
IF $PIECE(INCOME,U,2)="C"
Begin DoDot:1
+28 SET INCOME=+$GET(INCOME)
+29 IF $GET(DGBTRXTH)
IF '($GET(INCOME)>$GET(DGBTRXTH))
SET DGBTRET="1^Low Income Copay"
End DoDot:1
if $GET(DGBTRET)
QUIT $GET(DGBTRET)
+30 ;Get the patient Means Test for corresponding data and see if patient is M-test Low Income.
+31 ;Get last Means test
SET MTEST=+$$LST^DGMTU(DFN,DGBTDTI,1)
if 'MTEST
QUIT DGBTRET
+32 ;change by bld 10/9/2012@2346
IF $GET(DGBTRXTH)
IF '($GET(INCOME)>$GET(DGBTRXTH))
QUIT "2^Low Income M Test"
+33 QUIT $GET(DGBTRET)
+34 ;
EXIT ;
+1 QUIT
TEST ;
+1 WRITE !,"DATE/TIME REQUIRED.."
+2 SET X="OLD"
SET DTOUT=1
+3 QUIT
+4 ;
ABP(DGBTU) ;Function returns date if patient has an active bus pass. Function added in patch 20
+1 NEW DATE,IEN,EXPDT
+2 SET DATE=0
SET IEN=0
SET EXPDT=0
+3 FOR
SET DATE=$ORDER(^DGBT(392,"AI",DGBTU,DATE))
if '+DATE
QUIT
SET IEN=^DGBT(392,"AI",DGBTU,DATE)
IF $DATA(^DGBT(392,IEN,"B"))&($PIECE($GET(^DGBT(392,IEN,"B")),U,2)'<DT)
SET EXPDT=$PIECE(^("B"),U,2)
QUIT
+4 QUIT EXPDT
+5 ;
MHELP ;help text for Mileage/One Way field. Field 32 file 392.
+1 ;
+2 ;
+3 WRITE !,?5,"If patient used a common carrier, then the mileage entered here would be"
+4 WRITE !,?5,"only the mileage needed to get to the common carrier pick up point.",!
+5 QUIT
+6 ;
PAUSE(EXCEL) ;
+1 ;
+2 NEW DIR,PROMPT,PROMPT1,PROMPT2,PROMPT3
+3 KILL Y
+4 SET EXCEL=$GET(EXCEL)
+5 SET PROMPT1="REPORT HAS FINISHED, "
+6 ;quit if sent to a printer
IF IOST'["C-"
SET DGBTQ=1
WRITE !!!,PROMPT1
QUIT ""
+7 SET PROMPT2="TURN OFF CAPTURE, THEN "
+8 SET PROMPT3="PRESS RETURN TO CONTINUE OR '^' TO STOP...."
+9 IF EXCEL
SET PROMPT=PROMPT1_PROMPT2_PROMPT3
+10 IF 'EXCEL
SET PROMPT=PROMPT3
+11 WRITE !
+12 SET DIR("A")=PROMPT
SET DIR(0)="FAO"
DO ^DIR
+13 QUIT Y
+14 ;
YESNO(PROMPT) ;
+1 ;
+2 KILL DTOUT,DUOUT,DIRUT,DIROUT
+3 SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("?")="ENTER Y(ES) OR N(O)"
+4 IF $GET(PROMPT)'=""
SET DIR("A")=PROMPT
+5 DO ^DIR
KILL DIR
IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))!($DATA(DIROUT))
QUIT 0
+6 QUIT Y
+7 ;
DEVICE(RPTNAM,ROUTINE,DGBTEXCEL,COLWID) ;common device call for DGBT reports
+1 ;
+2 NEW %ZIS,ZTSK,ZTRTN,ZTIO,ZTDESC,ZTSAVE,POP,ZTQUEUED
+3 ; RPTNAM = NAME OF DGBT REPORT BEING RUN
+4 ; ROUTINE = "TAG^ROUTINE"
+5 ;
+6 SET DGBTQ1=0
+7 SET %ZIS="PQM"
+8 DO ^%ZIS
+9 IF POP
SET DGBTQ=1
QUIT
+10 ;
IF IOST["C-"
Begin DoDot:1
+11 NEW X
IF IOM=255
IF $DATA(^%ZOSF("RM"))
SET (X,IOM)=512
XECUTE ^%ZOSF("RM")
End DoDot:1
QUIT
+12 ;Check for exit
+13 IF $GET(IO("Q"))
Begin DoDot:1
+14 SET ZTRTN=ROUTINE
+15 SET ZTDESC="BT REPORT: "_RPTNAM
+16 SET ZTSAVE("*")=""
+17 DO ^%ZTLOAD
+18 WRITE !,$SELECT($DATA(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
+19 DO HOME^%ZIS
KILL IO("Q")
End DoDot:1
SET DGBTQ=1
+20 QUIT
+21 ;
SELEXCEL() ; - Returns whether to capture data for Excel report.
+1 ; Output: EXCEL = 1 - YES (capture data) / 0 - NO (DO NOT capture data)
+2 ;
+3 NEW EXCEL,DIR,DIRUT,DTOUT,DUOUT,DIROUT
+4 ;
+5 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("T")=DTIME
WRITE !
+6 SET DIR("A")="Do you want to capture report data for an Excel document"
+7 SET DIR("?")="^D HEXC^DGBTUTL"
+8 DO ^DIR
KILL DIR
IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT "^"
+9 KILL DIROUT,DTOUT,DUOUT,DIRUT
+10 SET EXCEL=0
IF Y
SET EXCEL=1
+11 ;
+12 ;Display Excel display message
+13 IF EXCEL=1
DO EXMSG
+14 ;
+15 QUIT EXCEL
+16 ;
HEXC ; - 'Do you want to capture data...' prompt
+1 WRITE !!," Enter: 'Y' - To capture detail report data to transfer"
+2 WRITE !," to an Excel document"
+3 WRITE !," '<CR>' - To skip this option"
+4 WRITE !," '^' - To quit this option"
+5 QUIT
+6 ;
PRINTMSG ;common help message if user selects a printer
+1 ;
+2 WRITE !!,"WARNING - THIS REPORT REQUIRES THAT A DEVICE WITH ",COLWID," COLUMN WIDTH BE USED."
+3 WRITE !,"IT WILL NOT DISPLAY CORRECTLY USING 80 COLUMN WIDTH DEVICES",!
+4 QUIT
+5 ;
EXMSG ;common help message if user selects Excel option
+1 WRITE !!?5,"Before continuing, please set up your terminal to capture the"
+2 WRITE !?5,"detail report data. On some terminals, this can be done by"
+3 WRITE !?5,"clicking on the 'Tools' menu above, then click on 'Capture"
+4 WRITE !?5,"Incoming Data' to save to Desktop. This report may take a"
+5 WRITE !?5,"while to run."
+6 WRITE !!?5,"Note: To avoid undesired wrapping of the data saved to the"
+7 WRITE !?5," file, please enter '0;512;999' at the 'DEVICE:' prompt.",!
+8 QUIT
+9 ;
RDV(DGBTRDV,DGBTDTI) ;this will process the remote sites for visits during current month.
+1 ;
+2 QUIT
+3 NEW DGBTIEN,CURDATE,LASTVISIT
+4 SET DGBTIEN=0
+5 SET CLMMONTH=$EXTRACT(DGBTDTI,1,5)
+6 FOR
SET DGBTIEN=$ORDER(DGBTRDV(DGBTIEN))
if DGBTIEN=""
QUIT
Begin DoDot:1
+7 SET VISITDATA=DGBTRDV(DGBTIEN)
+8 SET LASTVISIT=$EXTRACT($PIECE(VISITDATA,"^",3),1,5)
+9 if LASTVISIT'=CLMMONTH
QUIT
End DoDot:1
+10 ;
+11 QUIT
NMRNG(PATNAME,SNAME,ENAME,RESULT) ;
+1 IF (SNAME="AAA")
IF (ENAME="ZZZ")
QUIT 1
+2 NEW DONE,I,LEN1,LEN2,PNAM
+3 SET PNAM=$$UP^XLFSTR(PATNAME)
+4 IF '$$SNAM(PNAM,$$UP^XLFSTR(SNAME))
QUIT 0
+5 QUIT $$ENAM(PNAM,$$UP^XLFSTR(ENAME))
SNAM(PNAM,SNAM) ;
+1 IF SNAM="AAA"
QUIT 1
+2 SET LEN1=$LENGTH(PNAM)
SET LEN2=$LENGTH(SNAM)
SET DONE=0
+3 FOR I=1:1:$SELECT(LEN1<LEN2:LEN1,1:LEN2)
Begin DoDot:1
+4 IF $EXTRACT(PNAM,I)]$EXTRACT(SNAM,I)
SET DONE=1
QUIT
+5 IF $EXTRACT(PNAM,I)=$EXTRACT(SNAM,I)
QUIT
+6 SET RESULT=0
SET DONE=1
End DoDot:1
if DONE
QUIT
+7 QUIT RESULT
ENAM(PNAM,ENAM) ;
+1 IF ENAM="ZZZ"
QUIT 1
+2 SET LEN1=$LENGTH(PNAM)
SET LEN2=$LENGTH(ENAM)
SET DONE=0
+3 FOR I=1:1:$SELECT(LEN1<LEN2:LEN1,1:LEN2)
Begin DoDot:1
+4 IF $EXTRACT(ENAM,I)]$EXTRACT(PNAM,I)
SET DONE=1
QUIT
+5 IF $EXTRACT(ENAM,I)=$EXTRACT(PNAM,I)
QUIT
+6 SET RESULT=0
SET DONE=1
End DoDot:1
if DONE
QUIT
+7 QUIT RESULT
+8 ;
DRDV(DFN,DGBTDCV,DGBTDTI,DLM) ;Used in remote data view to get local Deductible
+1 NEW I,DGBTDCM
+2 ;Output Delimiter
SET DLM=$GET(DLM,";")
+3 ;Cumulative of Deductible
SET DGBTDCM=0
+4 ;Get Ded. paid.
+5 SET I=$EXTRACT(DGBTDTI,1,5)_"00.2399"
+6 FOR
SET I=$ORDER(^DGBT(392,"C",DFN,I))
if 'I!($EXTRACT(I,1,5)>$EXTRACT(DGBTDT,1,5))
QUIT
if $PIECE($GET(^DGBT(392,I,1)),U,2)'=15
SET DGBTDCM=DGBTDCM+($PIECE(^DGBT(392,I,0),"^",9))
+7 SET I=$$DWAIVER(DFN,DGBTDCV,DGBTDTI)
+8 ;Q Site;Ded paid;0 if ded reset to 0; Why deductible reset to 0
+9 QUIT $GET(DUZ(2))_DLM_DGBTDCM_DLM_$PIECE(I,U,1)_DLM_$PIECE(I,U,2)
+10 QUIT
+11 ;
NSC() ;
+1 IF VAEL(1)["NSC"
QUIT 1
+2 NEW HIT
+3 SET (HIT,I)=""
+4 FOR
SET I=$ORDER(VAEL(1,I))
if I=""
QUIT
Begin DoDot:1
+5 IF VAEL(1,I)["NSC"
SET HIT=1
End DoDot:1
if HIT
QUIT
+6 QUIT HIT
+7 ;
DAYFLAG() ; See if we have a valid income test
+1 ;Modified for patch 24
+2 NEW MTIEN,STATUS,RESULT,VFADT
+3 SET VFADT=+$$GET1^DIQ(43,"1,",1205,"I",,"ERR")
+4 ;S MTIEN=$O(^DGMT(408.31,"C",DFN,""),-1) ; Removed so MT associated with claim date can be retrieved
+5 SET MTIEN=+$$LST^DGMTCOU1(DFN,$PIECE(DGBTDTI,"."),3)
+6 IF MTIEN=""
QUIT 0
+7 SET STATUS=$PIECE($$MTS^DGMTU(DFN,$$GET1^DIQ(408.31,MTIEN,.03,"I")),U,2)
+8 IF (STATUS?1A)&("LN"[STATUS)
QUIT 0
+9 ;
+10 IF DGBTDTI'>VFADT
Begin DoDot:1
+11 SET RESULT=$$FMDIFF^XLFDT($PIECE(DGBTDTI,"."),$$GET1^DIQ(408.31,MTIEN,.01,"I"))'>365
End DoDot:1
+12 IF '$TEST
Begin DoDot:1
+13 IF $$GET1^DIQ(408.31,MTIEN,.019)["MEANS TEST"
Begin DoDot:2
+14 SET RESULT=$$MTCHK^DGBTUTL1(DFN,$PIECE(DGBTDTI,"."))
End DoDot:2
+15 IF '$TEST
Begin DoDot:2
+16 SET RESULT=$$FMDIFF^XLFDT($PIECE(DGBTDTI,"."),$$GET1^DIQ(408.31,MTIEN,.01,"I"))'>365
End DoDot:2
End DoDot:1
+17 QUIT +$GET(RESULT)
