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