- 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)
