FBPCR4 ;WOIFO/SS-LTC PHASE 3 UTILITIES ;03/17/04
;;3.5;FEE BASIS;**48,76,135**;JAN 30, 1995;Build 3
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
Q
;
INSURED(FBDFN,FBINDT1,FBINDT2) ;check if the patient has insurance ;modified for FB*3.5*135 filtering
;FBDFN - patient DFN
;FBINDT1 - the treatment date - for outpatients,
; FROM date - for inpatients,
; certified date - for Pharmacy
;FBINDT2 (optional) - TO date for inpatients
;
N FBINS1,FBINSDAT
S FBINS1=+$$INSUR^IBBAPI(FBDFN,FBINDT1,,.FBINSDAT,"1,21")
I FBINS1<0 D ADDERR(DFN) Q FBINCUNK ;error handling
S FBINS1=$$SETFBINS ;FB*3.5*135 filtering
Q:'$D(FBINDT2) FBINS1
Q:FBINS1=1 1 ;if was insured for FROM date - don't check TO date
K FBINSDAT S FBINS1=+$$INSUR^IBBAPI(FBDFN,FBINDT2,,.FBINSDAT,"1,21") ;otherwise return the state on TO date
I FBINS1<0 D ADDERR(DFN) Q FBINCUNK ;error handling
S FBINS1=$$SETFBINS ;FB*3.5*135 filtering for inpatient TO date
Q FBINS1
;
ADDERR(FBDFN) ;add error to ^TMP, FBDFN - patient DFN
I FBPARTY=1 Q
N DFN,FBPNAME,FBPID,FBDOB,FBPI
S DFN=FBDFN
D VET^FBPCR
S ^TMP($J,"FBINSIBAPI")=$G(^TMP($J,"FBINSIBAPI"))+1
S ^TMP($J,"FBINSIBAPI",DFN)=FBPID_"^"_FBDOB_"^"_FBPNAME
Q
;
SETFBINS() ;reset FBINS based on excluded Type of Plans (if any) and Patient 'Policy Not Billable' field
;TYPE OF PLAN (pointer to file 355.1) will be in FBINEXCL if user selected to exclude insurance type(s)
I 'FBINS1 Q FBINS1
N X,TYPID,FBPOLIEN
S X=0 F S X=$O(FBINSDAT("IBBAPI","INSUR",X)) Q:'X D
.S TYPID=+$G(FBINSDAT("IBBAPI","INSUR",X,21)) ;get Type of Plan
.I $D(FBINEXCL(TYPID)) K FBINSDAT("IBBAPI","INSUR",X) ; not billable, so kill it
.Q
I $D(FBINSDAT("IBBAPI","INSUR"))>1 Q 1 ; something left to bill
Q 0
;
ERRHDL ;Error handler called from FBPCR
I +$G(^TMP($J,"FBINSIBAPI"))=0 Q ;no errors
D PRNUNKN
Q
;
PRNUNKN ;write output
N FBDFN,FBDATA
D PAGEINS
I FBPG>1&(($Y+15)>IOSL) D HEADER Q:FBOUT
S FBDFN=0 F S FBDFN=$O(^TMP($J,"FBINSIBAPI",FBDFN)) Q:FBDFN']""!(FBOUT) D Q:FBOUT
. I ($Y+6)>IOSL D PAGEINS Q:FBOUT
. S FBDATA=$G(^TMP($J,"FBINSIBAPI",FBDFN))
. W !,$P(FBDATA,"^",3),?40,$P(FBDATA,"^",1),?62,$P(FBDATA,"^",2)
Q
PAGEINS ;new page
D CHKPAGE Q:FBOUT
D HEADER Q:FBOUT
Q
CHKPAGE ;form feed when new station/patient
S FBSTA=$G(FBPSF)_$G(FBPT)
I FBCRT&(FBPG'=0) D CR^FBPCR Q:FBOUT
I FBPG>0!FBCRT W @IOF
S FBPG=FBPG+1
Q
N FBSTR1 S FBSTR1="List of the patients whose insurance information is currently unavailable"
W !?(IOM-30/2),"POTENTIAL COST RECOVERY REPORT"
W !?(IOM-$L(FBSTR1)/2),FBSTR1
W !?71,"Page: ",FBPG
W !,"Patient",?40,"Pat. ID",?62,"DOB"
W !,FBDASH
Q
;/**filtering logic
;input:
; FBPARTY: 1-Patient copay only,2-Insurance only,3-Both
; FBCOPAY: 1-LTC copays only,2-MT copays only,3-Both
; FBINS: 1- has insurance,0-none
; FBCATC: 0 - no copay,1- MT copay,2-LTC copay,3-no 1010EC,4-more analysis is needed
;output:
; 1 - include to report
; 0 - exclude from report
FILTER() ;*/
I FBPARTY=1,FBCATC=0 Q 0
I FBPARTY=2,FBINS=0 Q 0
I FBPARTY=3,FBINS=1 Q 1
I FBCOPAY=1,FBCATC<2 Q 0
I FBCOPAY=2,FBCATC'=1 Q 0
Q 1
;
;/**
; returns LTC status
; input: Patient's DFN, Date of Care
;
; return values:
; 0 - no1010EC
; 1 - exemption from LTC copay
; 2 - LTC copay
LTCST(DFN,FBDT) ;*/
Q +$$COPAY^EASECCAL(DFN,$$LASTDT(FBDT),1)
;
LASTDT(X) ; compute the last day of the month in X
N XM,X1,X2
I $E(X,4,5)=12 Q $E(X,1,5)_"31"
S XM=$E(X,4,5)+1
S:XM<10 XM="0"_XM
S X1=$E(X,1,3)_XM_"01"
S X2=-1
D C^%DTC
Q X
;
;
;prepares local array with LTC POV codes
;input: FBARRLTC must be defined
;output: FBARRLTC with POV codes
MKARRLTC ;
N FBPOV,FBIEN,FBLTCTYP
S FBPOV="" F S FBPOV=$O(^FBAA(161.82,"C",FBPOV)) Q:'FBPOV S FBIEN=+$O(^FBAA(161.82,"C",FBPOV,0)),FBLTCTYP=+$P($G(^FBAA(161.82,FBIEN,0)),"^",4) S:FBLTCTYP=1!(FBLTCTYP=2) FBARRLTC(FBPOV)=FBLTCTYP
Q
;/**
; Determine if POV code is related to LTC.
;Input:
; FBPOV - POV code, pointer to #161.82
; FBARRLTC must be defined and populated - array with LTC POV codes (see MKARRLTC)
;Output:
; returns
; 0 - it is not LTC service
; 1 - this POV code is for LTC and recoverable from LTC copayment
; 2 - this POV code is for LTC but it is not a subject of LTC copayment
ISLTC(FBPOV) ;*/
Q +$G(FBARRLTC(FBPOV))
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBPCR4 4442 printed Apr 09, 2024@21:00:11 Page 2
FBPCR4 ;WOIFO/SS-LTC PHASE 3 UTILITIES ;03/17/04
+1 ;;3.5;FEE BASIS;**48,76,135**;JAN 30, 1995;Build 3
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
INSURED(FBDFN,FBINDT1,FBINDT2) ;check if the patient has insurance ;modified for FB*3.5*135 filtering
+1 ;FBDFN - patient DFN
+2 ;FBINDT1 - the treatment date - for outpatients,
+3 ; FROM date - for inpatients,
+4 ; certified date - for Pharmacy
+5 ;FBINDT2 (optional) - TO date for inpatients
+6 ;
+7 NEW FBINS1,FBINSDAT
+8 SET FBINS1=+$$INSUR^IBBAPI(FBDFN,FBINDT1,,.FBINSDAT,"1,21")
+9 ;error handling
IF FBINS1<0
DO ADDERR(DFN)
QUIT FBINCUNK
+10 ;FB*3.5*135 filtering
SET FBINS1=$$SETFBINS
+11 if '$DATA(FBINDT2)
QUIT FBINS1
+12 ;if was insured for FROM date - don't check TO date
if FBINS1=1
QUIT 1
+13 ;otherwise return the state on TO date
KILL FBINSDAT
SET FBINS1=+$$INSUR^IBBAPI(FBDFN,FBINDT2,,.FBINSDAT,"1,21")
+14 ;error handling
IF FBINS1<0
DO ADDERR(DFN)
QUIT FBINCUNK
+15 ;FB*3.5*135 filtering for inpatient TO date
SET FBINS1=$$SETFBINS
+16 QUIT FBINS1
+17 ;
ADDERR(FBDFN) ;add error to ^TMP, FBDFN - patient DFN
+1 IF FBPARTY=1
QUIT
+2 NEW DFN,FBPNAME,FBPID,FBDOB,FBPI
+3 SET DFN=FBDFN
+4 DO VET^FBPCR
+5 SET ^TMP($JOB,"FBINSIBAPI")=$GET(^TMP($JOB,"FBINSIBAPI"))+1
+6 SET ^TMP($JOB,"FBINSIBAPI",DFN)=FBPID_"^"_FBDOB_"^"_FBPNAME
+7 QUIT
+8 ;
SETFBINS() ;reset FBINS based on excluded Type of Plans (if any) and Patient 'Policy Not Billable' field
+1 ;TYPE OF PLAN (pointer to file 355.1) will be in FBINEXCL if user selected to exclude insurance type(s)
+2 IF 'FBINS1
QUIT FBINS1
+3 NEW X,TYPID,FBPOLIEN
+4 SET X=0
FOR
SET X=$ORDER(FBINSDAT("IBBAPI","INSUR",X))
if 'X
QUIT
Begin DoDot:1
+5 ;get Type of Plan
SET TYPID=+$GET(FBINSDAT("IBBAPI","INSUR",X,21))
+6 ; not billable, so kill it
IF $DATA(FBINEXCL(TYPID))
KILL FBINSDAT("IBBAPI","INSUR",X)
+7 QUIT
End DoDot:1
+8 ; something left to bill
IF $DATA(FBINSDAT("IBBAPI","INSUR"))>1
QUIT 1
+9 QUIT 0
+10 ;
ERRHDL ;Error handler called from FBPCR
+1 ;no errors
IF +$GET(^TMP($JOB,"FBINSIBAPI"))=0
QUIT
+2 DO PRNUNKN
+3 QUIT
+4 ;
PRNUNKN ;write output
+1 NEW FBDFN,FBDATA
+2 DO PAGEINS
+3 IF FBPG>1&(($Y+15)>IOSL)
DO HEADER
if FBOUT
QUIT
+4 SET FBDFN=0
FOR
SET FBDFN=$ORDER(^TMP($JOB,"FBINSIBAPI",FBDFN))
if FBDFN']""!(FBOUT)
QUIT
Begin DoDot:1
+5 IF ($Y+6)>IOSL
DO PAGEINS
if FBOUT
QUIT
+6 SET FBDATA=$GET(^TMP($JOB,"FBINSIBAPI",FBDFN))
+7 WRITE !,$PIECE(FBDATA,"^",3),?40,$PIECE(FBDATA,"^",1),?62,$PIECE(FBDATA,"^",2)
End DoDot:1
if FBOUT
QUIT
+8 QUIT
PAGEINS ;new page
+1 DO CHKPAGE
if FBOUT
QUIT
+2 DO HEADER
if FBOUT
QUIT
+3 QUIT
CHKPAGE ;form feed when new station/patient
+1 SET FBSTA=$GET(FBPSF)_$GET(FBPT)
+2 IF FBCRT&(FBPG'=0)
DO CR^FBPCR
if FBOUT
QUIT
+3 IF FBPG>0!FBCRT
WRITE @IOF
+4 SET FBPG=FBPG+1
+5 QUIT
+1 NEW FBSTR1
SET FBSTR1="List of the patients whose insurance information is currently unavailable"
+2 WRITE !?(IOM-30/2),"POTENTIAL COST RECOVERY REPORT"
+3 WRITE !?(IOM-$LENGTH(FBSTR1)/2),FBSTR1
+4 WRITE !?71,"Page: ",FBPG
+5 WRITE !,"Patient",?40,"Pat. ID",?62,"DOB"
+6 WRITE !,FBDASH
+7 QUIT
+8 ;/**filtering logic
+9 ;input:
+10 ; FBPARTY: 1-Patient copay only,2-Insurance only,3-Both
+11 ; FBCOPAY: 1-LTC copays only,2-MT copays only,3-Both
+12 ; FBINS: 1- has insurance,0-none
+13 ; FBCATC: 0 - no copay,1- MT copay,2-LTC copay,3-no 1010EC,4-more analysis is needed
+14 ;output:
+15 ; 1 - include to report
+16 ; 0 - exclude from report
FILTER() ;*/
+1 IF FBPARTY=1
IF FBCATC=0
QUIT 0
+2 IF FBPARTY=2
IF FBINS=0
QUIT 0
+3 IF FBPARTY=3
IF FBINS=1
QUIT 1
+4 IF FBCOPAY=1
IF FBCATC<2
QUIT 0
+5 IF FBCOPAY=2
IF FBCATC'=1
QUIT 0
+6 QUIT 1
+7 ;
+8 ;/**
+9 ; returns LTC status
+10 ; input: Patient's DFN, Date of Care
+11 ;
+12 ; return values:
+13 ; 0 - no1010EC
+14 ; 1 - exemption from LTC copay
+15 ; 2 - LTC copay
LTCST(DFN,FBDT) ;*/
+1 QUIT +$$COPAY^EASECCAL(DFN,$$LASTDT(FBDT),1)
+2 ;
LASTDT(X) ; compute the last day of the month in X
+1 NEW XM,X1,X2
+2 IF $EXTRACT(X,4,5)=12
QUIT $EXTRACT(X,1,5)_"31"
+3 SET XM=$EXTRACT(X,4,5)+1
+4 if XM<10
SET XM="0"_XM
+5 SET X1=$EXTRACT(X,1,3)_XM_"01"
+6 SET X2=-1
+7 DO C^%DTC
+8 QUIT X
+9 ;
+10 ;
+11 ;prepares local array with LTC POV codes
+12 ;input: FBARRLTC must be defined
+13 ;output: FBARRLTC with POV codes
MKARRLTC ;
+1 NEW FBPOV,FBIEN,FBLTCTYP
+2 SET FBPOV=""
FOR
SET FBPOV=$ORDER(^FBAA(161.82,"C",FBPOV))
if 'FBPOV
QUIT
SET FBIEN=+$ORDER(^FBAA(161.82,"C",FBPOV,0))
SET FBLTCTYP=+$PIECE($GET(^FBAA(161.82,FBIEN,0)),"^",4)
if FBLTCTYP=1!(FBLTCTYP=2)
SET FBARRLTC(FBPOV)=FBLTCTYP
+3 QUIT
+4 ;/**
+5 ; Determine if POV code is related to LTC.
+6 ;Input:
+7 ; FBPOV - POV code, pointer to #161.82
+8 ; FBARRLTC must be defined and populated - array with LTC POV codes (see MKARRLTC)
+9 ;Output:
+10 ; returns
+11 ; 0 - it is not LTC service
+12 ; 1 - this POV code is for LTC and recoverable from LTC copayment
+13 ; 2 - this POV code is for LTC but it is not a subject of LTC copayment
ISLTC(FBPOV) ;*/
+1 QUIT +$GET(FBARRLTC(FBPOV))
+2 ;
