IBAMTD.m

IBAMTD	;ALB/CPM - MOVEMENT EVENT DRIVER INTERFACE ; 21-OCT-91

	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

	;;Per VHA Directive 10-93-142, this routine should not be modified.

	;

	I $G(DGPMA)="",$G(DGPMP)="" Q

	;

EN	; Process events from the Movement Event Driver.

	;

	;S XRTL=$ZU(0),XRTN="IBAMTD-1" D T0^%ZOSV ;start rt clock

	;

	; -- add admissions to claims tracking

	D INP^IBTRKR

	;

	; - process billing for CHAMPVA patients

	I $$CVA^IBAUTL5(DFN) D PROC^IBACVA G END

	;

	; - unflag continuous patients

	S IBASIH=$$ASIH^IBAUTL5(DGPMA)

	I DGPMP="",($P(DGPMA,"^",2)=3!(IBASIH)),$O(^IBE(351.1,"B",DFN,0)),$D(^IBE(351.1,+$O(^(0)),0)),'$P(^(0),"^",2) D UNFLAG^IBAMTD1

	;

	; - update case record on discharge for special inpatient episodes

	S IBA=$P($S(DGPMA="":DGPMP,1:DGPMA),"^",14)

	I $O(^IBE(351.2,"AC",IBA,0)),DGPMP="",($P(DGPMA,"^",2)=3!(IBASIH)) D DIS^IBAMTI(IBA) G END

	;

	; - quit if patient was last Category C before admission date

	S IBLC=$$BILST^DGMTUB(DFN) G:'IBLC END I DGPMA="",$P(DGPMP,"^",2)=1,IBLC<$P(+DGPMP,".") G END

	D ORIG^IBAMTC I IBLC<$P(IBADMDT,".") G END

	;

	; - if editing or deleting a movement, send bulletin

	I DGPMP]"" S IBJOB=3 D ^IBAMTBU G END

	;

	; - add a case record for admission of special (ao/ir/ec) inpatients

	I $P(DGPMA,"^",2)=1 D  G END

	.N IBCLSF D CL^SDCO21(DFN,IBADMDT,"",.IBCLSF)

	.S IBCLSF=$O(IBCLSF(0)) I IBCLSF D ADM^IBAMTI(DFN,IBA,IBCLSF)

	;

	; - if adding a retro-active transfer or spec. transfer, send bulletin

	I ($P(DGPMA,"^",2)=2!($P(DGPMA,"^",2)=6)),+DGPMA<DT S IBJOB=6 D ^IBAMTBU

	;

	; - process discharges and ASIH movements only

	I $P(DGPMA,"^",2)'=3,'IBASIH G END

	;

	W !,"Billing Category C charges...."

	S (IBY,Y)=1,IBEVOLD=0,IBJOB=2,IBWHER=1,IBDISDT=+DGPMA\1,IBAFY=$S($E(DT,4,5)<10:$E(DT,2,3),1:$E(DT,2,3)+1)

	D SITE^IBAUTL I Y<1 S IBY=Y G END1

	D SERV^IBAUTL2 G:IBY<1 END1

	S IBWHER=24 D CLOCK^IBAUTL3 G:IBY<1 END1

	;

	; - handle the variations on the basis of the event record

	D EVFIND^IBAUTL3 ; sets IBEVDA to IEN of event record, or to 0 if none

	S IBWHER=25 D @$S(IBEVDA:"EVT",1:"NOEVT")

	;

	; - kill variables and close

END1	I IBY<1 S IBDUZ=DUZ D ^IBAERR1 K IBDUZ

	W "completed."

END	D KILL1^IBAMTC

	;

	;I $D(XRT0) S:'$D(XRTN) XRTN="IBAMTD" D T1^%ZOSV ;stop rt clock

	;

	Q

	;

