IBJDF41 ;ALB/RB - FIRST PARTY FOLLOW-UP REPORT (COMPILE) ;15-APR-00
;;2.0;INTEGRATED BILLING;**123,159,204,356,451,473,568,618,651,694,705,715,739**;21-MAR-94;Build 3
;;Per VA Directive 6402, this routine should not be modified.
;
; Reference to FILE 433.001 in ICR #7321
;
ST ; - Tasked entry point.
K IB,IBCAT,^TMP("IBJDF4",$J)
S IBQ=0
;
; - Set selected categories for report.
I IBSEL[1 S IBCAT(2)=1
I IBSEL[2 S IBCAT(1)=2
I IBSEL[3 S IBCAT(18)=3 F X=22,23 S IBCAT(X)=3
I IBSEL[4 F X=33:1:39 S IBCAT(X)=4
; *** new code
I IBSEL[5 D
. F X=61:1:74 S IBCAT(X)=5
. F X=81:1:85 S IBCAT(X)=5
;
; - Print the header line for the Excel spreadsheet
I $G(IBEXCEL) D PHDL
;
; - Find data required for report.
F IB=16,19,40 D G:IBQ ENQ
. I IBSTA="A",IB'=16 Q ; Active AR's only.
. I IBSTA="S",IB=16 Q ; Suspended AR's only.
. I IB'=40 D
. . S IBCAT=""
. . F S IBCAT=$O(IBCAT(IBCAT)) Q:IBCAT="" D
. . . D INIT^IBJDF43
. S IBA=0
. F S IBA=$O(^PRCA(430,"AC",IB,IBA)) Q:'IBA D Q:IBQ
. . D PROC
;
I 'IBQ,'$G(IBEXCEL) D EN^IBJDF42 ; Print the report.
;
ENQ K ^TMP("IBJDF4",$J)
I $D(ZTQUEUED) S ZTREQ="@" G ENQ1
;
D ^%ZISC
ENQ1 K IB,IB0,IBA,IBA1,IBADM,IBAGE,IBAR,IBAR1,IBBA,IBBN,IBBU,IBC,IBCAT,IBCAT1
K IBELIG,IBEXCEL,IBFLG,IBAI,IBAIQ,IBIDX,IBIO,IBINT,IBN,IBPA,IBPD,IBPAT
K IBPT,IBQ,IBRFD,IBRFT,IBSRC,IBRP,IBVA,COM,COM1,DAT,DFN,X,X1,X2,Y,Z
Q
;
PROC ; - Process data for report(s).
I IBA#100=0 D Q:IBQ
. S IBQ=$$STOP^IBOUTL("First Party Follow-Up Report")
S IBAR=$G(^PRCA(430,IBA,0)) I 'IBAR Q
S IBCAT=+$P(IBAR,U,2) I '$D(IBCAT(IBCAT)) Q ; Get valid AR category.
I '$$CLMACT^IBJD(IBA,IBCAT) Q ; Invalid IB claim/action.
S IBSUSTYP=""
I IB=40 S IBSUSTYP=$$SUST(IBA)
I IBSTA="S",IBSELST'[(","_IBSUSTYP_",") Q ; Filter by suspended type IB*2*568/DRF
S IBPT=$$PAT(IBA) I IBPT="" Q ; Get patient info.
S DFN=$P(IBPT,U,2)
S IBAGE=$$FMDIFF^XLFDT(DT,+$P(IBAR,U,10))
I IBSMN,IBAGE<IBSMN!(IBAGE>IBSMX) Q ; AR outside age range.
S IBVA=$$VA^IBJD1(DFN),IBBN=$P(IBAR,U),IBPD=$P($$PYMT^IBJD1(IBA),U)
S IBPAT=$P(IBPT,U)_"@@"_DFN
;
; - Check the AR balance amounts, if necessary.
S (IBADM,IBBA,IBINT,IBPA)=0,IBN=$G(^PRCA(430,IBA,7))
F X=1:1:5 D
. S IBBA=IBBA+$P(IBN,U,X)
. S:X=1 IBPA=+IBN S:X=2 IBINT=$P(IBN,U,2) S:X=3 IBADM=$P(IBN,U,3)
;
I '$G(IBEXCEL) D EN^IBJDF43 I IBRPT="S"!(IBRPT="O") Q ; Get summary stats.
;
I IBSAM,IBBA<IBSAM Q
;
; - Check if AR was referred to R-Regional Counsel, D-DMC, T-TOP,
; or C-CROSS SERVICING and exclude, if necessary.
S IB0=$S(IB=40:19,1:IB),IBIDX=0,IBRFT=""
S IBAIQ=0,IBAI=$G(^TMP("IBJDF4",$J,IBPAT,0,"A"))
S IBRFD=$P($G(^PRCA(430,IBA,6)),U,4)
I IBRPT="D",IBRFD D I IBAIQ Q ; Referred to RC
. S IBRFT="R" I IBAI'["R" S IBAI=IBAI_"R"
. I 'IBSRC S IBAIQ=1 Q
. D SREF("R",IBRFD,IB0,,.IBIDX)
S IBRFD=+$G(^PRCA(430,IBA,12))
I IBRPT="D",IBRFD D ; Referred to DMC
. S IBRFT=IBRFT_"D" I IBAI'["D" S IBAI=IBAI_"D"
. D SREF("D",IBRFD,IB0,,.IBIDX)
S IBRFD=+$G(^PRCA(430,IBA,14))
I IBRPT="D",IBRFD D ; Referred to TOP
. S IBRFT=IBRFT_"T" I IBAI'["T" S IBAI=IBAI_"T"
. D SREF("T",IBRFD,IB0,,.IBIDX)
; PRCA*4.5*338 added CS
S IBRFD=+$G(^PRCA(430,IBA,15))
I IBRPT="D",IBRFD D ; Referred to CS
. S IBRFT=IBRFT_"C" I IBAI'["C" S IBAI=IBAI_"C"
. D SREF("C",IBRFD,IB0,,.IBIDX)
;
; - Check if AR is on P-Repayment plan or F-Defaulted repayment plan.
; and exclude if repayment plan is active.
S IBRP=$$RP(IBA)
I IBRP D
. I IBRP=2 S IBRFT=IBRFT_"F" I IBAI'["F" S IBAI=IBAI_"F"
. I IBRP=1 S IBRFT=IBRFT_"P" I IBAI'["P"&(IBAI'["F") S IBAI=IBAI_"P"
. D SREF("P",$P(IBRP,"^",2),IB0,$S(+IBRP=2:1,1:0),.IBIDX)
;
I IBIDX S IBFLG=1
;
; - Check if VA Employee
I $P(IBVA,"^")["*",IBAI'["V" S IBAI=IBAI_"V"
;
I IBAI'="" S ^TMP("IBJDF4",$J,IBPAT,0,"A")=IBAI
;
; IB*2.0*451 - Check for EEOB on associated 3rd party bills and attach EOB indicator '%' if applicable
S IBBN=$$IBEEOBCK(IBBN,DFN)_IBBN ; Pass AR BILL#, Pat ID
;
; - Set up indexes for detail report.
I $G(IBEXCEL) D Q
. S IBEXCEL1=$P($G(^PRCA(430.2,IBCAT,0)),U,2)_U_$P(IBPT,U,3)_U_$P(IBVA,U)_U_U_$$DT^IBJD($P(IBPT,U,6),1)_U_$$ELIG^IBJDF42(+$P(IBPT,U,5))_U ;IB*2.0*739
. S IBEXCEL1=IBEXCEL1_$$GET1^DIQ(2,DFN,.381)_U_$$MTRX(DFN)_U_IBBN_U_$S(IB=16:"A",1:"S")_U_$S("BS"[IBSTA:$$ABBR($G(IBSUSTYP)),1:"")_U_IBRFT_U_$$DT^IBJD($P(IBAR,U,10),1)_U_$$DT^IBJD(IBPD,1)_U_IBBA_U_IBPA_U_IBINT_U_IBADM_U
. I IBSH D COM
. S IBD=0 I DAT!IBPD S IBD=$$FMDIFF^XLFDT(DT,$S('DAT:IBPD,1:$G(DAT)))
. S IBEXCEL1=IBEXCEL1_U_IBD
. W !,IBEXCEL1 K IBD,IBEXCEL1
;
I '($D(^TMP("IBJDF4",$J,IBPAT))#10) D
. S ^TMP("IBJDF4",$J,IBPAT)=$P(IBPT,U,3,5)_U_$$MTRX(DFN)_U_$P(IBPT,U,6)_"^"_$P(IBVA,"^",2)_"^"_$$ACCBAL($P(IBPT,U,7))
S ^TMP("IBJDF4",$J,IBPAT,IB0,IBCAT,IBBN)=IBPD_U_IBBA_U_IBPA_U_IBINT_U_IBADM_U_IBIDX_U_$S($D(IBSUSTYP):IBSUSTYP,1:"")
;
I IBSH D COM
Q
;
ACCBAL(DFN) ; Calculates the Account Balance for the Bill
; Input: DFN - Patient/Debtor internal number
; Output: BAL - Patient/Debtor Account Balance
;
N B0,B7,BAL,BILL,I
S (BAL,BILL)=0
F S BILL=$O(^PRCA(430,"C",DFN,BILL)) Q:BILL="" D
. S B0=$G(^PRCA(430,BILL,0)) I $P(B0,"^",8)'=16 Q
. S B7=$G(^PRCA(430,BILL,7))
. F I=1:1:5 S BAL=BAL+$P(B7,"^",I)
Q BAL
;
PHDL ; - Print the header line for the Excel spreadsheet
N X
S X="Cat^Patient^VA Empl.?^^Dt Death^Prim.Elig.^Med.Elig.?^" ;IB*2.0*739
S X=X_"Means Tst Sts^Means Tst Dt^RX Copay Exemp.Sts^RX Copay Exemp.Dt^"
S X=X_"Bill #^Act/Susp^Reason^Refer. to^Dt Bill prep.^Last Pymt Dt^" ;Added reason IB*2*568/DRF
S X=X_"Curr.Bal.^Princ.Bal.^Int.^Admin.^Last Comm.Dt^Days Lst Comm.^"
W !,X
Q
;
PAT(X) ; - Find the AR patient and decide to include the AR.
; Input: X=AR pointer to file #430 and pre-set variables IBS*
; Output: Y=Sort key (name or last 4) ^ Patient pointer to file #2
; ^ Name ^ SSN ^ Eligibilities ^ Date of death (if any)
; ^ Debtor pointer to file #340
N PAT,KEY,DBTR,DFN,DEATH,NAME,SSN,VAEL,VADM,X1,X2
S PAT="" G:'$G(X) PATQ
S DBTR=+$P($G(^PRCA(430,X,0)),U,9)
S X1=$P($G(^RCD(340,DBTR,0)),U) G:X1'["DPT" PATQ
S DFN=+X1 G:'DFN PATQ D DEM^VADPT
S NAME=VADM(1),SSN=$P(VADM(2),"^"),DEATH=VADM(6)\1
S KEY=$S(IBSN="N":NAME,1:$E(SSN,6,9))
I KEY=""!(IBSNF'="@"&('DFN)) G PATQ
I $D(IBSNA) G:IBSNA="ALL"&('DFN) PATQ G:IBSNA="NULL"&(DFN) PATQ
I $G(IBSNA)="ALL" G PATC
I IBSNF="@",IBSNL="zzzzz" G PATC
I IBSNF'=KEY,IBSNF]KEY G PATQ
I IBSNL'=KEY,KEY]IBSNL G PATQ
;
PATC ; - Set patient eligibilities.
D ELIG^VADPT S X2=+$G(VAEL(1))_";"
I +X2 S X1=0 F S X1=$O(VAEL(1,X1)) Q:'X1 S X2=X2_X1_";"
;
S PAT=KEY_U_DFN_U_$E(NAME,1,26)_U_SSN_U_X2_U_DEATH
S PAT=PAT_U_DBTR
PATQ Q PAT
;
RP(X) ; - Check if claim/receivable is under a repayment plan.
; Input: X=Bill pointer to file #430
; Output: 0-Not on repay plan, 1-On repay plan, 2-On defaulted plan
N RPIEN,Z
; IB*2.0*694
S RPIEN=$P($G(^PRCA(430,X,4)),U,5) ; file 340.5 ien
S Z=$$REPDATA(RPIEN,1) I Z="" Q 0
I $P(Z,U,9)=5 Q ("2^"_$P(Z,U)) ; IB*2.0*694
;
Q ("1^"_$P(Z,U)) ; IB*2.0*694
;
MTRX(X) ; - Return patient's means test and/or RX copay status and most recent
; test dates for both.
; Input: X=Patient pointer to file #2 and opt. variable IBEXCEL
; Output: Y=Means test status ^ Date ^ RX copay status ^ Date
N MTST,RXST,Y
S Y="^^^",MTST=$$LST^DGMTU(X),RXST=$$RXST^IBARXEU(X)
I '$G(IBEXCEL) D
. S $P(Y,"^",1,2)=$P(MTST,"^",3)_"^"_$$DAT1^IBOUTL($P(MTST,"^",2))
. S $P(Y,"^",3)=$S('RXST:"NON-EXEMPT",+RXST=1:"EXEMPT",1:"")
. I $P(Y,"^",3)'="" S $P(Y,"^",4)=$$DAT1^IBOUTL($P(RXST,"^",5))
I $G(IBEXCEL) D
. S $P(Y,"^",1,2)=$P(MTST,"^",4)_"^"_$$DT^IBJD($P(MTST,"^",2),1)
. S $P(Y,"^",3)=$S('RXST:"M",+RXST=1:"E",1:"")
. I $P(Y,"^",3)'="" S $P(Y,"^",4)=$$DT^IBJD($P(RXST,"^",5),1)
Q Y
;
SREF(RFT,DAT,STS,DEF,IDX) ; Set the "referred to" information on the
; temporary global ^TMP
;Input: RFT: "R": RC, "D": DMC, "T": TOP, "C": CROSS SERVICING, "P": REPAYMENT PLAN
; DAT: Date it was referred/established
; STS: Receivable status (16-Active,19-Suspended)
; DEF: Repayment Plan in Default? (1 - YES, 0 - NO)
; IDX: Subscript to be set in the Temporary global ^TMP
;Output: IDX: Subscript set in the Temporary global ^TMP
;
N SREF,IDX1
S DEF=+$G(DEF),IDX=+$G(IDX)
I RFT="R" S SREF="REFERRED TO RC"
I RFT="D" S SREF="REFERRED TO DMC"
I RFT="T" S SREF="REFERRED TO TOP"
I RFT="C" S SREF="REFERRED TO CS" ; PRCA*4.5*338
I RFT="P" D
. S SREF="REPAYMENT PLAN ESTABLISHED"
. I $G(DEF) S SREF=SREF_" (CURRENTLY IN DEFAULT)"
;
I 'IDX S IDX=$O(^TMP("IBJDF4",$J,IBPAT,0,"C",STS,""),-1)+1
S IDX1=$O(^TMP("IBJDF4",$J,IBPAT,0,"C",STS,IDX,""),-1)+1
S ^TMP("IBJDF4",$J,IBPAT,0,"C",STS,IDX,IDX1)=DAT
S ^TMP("IBJDF4",$J,IBPAT,0,"C",STS,IDX,IDX1,1)=SREF
Q
;
COM ; - Get bill comments.
I 'IBIDX,'$G(IBEXCEL) D
. S IBFLG=0,IBIDX=$O(^TMP("IBJDF4",$J,IBPAT,0,"C",IB0,""),-1)+1
;
S DAT=0,IBA1=$S(IBSH1="M":999999999,1:0)
F S IBA1=$S(IBSH1="M":$O(^PRCA(433,"C",IBA,IBA1),-1),1:$O(^PRCA(433,"C",IBA,IBA1))) Q:'IBA1 D I IBSH1="M",DAT Q
. S IBC=$G(^PRCA(433,IBA1,1)) Q:'IBC
. I $G(IBSH2),$$FMDIFF^XLFDT(DT,+IBC)>IBSH2 Q ; Comment age not minimum.
. I $P(IBC,U,2)'=35,$P(IBC,U,2)'=45 Q ; Not decrease/comment transact.
. S DAT=$S(IBC:+IBC\1,1:+$P(IBC,U,9)\1)
. I $G(IBEXCEL),IBSH1="M" S IBEXCEL1=IBEXCEL1_$$DT^IBJD(DAT,1) Q
. ;
. ; - Append brief and transaction comments.
. K COM,COM1 S COM(0)=DAT,X1=0
. S COM1(1)=$P($G(^PRCA(433,IBA1,5)),U,2)
. S COM1(2)=$E($P($G(^PRCA(433,IBA1,8)),U,6),1,70)
. S COM(1)=COM1(1)_$S(COM1(1)]""&(COM1(2)]""):"|",1:"")_COM1(2)
. I COM(1)]"" S COM(1)="**"_COM(1)_"**",X1=1
. ;
. ; - Get main comments.
. S X2=0
. F S X2=$O(^PRCA(433,IBA1,7,X2)) Q:'X2 D
. . S COM($S(X1:X2+1,1:X2))=^PRCA(433,IBA1,7,X2,0)
. ;
. I $G(IBEXCEL) Q
. ;
. S IBFLG=1,^TMP("IBJDF4",$J,IBPAT,0,"C",IB0,IBIDX,IBA1)=$G(COM(0)),X1=0
. F S X1=$O(COM(X1)) Q:X1="" D
. . S ^TMP("IBJDF4",$J,IBPAT,0,"C",IB0,IBIDX,IBA1,X1)=COM(X1)
;
I '$G(IBEXCEL),IBFLG D
. S $P(^TMP("IBJDF4",$J,IBPAT,IB0,IBCAT,IBBN),"^",6)=IBIDX
Q
; IB*2.0*451 - Use Event Date to find an associated 3rd Party bill with an associated EEOB
IBEEOBCK(IBBN,DFN) ; Passed AR Bill, Patient ID
; Function will quit as soon as a 3rd party bill is located that has an associated EEOB
;
; Find 3rd Party Bills with an Event Date
N IBREF,IBEEOB,IBDT
S IBEEOB=""
; Loop through Xref of ARbill (#430) to Action file (#350)
I +$G(IBBN) S IBREF=0 F S IBREF=$O(^IB("ABIL",IBBN,IBREF)) Q:'IBREF D Q:IBEEOB="%"
. S IBDT=$P($G(^IB(IBREF,0)),"^",17) ;Get event Date
. I IBDT S IBEEOB=$$TPEVDT(DFN,IBDT)
. I IBDT S IBEEOB=$$TPOPV(DFN,IBDT)
;
Q IBEEOB
;
; IB*2.0*451 - Traverse all THIRD PARTY bills for a patient with a specific Event Date (399,.03)
TPEVDT(DFN,EVDT) ;
; Function will quit as soon as a 3rd party bill is located that has an associated EEOB
; IB*2.0*473 - Use the 399,"APDT" (by patient) index instead of the 399,"D" index for efficiency
I '$G(DFN)!'$G(EVDT) Q ""
N IBIFN,IBEEOB
S IBEEOB="",IBIFN=""
F S IBIFN=$O(^DGCR(399,"APDT",DFN,IBIFN),-1) Q:'IBIFN D Q:IBEEOB="%"
. I $D(^DGCR(399,"APDT",DFN,IBIFN,9999999-EVDT)) S IBEEOB=$$EEOBCK(IBIFN)
Q IBEEOB
;
; IB*2.0*451 - Traverse all THIRD PARTY bills for a patient with any Opt Visit Dates same as Event Date (399,43)
TPOPV(DFN,EVDT) ;
; Function will quit as soon as a 3rd party bill is located that has an associated EEOB
N IBIFN,IBEEOB
S IBEEOB=""
I +$G(DFN),+$G(EVDT) S IBIFN=0 F S IBIFN=$O(^DGCR(399,"AOPV",DFN,EVDT,IBIFN)) Q:'IBIFN D Q:IBEEOB="%"
. ; attach EOB indicator '%' to bill # when applicable
. S IBEEOB=$$EEOBCK(IBIFN)
Q IBEEOB
;
; IB*2.0*451 - Check for EEOB indicator
EEOBCK(IBBILL) ;
; Check for 1st and 3rd party payment activity on bill
; IBBILL is the IEN for the bill # in files #399/#430 and must be valid,
; check the EOB type and exclude it if it is an MRA. Otherwise,
; returns the EEOB indicator '%' if payment activity was found.
; Access to file #361.1 covered by IA #4051.
; Access to file #399 covered by IA #3820.
N IBOUT,IBVAL,Z
I $G(IBBILL)=0 Q ""
I '$O(^IBM(361.1,"B",IBBILL,0)) Q "" ; no entry here
I $P($G(^DGCR(399,IBBILL,0)),"^",13)=1 Q "" ;avoid 'ENTERED/NOT REVIEWED' status
; handle both single and multiple bill entries in file #361.1
S Z=0 F S Z=$O(^IBM(361.1,"B",IBBILL,Z)) Q:'Z D Q:$G(IBOUT)="%"
. S IBVAL=$G(^IBM(361.1,Z,0))
. S IBOUT=$S($P(IBVAL,"^",4)=1:"",$P(IBVAL,"^",4)=0:"%",1:"")
Q IBOUT ; EOB indicator for either 1st or 3rd party payment on bill
;
;
SUST(IBA) ;Look for suspended type for a suspended bill IB*2*568/DRF
N TRANS,ST,STIEN
S IBA=$G(IBA) I IBA="" Q ""
S ST=""
; IB*2.0*715
S TRANS="" F S TRANS=$O(^PRCA(433,"C",IBA,TRANS),-1) Q:'TRANS Q:$$GET1^DIQ(433,TRANS_",",12)="CHARGE SUSPENDED"
I TRANS>0 S STIEN=$P($G(^PRCA(433,TRANS,1)),U,12) S:STIEN ST=$$GET1^DIQ(433.001,STIEN_",",.01)
I ST="" S ST=$P($G(^PRCA(433,TRANS,1)),U,11) ; if no type, try to get it from the old field 433/90
I ST="" S ST=14 ; if still no type, set it to NONE
;
Q ST
;
;
ABBR(SUSP) ;Return abbreviation for suspended bill types IB*2*568/DRF
S SUSP=$G(SUSP)
I SUSP=0 Q "NonCoS"
I SUSP=1 Q "IniCoS"
I SUSP=2 Q "AplCoW"
I SUSP=3 Q "AdminS"
I SUSP=4 Q "Compro"
I SUSP=5 Q "Termin"
I SUSP=6 Q "BnkCh7"
I SUSP=7 Q "BnkC13"
I SUSP=8 Q "BnkOth"
I SUSP=9 Q "Probat"
I SUSP=10 Q "Choice"
I SUSP=11 Q "Disput"
; IB*2.0*715
I SUSP=12 Q "IndAtt"
I SUSP=13 Q "Compct"
I SUSP=14 Q "None"
;
Q ""
;
REPDATA(RPIEN,DAYS) ; - Return Repayment Plan information IB*2.0*694
;
; RPIEN - file 340.5 ien
; DAYS - Number of days over the due date for a payment not
; received to be considered defaulted.
;
; Output: String with the following "^" (up-arrow) pieces:
; 1. Repayment Plan Start Date (FM Format)
; 2. Balance (Repayment Plan)
; 3. Monthly Payment Amount
; 4. Due Date (day of the month)
; 5. Last Payment Date
; 6. Last Payment Amount
; 7. Number of Payments Due
; 8. Number of Payments Defaulted
; 9. Plan status (internal)
; or NULL if either no RPP data was found or plan was paid in full
;
N DATA,IENS,LPAMT,LPDT,PDEF,PDUE,RES,STATUS,TMPDT,Z
S RES="",IENS=RPIEN_","
D GETS^DIQ(340.5,IENS,".04;.06;.07;.11;2*;3*","I","DATA") I '$D(DATA) Q RES
S RES=$G(DATA(340.5,IENS,.04,"I")) ; start date - 340.5/.04
S $P(RES,U,2)=$G(DATA(340.5,IENS,.11,"I")) ; amount owed - 340.5/.11
S $P(RES,U,3)=$G(DATA(340.5,IENS,.06,"I")) ; monthly amount - 340.5/.06
S STATUS=$G(DATA(340.5,IENS,.07,"I")) ; plan status - 340.5/.07
S $P(RES,U,4)=28 ; due date
S (LPAMT,LPDT)=0,Z="" F S Z=$O(DATA(340.53,Z)) Q:Z="" S TMPDT=+$G(DATA(340.53,Z,.01,"I")) S:TMPDT>LPDT LPDT=TMPDT,LPAMT=+$G(DATA(340.53,Z,1,"I"))
I LPDT>0 S $P(RES,U,5)=LPDT,$P(RES,U,6)=LPAMT ; last payment date & amount
S (PDEF,PDUE)=0,Z="" F S Z=$O(DATA(340.52,Z)) Q:Z="" D
.I +$G(DATA(340.52,Z,1,"I"))=1 Q ; payment was made
.S PDUE=PDUE+1 ; inc. # of payments due
.I +$G(DATA(340.52,Z,2,"I"))=1 Q ; payment forborne
.I $$FMDIFF^XLFDT(DT,+$G(DATA(340.52,Z,.01,"I")))'<DAYS S PDEF=PDEF+1 ; inc. # of defaulted payments
.Q
I PDUE=0 Q "" ; plan was paid in full
S $P(RES,U,7)=PDUE,$P(RES,U,8)=PDEF,$P(RES,U,9)=STATUS ; #of payments due, # of defaulted payments, & plan status
Q RES
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJDF41 15938 printed Oct 16, 2024@18:23:27 Page 2
IBJDF41 ;ALB/RB - FIRST PARTY FOLLOW-UP REPORT (COMPILE) ;15-APR-00
+1 ;;2.0;INTEGRATED BILLING;**123,159,204,356,451,473,568,618,651,694,705,715,739**;21-MAR-94;Build 3
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Reference to FILE 433.001 in ICR #7321
+5 ;
ST ; - Tasked entry point.
+1 KILL IB,IBCAT,^TMP("IBJDF4",$JOB)
+2 SET IBQ=0
+3 ;
+4 ; - Set selected categories for report.
+5 IF IBSEL[1
SET IBCAT(2)=1
+6 IF IBSEL[2
SET IBCAT(1)=2
+7 IF IBSEL[3
SET IBCAT(18)=3
FOR X=22,23
SET IBCAT(X)=3
+8 IF IBSEL[4
FOR X=33:1:39
SET IBCAT(X)=4
+9 ; *** new code
+10 IF IBSEL[5
Begin DoDot:1
+11 FOR X=61:1:74
SET IBCAT(X)=5
+12 FOR X=81:1:85
SET IBCAT(X)=5
End DoDot:1
+13 ;
+14 ; - Print the header line for the Excel spreadsheet
+15 IF $GET(IBEXCEL)
DO PHDL
+16 ;
+17 ; - Find data required for report.
+18 FOR IB=16,19,40
Begin DoDot:1
+19 ; Active AR's only.
IF IBSTA="A"
IF IB'=16
QUIT
+20 ; Suspended AR's only.
IF IBSTA="S"
IF IB=16
QUIT
+21 IF IB'=40
Begin DoDot:2
+22 SET IBCAT=""
+23 FOR
SET IBCAT=$ORDER(IBCAT(IBCAT))
if IBCAT=""
QUIT
Begin DoDot:3
+24 DO INIT^IBJDF43
End DoDot:3
End DoDot:2
+25 SET IBA=0
+26 FOR
SET IBA=$ORDER(^PRCA(430,"AC",IB,IBA))
if 'IBA
QUIT
Begin DoDot:2
+27 DO PROC
End DoDot:2
if IBQ
QUIT
End DoDot:1
if IBQ
GOTO ENQ
+28 ;
+29 ; Print the report.
IF 'IBQ
IF '$GET(IBEXCEL)
DO EN^IBJDF42
+30 ;
ENQ KILL ^TMP("IBJDF4",$JOB)
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
GOTO ENQ1
+2 ;
+3 DO ^%ZISC
ENQ1 KILL IB,IB0,IBA,IBA1,IBADM,IBAGE,IBAR,IBAR1,IBBA,IBBN,IBBU,IBC,IBCAT,IBCAT1
+1 KILL IBELIG,IBEXCEL,IBFLG,IBAI,IBAIQ,IBIDX,IBIO,IBINT,IBN,IBPA,IBPD,IBPAT
+2 KILL IBPT,IBQ,IBRFD,IBRFT,IBSRC,IBRP,IBVA,COM,COM1,DAT,DFN,X,X1,X2,Y,Z
+3 QUIT
+4 ;
PROC ; - Process data for report(s).
+1 IF IBA#100=0
Begin DoDot:1
+2 SET IBQ=$$STOP^IBOUTL("First Party Follow-Up Report")
End DoDot:1
if IBQ
QUIT
+3 SET IBAR=$GET(^PRCA(430,IBA,0))
IF 'IBAR
QUIT
+4 ; Get valid AR category.
SET IBCAT=+$PIECE(IBAR,U,2)
IF '$DATA(IBCAT(IBCAT))
QUIT
+5 ; Invalid IB claim/action.
IF '$$CLMACT^IBJD(IBA,IBCAT)
QUIT
+6 SET IBSUSTYP=""
+7 IF IB=40
SET IBSUSTYP=$$SUST(IBA)
+8 ; Filter by suspended type IB*2*568/DRF
IF IBSTA="S"
IF IBSELST'[(","_IBSUSTYP_",")
QUIT
+9 ; Get patient info.
SET IBPT=$$PAT(IBA)
IF IBPT=""
QUIT
+10 SET DFN=$PIECE(IBPT,U,2)
+11 SET IBAGE=$$FMDIFF^XLFDT(DT,+$PIECE(IBAR,U,10))
+12 ; AR outside age range.
IF IBSMN
IF IBAGE<IBSMN!(IBAGE>IBSMX)
QUIT
+13 SET IBVA=$$VA^IBJD1(DFN)
SET IBBN=$PIECE(IBAR,U)
SET IBPD=$PIECE($$PYMT^IBJD1(IBA),U)
+14 SET IBPAT=$PIECE(IBPT,U)_"@@"_DFN
+15 ;
+16 ; - Check the AR balance amounts, if necessary.
+17 SET (IBADM,IBBA,IBINT,IBPA)=0
SET IBN=$GET(^PRCA(430,IBA,7))
+18 FOR X=1:1:5
Begin DoDot:1
+19 SET IBBA=IBBA+$PIECE(IBN,U,X)
+20 if X=1
SET IBPA=+IBN
if X=2
SET IBINT=$PIECE(IBN,U,2)
if X=3
SET IBADM=$PIECE(IBN,U,3)
End DoDot:1
+21 ;
+22 ; Get summary stats.
IF '$GET(IBEXCEL)
DO EN^IBJDF43
IF IBRPT="S"!(IBRPT="O")
QUIT
+23 ;
+24 IF IBSAM
IF IBBA<IBSAM
QUIT
+25 ;
+26 ; - Check if AR was referred to R-Regional Counsel, D-DMC, T-TOP,
+27 ; or C-CROSS SERVICING and exclude, if necessary.
+28 SET IB0=$SELECT(IB=40:19,1:IB)
SET IBIDX=0
SET IBRFT=""
+29 SET IBAIQ=0
SET IBAI=$GET(^TMP("IBJDF4",$JOB,IBPAT,0,"A"))
+30 SET IBRFD=$PIECE($GET(^PRCA(430,IBA,6)),U,4)
+31 ; Referred to RC
IF IBRPT="D"
IF IBRFD
Begin DoDot:1
+32 SET IBRFT="R"
IF IBAI'["R"
SET IBAI=IBAI_"R"
+33 IF 'IBSRC
SET IBAIQ=1
QUIT
+34 DO SREF("R",IBRFD,IB0,,.IBIDX)
End DoDot:1
IF IBAIQ
QUIT
+35 SET IBRFD=+$GET(^PRCA(430,IBA,12))
+36 ; Referred to DMC
IF IBRPT="D"
IF IBRFD
Begin DoDot:1
+37 SET IBRFT=IBRFT_"D"
IF IBAI'["D"
SET IBAI=IBAI_"D"
+38 DO SREF("D",IBRFD,IB0,,.IBIDX)
End DoDot:1
+39 SET IBRFD=+$GET(^PRCA(430,IBA,14))
+40 ; Referred to TOP
IF IBRPT="D"
IF IBRFD
Begin DoDot:1
+41 SET IBRFT=IBRFT_"T"
IF IBAI'["T"
SET IBAI=IBAI_"T"
+42 DO SREF("T",IBRFD,IB0,,.IBIDX)
End DoDot:1
+43 ; PRCA*4.5*338 added CS
+44 SET IBRFD=+$GET(^PRCA(430,IBA,15))
+45 ; Referred to CS
IF IBRPT="D"
IF IBRFD
Begin DoDot:1
+46 SET IBRFT=IBRFT_"C"
IF IBAI'["C"
SET IBAI=IBAI_"C"
+47 DO SREF("C",IBRFD,IB0,,.IBIDX)
End DoDot:1
+48 ;
+49 ; - Check if AR is on P-Repayment plan or F-Defaulted repayment plan.
+50 ; and exclude if repayment plan is active.
+51 SET IBRP=$$RP(IBA)
+52 IF IBRP
Begin DoDot:1
+53 IF IBRP=2
SET IBRFT=IBRFT_"F"
IF IBAI'["F"
SET IBAI=IBAI_"F"
+54 IF IBRP=1
SET IBRFT=IBRFT_"P"
IF IBAI'["P"&(IBAI'["F")
SET IBAI=IBAI_"P"
+55 DO SREF("P",$PIECE(IBRP,"^",2),IB0,$SELECT(+IBRP=2:1,1:0),.IBIDX)
End DoDot:1
+56 ;
+57 IF IBIDX
SET IBFLG=1
+58 ;
+59 ; - Check if VA Employee
+60 IF $PIECE(IBVA,"^")["*"
IF IBAI'["V"
SET IBAI=IBAI_"V"
+61 ;
+62 IF IBAI'=""
SET ^TMP("IBJDF4",$JOB,IBPAT,0,"A")=IBAI
+63 ;
+64 ; IB*2.0*451 - Check for EEOB on associated 3rd party bills and attach EOB indicator '%' if applicable
+65 ; Pass AR BILL#, Pat ID
SET IBBN=$$IBEEOBCK(IBBN,DFN)_IBBN
+66 ;
+67 ; - Set up indexes for detail report.
+68 IF $GET(IBEXCEL)
Begin DoDot:1
+69 ;IB*2.0*739
SET IBEXCEL1=$PIECE($GET(^PRCA(430.2,IBCAT,0)),U,2)_U_$PIECE(IBPT,U,3)_U_$PIECE(IBVA,U)_U_U_$$DT^IBJD($PIECE(IBPT,U,6),1)_U_$$ELIG^IBJDF42(+$PIECE(IBPT,U,5))_U
+70 SET IBEXCEL1=IBEXCEL1_$$GET1^DIQ(2,DFN,.381)_U_$$MTRX(DFN)_U_IBBN_U_$SELECT(IB=16:"A",1:"S")_U_$SELECT("BS"[IBSTA:$$ABBR($GET(IBSUSTYP)),1:"")_U_IBRFT_U_$$DT^IBJD($PIECE(IBAR,U,10),1)_U_$$DT^IBJD(IBPD,1)_U_IBBA_U_IBPA_U_IBINT_U_IBADM_U
+71 IF IBSH
DO COM
+72 SET IBD=0
IF DAT!IBPD
SET IBD=$$FMDIFF^XLFDT(DT,$SELECT('DAT:IBPD,1:$GET(DAT)))
+73 SET IBEXCEL1=IBEXCEL1_U_IBD
+74 WRITE !,IBEXCEL1
KILL IBD,IBEXCEL1
End DoDot:1
QUIT
+75 ;
+76 IF '($DATA(^TMP("IBJDF4",$JOB,IBPAT))#10)
Begin DoDot:1
+77 SET ^TMP("IBJDF4",$JOB,IBPAT)=$PIECE(IBPT,U,3,5)_U_$$MTRX(DFN)_U_$PIECE(IBPT,U,6)_"^"_$PIECE(IBVA,"^",2)_"^"_$$ACCBAL($PIECE(IBPT,U,7))
End DoDot:1
+78 SET ^TMP("IBJDF4",$JOB,IBPAT,IB0,IBCAT,IBBN)=IBPD_U_IBBA_U_IBPA_U_IBINT_U_IBADM_U_IBIDX_U_$SELECT($DATA(IBSUSTYP):IBSUSTYP,1:"")
+79 ;
+80 IF IBSH
DO COM
+81 QUIT
+82 ;
ACCBAL(DFN) ; Calculates the Account Balance for the Bill
+1 ; Input: DFN - Patient/Debtor internal number
+2 ; Output: BAL - Patient/Debtor Account Balance
+3 ;
+4 NEW B0,B7,BAL,BILL,I
+5 SET (BAL,BILL)=0
+6 FOR
SET BILL=$ORDER(^PRCA(430,"C",DFN,BILL))
if BILL=""
QUIT
Begin DoDot:1
+7 SET B0=$GET(^PRCA(430,BILL,0))
IF $PIECE(B0,"^",8)'=16
QUIT
+8 SET B7=$GET(^PRCA(430,BILL,7))
+9 FOR I=1:1:5
SET BAL=BAL+$PIECE(B7,"^",I)
End DoDot:1
+10 QUIT BAL
+11 ;
PHDL ; - Print the header line for the Excel spreadsheet
+1 NEW X
+2 ;IB*2.0*739
SET X="Cat^Patient^VA Empl.?^^Dt Death^Prim.Elig.^Med.Elig.?^"
+3 SET X=X_"Means Tst Sts^Means Tst Dt^RX Copay Exemp.Sts^RX Copay Exemp.Dt^"
+4 ;Added reason IB*2*568/DRF
SET X=X_"Bill #^Act/Susp^Reason^Refer. to^Dt Bill prep.^Last Pymt Dt^"
+5 SET X=X_"Curr.Bal.^Princ.Bal.^Int.^Admin.^Last Comm.Dt^Days Lst Comm.^"
+6 WRITE !,X
+7 QUIT
+8 ;
PAT(X) ; - Find the AR patient and decide to include the AR.
+1 ; Input: X=AR pointer to file #430 and pre-set variables IBS*
+2 ; Output: Y=Sort key (name or last 4) ^ Patient pointer to file #2
+3 ; ^ Name ^ SSN ^ Eligibilities ^ Date of death (if any)
+4 ; ^ Debtor pointer to file #340
+5 NEW PAT,KEY,DBTR,DFN,DEATH,NAME,SSN,VAEL,VADM,X1,X2
+6 SET PAT=""
if '$GET(X)
GOTO PATQ
+7 SET DBTR=+$PIECE($GET(^PRCA(430,X,0)),U,9)
+8 SET X1=$PIECE($GET(^RCD(340,DBTR,0)),U)
if X1'["DPT"
GOTO PATQ
+9 SET DFN=+X1
if 'DFN
GOTO PATQ
DO DEM^VADPT
+10 SET NAME=VADM(1)
SET SSN=$PIECE(VADM(2),"^")
SET DEATH=VADM(6)\1
+11 SET KEY=$SELECT(IBSN="N":NAME,1:$EXTRACT(SSN,6,9))
+12 IF KEY=""!(IBSNF'="@"&('DFN))
GOTO PATQ
+13 IF $DATA(IBSNA)
if IBSNA="ALL"&('DFN)
GOTO PATQ
if IBSNA="NULL"&(DFN)
GOTO PATQ
+14 IF $GET(IBSNA)="ALL"
GOTO PATC
+15 IF IBSNF="@"
IF IBSNL="zzzzz"
GOTO PATC
+16 IF IBSNF'=KEY
IF IBSNF]KEY
GOTO PATQ
+17 IF IBSNL'=KEY
IF KEY]IBSNL
GOTO PATQ
+18 ;
PATC ; - Set patient eligibilities.
+1 DO ELIG^VADPT
SET X2=+$GET(VAEL(1))_";"
+2 IF +X2
SET X1=0
FOR
SET X1=$ORDER(VAEL(1,X1))
if 'X1
QUIT
SET X2=X2_X1_";"
+3 ;
+4 SET PAT=KEY_U_DFN_U_$EXTRACT(NAME,1,26)_U_SSN_U_X2_U_DEATH
+5 SET PAT=PAT_U_DBTR
PATQ QUIT PAT
+1 ;
RP(X) ; - Check if claim/receivable is under a repayment plan.
+1 ; Input: X=Bill pointer to file #430
+2 ; Output: 0-Not on repay plan, 1-On repay plan, 2-On defaulted plan
+3 NEW RPIEN,Z
+4 ; IB*2.0*694
+5 ; file 340.5 ien
SET RPIEN=$PIECE($GET(^PRCA(430,X,4)),U,5)
+6 SET Z=$$REPDATA(RPIEN,1)
IF Z=""
QUIT 0
+7 ; IB*2.0*694
IF $PIECE(Z,U,9)=5
QUIT ("2^"_$PIECE(Z,U))
+8 ;
+9 ; IB*2.0*694
QUIT ("1^"_$PIECE(Z,U))
+10 ;
MTRX(X) ; - Return patient's means test and/or RX copay status and most recent
+1 ; test dates for both.
+2 ; Input: X=Patient pointer to file #2 and opt. variable IBEXCEL
+3 ; Output: Y=Means test status ^ Date ^ RX copay status ^ Date
+4 NEW MTST,RXST,Y
+5 SET Y="^^^"
SET MTST=$$LST^DGMTU(X)
SET RXST=$$RXST^IBARXEU(X)
+6 IF '$GET(IBEXCEL)
Begin DoDot:1
+7 SET $PIECE(Y,"^",1,2)=$PIECE(MTST,"^",3)_"^"_$$DAT1^IBOUTL($PIECE(MTST,"^",2))
+8 SET $PIECE(Y,"^",3)=$SELECT('RXST:"NON-EXEMPT",+RXST=1:"EXEMPT",1:"")
+9 IF $PIECE(Y,"^",3)'=""
SET $PIECE(Y,"^",4)=$$DAT1^IBOUTL($PIECE(RXST,"^",5))
End DoDot:1
+10 IF $GET(IBEXCEL)
Begin DoDot:1
+11 SET $PIECE(Y,"^",1,2)=$PIECE(MTST,"^",4)_"^"_$$DT^IBJD($PIECE(MTST,"^",2),1)
+12 SET $PIECE(Y,"^",3)=$SELECT('RXST:"M",+RXST=1:"E",1:"")
+13 IF $PIECE(Y,"^",3)'=""
SET $PIECE(Y,"^",4)=$$DT^IBJD($PIECE(RXST,"^",5),1)
End DoDot:1
+14 QUIT Y
+15 ;
SREF(RFT,DAT,STS,DEF,IDX) ; Set the "referred to" information on the
+1 ; temporary global ^TMP
+2 ;Input: RFT: "R": RC, "D": DMC, "T": TOP, "C": CROSS SERVICING, "P": REPAYMENT PLAN
+3 ; DAT: Date it was referred/established
+4 ; STS: Receivable status (16-Active,19-Suspended)
+5 ; DEF: Repayment Plan in Default? (1 - YES, 0 - NO)
+6 ; IDX: Subscript to be set in the Temporary global ^TMP
+7 ;Output: IDX: Subscript set in the Temporary global ^TMP
+8 ;
+9 NEW SREF,IDX1
+10 SET DEF=+$GET(DEF)
SET IDX=+$GET(IDX)
+11 IF RFT="R"
SET SREF="REFERRED TO RC"
+12 IF RFT="D"
SET SREF="REFERRED TO DMC"
+13 IF RFT="T"
SET SREF="REFERRED TO TOP"
+14 ; PRCA*4.5*338
IF RFT="C"
SET SREF="REFERRED TO CS"
+15 IF RFT="P"
Begin DoDot:1
+16 SET SREF="REPAYMENT PLAN ESTABLISHED"
+17 IF $GET(DEF)
SET SREF=SREF_" (CURRENTLY IN DEFAULT)"
End DoDot:1
+18 ;
+19 IF 'IDX
SET IDX=$ORDER(^TMP("IBJDF4",$JOB,IBPAT,0,"C",STS,""),-1)+1
+20 SET IDX1=$ORDER(^TMP("IBJDF4",$JOB,IBPAT,0,"C",STS,IDX,""),-1)+1
+21 SET ^TMP("IBJDF4",$JOB,IBPAT,0,"C",STS,IDX,IDX1)=DAT
+22 SET ^TMP("IBJDF4",$JOB,IBPAT,0,"C",STS,IDX,IDX1,1)=SREF
+23 QUIT
+24 ;
COM ; - Get bill comments.
+1 IF 'IBIDX
IF '$GET(IBEXCEL)
Begin DoDot:1
+2 SET IBFLG=0
SET IBIDX=$ORDER(^TMP("IBJDF4",$JOB,IBPAT,0,"C",IB0,""),-1)+1
End DoDot:1
+3 ;
+4 SET DAT=0
SET IBA1=$SELECT(IBSH1="M":999999999,1:0)
+5 FOR
SET IBA1=$SELECT(IBSH1="M":$ORDER(^PRCA(433,"C",IBA,IBA1),-1),1:$ORDER(^PRCA(433,"C",IBA,IBA1)))
if 'IBA1
QUIT
Begin DoDot:1
+6 SET IBC=$GET(^PRCA(433,IBA1,1))
if 'IBC
QUIT
+7 ; Comment age not minimum.
IF $GET(IBSH2)
IF $$FMDIFF^XLFDT(DT,+IBC)>IBSH2
QUIT
+8 ; Not decrease/comment transact.
IF $PIECE(IBC,U,2)'=35
IF $PIECE(IBC,U,2)'=45
QUIT
+9 SET DAT=$SELECT(IBC:+IBC\1,1:+$PIECE(IBC,U,9)\1)
+10 IF $GET(IBEXCEL)
IF IBSH1="M"
SET IBEXCEL1=IBEXCEL1_$$DT^IBJD(DAT,1)
QUIT
+11 ;
+12 ; - Append brief and transaction comments.
+13 KILL COM,COM1
SET COM(0)=DAT
SET X1=0
+14 SET COM1(1)=$PIECE($GET(^PRCA(433,IBA1,5)),U,2)
+15 SET COM1(2)=$EXTRACT($PIECE($GET(^PRCA(433,IBA1,8)),U,6),1,70)
+16 SET COM(1)=COM1(1)_$SELECT(COM1(1)]""&(COM1(2)]""):"|",1:"")_COM1(2)
+17 IF COM(1)]""
SET COM(1)="**"_COM(1)_"**"
SET X1=1
+18 ;
+19 ; - Get main comments.
+20 SET X2=0
+21 FOR
SET X2=$ORDER(^PRCA(433,IBA1,7,X2))
if 'X2
QUIT
Begin DoDot:2
+22 SET COM($SELECT(X1:X2+1,1:X2))=^PRCA(433,IBA1,7,X2,0)
End DoDot:2
+23 ;
+24 IF $GET(IBEXCEL)
QUIT
+25 ;
+26 SET IBFLG=1
SET ^TMP("IBJDF4",$JOB,IBPAT,0,"C",IB0,IBIDX,IBA1)=$GET(COM(0))
SET X1=0
+27 FOR
SET X1=$ORDER(COM(X1))
if X1=""
QUIT
Begin DoDot:2
+28 SET ^TMP("IBJDF4",$JOB,IBPAT,0,"C",IB0,IBIDX,IBA1,X1)=COM(X1)
End DoDot:2
End DoDot:1
IF IBSH1="M"
IF DAT
QUIT
+29 ;
+30 IF '$GET(IBEXCEL)
IF IBFLG
Begin DoDot:1
+31 SET $PIECE(^TMP("IBJDF4",$JOB,IBPAT,IB0,IBCAT,IBBN),"^",6)=IBIDX
End DoDot:1
+32 QUIT
+33 ; IB*2.0*451 - Use Event Date to find an associated 3rd Party bill with an associated EEOB
IBEEOBCK(IBBN,DFN) ; Passed AR Bill, Patient ID
+1 ; Function will quit as soon as a 3rd party bill is located that has an associated EEOB
+2 ;
+3 ; Find 3rd Party Bills with an Event Date
+4 NEW IBREF,IBEEOB,IBDT
+5 SET IBEEOB=""
+6 ; Loop through Xref of ARbill (#430) to Action file (#350)
+7 IF +$GET(IBBN)
SET IBREF=0
FOR
SET IBREF=$ORDER(^IB("ABIL",IBBN,IBREF))
if 'IBREF
QUIT
Begin DoDot:1
+8 ;Get event Date
SET IBDT=$PIECE($GET(^IB(IBREF,0)),"^",17)
+9 IF IBDT
SET IBEEOB=$$TPEVDT(DFN,IBDT)
+10 IF IBDT
SET IBEEOB=$$TPOPV(DFN,IBDT)
End DoDot:1
if IBEEOB="%"
QUIT
+11 ;
+12 QUIT IBEEOB
+13 ;
+14 ; IB*2.0*451 - Traverse all THIRD PARTY bills for a patient with a specific Event Date (399,.03)
TPEVDT(DFN,EVDT) ;
+1 ; Function will quit as soon as a 3rd party bill is located that has an associated EEOB
+2 ; IB*2.0*473 - Use the 399,"APDT" (by patient) index instead of the 399,"D" index for efficiency
+3 IF '$GET(DFN)!'$GET(EVDT)
QUIT ""
+4 NEW IBIFN,IBEEOB
+5 SET IBEEOB=""
SET IBIFN=""
+6 FOR
SET IBIFN=$ORDER(^DGCR(399,"APDT",DFN,IBIFN),-1)
if 'IBIFN
QUIT
Begin DoDot:1
+7 IF $DATA(^DGCR(399,"APDT",DFN,IBIFN,9999999-EVDT))
SET IBEEOB=$$EEOBCK(IBIFN)
End DoDot:1
if IBEEOB="%"
QUIT
+8 QUIT IBEEOB
+9 ;
+10 ; IB*2.0*451 - Traverse all THIRD PARTY bills for a patient with any Opt Visit Dates same as Event Date (399,43)
TPOPV(DFN,EVDT) ;
+1 ; Function will quit as soon as a 3rd party bill is located that has an associated EEOB
+2 NEW IBIFN,IBEEOB
+3 SET IBEEOB=""
+4 IF +$GET(DFN)
IF +$GET(EVDT)
SET IBIFN=0
FOR
SET IBIFN=$ORDER(^DGCR(399,"AOPV",DFN,EVDT,IBIFN))
if 'IBIFN
QUIT
Begin DoDot:1
+5 ; attach EOB indicator '%' to bill # when applicable
+6 SET IBEEOB=$$EEOBCK(IBIFN)
End DoDot:1
if IBEEOB="%"
QUIT
+7 QUIT IBEEOB
+8 ;
+9 ; IB*2.0*451 - Check for EEOB indicator
EEOBCK(IBBILL) ;
+1 ; Check for 1st and 3rd party payment activity on bill
+2 ; IBBILL is the IEN for the bill # in files #399/#430 and must be valid,
+3 ; check the EOB type and exclude it if it is an MRA. Otherwise,
+4 ; returns the EEOB indicator '%' if payment activity was found.
+5 ; Access to file #361.1 covered by IA #4051.
+6 ; Access to file #399 covered by IA #3820.
+7 NEW IBOUT,IBVAL,Z
+8 IF $GET(IBBILL)=0
QUIT ""
+9 ; no entry here
IF '$ORDER(^IBM(361.1,"B",IBBILL,0))
QUIT ""
+10 ;avoid 'ENTERED/NOT REVIEWED' status
IF $PIECE($GET(^DGCR(399,IBBILL,0)),"^",13)=1
QUIT ""
+11 ; handle both single and multiple bill entries in file #361.1
+12 SET Z=0
FOR
SET Z=$ORDER(^IBM(361.1,"B",IBBILL,Z))
if 'Z
QUIT
Begin DoDot:1
+13 SET IBVAL=$GET(^IBM(361.1,Z,0))
+14 SET IBOUT=$SELECT($PIECE(IBVAL,"^",4)=1:"",$PIECE(IBVAL,"^",4)=0:"%",1:"")
End DoDot:1
if $GET(IBOUT)="%"
QUIT
+15 ; EOB indicator for either 1st or 3rd party payment on bill
QUIT IBOUT
+16 ;
+17 ;
SUST(IBA) ;Look for suspended type for a suspended bill IB*2*568/DRF
+1 NEW TRANS,ST,STIEN
+2 SET IBA=$GET(IBA)
IF IBA=""
QUIT ""
+3 SET ST=""
+4 ; IB*2.0*715
+5 SET TRANS=""
FOR
SET TRANS=$ORDER(^PRCA(433,"C",IBA,TRANS),-1)
if 'TRANS
QUIT
if $$GET1^DIQ(433,TRANS_",",12)="CHARGE SUSPENDED"
QUIT
+6 IF TRANS>0
SET STIEN=$PIECE($GET(^PRCA(433,TRANS,1)),U,12)
if STIEN
SET ST=$$GET1^DIQ(433.001,STIEN_",",.01)
+7 ; if no type, try to get it from the old field 433/90
IF ST=""
SET ST=$PIECE($GET(^PRCA(433,TRANS,1)),U,11)
+8 ; if still no type, set it to NONE
IF ST=""
SET ST=14
+9 ;
+10 QUIT ST
+11 ;
+12 ;
ABBR(SUSP) ;Return abbreviation for suspended bill types IB*2*568/DRF
+1 SET SUSP=$GET(SUSP)
+2 IF SUSP=0
QUIT "NonCoS"
+3 IF SUSP=1
QUIT "IniCoS"
+4 IF SUSP=2
QUIT "AplCoW"
+5 IF SUSP=3
QUIT "AdminS"
+6 IF SUSP=4
QUIT "Compro"
+7 IF SUSP=5
QUIT "Termin"
+8 IF SUSP=6
QUIT "BnkCh7"
+9 IF SUSP=7
QUIT "BnkC13"
+10 IF SUSP=8
QUIT "BnkOth"
+11 IF SUSP=9
QUIT "Probat"
+12 IF SUSP=10
QUIT "Choice"
+13 IF SUSP=11
QUIT "Disput"
+14 ; IB*2.0*715
+15 IF SUSP=12
QUIT "IndAtt"
+16 IF SUSP=13
QUIT "Compct"
+17 IF SUSP=14
QUIT "None"
+18 ;
+19 QUIT ""
+20 ;
REPDATA(RPIEN,DAYS) ; - Return Repayment Plan information IB*2.0*694
+1 ;
+2 ; RPIEN - file 340.5 ien
+3 ; DAYS - Number of days over the due date for a payment not
+4 ; received to be considered defaulted.
+5 ;
+6 ; Output: String with the following "^" (up-arrow) pieces:
+7 ; 1. Repayment Plan Start Date (FM Format)
+8 ; 2. Balance (Repayment Plan)
+9 ; 3. Monthly Payment Amount
+10 ; 4. Due Date (day of the month)
+11 ; 5. Last Payment Date
+12 ; 6. Last Payment Amount
+13 ; 7. Number of Payments Due
+14 ; 8. Number of Payments Defaulted
+15 ; 9. Plan status (internal)
+16 ; or NULL if either no RPP data was found or plan was paid in full
+17 ;
+18 NEW DATA,IENS,LPAMT,LPDT,PDEF,PDUE,RES,STATUS,TMPDT,Z
+19 SET RES=""
SET IENS=RPIEN_","
+20 DO GETS^DIQ(340.5,IENS,".04;.06;.07;.11;2*;3*","I","DATA")
IF '$DATA(DATA)
QUIT RES
+21 ; start date - 340.5/.04
SET RES=$GET(DATA(340.5,IENS,.04,"I"))
+22 ; amount owed - 340.5/.11
SET $PIECE(RES,U,2)=$GET(DATA(340.5,IENS,.11,"I"))
+23 ; monthly amount - 340.5/.06
SET $PIECE(RES,U,3)=$GET(DATA(340.5,IENS,.06,"I"))
+24 ; plan status - 340.5/.07
SET STATUS=$GET(DATA(340.5,IENS,.07,"I"))
+25 ; due date
SET $PIECE(RES,U,4)=28
+26 SET (LPAMT,LPDT)=0
SET Z=""
FOR
SET Z=$ORDER(DATA(340.53,Z))
if Z=""
QUIT
SET TMPDT=+$GET(DATA(340.53,Z,.01,"I"))
if TMPDT>LPDT
SET LPDT=TMPDT
SET LPAMT=+$GET(DATA(340.53,Z,1,"I"))
+27 ; last payment date & amount
IF LPDT>0
SET $PIECE(RES,U,5)=LPDT
SET $PIECE(RES,U,6)=LPAMT
+28 SET (PDEF,PDUE)=0
SET Z=""
FOR
SET Z=$ORDER(DATA(340.52,Z))
if Z=""
QUIT
Begin DoDot:1
+29 ; payment was made
IF +$GET(DATA(340.52,Z,1,"I"))=1
QUIT
+30 ; inc. # of payments due
SET PDUE=PDUE+1
+31 ; payment forborne
IF +$GET(DATA(340.52,Z,2,"I"))=1
QUIT
+32 ; inc. # of defaulted payments
IF $$FMDIFF^XLFDT(DT,+$GET(DATA(340.52,Z,.01,"I")))'<DAYS
SET PDEF=PDEF+1
+33 QUIT
End DoDot:1
+34 ; plan was paid in full
IF PDUE=0
QUIT ""
+35 ; #of payments due, # of defaulted payments, & plan status
SET $PIECE(RES,U,7)=PDUE
SET $PIECE(RES,U,8)=PDEF
SET $PIECE(RES,U,9)=STATUS
+36 QUIT RES
