IBAMTC.m

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