- 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 Feb 18, 2025@23:32:55 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