Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBAUTL3

IBAUTL3.m

Go to the documentation of this file.
  1. 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
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. DED ; Find Medicare deductible rate on the billing clock date.
  1. ; Input: IBSERV, IBCLDT Output: IBMED - Medicare deductible
  1. N X S IBMED=0
  1. I $G(IBSERV)="" S IBY="-1^IB031" G DEDQ ;IB*2.0*656 Ensure that the service is defined before performing the lookup
  1. S X=$O(^IBE(350.1,"ANEW",IBSERV,81,0)) I 'X S IBY="-1^IB031" G DEDQ
  1. S X=$O(^IBE(350.2,"AIVDT",+X,-(IBCLDT+.1))),X=$O(^(+X,0))
  1. S IBMED=$P($G(^IBE(350.2,+X,0)),"^",4) I 'IBMED S IBY="-1^IB032"
  1. DEDQ Q
  1. ;
  1. EVADD ; Add a new billable event in File #350.
  1. ; Input: IBSITE, DFN, IBSL, IBEVDT, IBSERV, IBNH Output: IBEVDA
  1. ; IBNHLTC (optional for LTC only)
  1. D ADD^IBAUTL I Y<1 S IBY=Y G EVADDQ
  1. N IBATYP,IBDESC
  1. S IBEVDA=IBN
  1. 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
  1. S IBDESC=$P($G(^IBE(350.1,+IBATYP,0)),"^")
  1. S $P(^IB(IBN,0),"^",3,17)=IBATYP_"^"_IBSL_"^1^^^"_IBDESC_"^^^^^"_IBFAC_"^^^"_IBN_"^"_IBEVDT
  1. D NOW^%DTC S $P(^IB(IBN,1),"^")=DUZ,$P(^(1),"^",3,4)=DUZ_"^"_%
  1. S DIK="^IB(",DA=IBN D IX1^DIK
  1. EVADDQ K DIK,DA Q
  1. ;
  1. EVFIND ; Find most recent active (incomplete - still being billed)
  1. ; inpatient/NHCU event since original admission.
  1. ; Input: DFN, IBADMDT Output: IBEVDT, IBEVDA, IBEVCAL
  1. N IBD,J S IBD=IBADMDT\1,(IBEVDA,IBEVCAL,IBEVDT)=0,J=-DT
  1. 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
  1. Q
  1. ;
  1. EVCLOS1 ; Set Last Calc date to yesterday before closing event. Input: IBDT
  1. S X1=IBDT,X2=-1 D C^%DTC S IBEVCLD=X
  1. EVCLOSE ; Close event record. Input: IBEVDA, IBEVCLD
  1. N IBDR S IBDR=".05////2;"
  1. EVUPD ; Update event record. Input: IBEVDA, IBEVCLD
  1. S DR=".18////"_IBEVCLD_";13////"_$S($D(DUZ):DUZ,1:.5)_";14///NOW"
  1. I $D(IBDR) S DR=IBDR_DR
  1. S DIE="^IB(",DA=IBEVDA D ^DIE K DIE,DA,DR Q
  1. ;
  1. CLADD ; Add a new billing clock in File #351. (Rewritten in IB*2*704)
  1. ; Input: IBSITE, DFN, IBCLDT, IBSERV Output: IBCLDA, IBMED
  1. L +^IBE(351,0):10 E S IBY="-1^IB014" G CLADDQ
  1. S X=$P($S($D(^IBE(351,0)):^(0),1:"^^-1"),"^",3)+1 I 'X S IBY="-1^IB015" G CLADDQ
  1. K DD,DO,DIC,DR S DIC="^IBE(351,",DIC(0)="L",DLAYGO=351
  1. 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
  1. 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"
  1. D ^DIE K DA,DR,DIE L -^IBE(351,IBCLDA)
  1. ;
  1. ;Add a call to fire of an HL7 message to synchronize billing 365 day clocks IB*2*704
  1. I '$G(IBCCUPDF) D EN^IBECECQ1(DFN)
  1. S IBY=$S('$D(Y):1,1:"-1^IB028") D:IBY>0 DED
  1. CLADDQ L -^IBE(351,0) K DO,DD,DINUM,DIC Q
  1. ;
  1. CLOCK ; Determine if the patient has an active billing clock.
  1. ; Input: IBSERV Output: IBCLDA, IBCLDT, IBCLDAY, IBCLDOL
  1. S IBCLDA=+$O(^IBE(351,"ACT",DFN,0))
  1. D:IBCLDA CLDATA,DED Q
  1. ;
  1. CLDATA ; Return data from the current billing clock.
  1. N X S X=$G(^IBE(351,+IBCLDA,0)),IBCLDT=$P(X,"^",3),IBCLDAY=$P(X,"^",9)
  1. S IBCLDOL=$P(X,"^",$S(IBCLDAY<91:5,IBCLDAY<181:6,IBCLDAY<271:7,1:8)) Q
  1. ;
  1. CLOCKCL ; Close out the current billing clock.
  1. ; Input: DFN, IBCLDA, IBCLDT; IBCLDOL, IBCLDAY {opt}
  1. ; Output: IBCLDA=0
  1. N IBCLENDT,K S K=$$BILST^DGMTUB(DFN)
  1. S X1=IBCLDT,X2=364 D C^%DTC S IBCLENDT=X
  1. I K S:K<IBCLENDT IBCLENDT=K
  1. I $D(IBCLDOL),$D(IBCLDAY) D CLUPD
  1. S DA=IBCLDA,DIE="^IBE(351,",DR=".04////2;.1////"_IBCLENDT_";13////"_$S($D(DUZ):DUZ,1:.5)_";14///NOW"
  1. D ^DIE K DA,DR,DIE S IBY=$S('$D(Y):1,1:"-1^IB028"),IBCLDA=0 Q
  1. ;
  1. CLUPD ; - update billing clock. Input: IBCLDA, IBCLDOL, IBCLDAY
  1. D NOW^%DTC
  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)_"^"_%
  1. S DIK="^IBE(351,",DA=IBCLDA D IX1^DIK K DIK,DA ; Remove the QUIT if we use the code below)
  1. ;LINE BELOW IS FOR IB*2.0*704
  1. I $P($G(^IBE(351,IBCLDA,1)),U,5)="" S IBNGHTSK=1 D EN^IBECECQ1(DFN) D Q
  1. .S ZTRTN="EN^IBECECU1("_DFN_","_IBCLDA_")",ZTSAVE("*")="",ZTDESC="Queue Billing Clock Sync update to allow time for query to run."
  1. .S ZTDTH=$$HADD^XLFDT($H,,,30,),ZTIO="" D ^%ZTLOAD
  1. ;Add a call to send an HL7 message to synchronize billing 365 day clocks IB*2*704
  1. ;
  1. I +$P($G(^IBE(351,IBCLDA,1)),U,5)>0 D EN^IBECECU1(DFN,IBCLDA) ; IB*2*704
  1. Q