EVT	; Billable admission event on record.

	I $$OE^IBAUTL5(IBA) S IBDT=IBDISDT D OE^IBAMTBU1,CLOSE1 G EVTQ

	I IBEVCAL'<IBDISDT S IBY="-1^IB033" G EVTQ

	I IBEVCAL S X1=IBEVCAL,X2=1 D C^%DTC S IBBDT=%H I X=IBDISDT S IBDT=IBEVCAL D PASS^IBAUTL5,CLOSE1:IBY>0 G EVTQ

	I 'IBEVCAL S X=IBEVDT D H^%DTC S IBBDT=%H

	S X=IBDISDT D H^%DTC S IBEDT=%H-1

	I IBCLDA S %H=IBBDT D YMD^%DTC S IBDT=X D COUNT

	D ^IBAUTL4,CLOSE:IBY>0

EVTQ	Q

	;

NOEVT	; No billable event on record since admission date.

	I $$OE^IBAUTL5(IBA) W " patient not billed (adm. for O&E)... " G NOEVTQ ; admitted for Observation & Examination

	S (IBCUR,VAIP("D"))=+$G(^DGPM(IBA,0)) D IN5^VADPT S IBBS=$$SECT^IBAUTL5(+VAIP(8))

	I 'IBASIH,'IBBS G NOEVTQ ; not in billable bedsection

	I 'IBASIH,IBCUR\1=IBDISDT S IBDT=IBDISDT D:IBBS ^IBAMTD1 G NOEVTQ

	S X=IBADMDT\1 D H^%DTC S IBBDT=%H

	I IBASIH S VAIP("D")=IBADMDT,IBSAVBS=IBBS D IN5^VADPT S IBBS=$$SECT^IBAUTL5(+VAIP(8)) I 'IBBS S X=IBCUR D H^%DTC S IBBDT=%H I IBCUR\1=IBDISDT S IBDT=IBDISDT,IBBS=IBSAVBS D:IBBS ^IBAMTD1 G NOEVTQ

	D LAST^IBAUTL5

	S X=IBDISDT D H^%DTC S IBEDT=%H-1

	I IBCLDA S %H=IBBDT D YMD^%DTC S IBDT=X D COUNT

	D ^IBAUTL4,CLOSE:IBY>0

NOEVTQ	Q

	;

COUNT	; Find number of days on clock.    Input:  IBDT

	S X1=IBDT,X2=IBCLDT D ^%DTC S IBCLCT=X Q

	;

CLOSE	; Close out charges, events; update clocks (at discharge: tag CLOSE1)

	I $G(IBCHPDA) S IBNOS=IBCHPDA D FILER^IBAUTL5 G:IBY<1 CLOSEQ

	I $G(IBCHCDA) S IBNOS=IBCHCDA D FILER^IBAUTL5 G:IBY<1 CLOSEQ

	I IBCLDA D CLUPD^IBAUTL3

CLOSE1	I IBEVDA,$D(IBDT) S IBEVCLD=IBDT D EVCLOSE^IBAUTL3

CLOSEQ	Q

IBAMTD    ;ALB/CPM - MOVEMENT EVENT DRIVER INTERFACE ; 21-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       ;

 +4        IF $GET(DGPMA)=""

               IF $GET(DGPMP)=""

                   QUIT 

 +5       ;

