FBPCR ;AISC/DMK,GRR,TET-POTENTIAL COST RECOVERY OUTPUT DRIVER ;5/23/2006
;;3.5;FEE BASIS;**12,48,76,98,103,135,163**;JAN 30, 1995;Build 21
;Per VA Directive 6402, this routine should not be modified.
; DBIA SUPPORTED REF $$NPI^XUSNPI = 4532
DOC ;Refer to fbdoc, tag fbpcr, for documentation of fbpcr* routines
PSF ;select one/many/all primary service failities
K FBBILL,FBNPB,FBADJ,FBADJR,FBPVL133,FBINV,FBPVLIST,Y ;FB*3.5*163
S FBARRLTC=""
W !! S DIC="^DIC(4,",VAUTSTR="Primary Service Facility",VAUTNI=2,VAUTVB="FBPSV" D FIRST^VAUTOMA K DIC I Y=-1 G EXIT
ARRAY ;set fee program array for all programs
S FBPI=0 F S FBPI=$O(^FBAA(161.8,FBPI)) Q:'FBPI S FBPIN=$G(^(FBPI,0)) I $P(FBPIN,U,3) S FBPROG(FBPI)=$P(FBPIN,U)
I '$D(FBPROG) G EXIT
;prepare array with LTC POV codes
D MKARRLTC^FBPCR4
;what party to include
K DIR
S DIR(0)="SO^P:Patient;I:Insurance;B:Both",DIR("A")="Include (P)atient Co-pays / (I)nsurance / (B)oth",DIR("B")="Both"
S DIR("?")=" Select type of recover to include",DIR("?",1)=" P - include only recover from patient copays",DIR("?",2)=" I - include only recover from insurance",DIR("?",3)=" B - include both",DIR("L")=""
D ^DIR S FBPARTY=$S($G(Y(0))="Patient":1,$G(Y(0))="Insurance":2,$G(Y(0))="Both":3,X="Both":3,1:0)
K DIR
G:FBPARTY=0 EXIT
;what type of copay to include
S FBCOPAY=3
I FBPARTY'=2 D
. S DIR(0)="SO^M:MeansTest;L:LTC;B:Both",DIR("A")="Include (M)eans Test Co-pays /(L)TC Co-pays /(B)oth",DIR("B")="Both"
. S DIR("?")=" Select services to include",DIR("?",1)=" M - include only Means Test copays",DIR("?",2)=" L - include only LTC copays",DIR("?",3)=" B - include both",DIR("L")=""
. D ^DIR S FBCOPAY=$S($G(Y(0))="LTC":1,$G(Y(0))="MeansTest":2,$G(Y(0))="Both":3,X="Both":3,1:0)
. K DIR
G:FBCOPAY=0 EXIT
;
;include patients if their insurance informations is unavailable?
S FBINCUNK=0
I FBPARTY=2!(FBPARTY=3) D
. S FBINCUNK=1
. N Y,X
. W !!
. S DIR("A")="Do you want to include patients whose insurance status is unavailable? "
. S DIR("?")="Please answer Yes or No."
. S DIR("B")="YES",DIR(0)="YA^^"
. D ^DIR K DIR
. I $G(DIRUT) S FBINCUNK=-1 Q
. I $G(Y)=0 S FBINCUNK=0
I FBINCUNK=-1 G EXIT ;uparrow - exit
N FBINEXCL ; FB*3.5*135
D EXCLINS ;select insurances to be excluded ; FB*3.5*135
;
PREBL ;Include Only Not Previously Billed NVC FB*3.5*163
N Y,X
W !
S DIR("A")="Include only Non VA Care not previously billed to third party carrier: "
S DIR("?")="Please answer Yes or No."
S DIR("B")="YES",DIR(0)="YA^^"
D ^DIR K DIR
S FBNPB=Y
;
DATE ;select date range
D DATE^FBAAUTL I FBPOP G PSF
S FBBDATE=BEGDATE,FBEDATE=ENDDATE
S Z=9999999.9999,FBBEG=Z-FBEDATE,FBEND=Z-FBBDATE
Q K ^TMP($J,"FB"),^TMP($J,"FBINSIBAPI"),DIC
;
S VAR="FBINCUNK^FBARRLTC^FBARRLTC(^FBPARTY^FBCOPAY^FBNAME^FBIEN^FBID^FBBEG^FBEND^FBBDATE^FBEDATE^FBPSV^FBPSV(^FBPROG(",VAL=VAR,PGM="DQ^FBPCR",IOP="Q" D ZIS^FBAAUTL G:FBPOP EXIT
DQ S $P(FBDASH,"=",80)="",$P(FBDASH1,"-",80)="",FBPG=0,FBCRT=$S($E(IOST,1,2)="C-":1,1:0),FBOUT=0,FBBEG=FBBEG-.9 U IO
SORT ;sort driver for payment output(s)
S FBPI=0 F S FBPI=$O(FBPROG(FBPI)) Q:'FBPI S FBXPROG=FBPROG(FBPI) D
.I FBPI=2 D EN^FBPCR2 ;outpatient payments
.I FBPI=3 D EN^FBPCR3 ;pharmacy payments
.I FBPI=6!(FBPI=7) S:FBPI=6&($D(FBPROG(7))) FBPI=67 D EN^FBPCR67 S:FBPI=67 FBPI=7 ;civil hospital/cnh payments
PRINT ;print driver for payment output(s)
I $G(^TMP($J,"FBINSIBAPI"))>0 D HDRUNK
S FBPI=$O(^TMP($J,"FB",0)) I FBPI']"" D WMSG G OUT
S FBSTA=0
S FBFIRST=0 ; FB*3.5*163
S FBPSF=0 F S FBPSF=$O(^TMP($J,"FB",FBPSF)) Q:'FBPSF!FBOUT D STA S FBPT="" F S FBPT=$O(^TMP($J,"FB",FBPSF,FBPT)) Q:FBPT']""!FBOUT S DFN=$P(FBPT,";",2) D VET S FBPI=0 F S FBPI=$O(FBPROG(FBPI)) Q:'FBPI S FBXPROG=FBPROG(FBPI) D Q:FBOUT
.I FBPSF_FBPT'=FBSTA D HDR Q:FBOUT
.I FBPI=2,$D(^TMP($J,"FB",FBPSF,FBPT,FBPI)) D PRINT^FBPCR2 Q
.I FBPI=3 D:$D(^TMP($J,"FB",FBPSF,FBPT,FBPI)) PRINT^FBPCR3 Q
.I FBPI=6!(FBPI=7) D:$D(^TMP($J,"FB",FBPSF,FBPT,FBPI)) PRINT^FBPCR671 Q
OUT I $G(^TMP($J,"FBINSIBAPI"))>0 D ERRHDL^FBPCR4
I FBFIRST=0 D WMSG ; FB*3.5*163
I FBOUT!$D(ZTQUEUED) G EXIT
D EXIT G PSF
Q
;
EXCLINS ;create list of insurance type to be excluded ; FB*3.5*135
N Y,X,DIC,DTOUT,DUOUT,DIR,DIRUT,DIROUT
K FBINEXCL S FBINEXCL=0,X=1
W !!!,"Select the TYPE of INSURANCE PLANS to be EXCLUDED from the PCR report:"
F Q:$G(X)="" S DIC="^IBE(355.1,",DIC(0)="QEAFIBS",DIC("S")="I '$P($G(^(0)),U,4)" K X,Y D ^DIC I $G(Y)>0 S FBINEXCL(+Y)=$P(Y,U,2),FBINEXCL("INS",$P(Y,U,2))=+Y
S FBINEXCL="A",X=0 F S FBINEXCL=$O(FBINEXCL("INS",FBINEXCL)) Q:FBINEXCL="" W:'X !!,"Type of Plan selected for EXCLUSION: " S X=1 W ?41,FBINEXCL,!
I $O(FBINEXCL(0)) K X,Y S DIR(0)="Y",DIR("B")="NO",DIR("A")="Recreate Exclusion List" D ^DIR I Y D EXCLINS
K FBINEXCL("INS")
Q
;
EXIT ;kill and quit
KILL ;kill all variables set in the FBPCR* routines, other than fbx
D CLOSE^FBAAUTL K ^TMP($J,"FB")
K A1,A2,A3,BEGDATE,C,D,D2,DFN,DIC,DIR,DTOUT,DUOUT,ENDDATE,FBPDXC,FBPARTY,FBCOPAY,FBARRLTC,FBINCUNK,FBFIRST
K FBAAA,FBAACPTC,FBAC,FBAP,FBBATCH,FBBDATE,FBBEG,FBBN,FBCATC,FBCNT,FBCP,FBCRT,FBDA1,FBDASH,FBDASH1,FBDATA,FBDOB,FBDRUG,FBDT,FBDT1,FBDOS,FBDX,FBDX1,FBEDATE,FBEND,FBERR,FBFD,FBFD1,FBHEAD
K FBI,FBID,FBIEN,FBIN,FBINS,FBINVN,FBIX,FBJ,FBLOC,FBM,FBNAME,FBOB,FBOPI,FBOUT,FBOV,FBP,FBPAT,FBPD,FBPDX,FBPG,FBPI,FBPID,FBPIN,FBPNAME,FBPROC,FBPROC1,FBPROG,FBPSF,FBPSFNAM,FBPSFNUM,FBPSV,FBPT,FBPV,FBQTY,FBREIM,FBRX
K FBSC,FBSL,FBSTA,FBSTR,FBSUSP,FBTA,FBTYPE,FBV,FBVCHAIN,FBVEN,FBVENID,FBVNAME,FBVI,FBVID,FBVP,FBXPROG,FBY,FBZ,I,IOP,J,K,L,M,N,PGM,T,V,VA,VAERR,VAL,VAR,VAUTNI,VAUTSTR,VAUTVB,X,Y,Z,FBSTANPI,FBXX
Q
;
WMSG ;write message if no matches found
D HDR W !!?3,"There are no potential cost recoveries on file"
W !?5,"for specified date range: ",$$DATX^FBAAUTL(FBBDATE)," through ",$$DATX^FBAAUTL(FBEDATE)
I 'FBPSV D
.W ",",!?5,"and selected Primary Service Area(s):"
.S FBPSF=0 F S FBPSF=$O(FBPSV(FBPSF)) Q:'FBPSF W !?31,$G(FBPSV(FBPSF))
E W !?5,"and ALL Primary Service Areas "
W ".",*7,!!
Q
;
CATC(DFN,FBDT,FBPOV) ;
;treats all copays as Means test for date < 3020705 (JULY 5,2002)
;check if patient is liable for copay
;INPUT:
; DFN = IEN of Patient file
; FBDT= Date
; FBPOV = POV code (for LTC determination)
;OUTPUT:
;0 - the patient is not liable for any co-pay;
;1 - if Means test catc or pending adjudication and agree to pay deduc
;2 - the patient is liable for LTC co-pay;
;3 - no 1010EC on file
;4 - more analysis is needed to determine the patient liability
N FBLTC,FBISLTC
S FBCATC=$$BIL^DGMTUB(DFN,FBDT)
I '$D(FBPOV)!(FBDT<3020705) Q $S(FBCATC:1,1:0)
S FBISLTC=$$ISLTC^FBPCR4(FBPOV)
I FBISLTC=0 Q $S(FBCATC:1,1:0) ;Means test
I FBISLTC=2 Q 0 ;LTC-service, but LTC-copay is not applicable
S FBLTC=$$LTCST^FBPCR4(DFN,FBDT)
I FBLTC=2 Q 2 ;LTC copay
I FBLTC=0 Q 3 ;no 1010EC on file
I FBLTC=4 Q 4 ;more info needed
Q 0 ;exemption from LTC -copay
;
VET ;set vet name/ssn/dob info
;INPUT: DFN = IEN of Patient file
; FBPI = IEN of fee program (optional)
;OUTPUT: FBPNAME = Patient's name
; FBPID = Patient's pid
; FBDOB = Patient's dob (if pharmacy fee program)
N N
S N=$G(^DPT(DFN,0)),FBPNAME=$P(N,U),FBPID=$$SSN^FBAAUTL(DFN),FBDOB=$$FMTE^XLFDT($P(N,U,3))
Q
;
STA ;set station name & number
;INPUT = FBPSF - IEN to institution file
;OUTPUT = FBPSFNAM = station name
; FBPSFNUM = station number
S FBPSFNAM=$P($G(^DIC(4,FBPSF,0)),U),FBPSFNUM=$P($G(^DIC(4,FBPSF,99)),U)
S:FBPSFNAM=+FBPSFNAM FBPSFNAM="UNKNOWN"
S FBSTANPI=$S($G(FBPSFNAM)="":"",FBPSFNAM="UNKNOWN":"",1:$P($$NPI^XUSNPI("Organization_ID",FBPSF),U,1))
Q
;
PAGE ;form feed when new station/patient
S FBSTA=$G(FBPSF)_$G(FBPT)
I FBCRT&(FBPG'=0) D CR Q:FBOUT
I FBPG>0!FBCRT W @IOF
S FBPG=FBPG+1
Q
;
CR ;read for display
S DIR(0)="E" W ! D ^DIR K DIR S:$D(DUOUT)!($D(DTOUT)) FBOUT=1
Q
;
HDR ;general header for potential recoveries
D PAGE Q:FBOUT
W !?(IOM-30/2),"POTENTIAL COST RECOVERY REPORT"
W !?(IOM-(11+$L($G(FBPSFNAM))+$L($G(FBPSFNUM)))/2),"Division/Station: ",$G(FBPSFNUM)," ",$G(FBPSFNAM) ;FB*3.5*163
W !?(IOM-14/2),"NPI: ",$S($G(FBSTANPI)="":"",$G(FBSTANPI)<1:"",1:$G(FBSTANPI))
W !?(IOM-19/2),$$DATX^FBAAUTL(FBBDATE)," - ",$$DATX^FBAAUTL(FBEDATE)
W !?71,"Page: ",FBPG
W !,"Patient: ",$G(FBPNAME),?40,"Pat. ID: ",$G(FBPID),?62,"DOB: ",$G(FBDOB)
W !
S FBFIRST=1 ;FB*3.5*163
I '$D(DFN) Q ;FB*3.5*163
D PATDEMO ;FB*3.5*163
I FBINCUNK=1,$D(^TMP($J,"FBINSIBAPI",+$G(DFN))) W ">> Warning: accurate insurance information for the patient is unavailable"
W !?3,"('*' Represents Reimbursement to Patient",?50,"'#' Represents Voided Payment)"
W !,FBDASH
; W ! D:$D(DFN) INS^DGRPDB ;FB*3.5*163
W ! D:$D(DFN) INS ;FB*3.5*163
Q
;
HDRUNK ;Warning message if patient's insurance status is unknown
D PAGE Q:FBOUT
W !?(IOM-30/2),"POTENTIAL COST RECOVERY REPORT"
;W !?(IOM-(11+$L($G(FBPSFNAM))+$L($G(FBPSFNUM)))/2),"Division: ",$G(FBPSFNUM)," ",$G(FBPSFNAM) ;FB*3.5*163
W !?(IOM-(19+$L($G(FBPSFNAM))+$L($G(FBPSFNUM)))/2),"Division/Station: ",$G(FBPSFNUM)," ",$G(FBPSFNAM) ;FB*3.5*163
W !?(IOM-19/2),$$DATX^FBAAUTL(FBBDATE)," - ",$$DATX^FBAAUTL(FBEDATE)
W !?71,"Page: ",FBPG
W !,"------------------------------ !!! WARNING !!! --------------------------------"
W !,"This report is incomplete due to problems with obtaining insurance information"
W !,"for those patients listed in a separate section in the end of the report. You"
W !,"may want to rerun the report again to get more accurate results."
W !,FBDASH
I FBINCUNK=1 D
. W !,"Note: You have chosen to include patients with unknown insurance status in"
. W !,"this report. Please be aware that these patients will be treated as if they"
. W !,"have billable insurance and their treatment details will be marked accordingly."
. W !,"The names of these patients will be accompanied with the following message"
. W !,"to order to identify them:"
. W !,">> Warning: accurate insurance information for the patient is unavailable"
. W !,FBDASH
Q
;
PATDEMO ; Patient Demographics FB*3.5*163
N VAEL,FBCP,FBMT
D ELIG^VADPT
S FBMT=$P($G(VAEL(9)),U,2)
W !,?10,"Outpatient Copayment Status: ",FBMT
D DISP^IBARXEU(DFN,DT,1,"")
D GETSC
D GETSTA
Q
;
GETSC ; Get Service Connected FB*3.5*163
N FBD,FBI,FBX,FBY,FBSC
W !,?20,"Service Connected: "
I VAEL(3)=0 W "NO" Q
I $P(VAEL(3),U,2)="" W "NO" Q
W $P(VAEL(3),U,2)_"%"
I '$O(^DPT(DFN,.372,0)) Q
S FBI=0 F S FBI=$O(^DPT(DFN,.372,FBI)) Q:'FBI D
. S FBX=$G(^DPT(DFN,.372,FBI,0)),FBY=$G(^DIC(31,+FBX,0))
. S FBD=$S($P(FBY,U,4)="":$P(FBY,U,1),1:$P(FBY,U,4))_" ("_$P(FBX,U,2)_"%-"_$S(+$P(FBX,U,3):"SC",1:"NSC")_")"
. W !?39,FBD
Q
;
GETSTA ; Get Special Authority Eligibility FB*3.5*163
N FBY,FBADT,FBARR
W !,?13,"Special Auth Eligibility: "
S FBADT=DT
D CL^SDCO21(DFN,FBADT,"",.FBARR)
I $D(FBARR(3)) W "SC TREATMENT",!
I $D(FBARR(7)),+$$CVEDT^DGCV(DFN,FBADT) W ?13,"COMBAT VETERAN",!
I $D(FBARR(1)) W ?39,"AGENT ORANGE",!
I $D(FBARR(2)) W ?39,"IONIZING RADIATION",!
I $D(FBARR(4)) W ?39,"SOUTHWEST ASIA",!
I $D(FBARR(8)) W ?39,"PROJECT 112/SHAD",!
I $D(FBARR(5)) W ?39,"MILITARY SEXUAL TRAUMA",!
I $D(FBARR(6)) W ?39,"HEAD/NECK CANCER",!
I '$D(FBARR) W "NO",!
Q
;
INS ;Print Insurance Information FB*3.5*163
N FBYN,FBINS,FBRTN,FBERR,FBX,FBSTAT,FBVAL
W !," Health Insurance: "
S FBSTAT="RB"
S FBYN=$$INSUR^IBBAPI(DFN,"",FBSTAT,.FBRTN,"*")
W $S(FBYN:"YES",1:"NO"),!
S:FBYN<0 FBERR=$O(FBRTN("IBBAPI","INSUR","ERROR",0))
D INSHDR
I $G(FBERR) W !?6,FBRTN("IBBAPI","INSUR","ERROR",FBERR) D INSQ Q
I 'FBYN W !!,"No Insurance Information" D INSQ Q
M FBINS=FBRTN("IBBAPI","INSUR")
S FBX=0
F S FBX=$O(FBINS(FBX)) Q:'FBX D INSDSP(FBX)
;
INSQ ;Check Insurance Buffer and verify no coverage then quit FB*3.5*163
N FBNC
W ! I $D(FBRTN("BUFFER")) D
. I FBRTN("BUFFER")>0 W !?17,"*** Patient has Insurance Buffer entries ***"
S FBNC=+$G(^IBA(354,DFN,60)) I +FBNC D
. W !?17,"*** Verification of No Coverage "_$$FMTE^XLFDT(FBNC)_" ***"
Q
;
INSHDR ;Print insurance header FB*3.5*163
N FBEQL
W !,"Insurance",?13,"COB",?17,"Subscriber ID",?35,"Group",?47,"Holder",?54,"Eff Dt",?63,"Exp Dt",?72,"Verified"
S FBEQL="",$P(FBEQL,"=",80)="=" W !,FBEQL
Q
;
INSDSP(FBVAL) ;Print insurance display line FB*3.5*163
N FBY,FBZ
Q:'$D(FBINS)
W !,$S($D(FBINS(FBVAL,1)):$E($P(FBINS(FBVAL,1),U,2),1,10),1:"UNKNOWN") ;Insurance Company
S FBY=+FBINS(FBVAL,7) I FBY'="" S FBY=$S(FBY=1:"p",FBY=2:"s",FBY=3:"t",1:"")
W ?13,FBY ;COB
W ?17,$E(FBINS(FBVAL,14),1,16) ;Subscriber ID
W ?35,$E(FBINS(FBVAL,18),1,10) ;Group
S FBZ=$P(FBINS(FBVAL,12),U,1)
W ?47,$S(FBZ="P":"SELF",FBZ="S":"SPOUSE",1:"OTHER") ;Policy Holder
W ?54,$TR($$FMTE^XLFDT(FBINS(FBVAL,10),"2DF")," ","0") ;Effective Date
W ?63,$TR($$FMTE^XLFDT(FBINS(FBVAL,11),"2DF")," ","0") ;Expiration Date
W ?72,$TR($$FMTE^XLFDT(FBINS(FBVAL,25),"2DF")," ","0") ;Date Last Verified
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBPCR 13132 printed Oct 16, 2024@18:00:24 Page 2
FBPCR ;AISC/DMK,GRR,TET-POTENTIAL COST RECOVERY OUTPUT DRIVER ;5/23/2006
+1 ;;3.5;FEE BASIS;**12,48,76,98,103,135,163**;JAN 30, 1995;Build 21
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ; DBIA SUPPORTED REF $$NPI^XUSNPI = 4532
DOC ;Refer to fbdoc, tag fbpcr, for documentation of fbpcr* routines
PSF ;select one/many/all primary service failities
+1 ;FB*3.5*163
KILL FBBILL,FBNPB,FBADJ,FBADJR,FBPVL133,FBINV,FBPVLIST,Y
+2 SET FBARRLTC=""
+3 WRITE !!
SET DIC="^DIC(4,"
SET VAUTSTR="Primary Service Facility"
SET VAUTNI=2
SET VAUTVB="FBPSV"
DO FIRST^VAUTOMA
KILL DIC
IF Y=-1
GOTO EXIT
ARRAY ;set fee program array for all programs
+1 SET FBPI=0
FOR
SET FBPI=$ORDER(^FBAA(161.8,FBPI))
if 'FBPI
QUIT
SET FBPIN=$GET(^(FBPI,0))
IF $PIECE(FBPIN,U,3)
SET FBPROG(FBPI)=$PIECE(FBPIN,U)
+2 IF '$DATA(FBPROG)
GOTO EXIT
+3 ;prepare array with LTC POV codes
+4 DO MKARRLTC^FBPCR4
+5 ;what party to include
+6 KILL DIR
+7 SET DIR(0)="SO^P:Patient;I:Insurance;B:Both"
SET DIR("A")="Include (P)atient Co-pays / (I)nsurance / (B)oth"
SET DIR("B")="Both"
+8 SET DIR("?")=" Select type of recover to include"
SET DIR("?",1)=" P - include only recover from patient copays"
SET DIR("?",2)=" I - include only recover from insurance"
SET DIR("?",3)=" B - include both"
SET DIR("L")=""
+9 DO ^DIR
SET FBPARTY=$SELECT($GET(Y(0))="Patient":1,$GET(Y(0))="Insurance":2,$GET(Y(0))="Both":3,X="Both":3,1:0)
+10 KILL DIR
+11 if FBPARTY=0
GOTO EXIT
+12 ;what type of copay to include
+13 SET FBCOPAY=3
+14 IF FBPARTY'=2
Begin DoDot:1
+15 SET DIR(0)="SO^M:MeansTest;L:LTC;B:Both"
SET DIR("A")="Include (M)eans Test Co-pays /(L)TC Co-pays /(B)oth"
SET DIR("B")="Both"
+16 SET DIR("?")=" Select services to include"
SET DIR("?",1)=" M - include only Means Test copays"
SET DIR("?",2)=" L - include only LTC copays"
SET DIR("?",3)=" B - include both"
SET DIR("L")=""
+17 DO ^DIR
SET FBCOPAY=$SELECT($GET(Y(0))="LTC":1,$GET(Y(0))="MeansTest":2,$GET(Y(0))="Both":3,X="Both":3,1:0)
+18 KILL DIR
End DoDot:1
+19 if FBCOPAY=0
GOTO EXIT
+20 ;
+21 ;include patients if their insurance informations is unavailable?
+22 SET FBINCUNK=0
+23 IF FBPARTY=2!(FBPARTY=3)
Begin DoDot:1
+24 SET FBINCUNK=1
+25 NEW Y,X
+26 WRITE !!
+27 SET DIR("A")="Do you want to include patients whose insurance status is unavailable? "
+28 SET DIR("?")="Please answer Yes or No."
+29 SET DIR("B")="YES"
SET DIR(0)="YA^^"
+30 DO ^DIR
KILL DIR
+31 IF $GET(DIRUT)
SET FBINCUNK=-1
QUIT
+32 IF $GET(Y)=0
SET FBINCUNK=0
End DoDot:1
+33 ;uparrow - exit
IF FBINCUNK=-1
GOTO EXIT
+34 ; FB*3.5*135
NEW FBINEXCL
+35 ;select insurances to be excluded ; FB*3.5*135
DO EXCLINS
+36 ;
PREBL ;Include Only Not Previously Billed NVC FB*3.5*163
+1 NEW Y,X
+2 WRITE !
+3 SET DIR("A")="Include only Non VA Care not previously billed to third party carrier: "
+4 SET DIR("?")="Please answer Yes or No."
+5 SET DIR("B")="YES"
SET DIR(0)="YA^^"
+6 DO ^DIR
KILL DIR
+7 SET FBNPB=Y
+8 ;
DATE ;select date range
+1 DO DATE^FBAAUTL
IF FBPOP
GOTO PSF
+2 SET FBBDATE=BEGDATE
SET FBEDATE=ENDDATE
+3 SET Z=9999999.9999
SET FBBEG=Z-FBEDATE
SET FBEND=Z-FBBDATE
Q KILL ^TMP($JOB,"FB"),^TMP($JOB,"FBINSIBAPI"),DIC
+1 ;
+2 SET VAR="FBINCUNK^FBARRLTC^FBARRLTC(^FBPARTY^FBCOPAY^FBNAME^FBIEN^FBID^FBBEG^FBEND^FBBDATE^FBEDATE^FBPSV^FBPSV(^FBPROG("
SET VAL=VAR
SET PGM="DQ^FBPCR"
SET IOP="Q"
DO ZIS^FBAAUTL
if FBPOP
GOTO EXIT
DQ SET $PIECE(FBDASH,"=",80)=""
SET $PIECE(FBDASH1,"-",80)=""
SET FBPG=0
SET FBCRT=$SELECT($EXTRACT(IOST,1,2)="C-":1,1:0)
SET FBOUT=0
SET FBBEG=FBBEG-.9
USE IO
SORT ;sort driver for payment output(s)
+1 SET FBPI=0
FOR
SET FBPI=$ORDER(FBPROG(FBPI))
if 'FBPI
QUIT
SET FBXPROG=FBPROG(FBPI)
Begin DoDot:1
+2 ;outpatient payments
IF FBPI=2
DO EN^FBPCR2
+3 ;pharmacy payments
IF FBPI=3
DO EN^FBPCR3
+4 ;civil hospital/cnh payments
IF FBPI=6!(FBPI=7)
if FBPI=6&($DATA(FBPROG(7)))
SET FBPI=67
DO EN^FBPCR67
if FBPI=67
SET FBPI=7
End DoDot:1
PRINT ;print driver for payment output(s)
+1 IF $GET(^TMP($JOB,"FBINSIBAPI"))>0
DO HDRUNK
+2 SET FBPI=$ORDER(^TMP($JOB,"FB",0))
IF FBPI']""
DO WMSG
GOTO OUT
+3 SET FBSTA=0
+4 ; FB*3.5*163
SET FBFIRST=0
+5 SET FBPSF=0
FOR
SET FBPSF=$ORDER(^TMP($JOB,"FB",FBPSF))
if 'FBPSF!FBOUT
QUIT
DO STA
SET FBPT=""
FOR
SET FBPT=$ORDER(^TMP($JOB,"FB",FBPSF,FBPT))
if FBPT']""!FBOUT
QUIT
SET DFN=$PIECE(FBPT,";",2)
DO VET
SET FBPI=0
FOR
SET FBPI=$ORDER(FBPROG(FBPI))
if 'FBPI
QUIT
SET FBXPROG=FBPROG(FBPI)
Begin DoDot:1
+6 IF FBPSF_FBPT'=FBSTA
DO HDR
if FBOUT
QUIT
+7 IF FBPI=2
IF $DATA(^TMP($JOB,"FB",FBPSF,FBPT,FBPI))
DO PRINT^FBPCR2
QUIT
+8 IF FBPI=3
if $DATA(^TMP($JOB,"FB",FBPSF,FBPT,FBPI))
DO PRINT^FBPCR3
QUIT
+9 IF FBPI=6!(FBPI=7)
if $DATA(^TMP($JOB,"FB",FBPSF,FBPT,FBPI))
DO PRINT^FBPCR671
QUIT
End DoDot:1
if FBOUT
QUIT
OUT IF $GET(^TMP($JOB,"FBINSIBAPI"))>0
DO ERRHDL^FBPCR4
+1 ; FB*3.5*163
IF FBFIRST=0
DO WMSG
+2 IF FBOUT!$DATA(ZTQUEUED)
GOTO EXIT
+3 DO EXIT
GOTO PSF
+4 QUIT
+5 ;
EXCLINS ;create list of insurance type to be excluded ; FB*3.5*135
+1 NEW Y,X,DIC,DTOUT,DUOUT,DIR,DIRUT,DIROUT
+2 KILL FBINEXCL
SET FBINEXCL=0
SET X=1
+3 WRITE !!!,"Select the TYPE of INSURANCE PLANS to be EXCLUDED from the PCR report:"
+4 FOR
if $GET(X)=""
QUIT
SET DIC="^IBE(355.1,"
SET DIC(0)="QEAFIBS"
SET DIC("S")="I '$P($G(^(0)),U,4)"
KILL X,Y
DO ^DIC
IF $GET(Y)>0
SET FBINEXCL(+Y)=$PIECE(Y,U,2)
SET FBINEXCL("INS",$PIECE(Y,U,2))=+Y
+5 SET FBINEXCL="A"
SET X=0
FOR
SET FBINEXCL=$ORDER(FBINEXCL("INS",FBINEXCL))
if FBINEXCL=""
QUIT
if 'X
WRITE !!,"Type of Plan selected for EXCLUSION: "
SET X=1
WRITE ?41,FBINEXCL,!
+6 IF $ORDER(FBINEXCL(0))
KILL X,Y
SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Recreate Exclusion List"
DO ^DIR
IF Y
DO EXCLINS
+7 KILL FBINEXCL("INS")
+8 QUIT
+9 ;
EXIT ;kill and quit
KILL ;kill all variables set in the FBPCR* routines, other than fbx
+1 DO CLOSE^FBAAUTL
KILL ^TMP($JOB,"FB")
+2 KILL A1,A2,A3,BEGDATE,C,D,D2,DFN,DIC,DIR,DTOUT,DUOUT,ENDDATE,FBPDXC,FBPARTY,FBCOPAY,FBARRLTC,FBINCUNK,FBFIRST
+3 KILL FBAAA,FBAACPTC,FBAC,FBAP,FBBATCH,FBBDATE,FBBEG,FBBN,FBCATC,FBCNT,FBCP,FBCRT,FBDA1,FBDASH,FBDASH1,FBDATA,FBDOB,FBDRUG,FBDT,FBDT1,FBDOS,FBDX,FBDX1,FBEDATE,FBEND,FBERR,FBFD,FBFD1,FBHEAD
+4 KILL FBI,FBID,FBIEN,FBIN,FBINS,FBINVN,FBIX,FBJ,FBLOC,FBM,FBNAME,FBOB,FBOPI,FBOUT,FBOV,FBP,FBPAT,FBPD,FBPDX,FBPG,FBPI,FBPID,FBPIN,FBPNAME,FBPROC,FBPROC1,FBPROG,FBPSF,FBPSFNAM,FBPSFNUM,FBPSV,FBPT,FBPV,FBQTY,FBREIM,FBRX
+5 KILL FBSC,FBSL,FBSTA,FBSTR,FBSUSP,FBTA,FBTYPE,FBV,FBVCHAIN,FBVEN,FBVENID,FBVNAME,FBVI,FBVID,FBVP,FBXPROG,FBY,FBZ,I,IOP,J,K,L,M,N,PGM,T,V,VA,VAERR,VAL,VAR,VAUTNI,VAUTSTR,VAUTVB,X,Y,Z,FBSTANPI,FBXX
+6 QUIT
+7 ;
WMSG ;write message if no matches found
+1 DO HDR
WRITE !!?3,"There are no potential cost recoveries on file"
+2 WRITE !?5,"for specified date range: ",$$DATX^FBAAUTL(FBBDATE)," through ",$$DATX^FBAAUTL(FBEDATE)
+3 IF 'FBPSV
Begin DoDot:1
+4 WRITE ",",!?5,"and selected Primary Service Area(s):"
+5 SET FBPSF=0
FOR
SET FBPSF=$ORDER(FBPSV(FBPSF))
if 'FBPSF
QUIT
WRITE !?31,$GET(FBPSV(FBPSF))
End DoDot:1
+6 IF '$TEST
WRITE !?5,"and ALL Primary Service Areas "
+7 WRITE ".",*7,!!
+8 QUIT
+9 ;
CATC(DFN,FBDT,FBPOV) ;
+1 ;treats all copays as Means test for date < 3020705 (JULY 5,2002)
+2 ;check if patient is liable for copay
+3 ;INPUT:
+4 ; DFN = IEN of Patient file
+5 ; FBDT= Date
+6 ; FBPOV = POV code (for LTC determination)
+7 ;OUTPUT:
+8 ;0 - the patient is not liable for any co-pay;
+9 ;1 - if Means test catc or pending adjudication and agree to pay deduc
+10 ;2 - the patient is liable for LTC co-pay;
+11 ;3 - no 1010EC on file
+12 ;4 - more analysis is needed to determine the patient liability
+13 NEW FBLTC,FBISLTC
+14 SET FBCATC=$$BIL^DGMTUB(DFN,FBDT)
+15 IF '$DATA(FBPOV)!(FBDT<3020705)
QUIT $SELECT(FBCATC:1,1:0)
+16 SET FBISLTC=$$ISLTC^FBPCR4(FBPOV)
+17 ;Means test
IF FBISLTC=0
QUIT $SELECT(FBCATC:1,1:0)
+18 ;LTC-service, but LTC-copay is not applicable
IF FBISLTC=2
QUIT 0
+19 SET FBLTC=$$LTCST^FBPCR4(DFN,FBDT)
+20 ;LTC copay
IF FBLTC=2
QUIT 2
+21 ;no 1010EC on file
IF FBLTC=0
QUIT 3
+22 ;more info needed
IF FBLTC=4
QUIT 4
+23 ;exemption from LTC -copay
QUIT 0
+24 ;
VET ;set vet name/ssn/dob info
+1 ;INPUT: DFN = IEN of Patient file
+2 ; FBPI = IEN of fee program (optional)
+3 ;OUTPUT: FBPNAME = Patient's name
+4 ; FBPID = Patient's pid
+5 ; FBDOB = Patient's dob (if pharmacy fee program)
+6 NEW N
+7 SET N=$GET(^DPT(DFN,0))
SET FBPNAME=$PIECE(N,U)
SET FBPID=$$SSN^FBAAUTL(DFN)
SET FBDOB=$$FMTE^XLFDT($PIECE(N,U,3))
+8 QUIT
+9 ;
STA ;set station name & number
+1 ;INPUT = FBPSF - IEN to institution file
+2 ;OUTPUT = FBPSFNAM = station name
+3 ; FBPSFNUM = station number
+4 SET FBPSFNAM=$PIECE($GET(^DIC(4,FBPSF,0)),U)
SET FBPSFNUM=$PIECE($GET(^DIC(4,FBPSF,99)),U)
+5 if FBPSFNAM=+FBPSFNAM
SET FBPSFNAM="UNKNOWN"
+6 SET FBSTANPI=$SELECT($GET(FBPSFNAM)="":"",FBPSFNAM="UNKNOWN":"",1:$PIECE($$NPI^XUSNPI("Organization_ID",FBPSF),U,1))
+7 QUIT
+8 ;
PAGE ;form feed when new station/patient
+1 SET FBSTA=$GET(FBPSF)_$GET(FBPT)
+2 IF FBCRT&(FBPG'=0)
DO CR
if FBOUT
QUIT
+3 IF FBPG>0!FBCRT
WRITE @IOF
+4 SET FBPG=FBPG+1
+5 QUIT
+6 ;
CR ;read for display
+1 SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
if $DATA(DUOUT)!($DATA(DTOUT))
SET FBOUT=1
+2 QUIT
+3 ;
HDR ;general header for potential recoveries
+1 DO PAGE
if FBOUT
QUIT
+2 WRITE !?(IOM-30/2),"POTENTIAL COST RECOVERY REPORT"
+3 ;FB*3.5*163
WRITE !?(IOM-(11+$LENGTH($GET(FBPSFNAM))+$LENGTH($GET(FBPSFNUM)))/2),"Division/Station: ",$GET(FBPSFNUM)," ",$GET(FBPSFNAM)
+4 WRITE !?(IOM-14/2),"NPI: ",$SELECT($GET(FBSTANPI)="":"",$GET(FBSTANPI)<1:"",1:$GET(FBSTANPI))
+5 WRITE !?(IOM-19/2),$$DATX^FBAAUTL(FBBDATE)," - ",$$DATX^FBAAUTL(FBEDATE)
+6 WRITE !?71,"Page: ",FBPG
+7 WRITE !,"Patient: ",$GET(FBPNAME),?40,"Pat. ID: ",$GET(FBPID),?62,"DOB: ",$GET(FBDOB)
+8 WRITE !
+9 ;FB*3.5*163
SET FBFIRST=1
+10 ;FB*3.5*163
IF '$DATA(DFN)
QUIT
+11 ;FB*3.5*163
DO PATDEMO
+12 IF FBINCUNK=1
IF $DATA(^TMP($JOB,"FBINSIBAPI",+$GET(DFN)))
WRITE ">> Warning: accurate insurance information for the patient is unavailable"
+13 WRITE !?3,"('*' Represents Reimbursement to Patient",?50,"'#' Represents Voided Payment)"
+14 WRITE !,FBDASH
+15 ; W ! D:$D(DFN) INS^DGRPDB ;FB*3.5*163
+16 ;FB*3.5*163
WRITE !
if $DATA(DFN)
DO INS
+17 QUIT
+18 ;
HDRUNK ;Warning message if patient's insurance status is unknown
+1 DO PAGE
if FBOUT
QUIT
+2 WRITE !?(IOM-30/2),"POTENTIAL COST RECOVERY REPORT"
+3 ;W !?(IOM-(11+$L($G(FBPSFNAM))+$L($G(FBPSFNUM)))/2),"Division: ",$G(FBPSFNUM)," ",$G(FBPSFNAM) ;FB*3.5*163
+4 ;FB*3.5*163
WRITE !?(IOM-(19+$LENGTH($GET(FBPSFNAM))+$LENGTH($GET(FBPSFNUM)))/2),"Division/Station: ",$GET(FBPSFNUM)," ",$GET(FBPSFNAM)
+5 WRITE !?(IOM-19/2),$$DATX^FBAAUTL(FBBDATE)," - ",$$DATX^FBAAUTL(FBEDATE)
+6 WRITE !?71,"Page: ",FBPG
+7 WRITE !,"------------------------------ !!! WARNING !!! --------------------------------"
+8 WRITE !,"This report is incomplete due to problems with obtaining insurance information"
+9 WRITE !,"for those patients listed in a separate section in the end of the report. You"
+10 WRITE !,"may want to rerun the report again to get more accurate results."
+11 WRITE !,FBDASH
+12 IF FBINCUNK=1
Begin DoDot:1
+13 WRITE !,"Note: You have chosen to include patients with unknown insurance status in"
+14 WRITE !,"this report. Please be aware that these patients will be treated as if they"
+15 WRITE !,"have billable insurance and their treatment details will be marked accordingly."
+16 WRITE !,"The names of these patients will be accompanied with the following message"
+17 WRITE !,"to order to identify them:"
+18 WRITE !,">> Warning: accurate insurance information for the patient is unavailable"
+19 WRITE !,FBDASH
End DoDot:1
+20 QUIT
+21 ;
PATDEMO ; Patient Demographics FB*3.5*163
+1 NEW VAEL,FBCP,FBMT
+2 DO ELIG^VADPT
+3 SET FBMT=$PIECE($GET(VAEL(9)),U,2)
+4 WRITE !,?10,"Outpatient Copayment Status: ",FBMT
+5 DO DISP^IBARXEU(DFN,DT,1,"")
+6 DO GETSC
+7 DO GETSTA
+8 QUIT
+9 ;
GETSC ; Get Service Connected FB*3.5*163
+1 NEW FBD,FBI,FBX,FBY,FBSC
+2 WRITE !,?20,"Service Connected: "
+3 IF VAEL(3)=0
WRITE "NO"
QUIT
+4 IF $PIECE(VAEL(3),U,2)=""
WRITE "NO"
QUIT
+5 WRITE $PIECE(VAEL(3),U,2)_"%"
+6 IF '$ORDER(^DPT(DFN,.372,0))
QUIT
+7 SET FBI=0
FOR
SET FBI=$ORDER(^DPT(DFN,.372,FBI))
if 'FBI
QUIT
Begin DoDot:1
+8 SET FBX=$GET(^DPT(DFN,.372,FBI,0))
SET FBY=$GET(^DIC(31,+FBX,0))
+9 SET FBD=$SELECT($PIECE(FBY,U,4)="":$PIECE(FBY,U,1),1:$PIECE(FBY,U,4))_" ("_$PIECE(FBX,U,2)_"%-"_$SELECT(+$PIECE(FBX,U,3):"SC",1:"NSC")_")"
+10 WRITE !?39,FBD
End DoDot:1
+11 QUIT
+12 ;
GETSTA ; Get Special Authority Eligibility FB*3.5*163
+1 NEW FBY,FBADT,FBARR
+2 WRITE !,?13,"Special Auth Eligibility: "
+3 SET FBADT=DT
+4 DO CL^SDCO21(DFN,FBADT,"",.FBARR)
+5 IF $DATA(FBARR(3))
WRITE "SC TREATMENT",!
+6 IF $DATA(FBARR(7))
IF +$$CVEDT^DGCV(DFN,FBADT)
WRITE ?13,"COMBAT VETERAN",!
+7 IF $DATA(FBARR(1))
WRITE ?39,"AGENT ORANGE",!
+8 IF $DATA(FBARR(2))
WRITE ?39,"IONIZING RADIATION",!
+9 IF $DATA(FBARR(4))
WRITE ?39,"SOUTHWEST ASIA",!
+10 IF $DATA(FBARR(8))
WRITE ?39,"PROJECT 112/SHAD",!
+11 IF $DATA(FBARR(5))
WRITE ?39,"MILITARY SEXUAL TRAUMA",!
+12 IF $DATA(FBARR(6))
WRITE ?39,"HEAD/NECK CANCER",!
+13 IF '$DATA(FBARR)
WRITE "NO",!
+14 QUIT
+15 ;
INS ;Print Insurance Information FB*3.5*163
+1 NEW FBYN,FBINS,FBRTN,FBERR,FBX,FBSTAT,FBVAL
+2 WRITE !," Health Insurance: "
+3 SET FBSTAT="RB"
+4 SET FBYN=$$INSUR^IBBAPI(DFN,"",FBSTAT,.FBRTN,"*")
+5 WRITE $SELECT(FBYN:"YES",1:"NO"),!
+6 if FBYN<0
SET FBERR=$ORDER(FBRTN("IBBAPI","INSUR","ERROR",0))
+7 DO INSHDR
+8 IF $GET(FBERR)
WRITE !?6,FBRTN("IBBAPI","INSUR","ERROR",FBERR)
DO INSQ
QUIT
+9 IF 'FBYN
WRITE !!,"No Insurance Information"
DO INSQ
QUIT
+10 MERGE FBINS=FBRTN("IBBAPI","INSUR")
+11 SET FBX=0
+12 FOR
SET FBX=$ORDER(FBINS(FBX))
if 'FBX
QUIT
DO INSDSP(FBX)
+13 ;
INSQ ;Check Insurance Buffer and verify no coverage then quit FB*3.5*163
+1 NEW FBNC
+2 WRITE !
IF $DATA(FBRTN("BUFFER"))
Begin DoDot:1
+3 IF FBRTN("BUFFER")>0
WRITE !?17,"*** Patient has Insurance Buffer entries ***"
End DoDot:1
+4 SET FBNC=+$GET(^IBA(354,DFN,60))
IF +FBNC
Begin DoDot:1
+5 WRITE !?17,"*** Verification of No Coverage "_$$FMTE^XLFDT(FBNC)_" ***"
End DoDot:1
+6 QUIT
+7 ;
INSHDR ;Print insurance header FB*3.5*163
+1 NEW FBEQL
+2 WRITE !,"Insurance",?13,"COB",?17,"Subscriber ID",?35,"Group",?47,"Holder",?54,"Eff Dt",?63,"Exp Dt",?72,"Verified"
+3 SET FBEQL=""
SET $PIECE(FBEQL,"=",80)="="
WRITE !,FBEQL
+4 QUIT
+5 ;
INSDSP(FBVAL) ;Print insurance display line FB*3.5*163
+1 NEW FBY,FBZ
+2 if '$DATA(FBINS)
QUIT
+3 ;Insurance Company
WRITE !,$SELECT($DATA(FBINS(FBVAL,1)):$EXTRACT($PIECE(FBINS(FBVAL,1),U,2),1,10),1:"UNKNOWN")
+4 SET FBY=+FBINS(FBVAL,7)
IF FBY'=""
SET FBY=$SELECT(FBY=1:"p",FBY=2:"s",FBY=3:"t",1:"")
+5 ;COB
WRITE ?13,FBY
+6 ;Subscriber ID
WRITE ?17,$EXTRACT(FBINS(FBVAL,14),1,16)
+7 ;Group
WRITE ?35,$EXTRACT(FBINS(FBVAL,18),1,10)
+8 SET FBZ=$PIECE(FBINS(FBVAL,12),U,1)
+9 ;Policy Holder
WRITE ?47,$SELECT(FBZ="P":"SELF",FBZ="S":"SPOUSE",1:"OTHER")
+10 ;Effective Date
WRITE ?54,$TRANSLATE($$FMTE^XLFDT(FBINS(FBVAL,10),"2DF")," ","0")
+11 ;Expiration Date
WRITE ?63,$TRANSLATE($$FMTE^XLFDT(FBINS(FBVAL,11),"2DF")," ","0")
+12 ;Date Last Verified
WRITE ?72,$TRANSLATE($$FMTE^XLFDT(FBINS(FBVAL,25),"2DF")," ","0")
+13 QUIT
