source: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATEI.m@ 628

Last change on this file since 628 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 8.2 KB
Line 
1IBATEI ;ALB/BGA - TRANSFER PRICING INPATIENT TRACKER ; 02-FEB-99
2 ;;2.0;INTEGRATED BILLING;**115,210**;21-MAR-94
3 ;; Per VHA Directive 10-93-142, this routine should not be modified
4 ;
5 ; This routine is called from ^IBAMTD and tracks all patient movements
6 ; as they relate to patients who are out of network.
7 ;
8EN ; Main Entry Point
9 I '$P($G(^IBE(350.9,1,10)),"^",2) Q ; transfer pricing turned off
10 I $G(DGPMA)="",$G(DGPMP)="" Q
11 N DFN,IBATIEN,DA,IBRTYPE,TYPE,IBA,IBIND,IBPTF,IBDISDT,IBDISPT,IBATFILE
12 N IBADMDT,IBSOURCE,IBPREF,PTF,ADMIS,IBDFN,IBREST
13 S IBA=$P($S(DGPMA="":DGPMP,1:DGPMA),U,14) Q:IBA<1 ; iba ptr to the admission
14 S IBIND=IBA_";DGPM("
15 ; $$FINDT checks to see if the entry exist and the entry is not cancelled
16 S IBATIEN=$$FINDT^IBATUTL(IBIND)
17 I IBATIEN D G END
18 . S DFN=$P($G(^IBAT(351.61,+IBATIEN,0)),U,2) Q:DFN<1
19 . ; if the MOVEMENT admission was deleted DELETE entry from 351.61
20 . I DGPMA="",($P(DGPMP,U,2)=1) D Q
21 . . D DEL^IBATFILE(IBATIEN)
22 . ; if the MOVEMENT deleted a discharge reset transaction STATUS="entered"
23 . I DGPMA="",($P(DGPMP,U,2)=3) D Q
24 . . S IBATFILE=$$DISC^IBATFILE(IBATIEN)
25 . ; if the MOVEMENT is adding a *DISCHARGE* add the event
26 . I DGPMP="",($P(DGPMA,U,2)=3) D Q
27 . . ; Look for ptf in the parent event
28 . . Q:'$P(DGPMA,U,14)
29 . . S IBPTF=$P($G(^DGPM($P(DGPMA,U,14),0)),U,16) Q:'IBPTF
30 . . S IBDISDT=$P($G(^DGPT(IBPTF,70)),U)
31 . . Q:IBDISDT']" "
32 . . S IBDISPT=$P($G(^DGPM($P(DGPMA,U,14),0)),U,17) Q:'IBDISPT
33 . . ; PASS IN=ien 351.61,discharge dt in ptf,discharge movement
34 . . S IBATFILE=$$DIS^IBATFILE(IBATIEN,IBDISDT,IBPTF,IBDISPT)
35 . . ; <<end of update existing entry>>
36 . . ; [if new admission not currently being tracked added to 351.61]
37 I DGPMP="",($P(DGPMA,U,2)=1) D G END
38 . ; check to see if this is a tp $$TTP returns '0' if not TP
39 . Q:'$$TPP^IBATUTL($P(DGPMA,U,3))
40 . S IBADMDT=$P(DGPMA,U),IBSOURCE=$P(DGPMA,U,14)
41 . S IBPREF=$$PPF^IBATUTL($P(DGPMA,U,3)) Q:'IBPREF
42 . Q:IBSOURCE=""!($P(DGPMA,U,14)="")
43 . S IBSOURCE=IBSOURCE_";DGPM("
44 . S IBATFILE=$$ADM^IBATFILE($P(DGPMA,U,3),IBADMDT,IBPREF,IBSOURCE)
45 ;
46 ; Case where we have a discharge but the admission was not recorded
47 I DGPMP="",($P(DGPMA,U,2)=3) D G END
48 . Q:'$$TPP^IBATUTL($P(DGPMA,U,3))
49 . ; add the admission and than add the discharge
50 . S IBADMDT=$P(DGPMA,U),IBSOURCE=$P(DGPMA,U,14)
51 . S IBPREF=$$PPF^IBATUTL($P(DGPMA,U,3)) Q:'IBPREF
52 . Q:IBSOURCE=""!($P(DGPMA,U,14)="")
53 . S IBSOURCE=IBSOURCE_";DGPM("
54 . S IBATFILE=$$ADM^IBATFILE($P(DGPMA,U,3),IBADMDT,IBPREF,IBSOURCE)
55 . ; add the discharge
56 . Q:'$P(DGPMA,U,14)!(IBATFILE<1)
57 . S IBATIEN=+IBATFILE,IBPTF=$P($G(^DGPM($P(DGPMA,U,14),0)),U,16) Q:'IBPTF
58 . S IBDISDT=$P($G(^DGPT(IBPTF,70)),U)
59 . Q:IBDISDT']" "
60 . S IBDISPT=$P($G(^DGPM($P(DGPMA,U,14),0)),U,17) Q:'IBDISPT
61 . ; PASS IN=ien 351.61,discharge dt in ptf,discharge movement
62 . S IBATFILE=$$DIS^IBATFILE(IBATIEN,IBDISDT,IBPTF,IBDISPT)
63 Q
64 ;
65FINDRT(PTF,ADMIS,IBDFN) ; Find the Rate
66 ;
67 ; Input: PTF=ien to PTF
68 ; ADMIS=ien to DGPM Patient Movement
69 ; IBDFN=ien to Patient File
70 ;
71 ; Output:
72 ; IBREST= if 0^ 2nd piece is error message
73 ; = if 1^ the rate has been calculated.
74 N IBATERR,IBRTYPE,IBADMDT,CHARGE,IBPREF,DISSPEC,TYPE,IBCALC,DRG
75 I '$G(PTF)!('$G(ADMIS))!('$G(IBDFN)) S IBREST="0^Parmeter passed in to FINDRT was less than one" Q IBREST
76 S IBATERR=0,IBADMDT=$P($P($G(^DGPM(+ADMIS,0)),U),".")
77 I IBADMDT<1 S IBREST="0^No admission date FOUND for ^dgpm ien="_ADMIS Q IBREST
78 S IBRTYPE=$$TYPRATE(PTF) ; returns bed or drg
79 I IBRTYPE["Could not find" Q IBRTYPE ;no DRG or Rate could be found
80 I $P(IBRTYPE,U,2)["DRG" D Q IBREST
81 . S DRG=$P(IBRTYPE,U)
82 . ; Find the home facility
83 . S IBPREF=$$PPF^IBATUTL(+IBDFN) I 'IBPREF S IBREST="0^No home facility found for DFN="_IBDFN Q
84 . ; Pass in DRG the date of the admission, the pref fac. and return
85 . ; CHARGE=1!0^default rate^nego rate^rate to use^tortliability rate
86 . S CHARGE=$$INPT^IBATCM(DRG,IBADMDT,IBPREF)
87 . I '$P(CHARGE,U)!$P(CHARGE,U,4)<1 S IBREST="0^Could not find a valid charge for the DRG" Q
88 . ; Pass in string "DRG",ien 405,DRG, DOLLAR AMOUNT)
89 . S IBREST=$$CALCRT("DRG",ADMIS,DRG,$P(CHARGE,U,4))
90 . ; if the second piece of IBVALUE is there than we have an
91 . ; error (need to do something) if not file away.
92 . ; if the filing was successful we need to set IBREST=1 and quit
93 . ; otherwise set IBREST="0^give reason for problem
94 I $P(IBRTYPE,U,2)["BED" D Q IBREST ; price and file the claim
95 . S IBREST=$$CALCRT("BED",ADMIS,$P(IBRTYPE,U))
96 ;
97TYPRATE(X) ; Pass in PTF ien and return either DRG or Bedsection or ERROR
98 ; see if PTF has a DRG
99 I '$G(X) S TYPE="0^Parameter passed into TYPRATE(X) has no value" Q TYPE
100 N IBPTF,IBPTFD,DIC,DA,DR,DIQ,IBDISCH,IBBED
101 S DIC="^DGPT(",DA=X,DR=".01;71;9",DIQ="IBPTF",DIQ(0)="I" D EN^DIQ1
102 K DIQ(0) S DIQ="IBPTFD" D EN^DIQ1 ; i need the computed drg value
103 I '$D(IBPTF),('$D(IBPTFD)) S TYPE="0^Could not find PTF RECORD" Q TYPE
104 I $G(IBPTFD(45,DA,9))="",$G(IBPTF(45,DA,71,"I"))="" S TYPE="0^Could not find a PTF RECORD" Q TYPE
105 S DISSPEC=$G(IBPTF(45,DA,71,"I")) ; used in $$calc when calculating outliers
106 ; Below if i have a drg and the drg can be priced SELECT drg
107 I $G(IBPTFD(45,DA,9)),+$$INPT^IBATCM(IBPTFD(45,DA,9),IBADMDT) S TYPE=$G(IBPTFD(45,DA,9))_U_"DRG"
108 E D
109 . S IBDISCH=$G(IBPTF(45,DA,71,"I")) ;gives you the discharge speciality
110 . S IBBED=$P($G(^DIC(42.4,+IBDISCH,0)),U,5) ; Bedsection 399.1
111 . S TYPE=IBBED_U_"BED"
112 Q TYPE
113 ;
114CALCRT(Z,Y,V,R) ; Calculate LOS, and price out claim.
115 ; INPUT:
116 ; Z = a string either "BED" or "DRG"
117 ; Y = ien for the admission movement
118 ; V = value either bedsection NAME or the drg NUMBER
119 ; R = used only with DRG and it is the dollar value of the drg.
120 ; OUTPUT:
121 ; IBCALC=" if 0^ 2nd piece is error message
122 ; if 1^ there are 2 possible options that can be returned
123 ; Option 1 - If we are calculating a Bed Section
124 ; 1^calculated amount^"B"
125 ; Option 2 - If we are calculating a DRG
126 ; 1^calculated amt^ien drg^los^hightrim^outlier days
127 ; ^bedsection rate for the outliers
128 ;
129 N X,IBBEDPTR,IBLOS,IBDATE,CALCDATE,DRGHIGH,IBBEDRT,IBDIFF,IBBED,IBOUTDT,IBBEDRT,DGPMIFN
130 I '$D(Z)!('$D(V))!($G(Y)<1) S IBCALC="0^parameter 'Z' is invalid" Q IBCALC
131 S IBCALC=0 I Z'="DRG"&(Z'="BED") S IBCALC="0^parameter is incorrect" Q IBCALC
132 ; calculate the LOS Y=ien for the admission movement
133 I '$D(^DGPM(+Y,0)) S IBCALC="0^ien "_Y_" in 405 does not exist" Q IBCALC
134 I Z["DRG",($G(R)<1) S IBCALC="0^the drg dollar value for ien "_Y_" was not passed in" Q IBCALC
135 S DGPMIFN=Y D ^DGPMLOS
136 I $P(X,U,5)<1 S IBCALC="0^no LOS found FOR movement "_Y Q IBCALC
137 E S IBLOS=$P(X,U,5)
138 S IBDATE=$P($P($G(^DGPM(+Y,0)),U),".") ; Date of patient movement
139 I Z="BED" D Q IBCALC
140 . ;get the pointer to the bedsection
141 . S IBBEDPTR=$$MCCRUTL^IBCRU1(V,5) ; 5 distinguishes bedsection in 399.1
142 . I IBBEDPTR<1 S IBCALC="0^could not find pointer to bedsection for name: "_V Q
143 . S CALCDATE=IBDATE
144 . ; below 1=ien to the charge set = TL-INPT(INCLUSIVE) #363.3
145 . S IBCALC=$$ITCHG^IBCRCI(1,IBBEDPTR,CALCDATE)
146 . S IBCALC=$P(IBCALC,U)
147 . S IBCALC=$S(IBCALC<1:"0^No rate found for bedsect "_Y,1:IBCALC)
148 . I IBCALC<1 Q
149 . S IBCALC="1^"_(IBLOS*(IBCALC*.8))_U_"B"
150 ;
151 ; (***** calculate DRG outliers here ******)
152 I Z="DRG" D Q IBCALC
153 . ; do look up calculate drg value
154 . S DRGHIGH=$P($$DRG^IBACSV(+V,IBDATE),U,4)
155 . S IBDIFF=$S(DRGHIGH:IBLOS-DRGHIGH,1:0)
156 . S IBCALC=R ;==DRG is calculated for the entire los except when there are high trim days
157 . ; if you have an outlier and you have a bedsection calc outlier
158 . ; disspec is the ptr to speciality from ptf set in $$typrate
159 . I IBDIFF>0,(DISSPEC>0) D
160 . . ; DISSPEC ;gives you the discharge speciality
161 . . S IBBED=$P($G(^DIC(42.4,+DISSPEC,0)),U,5) ; Name of Bedsection 399.1
162 . . S IBBEDPTR=$$MCCRUTL^IBCRU1(IBBED,5) ; Ptr to bedsection
163 . . S IBOUTDT=$P($G(^DGPM(+Y,0)),U)
164 . . S IBBEDRT=$$ITCHG^IBCRCI(1,IBBEDPTR,IBOUTDT) ; returns rate for bedsection
165 . . S IBBEDRT=$P(IBBEDRT,U)
166 . . I IBBEDRT>0 S IBBEDRT=(IBBEDRT*.8) ;**BGA-MOD 2/9/2000
167 . S IBCALC="1^"_IBCALC_U_V_U_IBLOS_U_DRGHIGH_U_$S(IBDIFF<1:0,1:IBDIFF)_U_$S($G(IBBEDRT)>0:IBBEDRT,1:0)
168 . ; All bedsections,drgs and outliers are calculated at 80% of there face value
169 Q IBCALC
170 ;
171END ;
172 W !,"Updating Transfer Pricing has been...completed."
173 Q
Note: See TracBrowser for help on using the repository browser.