EN        ; Process events from the Movement Event Driver.

 +1       ;

 +2       ;S XRTL=$ZU(0),XRTN="IBAMTD-1" D T0^%ZOSV ;start rt clock

 +3       ;

 +4       ; -- add admissions to claims tracking

 +5        DO INP^IBTRKR

 +6       ;

 +7       ; - process billing for CHAMPVA patients

 +8        IF $$CVA^IBAUTL5(DFN)

               DO PROC^IBACVA

               GOTO END

 +9       ;

 +10      ; - unflag continuous patients

 +11       SET IBASIH=$$ASIH^IBAUTL5(DGPMA)

 +12       IF DGPMP=""

               IF ($PIECE(DGPMA,"^",2)=3!(IBASIH))

                   IF $ORDER(^IBE(351.1,"B",DFN,0))

                       IF $DATA(^IBE(351.1,+$ORDER(^(0)),0))

                           IF '$PIECE(^(0),"^",2)

                               DO UNFLAG^IBAMTD1

 +13      ;

 +14      ; - update case record on discharge for special inpatient episodes

 +15       SET IBA=$PIECE($SELECT(DGPMA="":DGPMP,1:DGPMA),"^",14)

 +16       IF $ORDER(^IBE(351.2,"AC",IBA,0))

               IF DGPMP=""

                   IF ($PIECE(DGPMA,"^",2)=3!(IBASIH))

                       DO DIS^IBAMTI(IBA)

                       GOTO END

 +17      ;

 +18      ; - quit if patient was last Category C before admission date

 +19       SET IBLC=$$BILST^DGMTUB(DFN)

           IF 'IBLC

               GOTO END

           IF DGPMA=""

               IF $PIECE(DGPMP,"^",2)=1

                   IF IBLC<$PIECE(+DGPMP,".")

                       GOTO END

 +20       DO ORIG^IBAMTC

           IF IBLC<$PIECE(IBADMDT,".")

               GOTO END

 +21      ;

 +22      ; - if editing or deleting a movement, send bulletin

 +23       IF DGPMP]""

               SET IBJOB=3

               DO ^IBAMTBU

               GOTO END

 +24      ;

 +25      ; - add a case record for admission of special (ao/ir/ec) inpatients

 +26       IF $PIECE(DGPMA,"^",2)=1

               Begin DoDot:1

 +27               NEW IBCLSF

                   DO CL^SDCO21(DFN,IBADMDT,"",.IBCLSF)

 +28               SET IBCLSF=$ORDER(IBCLSF(0))

                   IF IBCLSF

                       DO ADM^IBAMTI(DFN,IBA,IBCLSF)

               End DoDot:1

               GOTO END

 +29      ;

 +30      ; - if adding a retro-active transfer or spec. transfer, send bulletin

 +31       IF ($PIECE(DGPMA,"^",2)=2!($PIECE(DGPMA,"^",2)=6))

               IF +DGPMA<DT

                   SET IBJOB=6

                   DO ^IBAMTBU

 +32      ;

 +33      ; - process discharges and ASIH movements only

 +34       IF $PIECE(DGPMA,"^",2)'=3

               IF 'IBASIH

                   GOTO END

 +35      ;

 +36       WRITE !,"Billing Category C charges...."

 +37       SET (IBY,Y)=1

           SET IBEVOLD=0

           SET IBJOB=2

           SET IBWHER=1

           SET IBDISDT=+DGPMA\1

           SET IBAFY=$SELECT($EXTRACT(DT,4,5)<10:$EXTRACT(DT,2,3),1:$EXTRACT(DT,2,3)+1)

 +38       DO SITE^IBAUTL

           IF Y<1

               SET IBY=Y

               GOTO END1

 +39       DO SERV^IBAUTL2

           IF IBY<1

               GOTO END1

 +40       SET IBWHER=24

           DO CLOCK^IBAUTL3

           IF IBY<1

               GOTO END1

 +41      ;

 +42      ; - handle the variations on the basis of the event record

 +43      ; sets IBEVDA to IEN of event record, or to 0 if none

           DO EVFIND^IBAUTL3

 +44       SET IBWHER=25

           DO @$SELECT(IBEVDA:"EVT",1:"NOEVT")

 +45      ;

 +46      ; - kill variables and close

END1       IF IBY<1

               SET IBDUZ=DUZ

               DO ^IBAERR1

               KILL IBDUZ

 +1        WRITE "completed."

END        DO KILL1^IBAMTC

 +1       ;

 +2       ;I $D(XRT0) S:'$D(XRTN) XRTN="IBAMTD" D T1^%ZOSV ;stop rt clock

 +3       ;

 +4        QUIT 

 +5       ;

