IBAUTL3 ;ALB/CPM-MEANS TEST BILLING UTILITIES (CON'T.) ; 05-SEP-91
;;2.0;INTEGRATED BILLING;**176,656**;21-MAR-94;Build 17
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
DED ; Find Medicare deductible rate on the billing clock date.
; Input: IBSERV, IBCLDT Output: IBMED - Medicare deductible
N X S IBMED=0
I $G(IBSERV)="" S IBY="-1^IB031" G DEDQ ;IB*2.0*656 Ensure that the service is defined before performing the lookup
S X=$O(^IBE(350.1,"ANEW",IBSERV,81,0)) I 'X S IBY="-1^IB031" G DEDQ
S X=$O(^IBE(350.2,"AIVDT",+X,-(IBCLDT+.1))),X=$O(^(+X,0))
S IBMED=$P($G(^IBE(350.2,+X,0)),"^",4) I 'IBMED S IBY="-1^IB032"
DEDQ Q
;
EVADD ; Add a new billable event in File #350.
; Input: IBSITE, DFN, IBSL, IBEVDT, IBSERV, IBNH Output: IBEVDA
; IBNHLTC (optional for LTC only)
D ADD^IBAUTL I Y<1 S IBY=Y G EVADDQ
N IBATYP,IBDESC
S IBEVDA=IBN
S IBATYP=$O(^IBE(350.1,"ANEW",IBSERV,$S($G(IBNHLTC):93,IBNH:92,1:91),0)) I 'IBATYP S IBY="-1^IB008" G EVADDQ
S IBDESC=$P($G(^IBE(350.1,+IBATYP,0)),"^")
S $P(^IB(IBN,0),"^",3,17)=IBATYP_"^"_IBSL_"^1^^^"_IBDESC_"^^^^^"_IBFAC_"^^^"_IBN_"^"_IBEVDT
D NOW^%DTC S $P(^IB(IBN,1),"^")=DUZ,$P(^(1),"^",3,4)=DUZ_"^"_%
S DIK="^IB(",DA=IBN D IX1^DIK
EVADDQ K DIK,DA Q
;
EVFIND ; Find most recent active (incomplete - still being billed)
; inpatient/NHCU event since original admission.
; Input: DFN, IBADMDT Output: IBEVDT, IBEVDA, IBEVCAL
N IBD,J S IBD=IBADMDT\1,(IBEVDA,IBEVCAL,IBEVDT)=0,J=-DT
F S J=$O(^IB("AFDT",DFN,J)) Q:'J!(-J<IBD)!(IBEVDT) F S IBEVDA=$O(^IB("AFDT",DFN,J,IBEVDA)) Q:'IBEVDA I $P($G(^IB(IBEVDA,0)),"^",5)=1 S IBEVDT=-J,IBEVCAL=$P(^(0),"^",18) Q
Q
;
EVCLOS1 ; Set Last Calc date to yesterday before closing event. Input: IBDT
S X1=IBDT,X2=-1 D C^%DTC S IBEVCLD=X
EVCLOSE ; Close event record. Input: IBEVDA, IBEVCLD
N IBDR S IBDR=".05////2;"
EVUPD ; Update event record. Input: IBEVDA, IBEVCLD
S DR=".18////"_IBEVCLD_";13////"_$S($D(DUZ):DUZ,1:.5)_";14///NOW"
I $D(IBDR) S DR=IBDR_DR
S DIE="^IB(",DA=IBEVDA D ^DIE K DIE,DA,DR Q
;
CLADD ; Add a new billing clock in File #351.
; Input: IBSITE, DFN, IBCLDT, IBSERV Output: IBCLDA, IBMED
L +^IBE(351,0):10 E S IBY="-1^IB014" G CLADDQ
S X=$P($S($D(^IBE(351,0)):^(0),1:"^^-1"),"^",3)+1 I 'X S IBY="-1^IB015" G CLADDQ
K DD,DO,DIC,DR S DIC="^IBE(351,",DIC(0)="L",DLAYGO=351
F X=X:1 I X>0,'$D(^IBE(351,X)) L +^IBE(351,X):1 I $T,'$D(^IBE(351,X)) S DINUM=X,X=+IBSITE_X D FILE^DICN I +Y>0 Q
S (DA,IBCLDA)=+Y,DIE="^IBE(351,",DR=".02////"_DFN_";.03////"_IBCLDT_";.04////1;11////"_$S($D(DUZ):DUZ,1:.5)_";12///NOW;13////"_$S($D(DUZ):DUZ,1:.5)_";14///NOW"
D ^DIE K DA,DR,DIE L -^IBE(351,IBCLDA)
S IBY=$S('$D(Y):1,1:"-1^IB028") D:IBY>0 DED
CLADDQ L -^IBE(351,0) K DO,DD,DINUM,DIC Q
;
CLOCK ; Determine if the patient has an active billing clock.
; Input: IBSERV Output: IBCLDA, IBCLDT, IBCLDAY, IBCLDOL
S IBCLDA=+$O(^IBE(351,"ACT",DFN,0))
D:IBCLDA CLDATA,DED Q
;
CLDATA ; Return data from the current billing clock.
N X S X=$G(^IBE(351,+IBCLDA,0)),IBCLDT=$P(X,"^",3),IBCLDAY=$P(X,"^",9)
S IBCLDOL=$P(X,"^",$S(IBCLDAY<91:5,IBCLDAY<181:6,IBCLDAY<271:7,1:8)) Q
;
CLOCKCL ; Close out the current billing clock.
; Input: DFN, IBCLDA, IBCLDT; IBCLDOL, IBCLDAY {opt}
; Output: IBCLDA=0
N IBCLENDT,K S K=$$BILST^DGMTUB(DFN)
S X1=IBCLDT,X2=364 D C^%DTC S IBCLENDT=X
I K S:K<IBCLENDT IBCLENDT=K
I $D(IBCLDOL),$D(IBCLDAY) D CLUPD
S DA=IBCLDA,DIE="^IBE(351,",DR=".04////2;.1////"_IBCLENDT_";13////"_$S($D(DUZ):DUZ,1:.5)_";14///NOW"
D ^DIE K DA,DR,DIE S IBY=$S('$D(Y):1,1:"-1^IB028"),IBCLDA=0 Q
;
CLUPD ; - update billing clock. Input: IBCLDA, IBCLDOL, IBCLDAY
D NOW^%DTC
S $P(^IBE(351,IBCLDA,0),"^",$S(IBCLDAY<91:5,IBCLDAY<181:6,IBCLDAY<271:7,1:8))=IBCLDOL,$P(^(0),"^",9)=IBCLDAY,$P(^(1),"^",3,4)=$S($D(DUZ):DUZ,1:.5)_"^"_%
S DIK="^IBE(351,",DA=IBCLDA D IX1^DIK K DIK,DA Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBAUTL3 3953 printed May 14, 2023@14:30:09 Page 2
IBAUTL3 ;ALB/CPM-MEANS TEST BILLING UTILITIES (CON'T.) ; 05-SEP-91
+1 ;;2.0;INTEGRATED BILLING;**176,656**;21-MAR-94;Build 17
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
DED ; Find Medicare deductible rate on the billing clock date.
+1 ; Input: IBSERV, IBCLDT Output: IBMED - Medicare deductible
+2 NEW X
SET IBMED=0
+3 ;IB*2.0*656 Ensure that the service is defined before performing the lookup
IF $GET(IBSERV)=""
SET IBY="-1^IB031"
GOTO DEDQ
+4 SET X=$ORDER(^IBE(350.1,"ANEW",IBSERV,81,0))
IF 'X
SET IBY="-1^IB031"
GOTO DEDQ
+5 SET X=$ORDER(^IBE(350.2,"AIVDT",+X,-(IBCLDT+.1)))
SET X=$ORDER(^(+X,0))
+6 SET IBMED=$PIECE($GET(^IBE(350.2,+X,0)),"^",4)
IF 'IBMED
SET IBY="-1^IB032"
DEDQ QUIT
+1 ;
EVADD ; Add a new billable event in File #350.
+1 ; Input: IBSITE, DFN, IBSL, IBEVDT, IBSERV, IBNH Output: IBEVDA
+2 ; IBNHLTC (optional for LTC only)
+3 DO ADD^IBAUTL
IF Y<1
SET IBY=Y
GOTO EVADDQ
+4 NEW IBATYP,IBDESC
+5 SET IBEVDA=IBN
+6 SET IBATYP=$ORDER(^IBE(350.1,"ANEW",IBSERV,$SELECT($GET(IBNHLTC):93,IBNH:92,1:91),0))
IF 'IBATYP
SET IBY="-1^IB008"
GOTO EVADDQ
+7 SET IBDESC=$PIECE($GET(^IBE(350.1,+IBATYP,0)),"^")
+8 SET $PIECE(^IB(IBN,0),"^",3,17)=IBATYP_"^"_IBSL_"^1^^^"_IBDESC_"^^^^^"_IBFAC_"^^^"_IBN_"^"_IBEVDT
+9 DO NOW^%DTC
SET $PIECE(^IB(IBN,1),"^")=DUZ
SET $PIECE(^(1),"^",3,4)=DUZ_"^"_%
+10 SET DIK="^IB("
SET DA=IBN
DO IX1^DIK
EVADDQ KILL DIK,DA
QUIT
+1 ;
EVFIND ; Find most recent active (incomplete - still being billed)
+1 ; inpatient/NHCU event since original admission.
+2 ; Input: DFN, IBADMDT Output: IBEVDT, IBEVDA, IBEVCAL
+3 NEW IBD,J
SET IBD=IBADMDT\1
SET (IBEVDA,IBEVCAL,IBEVDT)=0
SET J=-DT
+4 FOR
SET J=$ORDER(^IB("AFDT",DFN,J))
if 'J!(-J<IBD)!(IBEVDT)
QUIT
FOR
SET IBEVDA=$ORDER(^IB("AFDT",DFN,J,IBEVDA))
if 'IBEVDA
QUIT
IF $PIECE($GET(^IB(IBEVDA,0)),"^",5)=1
SET IBEVDT=-J
SET IBEVCAL=$PIECE(^(0),"^",18)
QUIT
+5 QUIT
+6 ;
EVCLOS1 ; Set Last Calc date to yesterday before closing event. Input: IBDT
+1 SET X1=IBDT
SET X2=-1
DO C^%DTC
SET IBEVCLD=X
EVCLOSE ; Close event record. Input: IBEVDA, IBEVCLD
+1 NEW IBDR
SET IBDR=".05////2;"
EVUPD ; Update event record. Input: IBEVDA, IBEVCLD
+1 SET DR=".18////"_IBEVCLD_";13////"_$SELECT($DATA(DUZ):DUZ,1:.5)_";14///NOW"
+2 IF $DATA(IBDR)
SET DR=IBDR_DR
+3 SET DIE="^IB("
SET DA=IBEVDA
DO ^DIE
KILL DIE,DA,DR
QUIT
+4 ;
CLADD ; Add a new billing clock in File #351.
+1 ; Input: IBSITE, DFN, IBCLDT, IBSERV Output: IBCLDA, IBMED
+2 LOCK +^IBE(351,0):10
IF '$TEST
SET IBY="-1^IB014"
GOTO CLADDQ
+3 SET X=$PIECE($SELECT($DATA(^IBE(351,0)):^(0),1:"^^-1"),"^",3)+1
IF 'X
SET IBY="-1^IB015"
GOTO CLADDQ
+4 KILL DD,DO,DIC,DR
SET DIC="^IBE(351,"
SET DIC(0)="L"
SET DLAYGO=351
+5 FOR X=X:1
IF X>0
IF '$DATA(^IBE(351,X))
LOCK +^IBE(351,X):1
IF $TEST
IF '$DATA(^IBE(351,X))
SET DINUM=X
SET X=+IBSITE_X
DO FILE^DICN
IF +Y>0
QUIT
+6 SET (DA,IBCLDA)=+Y
SET DIE="^IBE(351,"
SET DR=".02////"_DFN_";.03////"_IBCLDT_";.04////1;11////"_$SELECT($DATA(DUZ):DUZ,1:.5)_";12///NOW;13////"_$SELECT($DATA(DUZ):DUZ,1:.5)_";14///NOW"
+7 DO ^DIE
KILL DA,DR,DIE
LOCK -^IBE(351,IBCLDA)
+8 SET IBY=$SELECT('$DATA(Y):1,1:"-1^IB028")
if IBY>0
DO DED
CLADDQ LOCK -^IBE(351,0)
KILL DO,DD,DINUM,DIC
QUIT
+1 ;
CLOCK ; Determine if the patient has an active billing clock.
+1 ; Input: IBSERV Output: IBCLDA, IBCLDT, IBCLDAY, IBCLDOL
+2 SET IBCLDA=+$ORDER(^IBE(351,"ACT",DFN,0))
+3 if IBCLDA
DO CLDATA
DO DED
QUIT
+4 ;
CLDATA ; Return data from the current billing clock.
+1 NEW X
SET X=$GET(^IBE(351,+IBCLDA,0))
SET IBCLDT=$PIECE(X,"^",3)
SET IBCLDAY=$PIECE(X,"^",9)
+2 SET IBCLDOL=$PIECE(X,"^",$SELECT(IBCLDAY<91:5,IBCLDAY<181:6,IBCLDAY<271:7,1:8))
QUIT
+3 ;
CLOCKCL ; Close out the current billing clock.
+1 ; Input: DFN, IBCLDA, IBCLDT; IBCLDOL, IBCLDAY {opt}
+2 ; Output: IBCLDA=0
+3 NEW IBCLENDT,K
SET K=$$BILST^DGMTUB(DFN)
+4 SET X1=IBCLDT
SET X2=364
DO C^%DTC
SET IBCLENDT=X
+5 IF K
if K<IBCLENDT
SET IBCLENDT=K
+6 IF $DATA(IBCLDOL)
IF $DATA(IBCLDAY)
DO CLUPD
+7 SET DA=IBCLDA
SET DIE="^IBE(351,"
SET DR=".04////2;.1////"_IBCLENDT_";13////"_$SELECT($DATA(DUZ):DUZ,1:.5)_";14///NOW"
+8 DO ^DIE
KILL DA,DR,DIE
SET IBY=$SELECT('$DATA(Y):1,1:"-1^IB028")
SET IBCLDA=0
QUIT
+9 ;
CLUPD ; - update billing clock. Input: IBCLDA, IBCLDOL, IBCLDAY
+1 DO NOW^%DTC
+2 SET $PIECE(^IBE(351,IBCLDA,0),"^",$SELECT(IBCLDAY<91:5,IBCLDAY<181:6,IBCLDAY<271:7,1:8))=IBCLDOL
SET $PIECE(^(0),"^",9)=IBCLDAY
SET $PIECE(^(1),"^",3,4)=$SELECT($DATA(DUZ):DUZ,1:.5)_"^"_%
+3 SET DIK="^IBE(351,"
SET DA=IBCLDA
DO IX1^DIK
KILL DIK,DA
QUIT
