IBAMTD ;ALB/CPM - MOVEMENT EVENT DRIVER INTERFACE ; 21-OCT-91
;;2.0;INTEGRATED BILLING;**45,52,93,115,132,153,164,156,234,312,339,704**;21-MAR-94;Build 49
;Per VA Directive 6402, 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
;
Q:+$$SWSTAT^IBBAPI() ;IB*2.0*312
;
; -- add admissions to claims tracking
D INP^IBTRKR
;
; -- run billing clock query
D ADM^IBECECQ1
;
; -- update Transfer Pricing
D ^IBATEI
;
; -- check for Long Term Care
N IBALTC D EN^IBAECI Q:IBALTC
;
; - 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 Means Test copay patient before adm. 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; delete
; case record in #351.2 for deleted admissions
I DGPMP]"" S IBJOB=3 D G END
.D ^IBAMTBU
.I DGPMA="",$P(DGPMP,"^",2)=1,$O(^IBE(351.2,"AC",IBA,0)) S DA=$O(^(0)),DIK="^IBE(351.2," D ^DIK K DA,DIK
;
; - add a case record for admission of special (ao/ir/swa/mst/hnc/shad/cv) inpatients
I $P(DGPMA,"^",2)=1 D G END
.N IBCLSF D CL^IBACV(DFN,IBADMDT,"",.IBCLSF)
.S IBCLSF=$O(IBCLSF(0)) I IBCLSF,(IBCLSF<5) D ADM^IBAMTI(DFN,IBA,IBCLSF) Q
.I $P($$GETSTAT^DGMSTAPI(DFN,IBADMDT),U,2)="Y" S IBCLSF=5,IBCLSF(5)="" D ADM^IBAMTI(DFN,IBA,IBCLSF) Q
.I IBCLSF=6 D ADM^IBAMTI(DFN,IBA,IBCLSF) ; hnc
.I IBCLSF=8 D ADM^IBAMTI(DFN,IBA,IBCLSF) ; shad
.I IBCLSF=7 D ADM^IBAMTI(DFN,IBA,IBCLSF) ; CV has the lowest priority
;
; - 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:'$G(DGQUIET) !,"Billing Means Test charges...."
S (IBY,Y)=1,IBEVOLD=0,IBJOB=2,IBWHER=1,IBDISDT=+DGPMA\1,IBAFY=$$FY^IBOUTL(DT)
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
;
; - Create an Outpat Copay for discharge with Observation Speciality
I $$MVT^DGPMOBS(IBA) D OBS^IBECEAU5 G:IBY<1 END1 G END
;
; - 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:'$G(DGQUIET) "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 +$$MVT^DGPMOBS(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 +$$MVT^DGPMOBS(IBA) W:'$G(DGQUIET) " 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBAMTD 4818 printed Oct 16, 2024@18:07:11 Page 2
IBAMTD ;ALB/CPM - MOVEMENT EVENT DRIVER INTERFACE ; 21-OCT-91
+1 ;;2.0;INTEGRATED BILLING;**45,52,93,115,132,153,164,156,234,312,339,704**;21-MAR-94;Build 49
+2 ;Per VA Directive 6402, 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 ;IB*2.0*312
if +$$SWSTAT^IBBAPI()
QUIT
+5 ;
+6 ; -- add admissions to claims tracking
+7 DO INP^IBTRKR
+8 ;
+9 ; -- run billing clock query
+10 DO ADM^IBECECQ1
+11 ;
+12 ; -- update Transfer Pricing
+13 DO ^IBATEI
+14 ;
+15 ; -- check for Long Term Care
+16 NEW IBALTC
DO EN^IBAECI
if IBALTC
QUIT
+17 ;
+18 ; - process billing for CHAMPVA patients
+19 IF $$CVA^IBAUTL5(DFN)
DO PROC^IBACVA
GOTO END
+20 ;
+21 ; - unflag continuous patients
+22 SET IBASIH=$$ASIH^IBAUTL5(DGPMA)
+23 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
+24 ;
+25 ; - update case record on discharge for special inpatient episodes
+26 SET IBA=$PIECE($SELECT(DGPMA="":DGPMP,1:DGPMA),"^",14)
+27 IF $ORDER(^IBE(351.2,"AC",IBA,0))
IF DGPMP=""
IF ($PIECE(DGPMA,"^",2)=3!(IBASIH))
DO DIS^IBAMTI(IBA)
GOTO END
+28 ;
+29 ; - quit if patient was last Means Test copay patient before adm. date
+30 SET IBLC=$$BILST^DGMTUB(DFN)
if 'IBLC
GOTO END
IF DGPMA=""
IF $PIECE(DGPMP,"^",2)=1
IF IBLC<$PIECE(+DGPMP,".")
GOTO END
+31 DO ORIG^IBAMTC
IF IBLC<$PIECE(IBADMDT,".")
GOTO END
+32 ;
+33 ; - if editing or deleting a movement, send bulletin; delete
+34 ; case record in #351.2 for deleted admissions
+35 IF DGPMP]""
SET IBJOB=3
Begin DoDot:1
+36 DO ^IBAMTBU
+37 IF DGPMA=""
IF $PIECE(DGPMP,"^",2)=1
IF $ORDER(^IBE(351.2,"AC",IBA,0))
SET DA=$ORDER(^(0))
SET DIK="^IBE(351.2,"
DO ^DIK
KILL DA,DIK
End DoDot:1
GOTO END
+38 ;
+39 ; - add a case record for admission of special (ao/ir/swa/mst/hnc/shad/cv) inpatients
+40 IF $PIECE(DGPMA,"^",2)=1
Begin DoDot:1
+41 NEW IBCLSF
DO CL^IBACV(DFN,IBADMDT,"",.IBCLSF)
+42 SET IBCLSF=$ORDER(IBCLSF(0))
IF IBCLSF
IF (IBCLSF<5)
DO ADM^IBAMTI(DFN,IBA,IBCLSF)
QUIT
+43 IF $PIECE($$GETSTAT^DGMSTAPI(DFN,IBADMDT),U,2)="Y"
SET IBCLSF=5
SET IBCLSF(5)=""
DO ADM^IBAMTI(DFN,IBA,IBCLSF)
QUIT
+44 ; hnc
IF IBCLSF=6
DO ADM^IBAMTI(DFN,IBA,IBCLSF)
+45 ; shad
IF IBCLSF=8
DO ADM^IBAMTI(DFN,IBA,IBCLSF)
+46 ; CV has the lowest priority
IF IBCLSF=7
DO ADM^IBAMTI(DFN,IBA,IBCLSF)
End DoDot:1
GOTO END
+47 ;
+48 ; - if adding a retro-active transfer or spec. transfer, send bulletin
+49 IF ($PIECE(DGPMA,"^",2)=2!($PIECE(DGPMA,"^",2)=6))
IF +DGPMA<DT
SET IBJOB=6
DO ^IBAMTBU
+50 ;
+51 ; - process discharges and ASIH movements only
+52 IF $PIECE(DGPMA,"^",2)'=3
IF 'IBASIH
GOTO END
+53 ;
+54 if '$GET(DGQUIET)
WRITE !,"Billing Means Test charges...."
+55 SET (IBY,Y)=1
SET IBEVOLD=0
SET IBJOB=2
SET IBWHER=1
SET IBDISDT=+DGPMA\1
SET IBAFY=$$FY^IBOUTL(DT)
+56 DO SITE^IBAUTL
IF Y<1
SET IBY=Y
GOTO END1
+57 DO SERV^IBAUTL2
if IBY<1
GOTO END1
+58 SET IBWHER=24
DO CLOCK^IBAUTL3
if IBY<1
GOTO END1
+59 ;
+60 ; - Create an Outpat Copay for discharge with Observation Speciality
+61 IF $$MVT^DGPMOBS(IBA)
DO OBS^IBECEAU5
if IBY<1
GOTO END1
GOTO END
+62 ;
+63 ; - handle the variations on the basis of the event record
+64 ; sets IBEVDA to IEN of event record, or to 0 if none
DO EVFIND^IBAUTL3
+65 SET IBWHER=25
DO @$SELECT(IBEVDA:"EVT",1:"NOEVT")
+66 ;
+67 ; - kill variables and close
END1 IF IBY<1
SET IBDUZ=DUZ
DO ^IBAERR1
KILL IBDUZ
+1 if '$GET(DGQUIET)
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 ; I +$$MVT^DGPMOBS(IBA) S IBDT=IBDISDT D OE^IBAMTBU1,CLOSE1 G 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 ; I +$$MVT^DGPMOBS(IBA) W:'$G(DGQUIET) " patient not billed (adm. for O&E)... " G NOEVTQ ; admitted for Observation & Examination
+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