EVT       ; Billable admission event on record.

 +1        IF $$OE^IBAUTL5(IBA)

               SET IBDT=IBDISDT

               DO OE^IBAMTBU1

               DO CLOSE1

               GOTO EVTQ

 +2        IF IBEVCAL'<IBDISDT

               SET IBY="-1^IB033"

               GOTO EVTQ

 +3        IF IBEVCAL

               SET X1=IBEVCAL

               SET X2=1

               DO C^%DTC

               SET IBBDT=%H

               IF X=IBDISDT

                   SET IBDT=IBEVCAL

                   DO PASS^IBAUTL5

                   IF IBY>0

                       DO CLOSE1

                   GOTO EVTQ

 +4        IF 'IBEVCAL

               SET X=IBEVDT

               DO H^%DTC

               SET IBBDT=%H

 +5        SET X=IBDISDT

           DO H^%DTC

           SET IBEDT=%H-1

 +6        IF IBCLDA

               SET %H=IBBDT

               DO YMD^%DTC

               SET IBDT=X

               DO COUNT

 +7        DO ^IBAUTL4

           IF IBY>0

               DO CLOSE

EVTQ       QUIT 

 +1       ;

NOEVT     ; No billable event on record since admission date.

 +1       ; admitted for Observation & Examination

           IF $$OE^IBAUTL5(IBA)

               WRITE " patient not billed (adm. for O&E)... "

               GOTO NOEVTQ

 +2        SET (IBCUR,VAIP("D"))=+$GET(^DGPM(IBA,0))

           DO IN5^VADPT

           SET IBBS=$$SECT^IBAUTL5(+VAIP(8))

 +3       ; not in billable bedsection

           IF 'IBASIH

               IF 'IBBS

                   GOTO NOEVTQ

 +4        IF 'IBASIH

               IF IBCUR\1=IBDISDT

                   SET IBDT=IBDISDT

                   IF IBBS

                       DO ^IBAMTD1

                   GOTO NOEVTQ

 +5        SET X=IBADMDT\1

           DO H^%DTC

           SET IBBDT=%H

 +6        IF IBASIH

               SET VAIP("D")=IBADMDT

               SET IBSAVBS=IBBS

               DO IN5^VADPT

               SET IBBS=$$SECT^IBAUTL5(+VAIP(8))

               IF 'IBBS

                   SET X=IBCUR

                   DO H^%DTC

                   SET IBBDT=%H

                   IF IBCUR\1=IBDISDT

                       SET IBDT=IBDISDT

                       SET IBBS=IBSAVBS

                       IF IBBS

                           DO ^IBAMTD1

                       GOTO NOEVTQ

 +7        DO LAST^IBAUTL5

 +8        SET X=IBDISDT

           DO H^%DTC

           SET IBEDT=%H-1

 +9        IF IBCLDA

               SET %H=IBBDT

               DO YMD^%DTC

               SET IBDT=X

               DO COUNT

 +10       DO ^IBAUTL4

           IF IBY>0

               DO CLOSE

NOEVTQ     QUIT 

 +1       ;

COUNT     ; Find number of days on clock.    Input:  IBDT

 +1        SET X1=IBDT

           SET X2=IBCLDT

           DO ^%DTC

           SET IBCLCT=X

           QUIT 

 +2       ;

CLOSE     ; Close out charges, events; update clocks (at discharge: tag CLOSE1)

 +1        IF $GET(IBCHPDA)

               SET IBNOS=IBCHPDA

               DO FILER^IBAUTL5

               IF IBY<1

                   GOTO CLOSEQ

 +2        IF $GET(IBCHCDA)

               SET IBNOS=IBCHCDA

               DO FILER^IBAUTL5

               IF IBY<1

                   GOTO CLOSEQ

 +3        IF IBCLDA

               DO CLUPD^IBAUTL3

CLOSE1     IF IBEVDA

               IF $DATA(IBDT)

                   SET IBEVCLD=IBDT

                   DO EVCLOSE^IBAUTL3

CLOSEQ     QUIT