IBAUTL3 ;ALB/CPM - MEANS TEST BILLING UTILITIES (CON'T.) ; 31 May 2022 12:59 PM
;;2.0;INTEGRATED BILLING;**176,656,704,769**;21-MAR-94;Build 42
;Per VA Directive 6402, 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. (Rewritten in IB*2*704)
; 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,IB351IEN)=+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)
;
;Add a call to fire of an HL7 message to synchronize billing 365 day clocks IB*2*704
I '$G(IBCCUPDF) D EN^IBECECQ1(DFN)
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,SYNC Q ;IB*2*769 - add call to check if clocks are in sync across all sites
;
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
N IB351IEN,IBVSRNUP,IBCLKST,ZTREQ,ZTRTN,ZTDESC,ZTSAVE,ZTIO,ZTDTH ;IB*2.0*769 - New variables clock update
D NOW^%DTC
;IBVSRNUP used as a flag for EN^IBECECU1 so that the clock version is not updated as part of the nightly job
S IBVSRNUP=$S($G(IBNGHTSK):0,1:1)
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 ; Remove the QUIT if we use the code below)
;LINE BELOW IS FOR IB*2.0*704/769 - include 3rd parameter in queue to IBECECU1
I $P($G(^IBE(351,IBCLDA,1)),U,5)="" S IB351IEN=IBCLDA,IBCLKST=$$GET1^DIQ(351,IBCLDA,12,"I") D:($$FMDIFF^XLFDT($$NOW^XLFDT,IBCLKST,2)>10) EN^IBECECQ1(DFN) D Q
.S ZTRTN="EN^IBECECU1("_DFN_","_IBCLDA_","_IBVSRNUP_")",ZTSAVE("*")="",ZTDESC="Queue Billing Clock Sync update to allow time for query to run."
.S ZTDTH=$$HADD^XLFDT($H,,,10,),ZTIO="" D ^%ZTLOAD
;Add a call to send an HL7 message to synchronize billing 365 day clocks IB*2*704
;
I +$P($G(^IBE(351,IBCLDA,1)),U,5)>0 D EN^IBECECU1(DFN,IBCLDA,IBVSRNUP) ; IB*2*704
Q
SYNC ; Check if billing clock is out of sync
N IBECREF,IBECREFS,IBECTFL,IBECERR,IBECARY,IBECSITE,IBECVERN,IBVRNST,IBECENT
Q:$G(DGPMA) ;Quit if called from patient movement
Q:$G(IBNGHTSK) ;Quit if clocked is being updated by nightly task
Q:'$$GET1^DIQ(351,IBCLDA,18,"I")
S IBECREF=$O(^IBE(351.3,"B",IBCLDA,"")),IBECREFS=IBECREF_","
D GETS^DIQ(351.3,IBECREFS,"**","E","IBECTFL","IBECERR")
S IBECENT="" F S IBECENT=$O(IBECTFL(351.31,IBECENT)) Q:IBECENT="" D
.S IBECSITE=IBECTFL(351.31,IBECENT,10,"E"),IBECVERN=IBECTFL(351.31,IBECENT,11,"E")
.S IBECARY(IBECSITE)=IBECVERN
W !!,"**********************************WARNING**********************************"
W !!,"The local billing clock is out of sync with other facility(s) below.",!,"Please sync billing clock information before creating a copayment to ensure",!,"copayment billing accuracy.",!
;W "FACILTY FACILITY CLOCK VERSION"
W ! S IBVRNST="" F S IBVRNST=$O(IBECARY(IBVRNST)) Q:IBVRNST="" W IBVRNST W:$O(IBECARY(IBVRNST))'="" "; "
S DIR(0)="Y",DIR("A")="Do you still want to add a charge"
S DIR("?")="Enter 'Y' to continue to add the charge, or 'N' or '^' to quit",DIR("B")="No"
D ^DIR I Y<1 S IBSYNC=-1,IBY=-1,IBCLDA=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBAUTL3 6368 printed Sep 23, 2025@19:44:20 Page 2
IBAUTL3 ;ALB/CPM - MEANS TEST BILLING UTILITIES (CON'T.) ; 31 May 2022 12:59 PM
+1 ;;2.0;INTEGRATED BILLING;**176,656,704,769**;21-MAR-94;Build 42
+2 ;Per VA Directive 6402, 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. (Rewritten in IB*2*704)
+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,IB351IEN)=+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 ;
+9 ;Add a call to fire of an HL7 message to synchronize billing 365 day clocks IB*2*704
+10 IF '$GET(IBCCUPDF)
DO EN^IBECECQ1(DFN)
+11 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 ;IB*2*769 - add call to check if clocks are in sync across all sites
if IBCLDA
DO CLDATA
DO DED
DO SYNC
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 ;IB*2.0*769 - New variables clock update
NEW IB351IEN,IBVSRNUP,IBCLKST,ZTREQ,ZTRTN,ZTDESC,ZTSAVE,ZTIO,ZTDTH
+2 DO NOW^%DTC
+3 ;IBVSRNUP used as a flag for EN^IBECECU1 so that the clock version is not updated as part of the nightly job
+4 SET IBVSRNUP=$SELECT($GET(IBNGHTSK):0,1:1)
+5 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)_"^"_%
+6 ; Remove the QUIT if we use the code below)
SET DIK="^IBE(351,"
SET DA=IBCLDA
DO IX1^DIK
KILL DIK,DA
+7 ;LINE BELOW IS FOR IB*2.0*704/769 - include 3rd parameter in queue to IBECECU1
+8 IF $PIECE($GET(^IBE(351,IBCLDA,1)),U,5)=""
SET IB351IEN=IBCLDA
SET IBCLKST=$$GET1^DIQ(351,IBCLDA,12,"I")
if ($$FMDIFF^XLFDT($$NOW^XLFDT,IBCLKST,2)>10)
DO EN^IBECECQ1(DFN)
Begin DoDot:1
+9 SET ZTRTN="EN^IBECECU1("_DFN_","_IBCLDA_","_IBVSRNUP_")"
SET ZTSAVE("*")=""
SET ZTDESC="Queue Billing Clock Sync update to allow time for query to run."
+10 SET ZTDTH=$$HADD^XLFDT($HOROLOG,,,10,)
SET ZTIO=""
DO ^%ZTLOAD
End DoDot:1
QUIT
+11 ;Add a call to send an HL7 message to synchronize billing 365 day clocks IB*2*704
+12 ;
+13 ; IB*2*704
IF +$PIECE($GET(^IBE(351,IBCLDA,1)),U,5)>0
DO EN^IBECECU1(DFN,IBCLDA,IBVSRNUP)
+14 QUIT
SYNC ; Check if billing clock is out of sync
+1 NEW IBECREF,IBECREFS,IBECTFL,IBECERR,IBECARY,IBECSITE,IBECVERN,IBVRNST,IBECENT
+2 ;Quit if called from patient movement
if $GET(DGPMA)
QUIT
+3 ;Quit if clocked is being updated by nightly task
if $GET(IBNGHTSK)
QUIT
+4 if '$$GET1^DIQ(351,IBCLDA,18,"I")
QUIT
+5 SET IBECREF=$ORDER(^IBE(351.3,"B",IBCLDA,""))
SET IBECREFS=IBECREF_","
+6 DO GETS^DIQ(351.3,IBECREFS,"**","E","IBECTFL","IBECERR")
+7 SET IBECENT=""
FOR
SET IBECENT=$ORDER(IBECTFL(351.31,IBECENT))
if IBECENT=""
QUIT
Begin DoDot:1
+8 SET IBECSITE=IBECTFL(351.31,IBECENT,10,"E")
SET IBECVERN=IBECTFL(351.31,IBECENT,11,"E")
+9 SET IBECARY(IBECSITE)=IBECVERN
End DoDot:1
+10 WRITE !!,"**********************************WARNING**********************************"
+11 WRITE !!,"The local billing clock is out of sync with other facility(s) below.",!,"Please sync billing clock information before creating a copayment to ensure",!,"copayment billing accuracy.",!
+12 ;W "FACILTY FACILITY CLOCK VERSION"
+13 WRITE !
SET IBVRNST=""
FOR
SET IBVRNST=$ORDER(IBECARY(IBVRNST))
if IBVRNST=""
QUIT
WRITE IBVRNST
if $ORDER(IBECARY(IBVRNST))'=""
WRITE "; "
+14 SET DIR(0)="Y"
SET DIR("A")="Do you still want to add a charge"
+15 SET DIR("?")="Enter 'Y' to continue to add the charge, or 'N' or '^' to quit"
SET DIR("B")="No"
+16 DO ^DIR
IF Y<1
SET IBSYNC=-1
SET IBY=-1
SET IBCLDA=""
+17 QUIT
