IBFBNP1 ;ALB/RED- EDI-CPAC build 1st and 3rd party copayments ;10/01/15
;;2.0;INTEGRATED BILLING;**554**;21-MAR-94;Build 81
;Per VA Directive 6402, this routine should not be modified.
;
Q
NRUN ; main entry point - nightly run job to look at existing FB payments and add/edit entries in file #360
;Start by looking for recent FB payments
;
N FBSITE,IBVEN,IBSERVDT,IBCATC,IBSITE,IBMTC,FBARRLTC,IBDTPD,IBDUZ,IBREC,IBRECZ,IBDOS,IBTYP,IBADMDT,OTPTBIL,IBSTDT
N IBBILL,IBCLAIM,IBFBDT,IBIENS,IBLOG,IENROOT,IENS,IBSERV,FRSTPRT,IBFBINS,IBDOST,FBA,FBC,IBCARETY,DFN,%,FBSITE
S FBARRLTC="" D MKARRLTC^FBPCR4 ;build array needed later for POV in LTC co-pay
S (IBCATC,IBMTC,FRSTPRT)=0 ;(CAT C FLAG and IBMTC = Determine if patient is pending adjudication or category C and has agreed to pay the deductible
;
D SITE^FBAACO S IBSITE=$P(FBSITE(1),U,3)
;S IBN=$$PT^IBEFUNC(IBDFN) D UTIL^IBCA3,UTIL^IBOA32 ; check for all outstanding bills, build ^UTILITY($J
S IBSTDT=$P(^IBE(350.9,1,7),U,2)\1-1 ; set to last time Autobiller was ran -1 day (MOVED TO NODE 7, PIECE 2)
I IBSTDT<1 S IBSTDT=$$FMADD^XLFDT(DT,-5) ;default to today-5 if not set
F S IBSTDT=$O(^FBAAC("AK",IBSTDT)) Q:'IBSTDT D PAYMT
Q
PAYMT ;
N DFN,IBAUTH,IBPOV,IBINV
S (DFN,IBPOV,IBINV,IBDOS,IBCARETY)=0 F S DFN=$O(^FBAAC("AK",IBSTDT,DFN)) Q:'DFN D
. S IBVEN=0 F S IBVEN=$O(^FBAAC("AK",IBSTDT,DFN,IBVEN)) Q:'IBVEN D
.. S IBSERVDT=0 F S IBSERVDT=$O(^FBAAC("AK",IBSTDT,DFN,IBVEN,IBSERVDT)) Q:'IBSERVDT D
... S IBSERV=0 F S IBSERV=$O(^FBAAC("AK",IBSTDT,DFN,IBVEN,IBSERVDT,IBSERV)) Q:'IBSERV D
.... ; Set the temporary payment array to service date and the zero node (IBFB=patient;vendor;service prov IEN;service date IEN), Auth, Invoice and POV
.... Q:$G(^FBAAC(DFN,1,IBVEN,1,IBSERVDT,1,IBSERV,0))="" ; quit if the zero node of the payment is undefined
.... Q:$G(^FBAAC(DFN,1,IBVEN,1,IBSERVDT,1,IBSERV,"FBREJ"))]"" ;payment was rejected
.... S IBDTPD=$$GET1^DIQ(162.03,IBSERV_","_IBSERVDT_","_IBVEN_","_DFN_",",12,"I")
.... Q:'IBDTPD ; quit if the date paid is NULL/Empty
.... S IBDOS=$$GET1^DIQ(162.02,IBSERVDT_","_IBVEN_","_DFN_",",.01,"I")
.... S IBAUTH=$$GET1^DIQ(162.03,IBSERV_","_IBSERVDT_","_IBVEN_","_DFN_",",15.5,"I") ; New location as per FB*3.5*154
.... S IBTYP=$$GET1^DIQ(162.03,IBSERV_","_IBSERVDT_","_IBVEN_","_DFN_",",27,"I") I $G(IBTYP)["7078" S IBADMDT=$P($G(^FB7078(+IBTYP,0)),U,15) ; Find admission date
.... S IBINV=$$GET1^DIQ(162.03,IBSERV_","_IBSERVDT_","_IBVEN_","_DFN_",",14,"I")
.... Q:'IBINV ;Quit if there is no Invoice for this record
.... S IBCARETY=$$GET1^DIQ(162.03,IBSERV_","_IBSERVDT_","_IBVEN_","_DFN_",",23,"I") ;Fee Program pointer to #161.8
.... I "^2^3^6^7^"'[IBCARETY Q ;Fee Program categories
.... S IBPOV=$$GET1^DIQ(162.03,IBSERV_","_IBSERVDT_","_IBVEN_","_DFN_",",16,"I")
.... Q:'IBPOV
.... S IBCATC=$$CATC^FBPCR(DFN,IBDOS,IBPOV) ;determine 3rd party copayment requirements
.... S IBFBINS=$$INSURED^IBCNS1(DFN,IBDOS) ; Check for active insurance as per date of service
.... D ADMIT,CHKOTPT,FILE
Q
;
ADMIT ; check for inpatient 1st party bills
Q:$G(IBADMDT)=""
S IBBILL=0
K ^TMP("IBRBF",$J) ; kill of temp global before call
D FPINPT^IBEFURF(DFN,IBADMDT)
S IBBILL=$O(^TMP("IBRBF",$J,"FP",0))
K ^TMP("IBRBF",$J)
Q
;
;
FILE ; check payment against file #360
;
N FDA,IBEDIT,IBRECZ,IBOAUTH,IBOCLM,IBOBILL,IBFLAG
S (IBOAUTH,IBEDIT,IBREC,IBFLAG,IENS,IBCLAIM)=0,IBBILL=$G(IBBILL)
I $G(IBAUTH)="" S IBAUTH="0"
; check to see if the patient has that invoice, if so use that record
I IBINV,$D(^IBFB(360,"F",DFN,IBINV)) S IBREC=$O(^IBFB(360,"F",DFN,IBINV,0)) ;Check patient and invoice xref for existing record
;
; check to see if there is a record existing with no Auth that we can link to properly
I 'IBAUTH,$D(^IBFB(360,"C",DFN)) D
. S IBRECZ=0 ; set a temporary record number to check against former records by looping through "C" xref
. F S IBRECZ=$O(^IBFB(360,"C",DFN,IBRECZ)) Q:IBRECZ="" D
.. S IBOCLM=$P($G(^IBFB(360,IBRECZ,1)),U) ;Claim IEN exists for this record
.. S IBOBILL=$P($G(^IBFB(360,IBRECZ,1)),U,4) ; Bill IEN exists for this record
.. I IBOCLM!IBOBILL S IBREC=IBRECZ,IBRECZ="a" Q ;Found a record to edit, set missing Auth to zero and quit
.. Q
;
I ('FRSTPRT&'IBFBINS)!('IBCATC&'IBFBINS) Q ; Quit if no insurance and not Cat C or First party
;
; edit an existing record
I IBREC D
. K FDA
. ; S IBCLAIM=+$$GET1^DIQ(360,IBREC_",",1.01,"I")
. ; D STUB ;check/create stub record in file #356
. I $$GET1^DIQ(360,IBREC_",",1.03,"I")="" S FDA(360,IBREC_",",1.03)=$G(IBINV) ;Invoice number
. I $$GET1^DIQ(360,IBREC_",",.05,"I")="" S FDA(360,IBREC_",",.05)=IBDOS ;Initial treatment date
. I IBBILL,$$GET1^DIQ(360,IBREC_",",1.04,"I")="" S FDA(360,IBREC_",",1.04)=IBBILL ;1st Party Co-pay - Admission
. ; I IBCLAIM,$$GET1^DIQ(360,IBREC_",",1.01,"I")'=IBCLAIM S FDA(360,IBREC_",",1.01)=IBCLAIM ;Claim number
. I $$GET1^DIQ(360,IBREC_",",2.03,"I")="" S FDA(360,IBREC_",",2.03)="FR" ;Set facility revenue worklist queue
. Q:'$D(FDA)
. S IBFLAG=1 ; flag used for log file
. D UPDATE^DIE("","FDA")
. I 'IBCATC S IBBILL=$$GET1^DIQ(360,IBREC_",",1.04,"I") I IBBILL D SETOTPT
.;
;
; if the patient or the Invoice isn't present add a new record
I 'IBREC D
. K FDA,IENROOT
. S IBFLAG=1 ; flag used for log file
. S IBIENS="+1,",IENS=$P(^IBFB(360,0),U,3)+1
. S FDA(360,IBIENS,.01)=IENS,FDA(360,IBIENS,.02)=$G(DFN),FDA(360,IBIENS,.03)=$G(IBAUTH)
. S FDA(360,IBIENS,1.03)=$G(IBINV),FDA(360,IBIENS,.05)=IBDOS ;Invoice, Initial treatment date
. I IBBILL S FDA(360,IBIENS,1.04)=IBBILL ;1st Party Co-pay - Admission
. I OTPTBIL S FDA(360,IBIENS,1.04)=OTPTBIL ;1st Party Co-pay - outpt
. S FDA(360,IBIENS,2.03)="FR" ;Set facility revenue worklist queue
. S (IENROOT,IENROOT(1))="" ; adding new entry)
. D UPDATE^DIE("","FDA","IENROOT")
. I IENROOT(1)'="" S IBREC=IENROOT(1)
. ; D STUB K FDA
. ; S FDA(360,IBREC_",",1.01)=IBCLAIM
. ; D UPDATE^DIE("","FDA")
I IBREC,'FRSTPRT D
. Q:$P($G(^IBFB(360,IBREC,3)),U,2)=3
. K FDA
. S IBFLAG=1 ; flag used for log file
. S FDA(360,IBREC_",",3.02)=3
. D UPDATE^DIE("","FDA")
;
I FRSTPRT D
. Q:$P($G(^IBFB(360,IBREC,3)),U,2)=1
. K FDA
. S IENROOT="",IBFLAG=1 ; flag used for log file
. S FDA(360,IBREC_",",3.02)=1
. D UPDATE^DIE("","FDA","IENROOT")
;
I IBBILL!(OTPTBIL) D ; set pointer for Inpt or outpt 1st party copay
. I IBBILL Q:$P(^IB(IBBILL,0),U,23)=IBREC ; exists and valid
. I OTPTBIL Q:$P(^IB(OTPTBIL,0),U,23)=IBREC
. K FDA
. S IBFLAG=1 ; flag used for log file
. ;S FDA(350,IBBILL_",",.23)=IBREC ; set Non-Va Care value to the pointer to file 360
. D UPDATE^DIE("","FDA")
;
LOG ; set log (audit) file entries
N FDA,IBEVENT,IBMOD,IBDUZ
Q:'IBFLAG ;No changes were made
D NOW^%DTC S IBFBDT=%
S IBMOD=0,IBDUZ=$G(DUZ) I $G(IBDUZ)="" S IBDUZ=".5" ; Set user to postmaster (if ran via taskman)
S FDA(360.04,"+1,"_IBREC_",",.01)=IBFBDT,FDA(360.04,"+1,"_IBREC_",",.03)=$G(IBDUZ)
S IBMOD=0,IBLOG=$P($G(^IBFB(360,IBREC,4,0)),U,3)+1
I IBLOG="" S IBMOD=1
S IBEVENT=$S(IBMOD=0:"Auth log-FR queue",1:"Auth mod-FR queue"),FDA(360.04,"+1,"_IBREC_",",.02)=IBEVENT
D UPDATE^DIE("","FDA")
Q
;
STUB ; look for third party claim pointer in file #356
Q ;REMOVE SUBROUTINE
K IENROOT
I IBCLAIM,$$GET1^DIQ(360,IBREC_",",1.03,"I")'=IBINV S IBCLAIM=0 ;1 invoice per claim
I IBCLAIM,$D(^IBFB(360,"AD",IBCLAIM)),$O(^IBFB(360,"AD",IBCLAIM,0))'=IBREC S IBCLAIM=0 ;Claim already exists for another record
I 'IBCLAIM!($$GET1^DIQ(356,IBCLAIM_",",.33,"I")="") D Q ; invalid pointer to file #356 or it's not present (add if needed)
. K FDC,ZIENS,ZIEN
. I 'IBCLAIM S ZIENS="+1,",ZIEN=$P(^IBT(356,0),U,3)+1,IENROOT="" D
.. S FDC(356,ZIENS,.01)=IBSITE_ZIEN,FDC(356,ZIENS,.02)=DFN ;IEN and Patient
.. S FDC(356,ZIENS,.06)=IBDOS,FDC(356,ZIENS,.2)=1 ;Date of service and Active
. ;Edit an existing claim with no pointer
. I IBCLAIM S ZIENS=IBCLAIM_","
. S FDC(356,ZIENS,.33)=IBREC ;Link back to file #360 (IB-FB INTERFACE TRACKING FILE)
. I IBCARETY D
.. I IBCARETY=2 S FDC(356,ZIENS,.18)=6 Q ;Outpatient
.. I IBCARETY=3 S FDC(356,ZIENS,.18)=8 Q ;Pharmacy
.. I IBCARETY=6!(IBCARETY=7) S FDC(356,ZIENS,.18)=7 Q ;Inpatient
. I IBCLAIM D UPDATE^DIE("","FDC") ;edit
. I 'IBCLAIM D
.. D UPDATE^DIE("","FDC","IENROOT")
.. I IENROOT(1)'="" S IBCLAIM=IENROOT(1) ;New
Q
;
SETOTPT ; Look for first party claim pointer in file #360 to an exist Bill IEN
N FDA
;
Q:'$D(^IB(IBBILL,0)) ; invalid pointer to file #350 or it's not present
;Q:$P(^IB(IBBILL,0),U,23)=IBREC ; pointer is present and valid
;S FDA(350,IBBILL_",",.23)=IBREC ; set Non-Va Care value to the pointer to file 360
D UPDATE^DIE("","FDA")
Q
;
CHKOTPT ; check for Outpatient 1st party bills
K ^TMP("IBRBF",$J) ; kill of temp global before call
S (FRSTPRT,OTPTBIL)=0
D FPOPV^IBEFURF(DFN,IBDOS) Q:'$D(^TMP("IBRBF",$J))
S OTPTBIL=$O(^TMP("IBRBF",$J,"FP",0)),FRSTPRT=1 ;set outpt 1st party copay IEN and first party flag
K ^TMP("IBRBF",$J)
;
;END OF IBFBNP1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBFBNP1 9489 printed Apr 09, 2024@21:15:50 Page 2
IBFBNP1 ;ALB/RED- EDI-CPAC build 1st and 3rd party copayments ;10/01/15
+1 ;;2.0;INTEGRATED BILLING;**554**;21-MAR-94;Build 81
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
NRUN ; main entry point - nightly run job to look at existing FB payments and add/edit entries in file #360
+1 ;Start by looking for recent FB payments
+2 ;
+3 NEW FBSITE,IBVEN,IBSERVDT,IBCATC,IBSITE,IBMTC,FBARRLTC,IBDTPD,IBDUZ,IBREC,IBRECZ,IBDOS,IBTYP,IBADMDT,OTPTBIL,IBSTDT
+4 NEW IBBILL,IBCLAIM,IBFBDT,IBIENS,IBLOG,IENROOT,IENS,IBSERV,FRSTPRT,IBFBINS,IBDOST,FBA,FBC,IBCARETY,DFN,%,FBSITE
+5 ;build array needed later for POV in LTC co-pay
SET FBARRLTC=""
DO MKARRLTC^FBPCR4
+6 ;(CAT C FLAG and IBMTC = Determine if patient is pending adjudication or category C and has agreed to pay the deductible
SET (IBCATC,IBMTC,FRSTPRT)=0
+7 ;
+8 DO SITE^FBAACO
SET IBSITE=$PIECE(FBSITE(1),U,3)
+9 ;S IBN=$$PT^IBEFUNC(IBDFN) D UTIL^IBCA3,UTIL^IBOA32 ; check for all outstanding bills, build ^UTILITY($J
+10 ; set to last time Autobiller was ran -1 day (MOVED TO NODE 7, PIECE 2)
SET IBSTDT=$PIECE(^IBE(350.9,1,7),U,2)\1-1
+11 ;default to today-5 if not set
IF IBSTDT<1
SET IBSTDT=$$FMADD^XLFDT(DT,-5)
+12 FOR
SET IBSTDT=$ORDER(^FBAAC("AK",IBSTDT))
if 'IBSTDT
QUIT
DO PAYMT
+13 QUIT
PAYMT ;
+1 NEW DFN,IBAUTH,IBPOV,IBINV
+2 SET (DFN,IBPOV,IBINV,IBDOS,IBCARETY)=0
FOR
SET DFN=$ORDER(^FBAAC("AK",IBSTDT,DFN))
if 'DFN
QUIT
Begin DoDot:1
+3 SET IBVEN=0
FOR
SET IBVEN=$ORDER(^FBAAC("AK",IBSTDT,DFN,IBVEN))
if 'IBVEN
QUIT
Begin DoDot:2
+4 SET IBSERVDT=0
FOR
SET IBSERVDT=$ORDER(^FBAAC("AK",IBSTDT,DFN,IBVEN,IBSERVDT))
if 'IBSERVDT
QUIT
Begin DoDot:3
+5 SET IBSERV=0
FOR
SET IBSERV=$ORDER(^FBAAC("AK",IBSTDT,DFN,IBVEN,IBSERVDT,IBSERV))
if 'IBSERV
QUIT
Begin DoDot:4
+6 ; Set the temporary payment array to service date and the zero node (IBFB=patient;vendor;service prov IEN;service date IEN), Auth, Invoice and POV
+7 ; quit if the zero node of the payment is undefined
if $GET(^FBAAC(DFN,1,IBVEN,1,IBSERVDT,1,IBSERV,0))=""
QUIT
+8 ;payment was rejected
if $GET(^FBAAC(DFN,1,IBVEN,1,IBSERVDT,1,IBSERV,"FBREJ"))]""
QUIT
+9 SET IBDTPD=$$GET1^DIQ(162.03,IBSERV_","_IBSERVDT_","_IBVEN_","_DFN_",",12,"I")
+10 ; quit if the date paid is NULL/Empty
if 'IBDTPD
QUIT
+11 SET IBDOS=$$GET1^DIQ(162.02,IBSERVDT_","_IBVEN_","_DFN_",",.01,"I")
+12 ; New location as per FB*3.5*154
SET IBAUTH=$$GET1^DIQ(162.03,IBSERV_","_IBSERVDT_","_IBVEN_","_DFN_",",15.5,"I")
+13 ; Find admission date
SET IBTYP=$$GET1^DIQ(162.03,IBSERV_","_IBSERVDT_","_IBVEN_","_DFN_",",27,"I")
IF $GET(IBTYP)["7078"
SET IBADMDT=$PIECE($GET(^FB7078(+IBTYP,0)),U,15)
+14 SET IBINV=$$GET1^DIQ(162.03,IBSERV_","_IBSERVDT_","_IBVEN_","_DFN_",",14,"I")
+15 ;Quit if there is no Invoice for this record
if 'IBINV
QUIT
+16 ;Fee Program pointer to #161.8
SET IBCARETY=$$GET1^DIQ(162.03,IBSERV_","_IBSERVDT_","_IBVEN_","_DFN_",",23,"I")
+17 ;Fee Program categories
IF "^2^3^6^7^"'[IBCARETY
QUIT
+18 SET IBPOV=$$GET1^DIQ(162.03,IBSERV_","_IBSERVDT_","_IBVEN_","_DFN_",",16,"I")
+19 if 'IBPOV
QUIT
+20 ;determine 3rd party copayment requirements
SET IBCATC=$$CATC^FBPCR(DFN,IBDOS,IBPOV)
+21 ; Check for active insurance as per date of service
SET IBFBINS=$$INSURED^IBCNS1(DFN,IBDOS)
+22 DO ADMIT
DO CHKOTPT
DO FILE
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+23 QUIT
+24 ;
ADMIT ; check for inpatient 1st party bills
+1 if $GET(IBADMDT)=""
QUIT
+2 SET IBBILL=0
+3 ; kill of temp global before call
KILL ^TMP("IBRBF",$JOB)
+4 DO FPINPT^IBEFURF(DFN,IBADMDT)
+5 SET IBBILL=$ORDER(^TMP("IBRBF",$JOB,"FP",0))
+6 KILL ^TMP("IBRBF",$JOB)
+7 QUIT
+8 ;
+9 ;
FILE ; check payment against file #360
+1 ;
+2 NEW FDA,IBEDIT,IBRECZ,IBOAUTH,IBOCLM,IBOBILL,IBFLAG
+3 SET (IBOAUTH,IBEDIT,IBREC,IBFLAG,IENS,IBCLAIM)=0
SET IBBILL=$GET(IBBILL)
+4 IF $GET(IBAUTH)=""
SET IBAUTH="0"
+5 ; check to see if the patient has that invoice, if so use that record
+6 ;Check patient and invoice xref for existing record
IF IBINV
IF $DATA(^IBFB(360,"F",DFN,IBINV))
SET IBREC=$ORDER(^IBFB(360,"F",DFN,IBINV,0))
+7 ;
+8 ; check to see if there is a record existing with no Auth that we can link to properly
+9 IF 'IBAUTH
IF $DATA(^IBFB(360,"C",DFN))
Begin DoDot:1
+10 ; set a temporary record number to check against former records by looping through "C" xref
SET IBRECZ=0
+11 FOR
SET IBRECZ=$ORDER(^IBFB(360,"C",DFN,IBRECZ))
if IBRECZ=""
QUIT
Begin DoDot:2
+12 ;Claim IEN exists for this record
SET IBOCLM=$PIECE($GET(^IBFB(360,IBRECZ,1)),U)
+13 ; Bill IEN exists for this record
SET IBOBILL=$PIECE($GET(^IBFB(360,IBRECZ,1)),U,4)
+14 ;Found a record to edit, set missing Auth to zero and quit
IF IBOCLM!IBOBILL
SET IBREC=IBRECZ
SET IBRECZ="a"
QUIT
+15 QUIT
End DoDot:2
End DoDot:1
+16 ;
+17 ; Quit if no insurance and not Cat C or First party
IF ('FRSTPRT&'IBFBINS)!('IBCATC&'IBFBINS)
QUIT
+18 ;
+19 ; edit an existing record
+20 IF IBREC
Begin DoDot:1
+21 KILL FDA
+22 ; S IBCLAIM=+$$GET1^DIQ(360,IBREC_",",1.01,"I")
+23 ; D STUB ;check/create stub record in file #356
+24 ;Invoice number
IF $$GET1^DIQ(360,IBREC_",",1.03,"I")=""
SET FDA(360,IBREC_",",1.03)=$GET(IBINV)
+25 ;Initial treatment date
IF $$GET1^DIQ(360,IBREC_",",.05,"I")=""
SET FDA(360,IBREC_",",.05)=IBDOS
+26 ;1st Party Co-pay - Admission
IF IBBILL
IF $$GET1^DIQ(360,IBREC_",",1.04,"I")=""
SET FDA(360,IBREC_",",1.04)=IBBILL
+27 ; I IBCLAIM,$$GET1^DIQ(360,IBREC_",",1.01,"I")'=IBCLAIM S FDA(360,IBREC_",",1.01)=IBCLAIM ;Claim number
+28 ;Set facility revenue worklist queue
IF $$GET1^DIQ(360,IBREC_",",2.03,"I")=""
SET FDA(360,IBREC_",",2.03)="FR"
+29 if '$DATA(FDA)
QUIT
+30 ; flag used for log file
SET IBFLAG=1
+31 DO UPDATE^DIE("","FDA")
+32 IF 'IBCATC
SET IBBILL=$$GET1^DIQ(360,IBREC_",",1.04,"I")
IF IBBILL
DO SETOTPT
+33 ;
End DoDot:1
+34 ;
+35 ; if the patient or the Invoice isn't present add a new record
+36 IF 'IBREC
Begin DoDot:1
+37 KILL FDA,IENROOT
+38 ; flag used for log file
SET IBFLAG=1
+39 SET IBIENS="+1,"
SET IENS=$PIECE(^IBFB(360,0),U,3)+1
+40 SET FDA(360,IBIENS,.01)=IENS
SET FDA(360,IBIENS,.02)=$GET(DFN)
SET FDA(360,IBIENS,.03)=$GET(IBAUTH)
+41 ;Invoice, Initial treatment date
SET FDA(360,IBIENS,1.03)=$GET(IBINV)
SET FDA(360,IBIENS,.05)=IBDOS
+42 ;1st Party Co-pay - Admission
IF IBBILL
SET FDA(360,IBIENS,1.04)=IBBILL
+43 ;1st Party Co-pay - outpt
IF OTPTBIL
SET FDA(360,IBIENS,1.04)=OTPTBIL
+44 ;Set facility revenue worklist queue
SET FDA(360,IBIENS,2.03)="FR"
+45 ; adding new entry)
SET (IENROOT,IENROOT(1))=""
+46 DO UPDATE^DIE("","FDA","IENROOT")
+47 IF IENROOT(1)'=""
SET IBREC=IENROOT(1)
+48 ; D STUB K FDA
+49 ; S FDA(360,IBREC_",",1.01)=IBCLAIM
+50 ; D UPDATE^DIE("","FDA")
End DoDot:1
+51 IF IBREC
IF 'FRSTPRT
Begin DoDot:1
+52 if $PIECE($GET(^IBFB(360,IBREC,3)),U,2)=3
QUIT
+53 KILL FDA
+54 ; flag used for log file
SET IBFLAG=1
+55 SET FDA(360,IBREC_",",3.02)=3
+56 DO UPDATE^DIE("","FDA")
End DoDot:1
+57 ;
+58 IF FRSTPRT
Begin DoDot:1
+59 if $PIECE($GET(^IBFB(360,IBREC,3)),U,2)=1
QUIT
+60 KILL FDA
+61 ; flag used for log file
SET IENROOT=""
SET IBFLAG=1
+62 SET FDA(360,IBREC_",",3.02)=1
+63 DO UPDATE^DIE("","FDA","IENROOT")
End DoDot:1
+64 ;
+65 ; set pointer for Inpt or outpt 1st party copay
IF IBBILL!(OTPTBIL)
Begin DoDot:1
+66 ; exists and valid
IF IBBILL
if $PIECE(^IB(IBBILL,0),U,23)=IBREC
QUIT
+67 IF OTPTBIL
if $PIECE(^IB(OTPTBIL,0),U,23)=IBREC
QUIT
+68 KILL FDA
+69 ; flag used for log file
SET IBFLAG=1
+70 ;S FDA(350,IBBILL_",",.23)=IBREC ; set Non-Va Care value to the pointer to file 360
+71 DO UPDATE^DIE("","FDA")
End DoDot:1
+72 ;
LOG ; set log (audit) file entries
+1 NEW FDA,IBEVENT,IBMOD,IBDUZ
+2 ;No changes were made
if 'IBFLAG
QUIT
+3 DO NOW^%DTC
SET IBFBDT=%
+4 ; Set user to postmaster (if ran via taskman)
SET IBMOD=0
SET IBDUZ=$GET(DUZ)
IF $GET(IBDUZ)=""
SET IBDUZ=".5"
+5 SET FDA(360.04,"+1,"_IBREC_",",.01)=IBFBDT
SET FDA(360.04,"+1,"_IBREC_",",.03)=$GET(IBDUZ)
+6 SET IBMOD=0
SET IBLOG=$PIECE($GET(^IBFB(360,IBREC,4,0)),U,3)+1
+7 IF IBLOG=""
SET IBMOD=1
+8 SET IBEVENT=$SELECT(IBMOD=0:"Auth log-FR queue",1:"Auth mod-FR queue")
SET FDA(360.04,"+1,"_IBREC_",",.02)=IBEVENT
+9 DO UPDATE^DIE("","FDA")
+10 QUIT
+11 ;
STUB ; look for third party claim pointer in file #356
+1 ;REMOVE SUBROUTINE
QUIT
+2 KILL IENROOT
+3 ;1 invoice per claim
IF IBCLAIM
IF $$GET1^DIQ(360,IBREC_",",1.03,"I")'=IBINV
SET IBCLAIM=0
+4 ;Claim already exists for another record
IF IBCLAIM
IF $DATA(^IBFB(360,"AD",IBCLAIM))
IF $ORDER(^IBFB(360,"AD",IBCLAIM,0))'=IBREC
SET IBCLAIM=0
+5 ; invalid pointer to file #356 or it's not present (add if needed)
IF 'IBCLAIM!($$GET1^DIQ(356,IBCLAIM_",",.33,"I")="")
Begin DoDot:1
+6 KILL FDC,ZIENS,ZIEN
+7 IF 'IBCLAIM
SET ZIENS="+1,"
SET ZIEN=$PIECE(^IBT(356,0),U,3)+1
SET IENROOT=""
Begin DoDot:2
+8 ;IEN and Patient
SET FDC(356,ZIENS,.01)=IBSITE_ZIEN
SET FDC(356,ZIENS,.02)=DFN
+9 ;Date of service and Active
SET FDC(356,ZIENS,.06)=IBDOS
SET FDC(356,ZIENS,.2)=1
End DoDot:2
+10 ;Edit an existing claim with no pointer
+11 IF IBCLAIM
SET ZIENS=IBCLAIM_","
+12 ;Link back to file #360 (IB-FB INTERFACE TRACKING FILE)
SET FDC(356,ZIENS,.33)=IBREC
+13 IF IBCARETY
Begin DoDot:2
+14 ;Outpatient
IF IBCARETY=2
SET FDC(356,ZIENS,.18)=6
QUIT
+15 ;Pharmacy
IF IBCARETY=3
SET FDC(356,ZIENS,.18)=8
QUIT
+16 ;Inpatient
IF IBCARETY=6!(IBCARETY=7)
SET FDC(356,ZIENS,.18)=7
QUIT
End DoDot:2
+17 ;edit
IF IBCLAIM
DO UPDATE^DIE("","FDC")
+18 IF 'IBCLAIM
Begin DoDot:2
+19 DO UPDATE^DIE("","FDC","IENROOT")
+20 ;New
IF IENROOT(1)'=""
SET IBCLAIM=IENROOT(1)
End DoDot:2
End DoDot:1
QUIT
+21 QUIT
+22 ;
SETOTPT ; Look for first party claim pointer in file #360 to an exist Bill IEN
+1 NEW FDA
+2 ;
+3 ; invalid pointer to file #350 or it's not present
if '$DATA(^IB(IBBILL,0))
QUIT
+4 ;Q:$P(^IB(IBBILL,0),U,23)=IBREC ; pointer is present and valid
+5 ;S FDA(350,IBBILL_",",.23)=IBREC ; set Non-Va Care value to the pointer to file 360
+6 DO UPDATE^DIE("","FDA")
+7 QUIT
+8 ;
CHKOTPT ; check for Outpatient 1st party bills
+1 ; kill of temp global before call
KILL ^TMP("IBRBF",$JOB)
+2 SET (FRSTPRT,OTPTBIL)=0
+3 DO FPOPV^IBEFURF(DFN,IBDOS)
if '$DATA(^TMP("IBRBF",$JOB))
QUIT
+4 ;set outpt 1st party copay IEN and first party flag
SET OTPTBIL=$ORDER(^TMP("IBRBF",$JOB,"FP",0))
SET FRSTPRT=1
+5 KILL ^TMP("IBRBF",$JOB)
+6 ;
+7 ;END OF IBFBNP1
