IBAMTEDU ;ALB/CPM - MEANS TEST BULLETIN UTILITIES ; 15-JUN-93
;;Version 2.0 ; INTEGRATED BILLING ;; 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^"[("^"_$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 CATEGORY CHANGED FROM C",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
;
; - quit if the effective date of the test is today
I $P(IBDAT,".")=DT G EPQ
;
; - find scheduled visits on or after IBDAT
D NOW^%DTC S IBNOW=% K IBARR
S IBD=IBDAT F S IBD=$O(^DPT(DFN,"S",IBD)) Q:'IBD!(IBD>IBNOW) S IBAD=$G(^(IBD,0)) D
.Q:$P(IBAD,"^",2)]"" ; visit cancelled
.Q:$$IGN^IBEFUNC(+$P(IBAD,"^",16),IBD) ; non-billable appt type
.Q:$P($G(^SC(+IBAD,0)),"^",17)="Y" ; non-count clinic
.Q:$$ENCL^IBAMTS2($P(IBAD,"^",20))[1 ; claimed exposure
.S IBARR(IBD,"APP")=+IBAD_"^"_$P(IBAD,"^",16),IBEP=1
;
; - find stops on or after IBDAT
S IBD=IBDAT F S IBD=$O(^SDV("ADT",DFN,IBD)) Q:'IBD!(IBD>DT) S IBDT=^(IBD),IBI=0 F S IBI=$O(^SDV(IBDT,"CS",IBI)) Q:'IBI S IBAD=$G(^(IBI,0)) D
.Q:$$IGN^IBEFUNC(+$P(IBAD,"^",5),IBD) ; non-billable appt type
.Q:$P($G(^SC(+($P(IBAD,"^",3)),0)),"^",17)="Y" ; non-count clinic
.Q:$$ENCL^IBAMTS2($P(IBAD,"^",8))[1 ; claimed exposure
.S IBARR(IBD,"SC"_IBI)=+IBAD_"^"_$P(IBAD,"^",5),IBEP=1
;
; - find registrations on or after IBDAT
S IBD=0 F S IBD=$O(^DPT(DFN,"DIS",IBD)) Q:'IBD S IBDT=9999999-IBD Q:IBDT<IBDAT S IBAD=$G(^(IBD,0)) D
.Q:$P(IBAD,"^",2)=2 ; application w/o exam
.Q:$$ENCL^IBAMTS2($P(IBAD,"^",18))[1 ; claimed exposure
.S IBARR(IBDT,"R")=$P(IBAD,"^",7),IBEP=1
;
; - 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)
IBAMTEDU ;ALB/CPM - MEANS TEST BULLETIN UTILITIES ; 15-JUN-93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 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^"[("^"_$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 CATEGORY CHANGED FROM C",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
+7 ;
+8 ; - quit if the effective date of the test is today
+9 IF $PIECE(IBDAT,".")=DT
GOTO EPQ
+10 ;
+11 ; - find scheduled visits on or after IBDAT
+12 DO NOW^%DTC
SET IBNOW=%
KILL IBARR
+13 SET IBD=IBDAT
FOR
SET IBD=$ORDER(^DPT(DFN,"S",IBD))
IF 'IBD!(IBD>IBNOW)
QUIT
SET IBAD=$GET(^(IBD,0))
Begin DoDot:1
+14 ; visit cancelled
IF $PIECE(IBAD,"^",2)]""
QUIT
+15 ; non-billable appt type
IF $$IGN^IBEFUNC(+$PIECE(IBAD,"^",16),IBD)
QUIT
+16 ; non-count clinic
IF $PIECE($GET(^SC(+IBAD,0)),"^",17)="Y"
QUIT
+17 ; claimed exposure
IF $$ENCL^IBAMTS2($PIECE(IBAD,"^",20))[1
QUIT
+18 SET IBARR(IBD,"APP")=+IBAD_"^"_$PIECE(IBAD,"^",16)
SET IBEP=1
End DoDot:1
+19 ;
+20 ; - find stops on or after IBDAT
+21 SET IBD=IBDAT
FOR
SET IBD=$ORDER(^SDV("ADT",DFN,IBD))
IF 'IBD!(IBD>DT)
QUIT
SET IBDT=^(IBD)
SET IBI=0
FOR
SET IBI=$ORDER(^SDV(IBDT,"CS",IBI))
IF 'IBI
QUIT
SET IBAD=$GET(^(IBI,0))
Begin DoDot:1
+22 ; non-billable appt type
IF $$IGN^IBEFUNC(+$PIECE(IBAD,"^",5),IBD)
QUIT
+23 ; non-count clinic
IF $PIECE($GET(^SC(+($PIECE(IBAD,"^",3)),0)),"^",17)="Y"
QUIT
+24 ; claimed exposure
IF $$ENCL^IBAMTS2($PIECE(IBAD,"^",8))[1
QUIT
+25 SET IBARR(IBD,"SC"_IBI)=+IBAD_"^"_$PIECE(IBAD,"^",5)
SET IBEP=1
End DoDot:1
+26 ;
+27 ; - find registrations on or after IBDAT
+28 SET IBD=0
FOR
SET IBD=$ORDER(^DPT(DFN,"DIS",IBD))
IF 'IBD
QUIT
SET IBDT=9999999-IBD
IF IBDT<IBDAT
QUIT
SET IBAD=$GET(^(IBD,0))
Begin DoDot:1
+29 ; application w/o exam
IF $PIECE(IBAD,"^",2)=2
QUIT
+30 ; claimed exposure
IF $$ENCL^IBAMTS2($PIECE(IBAD,"^",18))[1
QUIT
+31 SET IBARR(IBDT,"R")=$PIECE(IBAD,"^",7)
SET IBEP=1
End DoDot:1
+32 ;
+33 ; - find admissions since IBDAT
+34 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
+35 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
+36 ;
EPQ QUIT +$GET(IBEP)
