- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBG.m
r613 r623 1 IBCRBG ;ALB/ARH - RATES: BILL SOURCE EVENTS (INPT) ; 21 MAY 96 2 ;;2.0;INTEGRATED BILLING;**52,80,106,51,142,159,210,245,382,389**;21-MAR-94;Build 6 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 INPTPTF(IBIFN,CS) ; search PTF record for billable bedsections, transfer DRGs, and length of stay 6 ; - screens out days for pass, leave and SC treatment 7 ; - adds charges for only one BS if the ins company does not allow multiple bedsections per bill (36,.06) 8 ; Output: ^TMP($J,"IBCRC-INDT", BILLABLE DATE) = MOVE DT/TM ^ BILL BS ^ SC FLAG ^ DRG ^ DIV ^ SPECIALTY ^ MOVE # 9 ; 10 N IB0,DFN,PTF,IBU,IBBDT,IBEDT,IBTF,IBADM,IBX,IBINSMBS 11 K ^TMP($J,"IBCRC-PTF"),^TMP($J,"IBCRC-DIV"),^TMP($J,"IBCRC-INDT") 12 ; 13 S IB0=$G(^DGCR(399,+$G(IBIFN),0)),DFN=$P(IB0,U,2) Q:'DFN 14 S IBTF=$P(IB0,U,6),PTF="" S:$P(IB0,U,5)<3 PTF=$P(IB0,U,8) Q:'PTF 15 S IBINSMBS=0,IBX=+$G(^DGCR(399,+IBIFN,"MP")) 16 I 'IBX,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBX=$$CURR^IBCEF2(IBIFN) 17 I $P($G(^DIC(36,+IBX,0)),U,6)=0 S IBINSMBS=1 ; 1 bs per bill 18 ; 19 S IBU=$G(^DGCR(399,+IBIFN,"U")) Q:'IBU 20 S IBBDT=+IBU,IBEDT=$P(IBU,U,2) Q:'IBEDT 21 ; 22 S IBADM=$O(^DGPM("APTF",PTF,0)) ; find corresponding admission 23 ; 24 D PTF(PTF) ; get movements and bedsections 25 D PTFDV(PTF) ; reset movements and bedsections for ward/division 26 D PTFFY(PTF,IBBDT,IBEDT) ; reset movements for FY DRG change 27 ; 28 D BSLOS(IBBDT,IBEDT,IBTF,IBADM,IBINSMBS) ; calculate days in bedsections within timeframe of the bill 29 ; 30 K ^TMP($J,"IBCRC-PTF"),^TMP($J,"IBCRC-DIV") 31 ; 32 D INPTRSET^IBCRBG2(IBIFN,$G(CS)) 33 Q 34 ; 35 PTF(PTF) ; find all movements in PTF for the admission by date and billing bedsection (501 movement) 36 ; the movement date is the date the patient left the bedsection 37 ; Output: ^TMP($J,"IBCRC-PTF", MOVE DT/TM)=MOVE DT/TM ^ BILL BED ^ SC FLAG ^ TRANSFER DRG ^ ^ SPECIALTY ^ MOVE # 38 ; 39 N IBMOVE,IBMVLN,IBBILLBS,IBENDDT,IBMSC,IBMDRG S PTF=+$G(PTF) 40 S IBMOVE=0 F S IBMOVE=$O(^DGPT(PTF,"M",IBMOVE)) Q:'IBMOVE D 41 . S IBMVLN=^DGPT(PTF,"M",IBMOVE,0) 42 . S IBBILLBS=+$$SPBB($P(IBMVLN,U,2)) ; billable bedsection 43 . S IBENDDT=+$P(IBMVLN,U,10) I 'IBENDDT S IBENDDT=DT ; movement date (last date in bedsection) 44 . S IBMSC="" I +$P(IBMVLN,U,18)=1 S IBMSC=1 ; sc movement 45 . S IBMDRG=$$MVDRG(PTF,IBMOVE) ; movement DRG 46 . S ^TMP($J,"IBCRC-PTF",IBENDDT)=IBENDDT_U_IBBILLBS_U_IBMSC_U_IBMDRG_U_U_+$P(IBMVLN,U,2)_U_IBMOVE 47 Q 48 ; 49 SPBB(SPCLTY) ; find the billable bedsection for a Specialty (42.4) 50 ; returns billable bedsection IFN ^ billable bedsection name 51 N IBX,IBY,IBZ S IBZ=0 52 S IBX=$P($G(^DIC(42.4,+$G(SPCLTY),0)),U,5) 53 I IBX'="" S IBY=$O(^DGCR(399.1,"B",IBX,0)) I +IBY S IBZ=IBY_U_IBX 54 Q IBZ 55 ; 56 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 57 ; adds all days for first cronological bs if ins comp wants only a single bs per bill, even if not sequential 58 ; the movement date is the date the patient left the bedsection, so admission date is not in PTF array 59 ; 60 ; Input: ^TMP($J,"IBCRC-PTF", MOVE DT/TM) = MOVE DT/TM ^ BILL BS ^ SC FLAG ^ DRG ^ DIV ^ SPECIALTY ^ MOVE # 61 ; Output: ^TMP($J,"IBCRC-INDT", BILLABLE DATE) = MOVE DT/TM ^ BILL BS ^ SC FLAG ^ DRG ^ DIV ^ SPECIALTY ^ MOVE # 62 ; 63 N IBSBDT,IBSEDT,IBS,IBLASTDT,IBX 64 S IBSBDT=IBBDT+.3 ; discount any movements ending on or before the begin date 65 S IBSEDT=IBEDT\1 66 ; 67 I ",2,3,"'[IBTF S IBSEDT=IBSEDT-.01 ; final bill, do not count last day 68 ; 69 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 70 ; 71 S IBS=IBSBDT-.01 F S IBS=$O(^TMP($J,"IBCRC-PTF",IBS)) Q:'IBS D SET S IBLASTDT=IBS Q:(IBLASTDT\1)>IBSEDT 72 ; 73 Q 74 ; 75 SET ; checks a specific movement to determine if it should be billed and what the length of stay is 76 ; setting of the movement date determines how many days are counted in the bedsection 77 N IBMVLN,IBMBDT,IBMEDT,IBMTF,IBMLOS,IBI,IBCHGDT 78 S IBMVLN=$G(^TMP($J,"IBCRC-PTF",IBS)) 79 I '$P(IBMVLN,U,2) Q ; non-billable bedsection 80 I +$P(IBMVLN,U,3) Q ; sc movement 81 I +IBINSMBS,+$G(IBLASTDT) Q ; ins does not allow multiple bs 82 ; 83 S IBMBDT=$S(IBBDT>$G(IBLASTDT):IBBDT,1:IBLASTDT),IBMBDT=IBMBDT\1 ; start cnt on begin dt or last move dt 84 S IBMEDT=$S(IBS<IBEDT:IBS,1:IBEDT),IBMEDT=IBMEDT\1 ; end cnt on move dt or end dt 85 S IBMTF=$S(IBEDT<(IBS\1):IBTF,1:1) ; last movement gets timeframe 86 S IBMLOS=$$LOS^IBCU64(IBMBDT,IBMEDT,IBMTF,IBADM) Q:'IBMLOS ; calculate the LOS for the movement 87 ; 88 F IBI=1:1:IBMLOS S IBCHGDT=$$FMADD^XLFDT(IBMBDT,(IBI-1)),^TMP($J,"IBCRC-INDT",+IBCHGDT)=IBMVLN 89 Q 90 ; 91 BBS(X) ; returns true if pointer passed in is a billable bedsection ^ bedsection name 92 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) 93 Q IBY 94 ; 95 Q 96 ; 97 PTFDV(PTF) ; find all ward/location transfers in PTF for the patient to determine the site/division the patient was in 98 ; the division of the ward will be added to the PTF bedsection movements 99 ; Input: ^TMP($J,"IBCRC-PTF", move dt/tm) = move dt/tm ^ bill bs ^ sc flag ^ move drg ^ ^ specialty ^ move # 100 ; Output: ^TMP($J,"IBCRC-PTF", move dt/tm) = move dt/tm ^ bill bs ^ sc flag ^ move drg ^ WARD DIV ^ spec ^ move# 101 ; ^TMP($J,"IBCRC-DIV", TRANSFER DATE/TIME) = WARD DIVISION 102 N IBTRNSF,IBTRLN,IBENDDT,IBTRDV,IBMVDT,IBTRDT 103 ; 104 I '$O(^TMP($J,"IBCRC-PTF",0)) Q 105 ; 106 ; get all ward transfers 107 S IBTRNSF=0 F S IBTRNSF=$O(^DGPT(PTF,535,IBTRNSF)) Q:'IBTRNSF D 108 . S IBTRLN=$G(^DGPT(PTF,535,+IBTRNSF,0)) 109 . S IBENDDT=$P(IBTRLN,U,10) I 'IBENDDT S IBENDDT=DT ; transfer date (last date in ward) 110 . S IBTRDV=$P($G(^DIC(42,+$P(IBTRLN,U,6),0)),U,11) Q:'IBTRDV ; losing ward division 111 . S ^TMP($J,"IBCRC-DIV",IBENDDT)=IBTRDV 112 ; 113 ; if the ward transfer does not coincide with a specialty transfer add bedsection move on the transfer date 114 S IBENDDT=0 F S IBENDDT=$O(^TMP($J,"IBCRC-DIV",IBENDDT)) Q:'IBENDDT D 115 . S IBMVDT=$O(^TMP($J,"IBCRC-PTF",(IBENDDT-.0000001))) 116 . I 'IBMVDT Q ; - transfer movement dates after the discharge date in the PTF file (inconsistent) 117 . I $P(IBENDDT,".")'=$P(IBMVDT,".") S ^TMP($J,"IBCRC-PTF",IBENDDT)=$G(^TMP($J,"IBCRC-PTF",IBMVDT)) 118 ; 119 ; add the ward division to the bedsection/specialty 120 S IBENDDT=0 F S IBENDDT=$O(^TMP($J,"IBCRC-PTF",IBENDDT)) Q:'IBENDDT D 121 . S IBTRDT=$O(^TMP($J,"IBCRC-DIV",(IBENDDT-.0000001))) ; ward transfer covering this bedsection 122 . S IBTRDV=$G(^TMP($J,"IBCRC-DIV",+IBTRDT)) ; ward division 123 . I +IBTRDV S $P(^TMP($J,"IBCRC-PTF",IBENDDT),U,5)=IBTRDV 124 Q 125 ; 126 PTFFY(PTF,BEGDT,ENDDT) ; add movement for FY (10/1) if date range covers FY and DRG changes 127 ; the DRG may change on FY so check and if necessary add movement for pre-FY with old DRG 128 ; Input: ^TMP($J,"IBCRC-PTF", move dt/tm) = move dt/tm ^ bill bs ^ sc flag ^ move drg ^ ^ specialty ^ move # 129 ; Output: ^TMP($J,"IBCRC-PTF", move dt/tm) = move dt/tm ^ bill bs ^ sc flag ^ MOVE DRG ^ ward div ^ spec ^ move# 130 N IBBEGDT,IBENDDT,IBYRB,IBYRE,IBYR,IBFY,IBMVLN,IBMVDRG,IBMOVE,IBFYDRG Q:'$G(PTF) 131 Q:'$G(BEGDT) S IBFY=$E(BEGDT,1,3)_"1001" 132 ; 133 S IBBEGDT=BEGDT,IBENDDT=BEGDT\1 F S IBENDDT=$O(^TMP($J,"IBCRC-PTF",IBENDDT)) Q:'IBENDDT D S IBBEGDT=IBENDDT 134 . S IBYRB=$E(IBBEGDT,1,3),IBYRE=$E(IBENDDT,1,3) I (IBYRE-IBYRB)>10 Q 135 . F IBYR=IBYRB:1:IBYRE S IBFY=IBYR_"1001" I IBBEGDT<IBFY,IBENDDT>IBFY D 136 .. S IBMVLN=$G(^TMP($J,"IBCRC-PTF",IBENDDT)),IBMVDRG=$P(IBMVLN,U,4),IBMOVE=$P(IBMVLN,U,7) 137 .. S IBFYDRG=$$MVDRG(PTF,IBMOVE,IBYR_"0930") 138 .. I IBMVDRG'=IBFYDRG S $P(IBMVLN,U,4)=IBFYDRG S ^TMP($J,"IBCRC-PTF",IBFY)=IBMVLN 139 Q 140 ; 141 MVDRG(PTF,M,CDATE) ; Return the DRG for a specific PTF Movememt (M=move ifn) 142 ; CDATE is optional, used if need to calculate DRG for some day within the move, not at the end date 143 N DPT0,PTF0,PTFM0,PTF70,IBBEG,IBEND,IBDSST,IBDX,IBPRC0,IBPRC,IBDRG,IBI,IBJ,IBP 144 N SEX,AGE,ICDDX,ICDPRC,ICDEXP,ICDDMS,ICDTRS,ICDDRG,ICDMDC,ICDRTC,ICDDATE 145 S IBDRG="" 146 ; 147 S PTF0=$G(^DGPT(+$G(PTF),0)),DPT0=$G(^DPT(+$P(PTF0,U,1),0)) I DPT0="" G MVDRGQ 148 S PTFM0=$G(^DGPT(+PTF,"M",+$G(M),0)) I 'PTFM0 G MVDRGQ 149 S PTF70=$G(^DGPT(+PTF,70)),IBDSST=+$P(PTF70,U,3) 150 ; 151 S IBEND=+$P(PTFM0,U,10) I 'IBEND S IBEND=DT+.9 152 S IBBEG=$O(^DGPT(+PTF,"M","AM",IBEND),-1) I 'IBBEG S IBBEG=$P(PTF0,U,2) 153 ; 154 S SEX=$P(DPT0,U,2) 155 S AGE=$P(DPT0,U,3),AGE=$$FMDIFF^XLFDT(IBEND,AGE)\365.25 156 ; 157 S (ICDEXP,ICDDMS,ICDTRS)=0 I +PTF70,+PTF70=$P(PTFM0,U,10) D 158 . I IBDSST>5 S ICDEXP=1 ; patient expired 159 . I IBDSST=4 S ICDDMS=1 ; patient left against medical advice 160 . I IBDSST=5,+$P(PTF70,U,13) S ICDTRS=1 ; patient transfered to another facility 161 ; 162 S IBJ=0 F IBI=5:1:9 S IBDX=$P(PTFM0,U,IBI) I +IBDX,($$ICD9^IBACSV(+IBDX)'="") S IBJ=IBJ+1,ICDDX(IBJ)=IBDX 163 ; 164 I '$O(ICDDX(0)) G MVDRGQ 165 ; 166 S IBJ=0 167 S IBP=0 F S IBP=$O(^DGPT(+PTF,"S",IBP)) Q:'IBP D ; surguries 168 . S IBPRC0=$G(^DGPT(+PTF,"S",IBP,0)) Q:'IBPRC0 169 . I +IBPRC0'<IBBEG,+IBPRC0'>IBEND D 170 .. F IBI=8:1:12 S IBPRC=$P(IBPRC0,U,IBI) I +IBPRC,($$ICD0^IBACSV(+IBPRC)'="") S IBJ=IBJ+1,ICDPRC(IBJ)=+IBPRC 171 ; 172 S IBP=0 F S IBP=$O(^DGPT(+PTF,"P",IBP)) Q:'IBP D ; procedures 173 . S IBPRC0=$G(^DGPT(+PTF,"P",IBP,0)) Q:'IBPRC0 174 . I +IBPRC0'<IBBEG,+IBPRC0'>IBEND D 175 .. F IBI=5:1:9 S IBPRC=$P(IBPRC0,U,IBI) I +IBPRC,($$ICD0^IBACSV(+IBPRC)'="") S IBJ=IBJ+1,ICDPRC(IBJ)=+IBPRC 176 ; 177 S ICDDATE=$S(+$G(CDATE):CDATE,+$P(PTFM0,U,10):+$P(PTFM0,U,10),1:DT) ; date for the DRG Grouper versioning 178 D ^ICDDRG S IBDRG=$G(ICDDRG) 179 ; 180 MVDRGQ Q IBDRG 1 IBCRBG ;ALB/ARH - RATES: BILL SOURCE EVENTS (INPT) ; 21 MAY 96 2 ;;2.0;INTEGRATED BILLING;**52,80,106,51,142,159,210,245**;21-MAR-94 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; 5 INPTPTF(IBIFN,CS) ; search PTF record for billable bedsections, transfer DRGs, and length of stay 6 ; - screens out days for pass, leave and SC treatment 7 ; - adds charges for only one BS if the ins company does not allow multiple bedsections per bill (36,.06) 8 ; Output: ^TMP($J,"IBCRC-INDT", BILLABLE DATE) = MOVE DT/TM ^ BILL BS ^ SC FLAG ^ DRG ^ DIVISION ^ SPECIALTY 9 ; 10 N IB0,DFN,PTF,IBU,IBBDT,IBEDT,IBTF,IBADM,IBX,IBINSMBS 11 K ^TMP($J,"IBCRC-PTF"),^TMP($J,"IBCRC-DIV"),^TMP($J,"IBCRC-INDT") 12 ; 13 S IB0=$G(^DGCR(399,+$G(IBIFN),0)),DFN=$P(IB0,U,2) Q:'DFN 14 S IBTF=$P(IB0,U,6),PTF="" S:$P(IB0,U,5)<3 PTF=$P(IB0,U,8) Q:'PTF 15 S IBINSMBS=0,IBX=+$G(^DGCR(399,+IBIFN,"MP")) 16 I 'IBX,$$MCRWNR^IBEFUNC($$CURR^IBCEF2(IBIFN)) S IBX=$$CURR^IBCEF2(IBIFN) 17 I $P($G(^DIC(36,+IBX,0)),U,6)=0 S IBINSMBS=1 ; 1 bs per bill 18 ; 19 S IBU=$G(^DGCR(399,+IBIFN,"U")) Q:'IBU 20 S IBBDT=+IBU,IBEDT=$P(IBU,U,2) Q:'IBEDT 21 ; 22 S IBADM=$O(^DGPM("APTF",PTF,0)) ; find corresponding admission 23 ; 24 D PTF(PTF) ; get movements and bedsections 25 D PTFDV(PTF) ; reset movements and bedsections for ward/division 26 ; 27 D BSLOS(IBBDT,IBEDT,IBTF,IBADM,IBINSMBS) ; calculate days in bedsections within timeframe of the bill 28 ; 29 K ^TMP($J,"IBCRC-PTF"),^TMP($J,"IBCRC-DIV") 30 ; 31 D INPTRSET^IBCRBG2(IBIFN,$G(CS)) 32 Q 33 ; 34 PTF(PTF) ; find all movements in PTF for the admission by date and billing bedsection (501 movement) 35 ; the movement date is the date the patient left the bedsection 36 ; Output: ^TMP($J,"IBCRC-PTF", MOVE DT/TM)=MOVE DT/TM ^ BILL BEDSECTION ^ SC FLAG ^ TRANSFER DRG ^ ^ SPECIALTY 37 ; 38 N IBMOVE,IBMVLN,IBBILLBS,IBENDDT,IBMSC,IBMDRG S PTF=+$G(PTF) 39 S IBMOVE=0 F S IBMOVE=$O(^DGPT(PTF,"M",IBMOVE)) Q:'IBMOVE D 40 . S IBMVLN=^DGPT(PTF,"M",IBMOVE,0) 41 . S IBBILLBS=+$$SPBB($P(IBMVLN,U,2)) ; billable bedsection 42 . S IBENDDT=+$P(IBMVLN,U,10) I 'IBENDDT S IBENDDT=DT ; movement date (last date in bedsection) 43 . S IBMSC="" I +$P(IBMVLN,U,18)=1 S IBMSC=1 ; sc movement 44 . S IBMDRG=$$MVDRG(PTF,IBMOVE) ; movement DRG 45 . S ^TMP($J,"IBCRC-PTF",IBENDDT)=IBENDDT_U_IBBILLBS_U_IBMSC_U_IBMDRG_U_U_+$P(IBMVLN,U,2) 46 Q 47 ; 48 SPBB(SPCLTY) ; find the billable bedsection for a Specialty (42.4) 49 ; returns billable bedsection IFN ^ billable bedsection name 50 N IBX,IBY,IBZ S IBZ=0 51 S IBX=$P($G(^DIC(42.4,+$G(SPCLTY),0)),U,5) 52 I IBX'="" S IBY=$O(^DGCR(399.1,"B",IBX,0)) I +IBY S IBZ=IBY_U_IBX 53 Q IBZ 54 ; 55 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 56 ; adds all days for first cronological bs if ins comp wants only a single bs per bill, even if not sequential 57 ; the movement date is the date the patient left the bedsection, so admission date is not in PTF array 58 ; 59 ; Input: ^TMP($J,"IBCRC-PTF", MOVE DT/TM) = MOVE DT/TM ^ BILL BS ^ SC FLAG ^ DRG ^ DIVISION ^ SPECIALTY 60 ; Output: ^TMP($J,"IBCRC-INDT", BILLABLE DATE) = MOVE DT/TM ^ BILL BS ^ SC FLAG ^ DRG ^ DIVISION ^ SPECIALTY 61 ; 62 N IBSBDT,IBSEDT,IBS,IBLASTDT,IBX 63 S IBSBDT=IBBDT+.3 ; discount any movements ending on or before the begin date 64 S IBSEDT=IBEDT\1 65 ; 66 I ",2,3,"'[IBTF S IBSEDT=IBSEDT-.01 ; final bill, do not count last day 67 ; 68 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 69 ; 70 S IBS=IBSBDT-.01 F S IBS=$O(^TMP($J,"IBCRC-PTF",IBS)) Q:'IBS D SET S IBLASTDT=IBS Q:(IBLASTDT\1)>IBSEDT 71 ; 72 Q 73 ; 74 SET ; checks a specific movement to determine if it should be billed and what the length of stay is 75 ; setting of the movement date determines how many days are counted in the bedsection 76 N IBMVLN,IBMBDT,IBMEDT,IBMTF,IBMLOS,IBI,IBCHGDT 77 S IBMVLN=$G(^TMP($J,"IBCRC-PTF",IBS)) 78 I '$P(IBMVLN,U,2) Q ; non-billable bedsection 79 I +$P(IBMVLN,U,3) Q ; sc movement 80 I +IBINSMBS,+$G(IBLASTDT) Q ; ins does not allow multiple bs 81 ; 82 S IBMBDT=$S(IBBDT>$G(IBLASTDT):IBBDT,1:IBLASTDT),IBMBDT=IBMBDT\1 ; start cnt on begin dt or last move dt 83 S IBMEDT=$S(IBS<IBEDT:IBS,1:IBEDT),IBMEDT=IBMEDT\1 ; end cnt on move dt or end dt 84 S IBMTF=$S(IBEDT<(IBS\1):IBTF,1:1) ; last movement gets timeframe 85 S IBMLOS=$$LOS^IBCU64(IBMBDT,IBMEDT,IBMTF,IBADM) Q:'IBMLOS ; calculate the LOS for the movement 86 ; 87 F IBI=1:1:IBMLOS S IBCHGDT=$$FMADD^XLFDT(IBMBDT,(IBI-1)),^TMP($J,"IBCRC-INDT",+IBCHGDT)=IBMVLN 88 Q 89 ; 90 BBS(X) ; returns true if pointer passed in is a billable bedsection ^ bedsection name 91 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) 92 Q IBY 93 ; 94 Q 95 ; 96 PTFDV(PTF) ; find all ward/location transfers in PTF for the patient to determine the site/division the patient was in 97 ; the division of the ward will be added to the PTF bedsection movements 98 ; Input: ^TMP($J,"IBCRC-PTF", move dt/tm) = move dt/tm ^ bill bs ^ sc flag ^ move drg ^^ specialty 99 ; Output: ^TMP($J,"IBCRC-PTF", move dt/tm) = move dt/tm ^ bill bs ^ sc flag ^ move drg ^ WARD DIV ^ specialty 100 ; ^TMP($J,"IBCRC-DIV", TRANSFER DATE/TIME) = WARD DIVISION 101 N IBTRNSF,IBTRLN,IBENDDT,IBTRDV,IBMVDT,IBTRDT 102 ; 103 I '$O(^TMP($J,"IBCRC-PTF",0)) Q 104 ; 105 ; get all ward transfers 106 S IBTRNSF=0 F S IBTRNSF=$O(^DGPT(PTF,535,IBTRNSF)) Q:'IBTRNSF D 107 . S IBTRLN=$G(^DGPT(PTF,535,+IBTRNSF,0)) 108 . S IBENDDT=$P(IBTRLN,U,10) I 'IBENDDT S IBENDDT=DT ; transfer date (last date in ward) 109 . S IBTRDV=$P($G(^DIC(42,+$P(IBTRLN,U,6),0)),U,11) Q:'IBTRDV ; losing ward division 110 . S ^TMP($J,"IBCRC-DIV",IBENDDT)=IBTRDV 111 ; 112 ; if the ward transfer does not coincide with a specialty transfer add bedsection move on the transfer date 113 S IBENDDT=0 F S IBENDDT=$O(^TMP($J,"IBCRC-DIV",IBENDDT)) Q:'IBENDDT D 114 . S IBMVDT=$O(^TMP($J,"IBCRC-PTF",(IBENDDT-.0000001))) 115 . I 'IBMVDT Q ; - transfer movement dates after the discharge date in the PTF file (inconsistent) 116 . I $P(IBENDDT,".")'=$P(IBMVDT,".") S ^TMP($J,"IBCRC-PTF",IBENDDT)=$G(^TMP($J,"IBCRC-PTF",IBMVDT)) 117 ; 118 ; add the ward division to the bedsection/specialty 119 S IBENDDT=0 F S IBENDDT=$O(^TMP($J,"IBCRC-PTF",IBENDDT)) Q:'IBENDDT D 120 . S IBTRDT=$O(^TMP($J,"IBCRC-DIV",(IBENDDT-.0000001))) ; ward transfer covering this bedsection 121 . S IBTRDV=$G(^TMP($J,"IBCRC-DIV",+IBTRDT)) ; ward division 122 . I +IBTRDV S $P(^TMP($J,"IBCRC-PTF",IBENDDT),U,5)=IBTRDV 123 Q 124 ; 125 MVDRG(PTF,M) ; Return the DRG for a specific PTF Movememt (M=move ifn) 126 N DPT0,PTF0,PTFM0,PTF70,IBBEG,IBEND,IBDSST,IBDX,IBPRC0,IBPRC,IBDRG,IBI,IBJ,IBP 127 N SEX,AGE,ICDDX,ICDPRC,ICDEXP,ICDDMS,ICDTRS,ICDDRG,ICDMDC,ICDRTC,ICDDATE 128 S IBDRG="" 129 ; 130 S PTF0=$G(^DGPT(+$G(PTF),0)),DPT0=$G(^DPT(+$P(PTF0,U,1),0)) I DPT0="" G MVDRGQ 131 S PTFM0=$G(^DGPT(+PTF,"M",+$G(M),0)) I 'PTFM0 G MVDRGQ 132 S PTF70=$G(^DGPT(+PTF,70)),IBDSST=+$P(PTF70,U,3) 133 ; 134 S IBEND=+$P(PTFM0,U,10) I 'IBEND S IBEND=DT+.9 135 S IBBEG=$O(^DGPT(+PTF,"M","AM",IBEND),-1) I 'IBBEG S IBBEG=$P(PTF0,U,2) 136 ; 137 S SEX=$P(DPT0,U,2) 138 S AGE=$P(DPT0,U,3),AGE=$$FMDIFF^XLFDT(IBEND,AGE)\365.25 139 ; 140 S (ICDEXP,ICDDMS,ICDTRS)=0 I +PTF70,+PTF70=$P(PTFM0,U,10) D 141 . I IBDSST>5 S ICDEXP=1 ; patient expired 142 . I IBDSST=4 S ICDDMS=1 ; patient left against medical advice 143 . I IBDSST=5,+$P(PTF70,U,13) S ICDTRS=1 ; patient transfered to another facility 144 ; 145 S IBJ=0 F IBI=5:1:9 S IBDX=$P(PTFM0,U,IBI) I +IBDX,($$ICD9^IBACSV(+IBDX)'="") S IBJ=IBJ+1,ICDDX(IBJ)=IBDX 146 ; 147 I '$O(ICDDX(0)) G MVDRGQ 148 ; 149 S IBJ=0 150 S IBP=0 F S IBP=$O(^DGPT(+PTF,"S",IBP)) Q:'IBP D ; surguries 151 . S IBPRC0=$G(^DGPT(+PTF,"S",IBP,0)) Q:'IBPRC0 152 . I +IBPRC0'<IBBEG,+IBPRC0'>IBEND D 153 .. F IBI=8:1:12 S IBPRC=$P(IBPRC0,U,IBI) I +IBPRC,($$ICD0^IBACSV(+IBPRC)'="") S IBJ=IBJ+1,ICDPRC(IBJ)=+IBPRC 154 ; 155 S IBP=0 F S IBP=$O(^DGPT(+PTF,"P",IBP)) Q:'IBP D ; procedures 156 . S IBPRC0=$G(^DGPT(+PTF,"P",IBP,0)) Q:'IBPRC0 157 . I +IBPRC0'<IBBEG,+IBPRC0'>IBEND D 158 .. F IBI=5:1:9 S IBPRC=$P(IBPRC0,U,IBI) I +IBPRC,($$ICD0^IBACSV(+IBPRC)'="") S IBJ=IBJ+1,ICDPRC(IBJ)=+IBPRC 159 ; 160 S ICDDATE=$P(PTFM0,U,10) ; use the movement date for the DRG Grouper versioning 161 D ^ICDDRG S IBDRG=$G(ICDDRG) 162 ; 163 MVDRGQ Q IBDRG
Note:
See TracChangeset
for help on using the changeset viewer.
