- IBAUTL3 ;ALB/CPM - MEANS TEST BILLING UTILITIES (CON'T.) ; 31 May 2022 12:59 PM
- ;;2.0;INTEGRATED BILLING;**176,656,704**;21-MAR-94;Build 49
- ;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)=+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 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 ; Remove the QUIT if we use the code below)
- ;LINE BELOW IS FOR IB*2.0*704
- I $P($G(^IBE(351,IBCLDA,1)),U,5)="" S IBNGHTSK=1 D EN^IBECECQ1(DFN) D Q
- .S ZTRTN="EN^IBECECU1("_DFN_","_IBCLDA_")",ZTSAVE("*")="",ZTDESC="Queue Billing Clock Sync update to allow time for query to run."
- .S ZTDTH=$$HADD^XLFDT($H,,,30,),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) ; IB*2*704
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBAUTL3 4629 printed Jan 18, 2025@03:09:19 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**;21-MAR-94;Build 49
- +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)=+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 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 ; Remove the QUIT if we use the code below)
- SET DIK="^IBE(351,"
- SET DA=IBCLDA
- DO IX1^DIK
- KILL DIK,DA
- +4 ;LINE BELOW IS FOR IB*2.0*704
- +5 IF $PIECE($GET(^IBE(351,IBCLDA,1)),U,5)=""
- SET IBNGHTSK=1
- DO EN^IBECECQ1(DFN)
- Begin DoDot:1
- +6 SET ZTRTN="EN^IBECECU1("_DFN_","_IBCLDA_")"
- SET ZTSAVE("*")=""
- SET ZTDESC="Queue Billing Clock Sync update to allow time for query to run."
- +7 SET ZTDTH=$$HADD^XLFDT($HOROLOG,,,30,)
- SET ZTIO=""
- DO ^%ZTLOAD
- End DoDot:1
- QUIT
- +8 ;Add a call to send an HL7 message to synchronize billing 365 day clocks IB*2*704
- +9 ;
- +10 ; IB*2*704
- IF +$PIECE($GET(^IBE(351,IBCLDA,1)),U,5)>0
- DO EN^IBECECU1(DFN,IBCLDA)
- +11 QUIT