IBAMTC ;ALB/CPM - MEANS TEST NIGHTLY COMPILATION JOB ; 09-OCT-91
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
INIT ; Entry point - initialize variables and parameters
;
;***
;S XRTL=$ZU(0),XRTN="IBAMTC-1" D T0^%ZOSV ;start rt clock
;
D NIGHTLY^IBTRKR ; claims tracking nightly update
;
D ^IBCD ; automated biller
;
D NOW^%DTC S IBAFY=$S($E(X,4,5)<10:$E(X,2,3),1:$E(X,2,3)+1),DT=X,U="^"
S (IBERRN,IBWHER,IBJOB,IBY,Y)=1,IBCNT=0 K ^TMP($J,"IBAMTC")
D SITE^IBAUTL I Y<1 S IBY=Y D ERR G CLEAN
D SERV^IBAUTL2 I IBY<1 D ERR G CLEAN
;
; Compile Category C co-pay and per diem charges for all inpatients
S (IBWARD,DFN)="" F S IBWARD=$O(^DPT("CN",IBWARD)) Q:IBWARD="" F S DFN=$O(^DPT("CN",IBWARD,DFN)) Q:'DFN S IBA=^(DFN),IBY=1 D PROC
;
; Clean up expired Category C billing clocks
CLEAN S %H=+$H-1 D YMD^%DTC S IBDT=X,(IBN,DFN)=0,IBWHER=23
F S DFN=$O(^IBE(351,"ACT",DFN)) Q:'DFN D
. F S IBN=$O(^IBE(351,"ACT",DFN,IBN)) Q:'IBN D
.. S IBY=1,X1=IBDT,(X2,IBCLDT)=+$P($G(^IBE(351,+IBN,0)),"^",3) D ^%DTC
.. I X>364 S IBCLDA=IBN D CLOCKCL^IBAUTL3,ERR:IBY<1
;
; Close out incomplete events where the patient has been discharged,
; pass the related charges if they appear correct, and send a bulletin
; - also, send bulletins on old incomplete charges where there is no
; incomplete event
D MAIN^IBAMTC2
;
;D ^IBAMTC1
;
; Send bulletin reporting job completion
D BULL^IBAMTC1
;
; -- purge alerts
D PURGE^IBAERR3
;
; Monitor special inpatient billing cases
D BGJ^IBAMTI
;
; Kill variables and quit.
D KILL1
;
I $D(ZTQUEUED),$G(ZTSK) D KILL^%ZTLOAD
;***
;I $D(XRT0) S:'$D(XRTN) XRTN="IBAMTC" D T1^%ZOSV ;stop rt clock
;
Q
;
;
PROC ; Process all currently admitted patients.
D ORIG ; find "original" admission date
Q:$$BILST^DGMTUB(DFN)<IBADMDT ; patient was last Cat C before admission
Q:IBADMDT\1=DT ; patient was admitted today - process tomorrow
Q:$$OE^IBAUTL5(IBA) ; admitted for Observation & Examination
Q:$O(^IBE(351.2,"AC",IBA,0)) ; skip special inpatient admissions
; - gather event information
D EVFIND^IBAUTL3 I 'IBEVDA D BSEC Q:'IBBS ; wasn't billable yesterday
S X=IBADMDT D H^%DTC S IBBDT=%H D:'IBEVDA LAST^IBAUTL5
I IBEVDA,IBEVCAL S X1=IBEVCAL,X2=1 D C^%DTC S IBBDT=%H
S IBEDT=+$H-1
; - gather clock information
S IBWHER=24 D CLOCK^IBAUTL3 I IBY<1 D ERR G PROCQ
I IBCLDA S X=IBCLDT D H^%DTC S IBCLCT=IBBDT-%H
; - build charges for inpatient days
D ^IBAUTL4 I IBY<1 D ERR G PROCQ
; - pass per diem if over 30 days old, or both per diem and the copay
; - if 4 days from patient's statement date; update event, clock
S IBWHER=22
I $G(IBCHPDA),$P($G(^IB(+IBCHPDA,0)),"^",6)>30!($$STD^IBAUTL5(DFN)) S IBNOS=IBCHPDA D FILER^IBAUTL5 I IBY<1 D ERR G PROCQ
I $G(IBCHCDA),$$STD^IBAUTL5(DFN) S IBNOS=IBCHCDA D FILER^IBAUTL5 I IBY<1 D ERR G PROCQ
I IBEVDA,$D(IBDT) S IBEVCLD=IBDT D EVUPD^IBAUTL3
I IBCLDA D CLUPD^IBAUTL3
PROCQ D KILL Q
;
BSEC ; Determine patient's bedsection for the previous day.
S X1=DT,X2=-1 D C^%DTC
S VAIP("D")=X_.2359 D IN5^VADPT S IBBS=$$SECT^IBAUTL5(+VAIP(8)) Q
;
ERR ; Error processing. Input: IBY, IBWHER, IBCNT
S IBDUZ=DUZ,IBCNT=IBCNT+1 D ^IBAERR1 K IBDUZ Q
;S ^TMP($J,"IBAMTC","E",IBERRN)=$P(IBY,"^",2)_"^"_$S($D(DFN):DFN,1:"")_"^"_IBWHER,IBERRN=IBERRN+1 Q
;
ORIG ; Find first admission date, considering ASIH movements
; Input: IBA Output: IBADMDT
N X,Y,Z S Z=IBA
F S X=$G(^DGPM(Z,0)),Y=$P(X,"^",21) Q:Y="" S Z=+$P($G(^DGPM(Y,0)),"^",14)
S IBADMDT=+X Q
;
KILL1 ; Kill all IB variables.
K VAERR,VAIP,IBA,IBADMDT,IBAFY,IBATYP,IBBDT,IBBS,IBCHARG,IBCHG,IBCNT,IBCUR,IBDESC,IBDISDT,IBDT,IBDUZ,IBFAC,IBI,IBIL,IBJOB,IBLC,IBMAX
K IBN,IBNOS,IBSAVBS,IBSEQNO,IBSERV,IBSITE,IBSL,IBTRAN,IBX,IBY,IBWHER,IBWARD,IBEDT,IBCHCTY,IBCHPDE,IBERRN,IBASIH,IBRTED
KILL ; Kill all IB variables needed to build charges.
K IBCLCT,IBCLDA,IBCLDT,IBCLDAY,IBCLDOL,IBCHPDA,IBCHCDA,IBCHG,IBCHFR,IBCHTO,IBCHTOTL,IBBS,IBNH
K IBEVDA,IBEVDT,IBEVCLD,IBEVCAL,IBEVNEW,IBEVOLD,IBMED,IBTOTL,IBDESC,IBIL,IBTRAN,IBATYP,IBDATE
Q
IBAMTC ;ALB/CPM - MEANS TEST NIGHTLY COMPILATION JOB ; 09-OCT-91
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
INIT ; Entry point - initialize variables and parameters
+1 ;
+2 ;***
+3 ;S XRTL=$ZU(0),XRTN="IBAMTC-1" D T0^%ZOSV ;start rt clock
+4 ;
+5 ; claims tracking nightly update
DO NIGHTLY^IBTRKR
+6 ;
+7 ; automated biller
DO ^IBCD
+8 ;
+9 DO NOW^%DTC
SET IBAFY=$SELECT($EXTRACT(X,4,5)<10:$EXTRACT(X,2,3),1:$EXTRACT(X,2,3)+1)
SET DT=X
SET U="^"
+10 SET (IBERRN,IBWHER,IBJOB,IBY,Y)=1
SET IBCNT=0
KILL ^TMP($JOB,"IBAMTC")
+11 DO SITE^IBAUTL
IF Y<1
SET IBY=Y
DO ERR
GOTO CLEAN
+12 DO SERV^IBAUTL2
IF IBY<1
DO ERR
GOTO CLEAN
+13 ;
+14 ; Compile Category C co-pay and per diem charges for all inpatients
+15 SET (IBWARD,DFN)=""
FOR
SET IBWARD=$ORDER(^DPT("CN",IBWARD))
IF IBWARD=""
QUIT
FOR
SET DFN=$ORDER(^DPT("CN",IBWARD,DFN))
IF 'DFN
QUIT
SET IBA=^(DFN)
SET IBY=1
DO PROC
+16 ;
+17 ; Clean up expired Category C billing clocks
CLEAN SET %H=+$HOROLOG-1
DO YMD^%DTC
SET IBDT=X
SET (IBN,DFN)=0
SET IBWHER=23
+1 FOR
SET DFN=$ORDER(^IBE(351,"ACT",DFN))
IF 'DFN
QUIT
Begin DoDot:1
+2 FOR
SET IBN=$ORDER(^IBE(351,"ACT",DFN,IBN))
IF 'IBN
QUIT
Begin DoDot:2
+3 SET IBY=1
SET X1=IBDT
SET (X2,IBCLDT)=+$PIECE($GET(^IBE(351,+IBN,0)),"^",3)
DO ^%DTC
+4 IF X>364
SET IBCLDA=IBN
DO CLOCKCL^IBAUTL3
IF IBY<1
DO ERR
End DoDot:2
End DoDot:1
+5 ;
+6 ; Close out incomplete events where the patient has been discharged,
+7 ; pass the related charges if they appear correct, and send a bulletin
+8 ; - also, send bulletins on old incomplete charges where there is no
+9 ; incomplete event
+10 DO MAIN^IBAMTC2
+11 ;
+12 ;D ^IBAMTC1
+13 ;
+14 ; Send bulletin reporting job completion
+15 DO BULL^IBAMTC1
+16 ;
+17 ; -- purge alerts
+18 DO PURGE^IBAERR3
+19 ;
+20 ; Monitor special inpatient billing cases
+21 DO BGJ^IBAMTI
+22 ;
+23 ; Kill variables and quit.
+24 DO KILL1
+25 ;
+26 IF $DATA(ZTQUEUED)
IF $GET(ZTSK)
DO KILL^%ZTLOAD
+27 ;***
+28 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBAMTC" D T1^%ZOSV ;stop rt clock
+29 ;
+30 QUIT
+31 ;
+32 ;
PROC ; Process all currently admitted patients.
+1 ; find "original" admission date
DO ORIG
+2 ; patient was last Cat C before admission
IF $$BILST^DGMTUB(DFN)<IBADMDT
QUIT
+3 ; patient was admitted today - process tomorrow
IF IBADMDT\1=DT
QUIT
+4 ; admitted for Observation & Examination
IF $$OE^IBAUTL5(IBA)
QUIT
+5 ; skip special inpatient admissions
IF $ORDER(^IBE(351.2,"AC",IBA,0))
QUIT
+6 ; - gather event information
+7 ; wasn't billable yesterday
DO EVFIND^IBAUTL3
IF 'IBEVDA
DO BSEC
IF 'IBBS
QUIT
+8 SET X=IBADMDT
DO H^%DTC
SET IBBDT=%H
IF 'IBEVDA
DO LAST^IBAUTL5
+9 IF IBEVDA
IF IBEVCAL
SET X1=IBEVCAL
SET X2=1
DO C^%DTC
SET IBBDT=%H
+10 SET IBEDT=+$HOROLOG-1
+11 ; - gather clock information
+12 SET IBWHER=24
DO CLOCK^IBAUTL3
IF IBY<1
DO ERR
GOTO PROCQ
+13 IF IBCLDA
SET X=IBCLDT
DO H^%DTC
SET IBCLCT=IBBDT-%H
+14 ; - build charges for inpatient days
+15 DO ^IBAUTL4
IF IBY<1
DO ERR
GOTO PROCQ
+16 ; - pass per diem if over 30 days old, or both per diem and the copay
+17 ; - if 4 days from patient's statement date; update event, clock
+18 SET IBWHER=22
+19 IF $GET(IBCHPDA)
IF $PIECE($GET(^IB(+IBCHPDA,0)),"^",6)>30!($$STD^IBAUTL5(DFN))
SET IBNOS=IBCHPDA
DO FILER^IBAUTL5
IF IBY<1
DO ERR
GOTO PROCQ
+20 IF $GET(IBCHCDA)
IF $$STD^IBAUTL5(DFN)
SET IBNOS=IBCHCDA
DO FILER^IBAUTL5
IF IBY<1
DO ERR
GOTO PROCQ
+21 IF IBEVDA
IF $DATA(IBDT)
SET IBEVCLD=IBDT
DO EVUPD^IBAUTL3
+22 IF IBCLDA
DO CLUPD^IBAUTL3
PROCQ DO KILL
QUIT
+1 ;
BSEC ; Determine patient's bedsection for the previous day.
+1 SET X1=DT
SET X2=-1
DO C^%DTC
+2 SET VAIP("D")=X_.2359
DO IN5^VADPT
SET IBBS=$$SECT^IBAUTL5(+VAIP(8))
QUIT
+3 ;
ERR ; Error processing. Input: IBY, IBWHER, IBCNT
+1 SET IBDUZ=DUZ
SET IBCNT=IBCNT+1
DO ^IBAERR1
KILL IBDUZ
QUIT
+2 ;S ^TMP($J,"IBAMTC","E",IBERRN)=$P(IBY,"^",2)_"^"_$S($D(DFN):DFN,1:"")_"^"_IBWHER,IBERRN=IBERRN+1 Q
+3 ;
ORIG ; Find first admission date, considering ASIH movements
+1 ; Input: IBA Output: IBADMDT
+2 NEW X,Y,Z
SET Z=IBA
+3 FOR
SET X=$GET(^DGPM(Z,0))
SET Y=$PIECE(X,"^",21)
IF Y=""
QUIT
SET Z=+$PIECE($GET(^DGPM(Y,0)),"^",14)
+4 SET IBADMDT=+X
QUIT
+5 ;
KILL1 ; Kill all IB variables.
+1 KILL VAERR,VAIP,IBA,IBADMDT,IBAFY,IBATYP,IBBDT,IBBS,IBCHARG,IBCHG,IBCNT,IBCUR,IBDESC,IBDISDT,IBDT,IBDUZ,IBFAC,IBI,IBIL,IBJOB,IBLC,IBMAX
+2 KILL IBN,IBNOS,IBSAVBS,IBSEQNO,IBSERV,IBSITE,IBSL,IBTRAN,IBX,IBY,IBWHER,IBWARD,IBEDT,IBCHCTY,IBCHPDE,IBERRN,IBASIH,IBRTED
KILL ; Kill all IB variables needed to build charges.
+1 KILL IBCLCT,IBCLDA,IBCLDT,IBCLDAY,IBCLDOL,IBCHPDA,IBCHCDA,IBCHG,IBCHFR,IBCHTO,IBCHTOTL,IBBS,IBNH
+2 KILL IBEVDA,IBEVDT,IBEVCLD,IBEVCAL,IBEVNEW,IBEVOLD,IBMED,IBTOTL,IBDESC,IBIL,IBTRAN,IBATYP,IBDATE
+3 QUIT
