- 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 Jan 18, 2025@03:07:42 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