IBAMTV1 ;ALB/CPM - BUILD ARRAY OF BILLABLE EPISODES ; 31-MAY-94
;;2.0;INTEGRATED BILLING;**15,33,91,132,153,293**;21-MAR-94;Build 1
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
CARE ; Build an array of episodes to be back-billed.
;
; Input: IBSTART -- First date that the patient is Means Test billable
; IBEND -- Last date that the patient is Means Test billable
; DFN -- Pointer to the patient in file #2
;
; Output: ^TMP("IBAMTV",$J,episode date) = 1^2^3, where
; 1 = adm date for inpatient care
; visit date for outpatient care
; 2 = disch/last bill date for inpatient care
; null for outpatient care
; 3 = null for inpatient care
; softlink for outpatient care
;
K ^TMP("IBAMTV",$J)
;
; - inpatient at IBSTART?
S VAINDT=IBSTART\1_.2359 D ADM^VADPT2
I VADMVT D
.S IBA=$$ORIG(VADMVT),IBADM=+$G(^DGPM(IBA,0))\1
.Q:+$$MVT^DGPMOBS(IBA)
.S IBDIS=+$G(^DGPM(+$P($G(^DGPM(IBA,0)),"^",17),0))\1
.S:'IBDIS!(IBDIS>IBEND) IBDIS=$$FMADD^XLFDT(IBEND,1)
.S ^TMP("IBAMTV",$J,IBADM)=(IBSTART\1)_"^"_IBDIS
;
; - get subsequent admissions
S IBD="" F S IBD=$O(^DGPM("ATID1",DFN,IBD)) Q:'IBD!((9999999.9999999-IBD)\1'>IBSTART) S IBA=+$O(^(IBD,0)) D
.S IBADM0=$G(^DGPM(IBA,0))
.Q:+IBADM0>IBEND ; adm after end date for MT
.Q:+$$MVT^DGPMOBS(IBA) ; adm for obs & examination
.Q:$$ASIH^IBAUTL5(IBADM0) ; asih admission (catch it later)
.;
.S IBDIS=+$G(^DGPM(+$P($G(^DGPM(IBA,0)),"^",17),0))\1
.S:'IBDIS!(IBDIS>IBEND) IBDIS=$$FMADD^XLFDT(IBEND,1)
.S ^TMP("IBAMTV",$J,+IBADM0\1)=(+IBADM0\1)_"^"_IBDIS
;
; Outpatient encounters
N IBVAL,IBCBK,IBFILTER,IBOE,IBOE0,IBCK,IBT,IBPB,Z
S IBVAL("DFN")=DFN,IBVAL("BDT")=IBSTART,IBVAL("EDT")=IBEND
; Only parent encounters
S IBFILTER=""
S IBCBK="I '$P(Y0,U,6) S ^TMP(""IBOE"",$J,+$P(Y0,U,8),Y)=Y0"
K ^TMP("IBOE",$J)
D SCAN^IBSDU("PATIENT/DATE",.IBVAL,IBFILTER,IBCBK,1) K ^TMP("DIERR",$J)
F Z=0:1:6,9,10,13 S IBCK(Z)=""
S IBT=0 F S IBT=$O(^TMP("IBOE",$J,IBT)) Q:'IBT D
. S IBOE=0 F S IBOE=$O(^TMP("IBOE",$J,IBT,IBOE)) Q:'IBOE S IBOE0=$G(^(IBOE)) D
.. K IBPB
.. I $$BILLCK^IBAMTEDU(IBOE,IBOE0,.IBCK,.IBPB) D
... S Z=$O(IBPB(0)) Q:'Z
...;
... ;Check any visits for that date for dispositions, add-edits
... I Z=3 Q:$D(^TMP("IBAMTV",$J,IBOE0\1))
... I Z=2 Q:$S($D(^TMP("IBAMTV",$J,IBOE0\1)):1,1:$$NBCSC^IBEFUNC($P(IBOE0,U,3),IBOE0\1))
...;
... S ^TMP("IBAMTV",$J,IBOE0\1)=IBOE0\1_U_U_IBOE
K ^TMP("IBOE",$J)
;
K IBA,IBADM,IBADM0,IBAD,IBD,IBDIS,IBDT,IBI,VAINDT,VADMVT
;
Q
;
INP(DATE) ; Was the patient an inpatient on DATE?
; Input: DATE -- Date of outpatient visit
; array IBARR
; Output: 1 -- Patient was an inpatient on DATE
; 0 -- Patient was not
N X,Y,Z S X=0
I '$G(DATE) G INPQ
S Y=0 F S Y=$O(IBARR(Y)) Q:X!'Y!(Y>DATE) D
.S Z=0 F S Z=$O(IBARR(Y,Z)) Q:'Z S Z1=$G(IBARR(Y,Z)) I DATE'<+Z1,DATE'>$P(Z1,"^",2) S X=1 Q
INPQ Q X
;
ORIG(IBA) ; Find first admission pointer, considering ASIH movements
; Input: IBA -- Pointer to admission in #405
; Output: Z -- Pointer to original admission in #405
N X,Y,Z S Z=+$G(IBA)
F S X=$G(^DGPM(Z,0)),Z=$P(X,"^",14),Y=$P(X,"^",21) Q:Y="" S Z=Y
Q Z
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBAMTV1 3442 printed Dec 13, 2024@02:06:45 Page 2
IBAMTV1 ;ALB/CPM - BUILD ARRAY OF BILLABLE EPISODES ; 31-MAY-94
+1 ;;2.0;INTEGRATED BILLING;**15,33,91,132,153,293**;21-MAR-94;Build 1
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
CARE ; Build an array of episodes to be back-billed.
+1 ;
+2 ; Input: IBSTART -- First date that the patient is Means Test billable
+3 ; IBEND -- Last date that the patient is Means Test billable
+4 ; DFN -- Pointer to the patient in file #2
+5 ;
+6 ; Output: ^TMP("IBAMTV",$J,episode date) = 1^2^3, where
+7 ; 1 = adm date for inpatient care
+8 ; visit date for outpatient care
+9 ; 2 = disch/last bill date for inpatient care
+10 ; null for outpatient care
+11 ; 3 = null for inpatient care
+12 ; softlink for outpatient care
+13 ;
+14 KILL ^TMP("IBAMTV",$JOB)
+15 ;
+16 ; - inpatient at IBSTART?
+17 SET VAINDT=IBSTART\1_.2359
DO ADM^VADPT2
+18 IF VADMVT
Begin DoDot:1
+19 SET IBA=$$ORIG(VADMVT)
SET IBADM=+$GET(^DGPM(IBA,0))\1
+20 if +$$MVT^DGPMOBS(IBA)
QUIT
+21 SET IBDIS=+$GET(^DGPM(+$PIECE($GET(^DGPM(IBA,0)),"^",17),0))\1
+22 if 'IBDIS!(IBDIS>IBEND)
SET IBDIS=$$FMADD^XLFDT(IBEND,1)
+23 SET ^TMP("IBAMTV",$JOB,IBADM)=(IBSTART\1)_"^"_IBDIS
End DoDot:1
+24 ;
+25 ; - get subsequent admissions
+26 SET IBD=""
FOR
SET IBD=$ORDER(^DGPM("ATID1",DFN,IBD))
if 'IBD!((9999999.9999999-IBD)\1'>IBSTART)
QUIT
SET IBA=+$ORDER(^(IBD,0))
Begin DoDot:1
+27 SET IBADM0=$GET(^DGPM(IBA,0))
+28 ; adm after end date for MT
if +IBADM0>IBEND
QUIT
+29 ; adm for obs & examination
if +$$MVT^DGPMOBS(IBA)
QUIT
+30 ; asih admission (catch it later)
if $$ASIH^IBAUTL5(IBADM0)
QUIT
+31 ;
+32 SET IBDIS=+$GET(^DGPM(+$PIECE($GET(^DGPM(IBA,0)),"^",17),0))\1
+33 if 'IBDIS!(IBDIS>IBEND)
SET IBDIS=$$FMADD^XLFDT(IBEND,1)
+34 SET ^TMP("IBAMTV",$JOB,+IBADM0\1)=(+IBADM0\1)_"^"_IBDIS
End DoDot:1
+35 ;
+36 ; Outpatient encounters
+37 NEW IBVAL,IBCBK,IBFILTER,IBOE,IBOE0,IBCK,IBT,IBPB,Z
+38 SET IBVAL("DFN")=DFN
SET IBVAL("BDT")=IBSTART
SET IBVAL("EDT")=IBEND
+39 ; Only parent encounters
+40 SET IBFILTER=""
+41 SET IBCBK="I '$P(Y0,U,6) S ^TMP(""IBOE"",$J,+$P(Y0,U,8),Y)=Y0"
+42 KILL ^TMP("IBOE",$JOB)
+43 DO SCAN^IBSDU("PATIENT/DATE",.IBVAL,IBFILTER,IBCBK,1)
KILL ^TMP("DIERR",$JOB)
+44 FOR Z=0:1:6,9,10,13
SET IBCK(Z)=""
+45 SET IBT=0
FOR
SET IBT=$ORDER(^TMP("IBOE",$JOB,IBT))
if 'IBT
QUIT
Begin DoDot:1
+46 SET IBOE=0
FOR
SET IBOE=$ORDER(^TMP("IBOE",$JOB,IBT,IBOE))
if 'IBOE
QUIT
SET IBOE0=$GET(^(IBOE))
Begin DoDot:2
+47 KILL IBPB
+48 IF $$BILLCK^IBAMTEDU(IBOE,IBOE0,.IBCK,.IBPB)
Begin DoDot:3
+49 SET Z=$ORDER(IBPB(0))
if 'Z
QUIT
+50 ;
+51 ;Check any visits for that date for dispositions, add-edits
+52 IF Z=3
if $DATA(^TMP("IBAMTV",$JOB,IBOE0\1))
QUIT
+53 IF Z=2
if $SELECT($DATA(^TMP("IBAMTV",$JOB,IBOE0\1))
QUIT
+54 ;
+55 SET ^TMP("IBAMTV",$JOB,IBOE0\1)=IBOE0\1_U_U_IBOE
End DoDot:3
End DoDot:2
End DoDot:1
+56 KILL ^TMP("IBOE",$JOB)
+57 ;
+58 KILL IBA,IBADM,IBADM0,IBAD,IBD,IBDIS,IBDT,IBI,VAINDT,VADMVT
+59 ;
+60 QUIT
+61 ;
INP(DATE) ; Was the patient an inpatient on DATE?
+1 ; Input: DATE -- Date of outpatient visit
+2 ; array IBARR
+3 ; Output: 1 -- Patient was an inpatient on DATE
+4 ; 0 -- Patient was not
+5 NEW X,Y,Z
SET X=0
+6 IF '$GET(DATE)
GOTO INPQ
+7 SET Y=0
FOR
SET Y=$ORDER(IBARR(Y))
if X!'Y!(Y>DATE)
QUIT
Begin DoDot:1
+8 SET Z=0
FOR
SET Z=$ORDER(IBARR(Y,Z))
if 'Z
QUIT
SET Z1=$GET(IBARR(Y,Z))
IF DATE'<+Z1
IF DATE'>$PIECE(Z1,"^",2)
SET X=1
QUIT
End DoDot:1
INPQ QUIT X
+1 ;
ORIG(IBA) ; Find first admission pointer, considering ASIH movements
+1 ; Input: IBA -- Pointer to admission in #405
+2 ; Output: Z -- Pointer to original admission in #405
+3 NEW X,Y,Z
SET Z=+$GET(IBA)
+4 FOR
SET X=$GET(^DGPM(Z,0))
SET Z=$PIECE(X,"^",14)
SET Y=$PIECE(X,"^",21)
if Y=""
QUIT
SET Z=Y
+5 QUIT Z
