- 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 Feb 18, 2025@23:07:32 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)