IBAMTEDU ;ALB/CPM - MEANS TEST BULLETIN UTILITIES ; 15-JUN-93
;;2.0;INTEGRATED BILLING;**15,91,153**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
CHG(IBDAT) ; Any charges billed on or after IBDAT?
; Input: IBDAT -- Date on or after which charges have been billed
; Output: 0 -- No charges billed
; 1 -- Charges were billed; IBARR contains array
; of those charges
N IBFND,IBD,IBN,IBX,IBJOB,IBWHER K IBARR
;
; - if the effective date of the test is today, cancel today's charges.
I $P(IBDAT,".")=DT D CANC G CHGQ
;
; - find all charges which may need to be cancelled.
S IBX="" F S IBX=$O(^IB("AFDT",DFN,IBX)) Q:'IBX S IBD=0 F S IBD=$O(^IB("AFDT",DFN,IBX,IBD)) Q:'IBD D
.I $P($G(^IB(IBD,0)),"^",8)'["ADMISSION" D:-IBX'<IBDAT CHK(IBD) Q
.S IBN=0 F S IBN=$O(^IB("AF",IBD,IBN)) Q:'IBN D CHK(IBN)
CHGQ Q +$G(IBFND)
;
CHK(IBN) ; Place charge into the array.
; Input: IBN -- Charge to check
N IBND,IBNDL,IBLAST
S IBND=$G(^IB(IBN,0)) I $P(IBND,"^",15)<IBDAT G CHKQ
S IBLAST=$$LAST^IBECEAU(+$P(IBND,"^",9)),IBNDL=$G(^IB(+IBLAST,0))
I $P($G(^IBE(350.1,+$P(IBNDL,"^",3),0)),"^",5)'=2,"^1^2^3^4^8^20^21^"[("^"_$P(IBNDL,"^",5)_"^") S IBARR(+$P(IBNDL,"^",14),IBLAST)="",IBFND=1
CHKQ Q
;
CANC ; Cancel any charges for the patient for today.
N IBD,IBN,IBCRES,IBFAC,IBSITE,IBSERV,IBDUZ
Q:'$$CHECK^IBECEAU
S IBCRES=+$O(^IBE(350.3,"B","MT STATUS CHANGED FROM YES",0))
S:'IBCRES IBCRES=22 S IBJOB=7,IBWHER=30,IBDUZ=DUZ
S IBD=0 F S IBD=$O(^IB("AFDT",DFN,-DT,IBD)) Q:'IBD D
.I $P($G(^IB(IBD,0)),"^",8)'["ADMISSION" D CANCH^IBECEAU4(IBD,IBCRES,1) Q
.S IBN=0 F S IBN=$O(^IB("AF",IBD,IBN)) Q:'IBN D CANCH^IBECEAU4(IBN,IBCRES,1)
Q
;
;
EP(IBDAT) ; Any billable episodes of care since IBDAT?
; Input: IBDAT -- Date on or after which patient received care
; Output: 0 -- No billable episodes found
; 1 -- Billable episodes were found; IBARR contains an
; array of those episodes
;
N IBD,IBAD,IBNOW,IBEP,IBDT,IBI,IBPM,VA,VAIP,VAERR,IBVAL,IBCBK,IBZ,IBPB
;
; - quit if the effective date of the test is today
I $P(IBDAT,".")=DT G EPQ
;
; - find scheduled visits, stand-alone encounters and dispositions
; on or after IBDAT from the outpatient encounters file
D NOW^%DTC S IBNOW=%
K IBARR,^TMP("IBOE",$J)
S IBVAL("DFN")=DFN,IBVAL("BDT")=IBDAT,IBVAL("EDT")=IBNOW
;Consider only parent encounters
S IBFILTER=""
S IBCBK="I '$P(Y0,U,6) S ^TMP(""IBOE"",$J,Y)=Y0"
D SCAN^IBSDU("PATIENT/DATE",.IBVAL,IBFILTER,IBCBK,1) K ^TMP("DIERR",$J)
F IBZ=0,1,2,9,13 S IBCK(IBZ)=""
S IBOE=0 F S IBOE=$O(^TMP("IBOE",$J,IBOE)) Q:'IBOE S IBOE0=$G(^(IBOE)) D
. K IBPB
. S IBEP=$$BILLCK(IBOE,IBOE0,.IBCK,.IBPB)
. S IBZ=0 F S IBZ=$O(IBPB(IBZ)) Q:'IBZ D
.. I IBZ=1 S IBARR(+IBOE0,"APP")=$P(IBOE0,U,4)_U_$P(IBOE0,U,10)
.. I IBZ=2 S IBARR(IBOE0\1,"SC"_IBOE)=$P(IBOE0,U,3)_U_$P(IBOE0,U,10)
.. I IBZ=3 S IBARR(+IBOE0,"R")=$P(IBPB(3),U,7)
K ^TMP("IBOE",$J)
;
; - find admissions since IBDAT
S VAIP("D")=IBDAT D IN5^VADPT I VAIP(13) S IBPM=$G(^DGPM(+VAIP(13),0)),IBARR(+IBPM,"ADM")=$P(IBPM,"^",6),IBEP=1
S IBD="" F S IBD=$O(^DGPM("ATID1",DFN,IBD)) Q:'IBD!(9999999.999999-IBD<IBDAT) S IBPM=$G(^DGPM(+$O(^(IBD,0)),0)),IBARR(+IBPM,"ADM")=$P(IBPM,"^",6),IBEP=1
;
EPQ Q +$G(IBEP)
;
BILLCK(IBOE,IBOE0,IBCK,IBPB) ; Check for potentially billable outpt enctr
; IBOE = encounter ien in file 409.68
; IBOE0 = encounter 0-node
; IBCK = array subscriptd by # that, if defined, specifies edit to check
; and exclude if it doesn't pass it
; (0) = check if pt claimed exposure
; (1) = check if non-billable appt type for means test
; (2) = check if non-count clinic
; (3) = check if non-billable clinic
; (4) = check if pt not Means Test copay pt
; (5) = check if pt admitted by midnight same date
; (6) = check if C&P exam same date
; (7) = check if non-billable stop code (third party)
; (8) = check if non-billable stop code (auto-biller)
; (9) = check if disposition and application without exam
; (10) = check if non-billable disposition
; (11) = check if service connected (ck parent only)
; (12) = check if non-billable clinic
; (13) = check if appt status is set (cancelled/noshow/inpt/etc)
; (13.1) = same as (13) except don't exclude if encounter status is non-count
; (14) = check if non-billable appt type for report
; Returns IBPB = the # of the edit that failed
; IBPB(1) = "" if valid appt
; IBPB(2) = "" if valid add/edit stop code
; IBPB(3) = 0-node of disposition file entry if valid disp
; Function returns true if potentially billable or false if not
N DFN,IBAD,IBD,IBSRCE,QUIT
S DFN=$P(IBOE0,U,2),IBSRCE=$P(IBOE0,U,8),IBD=IBOE0\1
I $D(IBCK(0))!($D(IBCK(11))) S QUIT=0 D G:QUIT BILLCKQ
. N Z
. I $D(IBCK(11)),$P(IBOE0,U,6) D Q:QUIT ;Check parent encounter
.. S Z=$$ENCL^IBAMTS2($P(IBOE0,U,6))
.. I $P(Z,U,3)=1 S QUIT=1,IBPB=11
. S Z=$$ENCL^IBAMTS2(IBOE)
. I $D(IBCK(0)),Z[1 S QUIT=1,IBPB=0 Q
. I $D(IBCK(11)),'$P(IBOE0,U,6),$P(Z,U,3)=1 S QUIT=1,IBPB=11
I $D(IBCK(4)),'$$BIL^DGMTUB(DFN,+IBOE0) S IBPB=4 G BILLCKQ
I $D(IBCK(5)),$$INPT^IBAMTS1(DFN,IBD_.2359) S IBPB=5 G BILLCKQ
I $D(IBCK(6)),$$CNP^IBECEAU(DFN,IBD) S IBPB=6 G BILLCKQ
;
; - Appointment or stop code
I "12"[IBSRCE D G BILLCKQ
. I $D(IBCK(13))!($D(IBCK(13.1))),IBSRCE=1 D Q:$G(IBPB)
.. I '$$APPTCT^IBEFUNC(IBOE0),$S('$D(IBCK(13.1)):1,1:$P(IBOE0,U,12)'=12) S IBPB=13
. I $D(IBCK(14)),$$RPT^IBEFUNC(+$P(IBOE0,U,10),IBD) S IBPB=14 Q
. I $D(IBCK(1)),$$IGN^IBEFUNC(+$P(IBOE0,U,10),IBD) S IBPB=1 Q
. I $D(IBCK(2)),$$NCTCL^IBEFUNC(IBOE) S IBPB=2 Q
. I $D(IBCK(3)),$$NBCL^IBEFUNC(+$P(IBOE0,U,4),IBD) S IBPB=3 Q
. I $D(IBCK(7)),$$NBST^IBEFUNC(+$P(IBOE0,U,3),IBD) S IBPB=7 Q
. I $D(IBCK(8)),$$NBCSC^IBEFUNC(+$P(IBOE0,U,3),IBD) S IBPB=8 Q
. I $D(IBCK(12)),$$NBCT^IBEFUNC(+$P(IBOE0,U,4),IBD) S IBPB=12 Q
. ;
. S IBPB(IBSRCE)=""
;
; - Disposition
S IBAD=$$DISND^IBSDU(IBOE,IBOE0)
I $D(IBCK(9)),'$$DISCT^IBEFUNC(IBOE,IBOE0) S IBPB=9 G BILLCKQ
I $D(IBCK(10)),$$NBDIS^IBEFUNC(+$P(IBAD,U,7),IBD) S IBPB=10 G BILLCKQ
S IBPB(3)=IBAD
;
BILLCKQ Q ($G(IBPB)="")
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBAMTEDU 6399 printed Oct 16, 2024@18:07:17 Page 2
IBAMTEDU ;ALB/CPM - MEANS TEST BULLETIN UTILITIES ; 15-JUN-93
+1 ;;2.0;INTEGRATED BILLING;**15,91,153**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
CHG(IBDAT) ; Any charges billed on or after IBDAT?
+1 ; Input: IBDAT -- Date on or after which charges have been billed
+2 ; Output: 0 -- No charges billed
+3 ; 1 -- Charges were billed; IBARR contains array
+4 ; of those charges
+5 NEW IBFND,IBD,IBN,IBX,IBJOB,IBWHER
KILL IBARR
+6 ;
+7 ; - if the effective date of the test is today, cancel today's charges.
+8 IF $PIECE(IBDAT,".")=DT
DO CANC
GOTO CHGQ
+9 ;
+10 ; - find all charges which may need to be cancelled.
+11 SET IBX=""
FOR
SET IBX=$ORDER(^IB("AFDT",DFN,IBX))
if 'IBX
QUIT
SET IBD=0
FOR
SET IBD=$ORDER(^IB("AFDT",DFN,IBX,IBD))
if 'IBD
QUIT
Begin DoDot:1
+12 IF $PIECE($GET(^IB(IBD,0)),"^",8)'["ADMISSION"
if -IBX'<IBDAT
DO CHK(IBD)
QUIT
+13 SET IBN=0
FOR
SET IBN=$ORDER(^IB("AF",IBD,IBN))
if 'IBN
QUIT
DO CHK(IBN)
End DoDot:1
CHGQ QUIT +$GET(IBFND)
+1 ;
CHK(IBN) ; Place charge into the array.
+1 ; Input: IBN -- Charge to check
+2 NEW IBND,IBNDL,IBLAST
+3 SET IBND=$GET(^IB(IBN,0))
IF $PIECE(IBND,"^",15)<IBDAT
GOTO CHKQ
+4 SET IBLAST=$$LAST^IBECEAU(+$PIECE(IBND,"^",9))
SET IBNDL=$GET(^IB(+IBLAST,0))
+5 IF $PIECE($GET(^IBE(350.1,+$PIECE(IBNDL,"^",3),0)),"^",5)'=2
IF "^1^2^3^4^8^20^21^"[("^"_$PIECE(IBNDL,"^",5)_"^")
SET IBARR(+$PIECE(IBNDL,"^",14),IBLAST)=""
SET IBFND=1
CHKQ QUIT
+1 ;
CANC ; Cancel any charges for the patient for today.
+1 NEW IBD,IBN,IBCRES,IBFAC,IBSITE,IBSERV,IBDUZ
+2 if '$$CHECK^IBECEAU
QUIT
+3 SET IBCRES=+$ORDER(^IBE(350.3,"B","MT STATUS CHANGED FROM YES",0))
+4 if 'IBCRES
SET IBCRES=22
SET IBJOB=7
SET IBWHER=30
SET IBDUZ=DUZ
+5 SET IBD=0
FOR
SET IBD=$ORDER(^IB("AFDT",DFN,-DT,IBD))
if 'IBD
QUIT
Begin DoDot:1
+6 IF $PIECE($GET(^IB(IBD,0)),"^",8)'["ADMISSION"
DO CANCH^IBECEAU4(IBD,IBCRES,1)
QUIT
+7 SET IBN=0
FOR
SET IBN=$ORDER(^IB("AF",IBD,IBN))
if 'IBN
QUIT
DO CANCH^IBECEAU4(IBN,IBCRES,1)
End DoDot:1
+8 QUIT
+9 ;
+10 ;
EP(IBDAT) ; Any billable episodes of care since IBDAT?
+1 ; Input: IBDAT -- Date on or after which patient received care
+2 ; Output: 0 -- No billable episodes found
+3 ; 1 -- Billable episodes were found; IBARR contains an
+4 ; array of those episodes
+5 ;
+6 NEW IBD,IBAD,IBNOW,IBEP,IBDT,IBI,IBPM,VA,VAIP,VAERR,IBVAL,IBCBK,IBZ,IBPB
+7 ;
+8 ; - quit if the effective date of the test is today
+9 IF $PIECE(IBDAT,".")=DT
GOTO EPQ
+10 ;
+11 ; - find scheduled visits, stand-alone encounters and dispositions
+12 ; on or after IBDAT from the outpatient encounters file
+13 DO NOW^%DTC
SET IBNOW=%
+14 KILL IBARR,^TMP("IBOE",$JOB)
+15 SET IBVAL("DFN")=DFN
SET IBVAL("BDT")=IBDAT
SET IBVAL("EDT")=IBNOW
+16 ;Consider only parent encounters
+17 SET IBFILTER=""
+18 SET IBCBK="I '$P(Y0,U,6) S ^TMP(""IBOE"",$J,Y)=Y0"
+19 DO SCAN^IBSDU("PATIENT/DATE",.IBVAL,IBFILTER,IBCBK,1)
KILL ^TMP("DIERR",$JOB)
+20 FOR IBZ=0,1,2,9,13
SET IBCK(IBZ)=""
+21 SET IBOE=0
FOR
SET IBOE=$ORDER(^TMP("IBOE",$JOB,IBOE))
if 'IBOE
QUIT
SET IBOE0=$GET(^(IBOE))
Begin DoDot:1
+22 KILL IBPB
+23 SET IBEP=$$BILLCK(IBOE,IBOE0,.IBCK,.IBPB)
+24 SET IBZ=0
FOR
SET IBZ=$ORDER(IBPB(IBZ))
if 'IBZ
QUIT
Begin DoDot:2
+25 IF IBZ=1
SET IBARR(+IBOE0,"APP")=$PIECE(IBOE0,U,4)_U_$PIECE(IBOE0,U,10)
+26 IF IBZ=2
SET IBARR(IBOE0\1,"SC"_IBOE)=$PIECE(IBOE0,U,3)_U_$PIECE(IBOE0,U,10)
+27 IF IBZ=3
SET IBARR(+IBOE0,"R")=$PIECE(IBPB(3),U,7)
End DoDot:2
End DoDot:1
+28 KILL ^TMP("IBOE",$JOB)
+29 ;
+30 ; - find admissions since IBDAT
+31 SET VAIP("D")=IBDAT
DO IN5^VADPT
IF VAIP(13)
SET IBPM=$GET(^DGPM(+VAIP(13),0))
SET IBARR(+IBPM,"ADM")=$PIECE(IBPM,"^",6)
SET IBEP=1
+32 SET IBD=""
FOR
SET IBD=$ORDER(^DGPM("ATID1",DFN,IBD))
if 'IBD!(9999999.999999-IBD<IBDAT)
QUIT
SET IBPM=$GET(^DGPM(+$ORDER(^(IBD,0)),0))
SET IBARR(+IBPM,"ADM")=$PIECE(IBPM,"^",6)
SET IBEP=1
+33 ;
EPQ QUIT +$GET(IBEP)
+1 ;
BILLCK(IBOE,IBOE0,IBCK,IBPB) ; Check for potentially billable outpt enctr
+1 ; IBOE = encounter ien in file 409.68
+2 ; IBOE0 = encounter 0-node
+3 ; IBCK = array subscriptd by # that, if defined, specifies edit to check
+4 ; and exclude if it doesn't pass it
+5 ; (0) = check if pt claimed exposure
+6 ; (1) = check if non-billable appt type for means test
+7 ; (2) = check if non-count clinic
+8 ; (3) = check if non-billable clinic
+9 ; (4) = check if pt not Means Test copay pt
+10 ; (5) = check if pt admitted by midnight same date
+11 ; (6) = check if C&P exam same date
+12 ; (7) = check if non-billable stop code (third party)
+13 ; (8) = check if non-billable stop code (auto-biller)
+14 ; (9) = check if disposition and application without exam
+15 ; (10) = check if non-billable disposition
+16 ; (11) = check if service connected (ck parent only)
+17 ; (12) = check if non-billable clinic
+18 ; (13) = check if appt status is set (cancelled/noshow/inpt/etc)
+19 ; (13.1) = same as (13) except don't exclude if encounter status is non-count
+20 ; (14) = check if non-billable appt type for report
+21 ; Returns IBPB = the # of the edit that failed
+22 ; IBPB(1) = "" if valid appt
+23 ; IBPB(2) = "" if valid add/edit stop code
+24 ; IBPB(3) = 0-node of disposition file entry if valid disp
+25 ; Function returns true if potentially billable or false if not
+26 NEW DFN,IBAD,IBD,IBSRCE,QUIT
+27 SET DFN=$PIECE(IBOE0,U,2)
SET IBSRCE=$PIECE(IBOE0,U,8)
SET IBD=IBOE0\1
+28 IF $DATA(IBCK(0))!($DATA(IBCK(11)))
SET QUIT=0
Begin DoDot:1
+29 NEW Z
+30 ;Check parent encounter
IF $DATA(IBCK(11))
IF $PIECE(IBOE0,U,6)
Begin DoDot:2
+31 SET Z=$$ENCL^IBAMTS2($PIECE(IBOE0,U,6))
+32 IF $PIECE(Z,U,3)=1
SET QUIT=1
SET IBPB=11
End DoDot:2
if QUIT
QUIT
+33 SET Z=$$ENCL^IBAMTS2(IBOE)
+34 IF $DATA(IBCK(0))
IF Z[1
SET QUIT=1
SET IBPB=0
QUIT
+35 IF $DATA(IBCK(11))
IF '$PIECE(IBOE0,U,6)
IF $PIECE(Z,U,3)=1
SET QUIT=1
SET IBPB=11
End DoDot:1
if QUIT
GOTO BILLCKQ
+36 IF $DATA(IBCK(4))
IF '$$BIL^DGMTUB(DFN,+IBOE0)
SET IBPB=4
GOTO BILLCKQ
+37 IF $DATA(IBCK(5))
IF $$INPT^IBAMTS1(DFN,IBD_.2359)
SET IBPB=5
GOTO BILLCKQ
+38 IF $DATA(IBCK(6))
IF $$CNP^IBECEAU(DFN,IBD)
SET IBPB=6
GOTO BILLCKQ
+39 ;
+40 ; - Appointment or stop code
+41 IF "12"[IBSRCE
Begin DoDot:1
+42 IF $DATA(IBCK(13))!($DATA(IBCK(13.1)))
IF IBSRCE=1
Begin DoDot:2
+43 IF '$$APPTCT^IBEFUNC(IBOE0)
IF $SELECT('$DATA(IBCK(13.1)):1,1:$PIECE(IBOE0,U,12)'=12)
SET IBPB=13
End DoDot:2
if $GET(IBPB)
QUIT
+44 IF $DATA(IBCK(14))
IF $$RPT^IBEFUNC(+$PIECE(IBOE0,U,10),IBD)
SET IBPB=14
QUIT
+45 IF $DATA(IBCK(1))
IF $$IGN^IBEFUNC(+$PIECE(IBOE0,U,10),IBD)
SET IBPB=1
QUIT
+46 IF $DATA(IBCK(2))
IF $$NCTCL^IBEFUNC(IBOE)
SET IBPB=2
QUIT
+47 IF $DATA(IBCK(3))
IF $$NBCL^IBEFUNC(+$PIECE(IBOE0,U,4),IBD)
SET IBPB=3
QUIT
+48 IF $DATA(IBCK(7))
IF $$NBST^IBEFUNC(+$PIECE(IBOE0,U,3),IBD)
SET IBPB=7
QUIT
+49 IF $DATA(IBCK(8))
IF $$NBCSC^IBEFUNC(+$PIECE(IBOE0,U,3),IBD)
SET IBPB=8
QUIT
+50 IF $DATA(IBCK(12))
IF $$NBCT^IBEFUNC(+$PIECE(IBOE0,U,4),IBD)
SET IBPB=12
QUIT
+51 ;
+52 SET IBPB(IBSRCE)=""
End DoDot:1
GOTO BILLCKQ
+53 ;
+54 ; - Disposition
+55 SET IBAD=$$DISND^IBSDU(IBOE,IBOE0)
+56 IF $DATA(IBCK(9))
IF '$$DISCT^IBEFUNC(IBOE,IBOE0)
SET IBPB=9
GOTO BILLCKQ
+57 IF $DATA(IBCK(10))
IF $$NBDIS^IBEFUNC(+$PIECE(IBAD,U,7),IBD)
SET IBPB=10
GOTO BILLCKQ
+58 SET IBPB(3)=IBAD
+59 ;
BILLCKQ QUIT ($GET(IBPB)="")
+1 ;
