Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGBTUTL

DGBTUTL.m

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