IBAMTS1 ;ALB/CPM - PROCESS NEW OUTPATIENT ENCOUNTERS ; 22-JUL-93
;;2.0;INTEGRATED BILLING;**20,52,132,153,166,156,167,247,339,614,760**;21-MAR-94;Build 25
;;Per VHA Directive 2004-038, this routine should not be modified.
;
NEW ; Appointment fully processed - prepare a new charge.
;
; ibbilled is set to 1 if the patient has already been billed on this
; date. if the date is after 12/5/01, check the type of bill to see
; if it is an upgrade from primary (1st bill) to specialty (new bill)
I IBBILLED D:IBDAT'<3011206 CHKPRIM I IBBILLED G NEWQ
;
; - for registrations, get disposition, and use log-out date/time
I IBORG=3 D G:'IBDISP NEWQ
.S IBDISP=+$P($G(^TMP("SDEVT",$J,SDHDL,IBORG,"DIS",0,"AFTER")),"^",7)
.Q:'IBDISP
.S IBTEMP=+$P($G(^TMP("SDEVT",$J,SDHDL,IBORG,"DIS",0,"AFTER")),"^",6)
.S:IBTEMP IBDT=IBTEMP,IBDAT=$P(IBDT,".")
;
I '$$BIL^DGMTUB(DFN,IBDT) G NEWQ ; patient is not Means Test billable
;
; - perform batch of edits
I '$$CHKS G NEWQ
;
; - quit if AO/IR/SWA/MST/HNC/CV/SHAD exposure is indicated, or SC related
D CLSF(0,.IBCLSF)
I IBCLSF[1 G NEWQ
;
; - quit if the Pt is Visit Copay exempt based on HRfS flag (IB*2.0*614)
I $$CHKHRFS^IBAMTS3(DFN,IBDAT) G NEWQ
;
S IBSL="409.68:"_IBOE
;
BLD ; - build the charge. May also enter from IBAMTS2 (requires IBSL)
;
; find the clinic stop code in 409.68 (dbia402) and find the matching
; entry in file 352.5. the 352.5 entry is populated in the 350 field
; for reference using the ibstopda variable
N %,IBSTOPDA,IBTYPE
S %=$$GETSC^IBEMTSCU(IBSL,IBDAT) I % S IBSTOPDA=%
;
; get the rate, ibtype = primary or specialty
S IBTYPE=$P($G(^IBE(352.5,+$G(IBSTOPDA),0)),"^",3) I IBTYPE=0 Q
; if the type is not defined, must be a local created sc, set it to primary
I 'IBTYPE S IBTYPE=1
S IBX="O" D TYPE^IBAUTL2 G:IBY<0 NEWQ
S IBUNIT=1,(IBFR,IBTO)=IBDAT,IBEVDA="*"
D ADD^IBECEAU3 G:IBY<0 NEWQ
;
; - if enctr is exempt from classification, but patient isn't, send msg
I $$EXOE^SDCOU2($S($G(IBOEN):IBOEN,1:IBOE)),$$CLPT(DFN,IBDAT) D BULL^IBAMTS
;
; - if the opt billing rate is over a year old, place the charge on hold
;I $$OLDRATE(IBRTED,IBFR) D G CLOCK
;.S DIE="^IB(",DA=IBN,DR=".05////20" D ^DIE K DIE,DA,DR
;
; - drop the charge into the background filer
D IBFLR G:IBY<0 NEWQ
;
; - if there is no active billing clock, add one
CLOCK I '$D(^IBE(351,"ACT",DFN)) S IBCLDT=IBDAT D CLADD^IBAUTL3
;
NEWQ I IBY<0 D ^IBAERR1
K IBDISP,IBCLSF,IBCLDA,IBMED,IBCLDT,IBN,IBBS,IBTEMP
K IBUNIT,IBFR,IBTO,IBSL,IBEVDA,IBX,IBDESC,IBATYP,IBCHG
Q
;
CHKS() ; Perform a batch of edits to determine whether to bill.
; Input variables required: IBEVT -- encounter
; IBAPTY -- appt type
; IBDAT -- appt date
; IBDT -- appt date/time
; IBORG -- originating process
; IBDISP -- disposition (if registration)
N IBRESULT
;
; default is fail the checks
S IBRESULT=0
;
; for appts prior to 12/6/2001
I IBDAT<3011206 D Q IBRESULT
. ; - non-count clinic
. I $P($G(^SC(+$P(IBEVT,"^",4),0)),"^",17)="Y" Q
. ;
. ; - non-billable appointment type
. I $$IGN^IBEFUNC(IBAPTY,IBDAT) Q
. ;
. ; - non-billable disposition/stop code/clinic
. I IBORG=1!(IBORG=2),$$NBCL^IBEFUNC(+$P(IBEVT,"^",4),IBDT) Q
. I IBORG=1!(IBORG=2),$$NBCSC^IBEFUNC(+$P(IBEVT,"^",3),IBDT) Q
. I IBORG=3,$$NBDIS^IBEFUNC(IBDISP,IBDT) Q
. ;
. ; - ignore if checked out late and pt was an inpatient at midnight
. I DT>IBDAT,$$INPT(DFN,IBDAT_".2359") Q
. ;
. ; pass the checks
. S IBRESULT=1
;
; for appts on or after 12/6/2001
;
; - non-billable appointment type
I $$IGN^IBEFUNC(IBAPTY,IBDAT) Q 0
;
; - non-count clinic
I $P($G(^SC(+$P(IBEVT,"^",4),0)),"^",17)="Y" Q 0
;
; - ignore if checked out late and pt was an inpatient at midnight
I DT>IBDAT,$$INPT(DFN,IBDAT_".2359") Q 0
;
; pass the checks
Q 1
;
;
IBFLR ; Drop the charge into the IB Background filer.
N IBSEQNO,IBNOS,IBNOW,IBTOTL,IBSERV,IBWHER,IBFAC,IBSITE,IBAFY,IBARTYP,IBIL,IBTRAN
D NOW^%DTC S IBNOW=%,IBNOS=IBN
S IBSEQNO=$P($G(^IBE(350.1,+IBATYP,0)),"^",5) I 'IBSEQNO S IBY="-1^IB023"
I IBY>0 D ^IBAFIL
Q
;
CLPT(DFN,VDATE) ; Should the patient be asked the classification questions?
; Input: DFN -- Pointer to the patient in file #2
; VDATE -- Visit date
N IBARR D CL^SDCO21(DFN,VDATE,"",.IBARR)
Q $D(IBARR)>0
;
INPT(DFN,VAINDT) ; Was the patient an inpatient at VAINDT?
; Input: DFN -- Pointer to the patient in file #2
; VAINDT -- Date/time to check for inpatient status
; Output: 1 - inpatient | 0 - not an inpatient
N VADMVT D ADM^VADPT2
Q VADMVT>0
;
CLSF(IBUPD,Y) ; Examine classification questions.
; Input: IBUPD -- 0 if event just checked out
; 1 if event is being updated
; Y -- array to place output
; Output: indicators returned as ao^ir^sc^swa^mst^hnc^cv^shad [1|yes, 0|no]
; if IBUPD=0, Y is returned as a single string
; if IBUPD=1, Y("BEFORE"),Y("AFTER") are defined.
N X,ZA,ZB S:'$G(IBUPD) Y="" S:$G(IBUPD) (Y("BEFORE"),Y("AFTER"))=""
S X=0 F S X=$O(^TMP("SDEVT",$J,SDHDL,IBORG,"SDOE",IBOE,"CL",X)) Q:'X S ZB=$G(^(X,0,"BEFORE")),ZA=$G(^("AFTER")) D
.I '$G(IBUPD) S:ZA $P(Y,"^",+ZA)=+$P(ZA,"^",3) Q
.S $P(Y("BEFORE"),"^",+ZB)=+$P(ZB,"^",3),$P(Y("AFTER"),"^",+ZA)=+$P(ZA,"^",3)
Q
;
OLDRATE(IBRTED,IBFR) ; See if the copay rate effective date is too old.
; Input: IBRTED -- Charge Effective Date
; IBFR -- Visit Date
; Output: 1 -- Effective Date is too old
; 0 -- Not
;
N IBNUM,IBYR
S IBNUM=$$FMDIFF^XLFDT(IBFR,IBRTED),IBYR=$E(IBFR,1,3)
Q IBYR#4&(IBNUM>364)!(IBYR#4=0&(IBNUM>365))
;
;
CHKPRIM ; check to see if patient has been billed for primary
; and this is a specialty stop. if so, cancel the primary
; bill and let the software create the new specialty charge
; input ibbilled = last parent bill to check (ien 350)
; used to check the rate
; output ibbilled = last parent bill number to prevent
; adding specialty charge
N %,IBSTOPDA,IBTYPE,IBCRES,IBI,IBS
;
; get the stop code for the 2nd visit on the same day
S IBSTOPDA=$$GETSC^IBEMTSCU("409.68:"_IBOE,IBDAT) I 'IBSTOPDA Q
;
; get the rate, ibtype = primary or specialty
S IBTYPE=$P(^IBE(352.5,IBSTOPDA,0),"^",3)
; if the new appt is not specialty, quit ... no need to create
; a new charge
I IBTYPE'=2 Q
;
; if the last charge was billed at specialty, quit
I $P($G(^IBE(352.5,+$P($G(^IB(+IBBILLED,0)),"^",20),0)),"^",3)=2 Q
;
; cancel the charge
; cancellation reason = billed at higher tier rate
S IBCRES=6,IBS=$P($G(^IB(+IBBILLED,0)),"^",5)
;
; if not billed, on hold, or cancelled wait
I IBS'=3!(IBS'=8)!(IBS'=10) F IBI=1:1:10 H 1 S IBS=$P($G(^IB(+IBBILLED,0)),"^",5) I IBS=3!(IBS=8)!(IBS=10) Q
;
D CANC^IBAMTS2
D UPDCANC^IBAMTC(+IBBILLED) ; update MH visit tracking for cancelled charge IB*2.0*760
;
; set ibbilled = 0 to create the specialty charge
S IBBILLED=0
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBAMTS1 7379 printed Dec 13, 2024@02:06:41 Page 2
IBAMTS1 ;ALB/CPM - PROCESS NEW OUTPATIENT ENCOUNTERS ; 22-JUL-93
+1 ;;2.0;INTEGRATED BILLING;**20,52,132,153,166,156,167,247,339,614,760**;21-MAR-94;Build 25
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
NEW ; Appointment fully processed - prepare a new charge.
+1 ;
+2 ; ibbilled is set to 1 if the patient has already been billed on this
+3 ; date. if the date is after 12/5/01, check the type of bill to see
+4 ; if it is an upgrade from primary (1st bill) to specialty (new bill)
+5 IF IBBILLED
if IBDAT'<3011206
DO CHKPRIM
IF IBBILLED
GOTO NEWQ
+6 ;
+7 ; - for registrations, get disposition, and use log-out date/time
+8 IF IBORG=3
Begin DoDot:1
+9 SET IBDISP=+$PIECE($GET(^TMP("SDEVT",$JOB,SDHDL,IBORG,"DIS",0,"AFTER")),"^",7)
+10 if 'IBDISP
QUIT
+11 SET IBTEMP=+$PIECE($GET(^TMP("SDEVT",$JOB,SDHDL,IBORG,"DIS",0,"AFTER")),"^",6)
+12 if IBTEMP
SET IBDT=IBTEMP
SET IBDAT=$PIECE(IBDT,".")
End DoDot:1
if 'IBDISP
GOTO NEWQ
+13 ;
+14 ; patient is not Means Test billable
IF '$$BIL^DGMTUB(DFN,IBDT)
GOTO NEWQ
+15 ;
+16 ; - perform batch of edits
+17 IF '$$CHKS
GOTO NEWQ
+18 ;
+19 ; - quit if AO/IR/SWA/MST/HNC/CV/SHAD exposure is indicated, or SC related
+20 DO CLSF(0,.IBCLSF)
+21 IF IBCLSF[1
GOTO NEWQ
+22 ;
+23 ; - quit if the Pt is Visit Copay exempt based on HRfS flag (IB*2.0*614)
+24 IF $$CHKHRFS^IBAMTS3(DFN,IBDAT)
GOTO NEWQ
+25 ;
+26 SET IBSL="409.68:"_IBOE
+27 ;
BLD ; - build the charge. May also enter from IBAMTS2 (requires IBSL)
+1 ;
+2 ; find the clinic stop code in 409.68 (dbia402) and find the matching
+3 ; entry in file 352.5. the 352.5 entry is populated in the 350 field
+4 ; for reference using the ibstopda variable
+5 NEW %,IBSTOPDA,IBTYPE
+6 SET %=$$GETSC^IBEMTSCU(IBSL,IBDAT)
IF %
SET IBSTOPDA=%
+7 ;
+8 ; get the rate, ibtype = primary or specialty
+9 SET IBTYPE=$PIECE($GET(^IBE(352.5,+$GET(IBSTOPDA),0)),"^",3)
IF IBTYPE=0
QUIT
+10 ; if the type is not defined, must be a local created sc, set it to primary
+11 IF 'IBTYPE
SET IBTYPE=1
+12 SET IBX="O"
DO TYPE^IBAUTL2
if IBY<0
GOTO NEWQ
+13 SET IBUNIT=1
SET (IBFR,IBTO)=IBDAT
SET IBEVDA="*"
+14 DO ADD^IBECEAU3
if IBY<0
GOTO NEWQ
+15 ;
+16 ; - if enctr is exempt from classification, but patient isn't, send msg
+17 IF $$EXOE^SDCOU2($SELECT($GET(IBOEN):IBOEN,1:IBOE))
IF $$CLPT(DFN,IBDAT)
DO BULL^IBAMTS
+18 ;
+19 ; - if the opt billing rate is over a year old, place the charge on hold
+20 ;I $$OLDRATE(IBRTED,IBFR) D G CLOCK
+21 ;.S DIE="^IB(",DA=IBN,DR=".05////20" D ^DIE K DIE,DA,DR
+22 ;
+23 ; - drop the charge into the background filer
+24 DO IBFLR
if IBY<0
GOTO NEWQ
+25 ;
+26 ; - if there is no active billing clock, add one
CLOCK IF '$DATA(^IBE(351,"ACT",DFN))
SET IBCLDT=IBDAT
DO CLADD^IBAUTL3
+1 ;
NEWQ IF IBY<0
DO ^IBAERR1
+1 KILL IBDISP,IBCLSF,IBCLDA,IBMED,IBCLDT,IBN,IBBS,IBTEMP
+2 KILL IBUNIT,IBFR,IBTO,IBSL,IBEVDA,IBX,IBDESC,IBATYP,IBCHG
+3 QUIT
+4 ;
CHKS() ; Perform a batch of edits to determine whether to bill.
+1 ; Input variables required: IBEVT -- encounter
+2 ; IBAPTY -- appt type
+3 ; IBDAT -- appt date
+4 ; IBDT -- appt date/time
+5 ; IBORG -- originating process
+6 ; IBDISP -- disposition (if registration)
+7 NEW IBRESULT
+8 ;
+9 ; default is fail the checks
+10 SET IBRESULT=0
+11 ;
+12 ; for appts prior to 12/6/2001
+13 IF IBDAT<3011206
Begin DoDot:1
+14 ; - non-count clinic
+15 IF $PIECE($GET(^SC(+$PIECE(IBEVT,"^",4),0)),"^",17)="Y"
QUIT
+16 ;
+17 ; - non-billable appointment type
+18 IF $$IGN^IBEFUNC(IBAPTY,IBDAT)
QUIT
+19 ;
+20 ; - non-billable disposition/stop code/clinic
+21 IF IBORG=1!(IBORG=2)
IF $$NBCL^IBEFUNC(+$PIECE(IBEVT,"^",4),IBDT)
QUIT
+22 IF IBORG=1!(IBORG=2)
IF $$NBCSC^IBEFUNC(+$PIECE(IBEVT,"^",3),IBDT)
QUIT
+23 IF IBORG=3
IF $$NBDIS^IBEFUNC(IBDISP,IBDT)
QUIT
+24 ;
+25 ; - ignore if checked out late and pt was an inpatient at midnight
+26 IF DT>IBDAT
IF $$INPT(DFN,IBDAT_".2359")
QUIT
+27 ;
+28 ; pass the checks
+29 SET IBRESULT=1
End DoDot:1
QUIT IBRESULT
+30 ;
+31 ; for appts on or after 12/6/2001
+32 ;
+33 ; - non-billable appointment type
+34 IF $$IGN^IBEFUNC(IBAPTY,IBDAT)
QUIT 0
+35 ;
+36 ; - non-count clinic
+37 IF $PIECE($GET(^SC(+$PIECE(IBEVT,"^",4),0)),"^",17)="Y"
QUIT 0
+38 ;
+39 ; - ignore if checked out late and pt was an inpatient at midnight
+40 IF DT>IBDAT
IF $$INPT(DFN,IBDAT_".2359")
QUIT 0
+41 ;
+42 ; pass the checks
+43 QUIT 1
+44 ;
+45 ;
IBFLR ; Drop the charge into the IB Background filer.
+1 NEW IBSEQNO,IBNOS,IBNOW,IBTOTL,IBSERV,IBWHER,IBFAC,IBSITE,IBAFY,IBARTYP,IBIL,IBTRAN
+2 DO NOW^%DTC
SET IBNOW=%
SET IBNOS=IBN
+3 SET IBSEQNO=$PIECE($GET(^IBE(350.1,+IBATYP,0)),"^",5)
IF 'IBSEQNO
SET IBY="-1^IB023"
+4 IF IBY>0
DO ^IBAFIL
+5 QUIT
+6 ;
CLPT(DFN,VDATE) ; Should the patient be asked the classification questions?
+1 ; Input: DFN -- Pointer to the patient in file #2
+2 ; VDATE -- Visit date
+3 NEW IBARR
DO CL^SDCO21(DFN,VDATE,"",.IBARR)
+4 QUIT $DATA(IBARR)>0
+5 ;
INPT(DFN,VAINDT) ; Was the patient an inpatient at VAINDT?
+1 ; Input: DFN -- Pointer to the patient in file #2
+2 ; VAINDT -- Date/time to check for inpatient status
+3 ; Output: 1 - inpatient | 0 - not an inpatient
+4 NEW VADMVT
DO ADM^VADPT2
+5 QUIT VADMVT>0
+6 ;
CLSF(IBUPD,Y) ; Examine classification questions.
+1 ; Input: IBUPD -- 0 if event just checked out
+2 ; 1 if event is being updated
+3 ; Y -- array to place output
+4 ; Output: indicators returned as ao^ir^sc^swa^mst^hnc^cv^shad [1|yes, 0|no]
+5 ; if IBUPD=0, Y is returned as a single string
+6 ; if IBUPD=1, Y("BEFORE"),Y("AFTER") are defined.
+7 NEW X,ZA,ZB
if '$GET(IBUPD)
SET Y=""
if $GET(IBUPD)
SET (Y("BEFORE"),Y("AFTER"))=""
+8 SET X=0
FOR
SET X=$ORDER(^TMP("SDEVT",$JOB,SDHDL,IBORG,"SDOE",IBOE,"CL",X))
if 'X
QUIT
SET ZB=$GET(^(X,0,"BEFORE"))
SET ZA=$GET(^("AFTER"))
Begin DoDot:1
+9 IF '$GET(IBUPD)
if ZA
SET $PIECE(Y,"^",+ZA)=+$PIECE(ZA,"^",3)
QUIT
+10 SET $PIECE(Y("BEFORE"),"^",+ZB)=+$PIECE(ZB,"^",3)
SET $PIECE(Y("AFTER"),"^",+ZA)=+$PIECE(ZA,"^",3)
End DoDot:1
+11 QUIT
+12 ;
OLDRATE(IBRTED,IBFR) ; See if the copay rate effective date is too old.
+1 ; Input: IBRTED -- Charge Effective Date
+2 ; IBFR -- Visit Date
+3 ; Output: 1 -- Effective Date is too old
+4 ; 0 -- Not
+5 ;
+6 NEW IBNUM,IBYR
+7 SET IBNUM=$$FMDIFF^XLFDT(IBFR,IBRTED)
SET IBYR=$EXTRACT(IBFR,1,3)
+8 QUIT IBYR#4&(IBNUM>364)!(IBYR#4=0&(IBNUM>365))
+9 ;
+10 ;
CHKPRIM ; check to see if patient has been billed for primary
+1 ; and this is a specialty stop. if so, cancel the primary
+2 ; bill and let the software create the new specialty charge
+3 ; input ibbilled = last parent bill to check (ien 350)
+4 ; used to check the rate
+5 ; output ibbilled = last parent bill number to prevent
+6 ; adding specialty charge
+7 NEW %,IBSTOPDA,IBTYPE,IBCRES,IBI,IBS
+8 ;
+9 ; get the stop code for the 2nd visit on the same day
+10 SET IBSTOPDA=$$GETSC^IBEMTSCU("409.68:"_IBOE,IBDAT)
IF 'IBSTOPDA
QUIT
+11 ;
+12 ; get the rate, ibtype = primary or specialty
+13 SET IBTYPE=$PIECE(^IBE(352.5,IBSTOPDA,0),"^",3)
+14 ; if the new appt is not specialty, quit ... no need to create
+15 ; a new charge
+16 IF IBTYPE'=2
QUIT
+17 ;
+18 ; if the last charge was billed at specialty, quit
+19 IF $PIECE($GET(^IBE(352.5,+$PIECE($GET(^IB(+IBBILLED,0)),"^",20),0)),"^",3)=2
QUIT
+20 ;
+21 ; cancel the charge
+22 ; cancellation reason = billed at higher tier rate
+23 SET IBCRES=6
SET IBS=$PIECE($GET(^IB(+IBBILLED,0)),"^",5)
+24 ;
+25 ; if not billed, on hold, or cancelled wait
+26 IF IBS'=3!(IBS'=8)!(IBS'=10)
FOR IBI=1:1:10
HANG 1
SET IBS=$PIECE($GET(^IB(+IBBILLED,0)),"^",5)
IF IBS=3!(IBS=8)!(IBS=10)
QUIT
+27 ;
+28 DO CANC^IBAMTS2
+29 ; update MH visit tracking for cancelled charge IB*2.0*760
DO UPDCANC^IBAMTC(+IBBILLED)
+30 ;
+31 ; set ibbilled = 0 to create the specialty charge
+32 SET IBBILLED=0
+33 QUIT
+34 ;
