source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBG.m@ 1000

Last change on this file since 1000 was 623, checked in by George Lilly, 15 years ago

revised back to 6/30/08 version
File size: 8.2 KB
Line 
1IBCRBG ;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 ;
5INPTPTF(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 ;
34PTF(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 ;
48SPBB(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 ;
55BSLOS(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 ;
74SET ; 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 ;
90BBS(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 ;
96PTFDV(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 ;
125MVDRG(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 ;
163MVDRGQ Q IBDRG
Note: See TracBrowser for help on using the repository browser.