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

IBCRBG.m

Go to the documentation of this file.
  1. IBCRBG ;ALB/ARH - RATES: BILL SOURCE EVENTS (INPT) ;21 MAY 96
  1. ;;2.0;INTEGRATED BILLING;**52,80,106,51,142,159,210,245,382,389,461,522**;21-MAR-94;Build 11
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. INPTPTF(IBIFN,CS) ; search PTF record for billable bedsections, transfer DRGs, and length of stay
  1. ; - screens out days for pass, leave and SC treatment
  1. ; - adds charges for only one BS if the ins company does not allow multiple bedsections per bill (36,.06)
  1. ; Output: ^TMP($J,"IBCRC-INDT", BILLABLE DATE) = MOVE DT/TM ^ BILL BS ^ SC FLAG ^ DRG ^ DIV ^ SPECIALTY ^ MOVE #
  1. ;
  1. N IB0,DFN,PTF,IBU,IBBDT,IBEDT,IBTF,IBADM,IBX,IBINSMBS
  1. K ^TMP($J,"IBCRC-PTF"),^TMP($J,"IBCRC-DIV"),^TMP($J,"IBCRC-INDT")
  1. ;
  1. S IB0=$G(^DGCR(399,+$G(IBIFN),0)),DFN=$P(IB0,U,2) Q:'DFN
  1. S IBTF=$P(IB0,U,6),PTF="" S:$P(IB0,U,5)<3 PTF=$P(IB0,U,8) Q:'PTF
  1. S IBINSMBS=0,IBX=+$G(^DGCR(399,+IBIFN,"MP"))
  1. I 'IBX,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBX=$$CURR^IBCEF2(IBIFN)
  1. I $P($G(^DIC(36,+IBX,0)),U,6)=0 S IBINSMBS=1 ; 1 bs per bill
  1. ;
  1. S IBU=$G(^DGCR(399,+IBIFN,"U")) Q:'IBU
  1. S IBBDT=+IBU,IBEDT=$P(IBU,U,2) Q:'IBEDT
  1. ;
  1. S IBADM=$O(^DGPM("APTF",PTF,0)) ; find corresponding admission
  1. ;
  1. D PTF(PTF) ; get movements and bedsections
  1. D PTFDV(PTF) ; reset movements and bedsections for ward/division
  1. D PTFFY(PTF,IBBDT,IBEDT) ; reset movements for FY DRG change
  1. ;
  1. D BSLOS(IBBDT,IBEDT,IBTF,IBADM,IBINSMBS) ; calculate days in bedsections within timeframe of the bill
  1. ;
  1. K ^TMP($J,"IBCRC-PTF"),^TMP($J,"IBCRC-DIV")
  1. ;
  1. D INPTRSET^IBCRBG2(IBIFN,$G(CS))
  1. Q
  1. ;
  1. PTF(PTF) ; find all movements in PTF for the admission by date and billing bedsection (501 movement)
  1. ; the movement date is the date the patient left the bedsection
  1. ; Output: ^TMP($J,"IBCRC-PTF", MOVE DT/TM)=MOVE DT/TM ^ BILL BED ^ SC FLAG ^ TRANSFER DRG ^ ^ SPECIALTY ^ MOVE #
  1. ;
  1. N IBMOVE,IBMVLN,IBBILLBS,IBENDDT,IBMSC,IBMDRG S PTF=+$G(PTF)
  1. S IBMOVE=0 F S IBMOVE=$O(^DGPT(PTF,"M",IBMOVE)) Q:'IBMOVE D
  1. . S IBMVLN=^DGPT(PTF,"M",IBMOVE,0)
  1. . S IBBILLBS=+$$SPBB($P(IBMVLN,U,2)) ; billable bedsection
  1. . S IBENDDT=+$P(IBMVLN,U,10) I 'IBENDDT S IBENDDT=DT ; movement date (last date in bedsection)
  1. . S IBMSC="" I +$P(IBMVLN,U,18)=1 S IBMSC=1 ; sc movement
  1. . S IBMDRG=$$MVDRG(PTF,IBMOVE) ; movement DRG
  1. . S ^TMP($J,"IBCRC-PTF",IBENDDT)=IBENDDT_U_IBBILLBS_U_IBMSC_U_IBMDRG_U_U_+$P(IBMVLN,U,2)_U_IBMOVE
  1. Q
  1. ;
  1. SPBB(SPCLTY) ; find the billable bedsection for a Specialty (42.4)
  1. ; returns billable bedsection IFN ^ billable bedsection name
  1. N IBX,IBY,IBZ S IBZ=0
  1. S IBX=$P($G(^DIC(42.4,+$G(SPCLTY),0)),U,5)
  1. I IBX'="" S IBY=$O(^DGCR(399.1,"B",IBX,0)) I +IBY S IBZ=IBY_U_IBX
  1. Q IBZ
  1. ;
  1. BSLOS(IBBDT,IBEDT,IBTF,IBADM,IBINSMBS) ; from the array of PTF movments get all bedsections and their LOS covered by date range of the bill
  1. ; adds all days for first cronological bs if ins comp wants only a single bs per bill, even if not sequential
  1. ; the movement date is the date the patient left the bedsection, so admission date is not in PTF array
  1. ;
  1. ; Input: ^TMP($J,"IBCRC-PTF", MOVE DT/TM) = MOVE DT/TM ^ BILL BS ^ SC FLAG ^ DRG ^ DIV ^ SPECIALTY ^ MOVE #
  1. ; Output: ^TMP($J,"IBCRC-INDT", BILLABLE DATE) = MOVE DT/TM ^ BILL BS ^ SC FLAG ^ DRG ^ DIV ^ SPECIALTY ^ MOVE #
  1. ;
  1. N IBSBDT,IBSEDT,IBS,IBLASTDT,IBX
  1. S IBSBDT=IBBDT+.3 ; discount any movements ending on or before the begin date
  1. S IBSEDT=IBEDT\1
  1. ;
  1. I ",2,3,"'[IBTF S IBSEDT=IBSEDT-.01 ; final bill, do not count last day
  1. ;
  1. I +$G(IBADM) S IBX=$$AD^IBCU64(IBADM) I +IBX,($P(IBX,U,1)\1)=($P(IBX,U,2)\1) S IBSBDT=IBBDT ; reset 1 day stays
  1. ;
  1. S IBS=IBSBDT-.01 F S IBS=$O(^TMP($J,"IBCRC-PTF",IBS)) Q:'IBS D SET S IBLASTDT=IBS Q:(IBLASTDT\1)>IBSEDT
  1. ;
  1. Q
  1. ;
  1. SET ; checks a specific movement to determine if it should be billed and what the length of stay is
  1. ; setting of the movement date determines how many days are counted in the bedsection
  1. N IBMVLN,IBMBDT,IBMEDT,IBMTF,IBMLOS,IBI,IBCHGDT
  1. S IBMVLN=$G(^TMP($J,"IBCRC-PTF",IBS))
  1. I '$P(IBMVLN,U,2) Q ; non-billable bedsection
  1. I +$P(IBMVLN,U,3) Q ; sc movement
  1. I +IBINSMBS,+$G(IBLASTDT) Q ; ins does not allow multiple bs
  1. ;
  1. S IBMBDT=$S(IBBDT>$G(IBLASTDT):IBBDT,1:IBLASTDT),IBMBDT=IBMBDT\1 ; start cnt on begin dt or last move dt
  1. S IBMEDT=$S(IBS<IBEDT:IBS,1:IBEDT),IBMEDT=IBMEDT\1 ; end cnt on move dt or end dt
  1. S IBMTF=$S(IBEDT<(IBS\1):IBTF,1:1) ; last movement gets timeframe
  1. S IBMLOS=$$LOS^IBCU64(IBMBDT,IBMEDT,IBMTF,IBADM) Q:'IBMLOS ; calculate the LOS for the movement
  1. ;
  1. F IBI=1:1:IBMLOS S IBCHGDT=$$FMADD^XLFDT(IBMBDT,(IBI-1)),^TMP($J,"IBCRC-INDT",+IBCHGDT)=IBMVLN
  1. Q
  1. ;
  1. BBS(X) ; returns true if pointer passed in is a billable bedsection ^ bedsection name
  1. N IBX,IBY S IBY=0,IBX=$G(^DGCR(399.1,+$G(X),0)) I +$P(IBX,U,5) S IBY=1_U_$P(IBX,U,1)
  1. Q IBY
  1. ;
  1. Q
  1. ;
  1. PTFDV(PTF) ; find all ward/location transfers in PTF for the patient to determine the site/division the patient was in
  1. ; the division of the ward will be added to the PTF bedsection movements
  1. ; Input: ^TMP($J,"IBCRC-PTF", move dt/tm) = move dt/tm ^ bill bs ^ sc flag ^ move drg ^ ^ specialty ^ move #
  1. ; Output: ^TMP($J,"IBCRC-PTF", move dt/tm) = move dt/tm ^ bill bs ^ sc flag ^ move drg ^ WARD DIV ^ spec ^ move#
  1. ; ^TMP($J,"IBCRC-DIV", TRANSFER DATE/TIME) = WARD DIVISION
  1. N IBTRNSF,IBTRLN,IBENDDT,IBTRDV,IBMVDT,IBTRDT
  1. ;
  1. I '$O(^TMP($J,"IBCRC-PTF",0)) Q
  1. ;
  1. ; get all ward transfers
  1. S IBTRNSF=0 F S IBTRNSF=$O(^DGPT(PTF,535,IBTRNSF)) Q:'IBTRNSF D
  1. . S IBTRLN=$G(^DGPT(PTF,535,+IBTRNSF,0))
  1. . S IBENDDT=$P(IBTRLN,U,10) I 'IBENDDT S IBENDDT=DT ; transfer date (last date in ward)
  1. . S IBTRDV=$P($G(^DIC(42,+$P(IBTRLN,U,6),0)),U,11) Q:'IBTRDV ; losing ward division
  1. . S ^TMP($J,"IBCRC-DIV",IBENDDT)=IBTRDV
  1. ;
  1. ; if the ward transfer does not coincide with a specialty transfer add bedsection move on the transfer date
  1. S IBENDDT=0 F S IBENDDT=$O(^TMP($J,"IBCRC-DIV",IBENDDT)) Q:'IBENDDT D
  1. . S IBMVDT=$O(^TMP($J,"IBCRC-PTF",(IBENDDT-.0000001)))
  1. . I 'IBMVDT Q ; - transfer movement dates after the discharge date in the PTF file (inconsistent)
  1. . I $P(IBENDDT,".")'=$P(IBMVDT,".") S ^TMP($J,"IBCRC-PTF",IBENDDT)=$G(^TMP($J,"IBCRC-PTF",IBMVDT))
  1. ;
  1. ; add the ward division to the bedsection/specialty
  1. S IBENDDT=0 F S IBENDDT=$O(^TMP($J,"IBCRC-PTF",IBENDDT)) Q:'IBENDDT D
  1. . S IBTRDT=$O(^TMP($J,"IBCRC-DIV",(IBENDDT-.0000001))) ; ward transfer covering this bedsection
  1. . S IBTRDV=$G(^TMP($J,"IBCRC-DIV",+IBTRDT)) ; ward division
  1. . I +IBTRDV S $P(^TMP($J,"IBCRC-PTF",IBENDDT),U,5)=IBTRDV
  1. Q
  1. ;
  1. PTFFY(PTF,BEGDT,ENDDT) ; add movement for FY (10/1) if date range covers FY and DRG changes
  1. ; the DRG may change on FY so check and if necessary add movement for pre-FY with old DRG
  1. ; Input: ^TMP($J,"IBCRC-PTF", move dt/tm) = move dt/tm ^ bill bs ^ sc flag ^ move drg ^ ^ specialty ^ move #
  1. ; Output: ^TMP($J,"IBCRC-PTF", move dt/tm) = move dt/tm ^ bill bs ^ sc flag ^ MOVE DRG ^ ward div ^ spec ^ move#
  1. N IBBEGDT,IBENDDT,IBYRB,IBYRE,IBYR,IBFY,IBMVLN,IBMVDRG,IBMOVE,IBFYDRG Q:'$G(PTF)
  1. Q:'$G(BEGDT) S IBFY=$E(BEGDT,1,3)_"1001"
  1. ;
  1. S IBBEGDT=BEGDT,IBENDDT=BEGDT\1 F S IBENDDT=$O(^TMP($J,"IBCRC-PTF",IBENDDT)) Q:'IBENDDT D S IBBEGDT=IBENDDT
  1. . S IBYRB=$E(IBBEGDT,1,3),IBYRE=$E(IBENDDT,1,3) I (IBYRE-IBYRB)>10 Q
  1. . F IBYR=IBYRB:1:IBYRE S IBFY=IBYR_"1001" I IBBEGDT<IBFY,IBENDDT>IBFY D
  1. .. S IBMVLN=$G(^TMP($J,"IBCRC-PTF",IBENDDT)),IBMVDRG=$P(IBMVLN,U,4),IBMOVE=$P(IBMVLN,U,7)
  1. .. S IBFYDRG=$$MVDRG(PTF,IBMOVE,IBYR_"0930")
  1. .. I IBMVDRG'=IBFYDRG S $P(IBMVLN,U,4)=IBFYDRG S ^TMP($J,"IBCRC-PTF",IBFY)=IBMVLN
  1. Q
  1. ;
  1. DXVER(DX,DATE) ; check the code version of the diagnosis matchs the code version on the date
  1. ; with ICD-10, bills may span the activation date and Dx may be coded in either version (should be ICD-10)
  1. ; returns null or if versions don't match then last ICD-9 date for ICD-9 Dx or first ICD-10 date for ICD-10 Dx
  1. N DXVER,CSVDATE,VDATE S VDATE=""
  1. S DXVER=$$ICD9VER^IBACSV(DX)
  1. I DXVER'=$$ICD9SYS^IBACSV(DATE) S CSVDATE=$$CSVDATE^IBACSV(30) S VDATE=CSVDATE I DXVER=1 S VDATE=$$FMADD^XLFDT(CSVDATE,-1)
  1. Q VDATE
  1. ;
  1. MVDRG(PTF,M,CDATE) ; Return the DRG for a specific PTF Movememt (M=move ifn)
  1. ; CDATE is optional, used if need to calculate DRG for some day within the move, not at the end date
  1. N DPT0,PTF0,PTFM0,PTFM82,PTF70,IBBEG,IBEND,IBDSST,IBDX,IBPRC0,IBPRC,IBDRG,IBVDATE,IBI,IBJ,IBP,PTFARR
  1. N SEX,AGE,ICDDX,ICDPOA,ICDPRC,ICDEXP,ICDDMS,ICDTRS,ICDDRG,ICDMDC,ICDRTC,ICDDATE
  1. N ICDCSYS,ICD0,ICDCDSY,ICDEDT,ICDX,ICDTMP,ICDRG,ICD10ORNIT,ICD10ORT,X1,X2,ICDSEX,ICDY ; ICDDRG clean-up
  1. S IBDRG=""
  1. ;
  1. S PTF0=$G(^DGPT(+$G(PTF),0)),DPT0=$G(^DPT(+$P(PTF0,U,1),0)) I DPT0="" G MVDRGQ
  1. S PTFM0=$G(^DGPT(+PTF,"M",+$G(M),0)) I 'PTFM0 G MVDRGQ
  1. S PTFM82=$G(^DGPT(+PTF,"M",+$G(M),82))
  1. S PTF70=$G(^DGPT(+PTF,70)),IBDSST=+$P(PTF70,U,3)
  1. ;
  1. S IBEND=+$P(PTFM0,U,10) I 'IBEND S IBEND=DT+.9
  1. S IBBEG=$O(^DGPT(+PTF,"M","AM",IBEND),-1) I 'IBBEG S IBBEG=$P(PTF0,U,2)
  1. ;
  1. S SEX=$P(DPT0,U,2)
  1. S AGE=$P(DPT0,U,3),AGE=$$FMDIFF^XLFDT(IBEND,AGE)\365.25
  1. ;
  1. S (ICDEXP,ICDDMS,ICDTRS)=0 I +PTF70,+PTF70=$P(PTFM0,U,10) D
  1. . I IBDSST>5 S ICDEXP=1 ; patient expired
  1. . I IBDSST=4 S ICDDMS=1 ; patient left against medical advice
  1. . I IBDSST=5,+$P(PTF70,U,13) S ICDTRS=1 ; patient transfered to another facility
  1. ;
  1. D PTFCDS^IBCSC4F(+PTF,501,+$G(M),.PTFARR) D K PTFARR ; Diagnosis
  1. . S IBJ=0,IBI="" F S IBI=$O(PTFARR(IBI)) Q:IBI="" S IBDX=PTFARR(IBI) I +IBDX D
  1. .. S IBJ=IBJ+1,ICDDX(IBJ)=+IBDX,ICDPOA(IBJ)=$P(IBDX,U,2)
  1. ;
  1. I '$G(ICDDX(1)) G MVDRGQ
  1. ;
  1. S IBJ=0
  1. S IBP=0 F S IBP=$O(^DGPT(+PTF,"S",IBP)) Q:'IBP D ; surgeries
  1. . S IBPRC0=$G(^DGPT(+PTF,"S",IBP,0)) Q:'IBPRC0
  1. . I +IBPRC0'<IBBEG,+IBPRC0'>IBEND D PTFCDS^IBCSC4F(+PTF,401,IBP,.PTFARR) D K PTFARR
  1. .. S IBI="" F S IBI=$O(PTFARR(IBI)) Q:IBI="" S IBPRC=PTFARR(IBI) I +IBPRC S IBJ=IBJ+1,ICDPRC(IBJ)=+IBPRC
  1. ;
  1. S IBP=0 F S IBP=$O(^DGPT(+PTF,"P",IBP)) Q:'IBP D ; procedures
  1. . S IBPRC0=$G(^DGPT(+PTF,"P",IBP,0)) Q:'IBPRC0
  1. . I +IBPRC0'<IBBEG,+IBPRC0'>IBEND D PTFCDS^IBCSC4F(+PTF,601,IBP,.PTFARR) D K PTFARR
  1. .. S IBI="" F S IBI=$O(PTFARR(IBI)) Q:IBI="" S IBPRC=PTFARR(IBI) I +IBPRC S IBJ=IBJ+1,ICDPRC(IBJ)=+IBPRC
  1. ;
  1. S ICDDATE=$S(+$G(CDATE):CDATE,+$P(PTFM0,U,10):+$P(PTFM0,U,10),1:DT) ; date for the DRG Grouper versioning
  1. S IBVDATE=$$DXVER(ICDDX(1),ICDDATE) I +IBVDATE S ICDDATE=IBVDATE ; reset date to within Dx code version
  1. ;
  1. D ^ICDDRG S IBDRG=$G(ICDDRG)
  1. ;
  1. MVDRGQ Q IBDRG