IBAMTC2 ;ALB/CJM - INTEGRATED BILLING, CLEANUP OF UNCLOSED EVENTS, UNPASSED CHARGES ; 04-APRIL-1992
;;2.0;INTEGRATED BILLING;**132,176**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
MAIN ;
N IBAGE,IBFREQ,IBCHG,DFN,IBN,IBND,IBSL,IBDISC,DIE,DR,DA,IBQUIT,IBPASS,IBOLD,IBDATE,IBDUZ S IBDUZ=$G(DUZ)
D NOW^%DTC S IBDATE=X
S IBAGE=44,IBFREQ=15 ; age of unpassed charges to report, frequency
; loop through all incomplete entries in file 350
N IBFLLTC
S IBN="" F S IBN=$O(^IB("AC",1,IBN)) Q:'IBN S IBND=$G(^IB(IBN,0)) D
.Q:($P(IBND,"^",5)'=1)!($P(IBND,"^",16)']"")
.I $P(IBND,"^",16)=IBN S IBFLLTC="" D Q:IBFLLTC="L"
..;
..N IBDISC,IBSL,VAIN,VAINDT,IBLDT D DISC Q:+IBDISC=0
..S DFN=$P(IBND,"^",2),VAINDT=IBDISC D INP^VADPT S IBFLLTC=$P($$TREATSP^IBAECU2($P($G(^DIC(45.7,+VAIN(3),0)),U,2)),"^",1)
..S IBLDT=$$LASTMJ^IBAECU() I IBLDT>0,$E(IBDISC,1,5)<$E(IBLDT,1,5),IBFLLTC="L" D CLOSE
.I $P(IBND,"^",16)=IBN D
..D EVENT
.E D CHARGE
Q
EVENT ; closes events if the patient was discharged
S (IBPASS,IBQUIT)=0
D DISC I IBDISC D CLOSE D:'IBQUIT FNDCHGS,PASS:IBCHG,BULLET1^IBAMTC3
Q
DISC ; gets the discharge date
S IBDISC="",IBSL=$P(IBND,"^",4)
I $P(IBSL,":")=405 S IBDISC=$P(IBSL,":",2) S:IBDISC]"" IBDISC=$P($G(^DGPM(IBDISC,0)),"^",17)
S:IBDISC IBDISC=($P($G(^DGPM(IBDISC,0)),"^")\1)
Q
CLOSE ;
S IBQUIT=1
L +^IB(IBN):3 I $T D
.S IBQUIT=0
.S DIE="^IB(",DA=IBN,DR=".05////2"
.D ^DIE L -^IB(IBN)
Q
FNDCHGS ;
N I S IBCHG="" F I=1:1 S IBCHG=$O(^IB("ACT",IBN,IBCHG)) Q:'IBCHG S IBCHG(I)=IBCHG
S IBCHG=(I-1)
Q
PASS ; pass the charges if they appear correct, complete, and can be locked
S IBPASS=0
N IBI,IBNOS,IBADMIT S DFN=$P(IBND,"^",2),IBADMIT=($P(IBND,"^",17)\1)
Q:+$$MVT^DGPMOBS($P(IBSL,":",2))
I IBDISC=$P(IBND,"^",17) Q:$P(IBND,"^",18)'=IBDISC
E S X1=$P(IBND,"^",18),X2=1 D C^%DTC Q:X'=IBDISC
S IBPASS=1 F IBI=1:1:IBCHG L +^IB(IBCHG(IBI)):1 S IBPASS=$T Q:'IBPASS I ($P($G(^IB(IBCHG(IBI),0)),"^",15)>IBDISC)!($P($G(^IB(IBCHG(IBI),0)),"^",14)<IBADMIT) S IBPASS=0 Q
I IBPASS N IBN F IBI=1:1:IBCHG S IBNOS=IBCHG(IBI),IBY=1 D FILER^IBAUTL5 D:IBY<1 ^IBAERR1
F IBI=1:1:IBCHG L -^IB(IBCHG(IBI))
Q
;
CHARGE ; if the charge is old send a bulletin
N IBWHEN S IBWHEN=$P($G(^IB(IBN,1)),"^",2)
S X2=IBWHEN,X1=IBDATE D ^%DTC
S IBOLD=(+$FN(X,"T")) I IBOLD>IBAGE,X#IBFREQ=0 D BULLET2^IBAMTC3
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBAMTC2 2411 printed Dec 13, 2024@02:06:28 Page 2
IBAMTC2 ;ALB/CJM - INTEGRATED BILLING, CLEANUP OF UNCLOSED EVENTS, UNPASSED CHARGES ; 04-APRIL-1992
+1 ;;2.0;INTEGRATED BILLING;**132,176**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
MAIN ;
+1 NEW IBAGE,IBFREQ,IBCHG,DFN,IBN,IBND,IBSL,IBDISC,DIE,DR,DA,IBQUIT,IBPASS,IBOLD,IBDATE,IBDUZ
SET IBDUZ=$GET(DUZ)
+2 DO NOW^%DTC
SET IBDATE=X
+3 ; age of unpassed charges to report, frequency
SET IBAGE=44
SET IBFREQ=15
+4 ; loop through all incomplete entries in file 350
+5 NEW IBFLLTC
+6 SET IBN=""
FOR
SET IBN=$ORDER(^IB("AC",1,IBN))
if 'IBN
QUIT
SET IBND=$GET(^IB(IBN,0))
Begin DoDot:1
+7 if ($PIECE(IBND,"^",5)'=1)!($PIECE(IBND,"^",16)']"")
QUIT
+8 IF $PIECE(IBND,"^",16)=IBN
SET IBFLLTC=""
Begin DoDot:2
+9 ;
+10 NEW IBDISC,IBSL,VAIN,VAINDT,IBLDT
DO DISC
if +IBDISC=0
QUIT
+11 SET DFN=$PIECE(IBND,"^",2)
SET VAINDT=IBDISC
DO INP^VADPT
SET IBFLLTC=$PIECE($$TREATSP^IBAECU2($PIECE($GET(^DIC(45.7,+VAIN(3),0)),U,2)),"^",1)
+12 SET IBLDT=$$LASTMJ^IBAECU()
IF IBLDT>0
IF $EXTRACT(IBDISC,1,5)<$EXTRACT(IBLDT,1,5)
IF IBFLLTC="L"
DO CLOSE
End DoDot:2
if IBFLLTC="L"
QUIT
+13 IF $PIECE(IBND,"^",16)=IBN
Begin DoDot:2
+14 DO EVENT
End DoDot:2
+15 IF '$TEST
DO CHARGE
End DoDot:1
+16 QUIT
EVENT ; closes events if the patient was discharged
+1 SET (IBPASS,IBQUIT)=0
+2 DO DISC
IF IBDISC
DO CLOSE
if 'IBQUIT
DO FNDCHGS
if IBCHG
DO PASS
DO BULLET1^IBAMTC3
+3 QUIT
DISC ; gets the discharge date
+1 SET IBDISC=""
SET IBSL=$PIECE(IBND,"^",4)
+2 IF $PIECE(IBSL,":")=405
SET IBDISC=$PIECE(IBSL,":",2)
if IBDISC]""
SET IBDISC=$PIECE($GET(^DGPM(IBDISC,0)),"^",17)
+3 if IBDISC
SET IBDISC=($PIECE($GET(^DGPM(IBDISC,0)),"^")\1)
+4 QUIT
CLOSE ;
+1 SET IBQUIT=1
+2 LOCK +^IB(IBN):3
IF $TEST
Begin DoDot:1
+3 SET IBQUIT=0
+4 SET DIE="^IB("
SET DA=IBN
SET DR=".05////2"
+5 DO ^DIE
LOCK -^IB(IBN)
End DoDot:1
+6 QUIT
FNDCHGS ;
+1 NEW I
SET IBCHG=""
FOR I=1:1
SET IBCHG=$ORDER(^IB("ACT",IBN,IBCHG))
if 'IBCHG
QUIT
SET IBCHG(I)=IBCHG
+2 SET IBCHG=(I-1)
+3 QUIT
PASS ; pass the charges if they appear correct, complete, and can be locked
+1 SET IBPASS=0
+2 NEW IBI,IBNOS,IBADMIT
SET DFN=$PIECE(IBND,"^",2)
SET IBADMIT=($PIECE(IBND,"^",17)\1)
+3 if +$$MVT^DGPMOBS($PIECE(IBSL,"
QUIT
+4 IF IBDISC=$PIECE(IBND,"^",17)
if $PIECE(IBND,"^",18)'=IBDISC
QUIT
+5 IF '$TEST
SET X1=$PIECE(IBND,"^",18)
SET X2=1
DO C^%DTC
if X'=IBDISC
QUIT
+6 SET IBPASS=1
FOR IBI=1:1:IBCHG
LOCK +^IB(IBCHG(IBI)):1
SET IBPASS=$TEST
if 'IBPASS
QUIT
IF ($PIECE($GET(^IB(IBCHG(IBI),0)),"^",15)>IBDISC)!($PIECE($GET(^IB(IBCHG(IBI),0)),"^",14)<IBADMIT)
SET IBPASS=0
QUIT
+7 IF IBPASS
NEW IBN
FOR IBI=1:1:IBCHG
SET IBNOS=IBCHG(IBI)
SET IBY=1
DO FILER^IBAUTL5
if IBY<1
DO ^IBAERR1
+8 FOR IBI=1:1:IBCHG
LOCK -^IB(IBCHG(IBI))
+9 QUIT
+10 ;
CHARGE ; if the charge is old send a bulletin
+1 NEW IBWHEN
SET IBWHEN=$PIECE($GET(^IB(IBN,1)),"^",2)
+2 SET X2=IBWHEN
SET X1=IBDATE
DO ^%DTC
+3 SET IBOLD=(+$FNUMBER(X,"T"))
IF IBOLD>IBAGE
IF X#IBFREQ=0
DO BULLET2^IBAMTC3
+4 QUIT
