source: FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDGTDRG.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 9.5 KB
Line 
1ICDGTDRG ;ALB/ADL/KER - COLLECTION OF DRG APIS ; 04/18/2004
2 ;;18.0;DRG Grouper;**7,12,14,17**;Oct 20, 2000
3 ; Collection of API's for accessing new "DRG" level
4 ; of files #80, #80.1, and #80.2. These new levels
5 ; were added for the Code Set Versioning Project
6 ;
7GETDRG(CODE,DGNDT,FILE) ; Get DRG or DRG string associated with a Code
8 ; Input:
9 ; CODE - IEN number
10 ; DRGDT - Effective date of the Code
11 ; FILE - File to check : 9 - ICD9 (file #80)
12 ; 0 - ICD0 (file 80.1)
13 ; Output:
14 ; DRGS - DRG or string of DRG's (delimited
15 ; by "^") or -1 if not defined
16 ;
17 ; Effective date or error message;
18 ; status flag (1=Active;0=Inactive)
19 ; Delimited by ";" because DRG's can be
20 ; multiple and are already delimited by "^"
21 ;
22 N DRG0,D1,DCS,DCSINF,DRGS,DCSV,DAMDC,DRGFY,DRG,DRGS,DADRGFY,MDC
23 S (DRG0,DRGFY,DRGS,DRG,MDC,DAMDC,DADRGFY,DRG0)=""
24 I $G(CODE)="" S DRGS="-1;NO CODE SELECTED;0" G GETDRGQ
25 I $G(FILE)="" S DRGS="-1;NO FILE INPUT;0" G GETDRGQ
26 I $G(DGNDT)="" S DGNDT=DT
27 I FILE'=9,FILE'=0 S DRGS="-1;INVALID FILE INPUT;0" G GETDRGQ
28 S DGNDT=DGNDT+.001
29 ; ICD Operations/Procedures
30 I FILE=0 D
31 . I CODE<1!'$D(^ICD0(CODE)) S DRGS="-1;NO SUCH ENTRY;0" Q
32 . S DRGFY=$O(^ICD0(CODE,2,"B",+DGNDT),-1),DADRGFY=$O(^ICD0(CODE,2,"B",+$G(DRGFY),DADRGFY)),DAMDC=$O(^ICD0(CODE,2,+DADRGFY,1,"B",ICDMDC,DAMDC))
33 . ;If no entry check previous FY
34 . I DAMDC'>0 D GETPVMDC^ICDREF
35 . F S DRG=$O(^ICD0(CODE,2,+DADRGFY,1,+DAMDC,1,"B",DRG)) Q:DRG="" S DRG0=DRG0_DRG_U
36 . I DRG0="" S DRGS="-1;NO DRG LEVEL;0"
37 . S DRGS=DRG0_";"_DRGFY
38 ; ICD Diagnosis
39 I FILE=9 D
40 . I CODE<1!'$D(^ICD9(CODE)) S DRGS="-1;NO SUCH ENTRY;0" Q
41 . S DRGFY=$O(^ICD9(CODE,3,"B",+DGNDT+.01),-1),DADRGFY=$O(^ICD9(CODE,3,"B",+$G(DRGFY),DADRGFY))
42 . F S DRG=$O(^ICD9(CODE,3,+DADRGFY,1,"B",DRG)) Q:DRG="" S DRG0=DRG0_DRG_U
43 . I DRG0="" S DRGS="-1;NO DRG LEVEL;0"
44 . S DRGS=DRG0_";"_DRGFY
45 ;
46GETDRGQ Q DRGS ; Exit API GETDRG
47 ;
48DRG(CODE,EDT) ; Returns a string of information from the DRG file (#80.2)
49 ; Input: CODE DRG code, internal or external format (Required)
50 ; CDT Date to check status for, FileMan format (default = TODAY)
51 ; If CDT < 10/1/1978, use 10/1/1978
52 ; If CDT > DT, validate with In/Activation Dates
53 ; If CDT is year only, use first of the year
54 ; If CDT is year and month, use first of the month
55 ;
56 ; Output: Returns an 22 piece string delimited by the up-arrow (^), where the
57 ; pieces are:
58 ; 1 DRG name (field #.01)
59 ; 2 Weight (field #2)
60 ; 3 Low Trim (days) (field #3)
61 ; 4 High Trim (days) (field #4)
62 ; 5 MDC (field #5)
63 ; 6 Surgery Flag (field #.06)
64 ; 7 <null>
65 ; 8 Avg Length of Stay (days) (field 10)
66 ; 9 Local Low Trim Days (field #11)
67 ; 10 Local High Trim Days (field #12)
68 ; 11 <null>
69 ; 12 Local Breakeven (field #13)
70 ; 13 Activation Date (.01 field of the 66 multiple)
71 ; 14 Status (.03 field of the 66 multiple)
72 ; 15 Inactivation Date (.01 field of the 66 multiple)
73 ; 16 Effective date (.01 field of the 66 multiple)
74 ; 17 Internal Entry Number (IEN)
75 ; 18 Effective date of CSV (.01 field of the 66 multiple)
76 ; 19 Reference (field #900)
77 ; 20 Weight (Non Affil) (field #7)
78 ; 21 Weight (Int Affil) (field #7.5)
79 ; 22 Message
80 ;
81 ; or
82 ;
83 ; -1^Error Description
84 ;
85 N D0,DCS,DFY,DFYINF,DCSINF,DMC1,D1,FYDT,FYMD,ICDFY
86 I $G(CODE)="" S STR="-1^NO CODE SELECTED",$P(STR,"^",14)=0 G DRGQ
87 I $G(EDT)="" S EDT=DT ; No date, use today
88 S EDT=$$DTBR^ICDAPIU(EDT,2) ; Verify that date is not earlier that the earliest allowed date per the bus. rule
89 S EDT=EDT+.001
90 S CODE=$G(CODE),CODE=$S(CODE:+CODE,1:$$CODEN(CODE)) ; GET ien
91 I CODE<1!'$D(^ICD(CODE)) S STR="-1^NO SUCH ENTRY",$P(STR,"^",14)=0 G DRGQ
92 S D0=^ICD(CODE,0)
93 S FYDT=$$DGY2K^DGPTOD0($$FY^DGPTOD0(EDT))+.001 ; get the correct FY in YYY0000 format for the effective date
94 S DFY=$O(^ICD(CODE,"FY",FYDT),-1) S:DFY>0 DFYINF=^(DFY,0) I DFY'>0 D ;date stored in YYY0000 w/YYY = Fiscal Year
95 . S DFYINF=U_$P(D0,U,2,4)_U_U_$P(D0,U,9)_U_$P(D0,U,12)_U_$P(D0,U,7)_U_$P(D0,U,8)_U_$P(D0,U,11)
96 S DCS=$O(^ICD(CODE,66,"B",EDT),-1),D1=$S(DCS'="":$O(^ICD(CODE,66,"B",DCS,0)),1:0) S DCSINF=$S(D1>0:^ICD(CODE,66,D1,0),1:"")
97 I DCSINF="" S DCSINF=U_U_"0"_U_U_$P(D0,U,5,6) ;if CSV level does not exist, default to info at .01 level with status = inactive
98 ;Resolve reference table using "B" cross reference and fiscal year
99 ;If ICDFY is not resolved set it to current fiscal year
100 S ICDFY=$O(^ICD(CODE,2,"B",EDT+.01),-1),DMC1=""
101 S DMC1=$O(^ICD(CODE,2,"B",+$G(ICDFY),DMC1)),DMC1=$P($G(^ICD(CODE,2,+DMC1,0)),U,3)
102 S STR=$P(D0,U)_U_$P(DFYINF,U,2,4)_U_$P(DCSINF,U,5,6)_U_U_$P(DFYINF,U,9)_U_$P(DFYINF,U,6,7)
103 S STR=STR_U_U_$P(D0,U,12)_U_$P(D0,U,13)_U_$P(DCSINF,U,3)_U_$P(D0,U,15)_U_$P(DCSINF,U)_U_CODE_U_DCS_U_$P(DMC1,U)_U_$P(DFYINF,U,8)_U_$P(DFYINF,U,10)
104 ;
105DRGQ Q STR
106 ;
107CODEI(CODE) ; Returns the IEN of an ICD code
108 Q +$O(^ICD9("BA",+CODE,0))
109 ;
110GETDATE(PATNUM) ; Find the correct "EFFECTIVE DATE" for locating the DRG/ICD/CPT codes
111 ;
112 ; Input: PATNUM - PTF Record Number
113 ; Output: "effective date" to use
114 ;
115 N EFFD,PTR
116 ; Census Date
117 S PTR=$P($G(^DGPT(PATNUM,0)),U,13) I PTR'="" S EFFD=$P($G(^DG(45.86,PTR,0)),U,1) G:EFFD'="" GDOUT
118 ; Discharge Date
119 S EFFD=$P($G(^DGPT(PATNUM,70)),U,1) G:EFFD'="" GDOUT
120 ; Surgery Date
121 S EFFD=$P($G(^DGPT(PATNUM,"S",1,0)),U,1) G:EFFD'="" GDOUT
122 ; Movement Date
123 S EFFD=$P($G(^DGPT(PATNUM,"M",1,0)),U,10)
124 ; Default TODAY
125 I EFFD="" S EFFD=DT
126GDOUT Q EFFD
127 ;
128ISVALID(CODE,EDATE,FILE) ; Is an ICD/CPT code Valid
129 ; This is a function call to be used in DIC("S") FileMan
130 ; calls to check the validation of a ICD/CPT code
131 ; Input:
132 ; CODE - ICD/CPT code (ien)
133 ; EDATE - Effective date to be used
134 ; FILE - File to use: 0 - ICD0; 9 - ICD9
135 ;
136 ; Output:
137 ; OUT - 1 if valid; 0 if not
138 ;
139 N OUT,TEMP
140 S OUT=0
141 I FILE=0 S TEMP=$$ICDOP^ICDCODE(CODE,EDATE) I TEMP>0,$P(TEMP,U,10) S OUT=1
142 I FILE=9 S TEMP=$$ICDDX^ICDCODE(CODE,EDATE) I TEMP>0,$P(TEMP,U,10) S OUT=1
143 Q OUT
144 ;
145DRGD(CODE,OUTARR,DFN,CDT) ; returns CPT description in array
146 ; Input: CODE ICD Code, Internal or External Format (required)
147 ; ARY Output Array Name for description
148 ; e.g. "ABC" or "ABC("TEST")"
149 ; Default = ^TMP("DRGD",$J)
150 ; DFN Not in use but included in anticipation of future need
151 ; CDT Date to screen against (default = TODAY)
152 ; If CDT < 10/1/1978, use 10/1/1978
153 ; If CDT > DT, use DT
154 ; If CDT is year only, use first of the year
155 ; If CDT is year and month only, use first of the month
156 ;
157 ; Output: # Number of lines in description output array
158 ; @ARY(1:n) - Versioned Description (lines 1-n) (from the 68 multiple)
159 ; @ARY(n+1) - Blank
160 ; @ARY(n+1) - A message stating: CODE TEXT MAY BE INACCURATE
161 ;
162 ; or
163 ;
164 ; -1^Error Description
165 ;
166 ; ** NOTE - USER MUST INITIALIZE ^TMP("DRGD",$J), IF USED **
167 ;
168 N ARR,END,I,N,CTV,IEN
169 I $G(CODE)="" S N="-1^NO CODE SELECTED" G DRGDQ
170 I $G(OUTARR)="" S OUTARR="^TMP(""DRGD"",$J,"
171 I OUTARR'["(" S OUTARR=OUTARR_"("
172 I OUTARR[")" S OUTARR=$P(OUTARR,")")
173 S END=$E(OUTARR,$L(OUTARR)) I END'="("&(END'=",") S OUTARR=OUTARR_","
174 K:OUTARR="^TMP(""DRGD"",$J," ^TMP("DRGD",$J)
175 S CODE=$G(CODE),IEN=$S(CODE:+CODE,1:$$CODEN(CODE)),I=0,N=0
176 I +IEN<1!('$D(^ICD(IEN))) S N="-1^NO SUCH CODE" G DRGDQ
177 S CDT=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICDAPIU(CDT,2))
178 D VLTDR(+IEN,CDT,.CTV) S (N,I)=0 F S I=$O(CTV(I)) Q:+I=0 D
179 . S N=N+1,ARR=OUTARR_N_")",@ARR=$$TRIM($G(CTV(I)))
180 I +N>0 S N=N+1,ARR=OUTARR_N_")",@ARR=" ",N=N+1,ARR=OUTARR_N_")",@ARR=$$MSG^ICDAPIU(CDT,2)
181 I +N'>0 S N="-1^VERSIONED DESCRIPTION NOT FOUND FOR "_CODE
182DRGDQ Q N
183 ;
184VLTDR(IEN,VDATE,ARY) ; Versioned Description - Long Text
185 ; Input:
186 ; IEN - Internal Entry Number file 80.2
187 ; VDATE - Effective/Versioning date to be used
188 ; .ARY - Array for output, passed by reference
189 ;
190 ; Output:
191 ; ARY() - Local array containing versioned description
192 ;
193 N ICD0,ICDC,ICDI,ICDSTD,ICDSTI,ICDVDT,ICDTXT,ICDD,ICDT,ICDE
194 S ICDI=+($G(IEN)) Q:+ICDI'>0 Q:'$D(^ICD(+ICDI))
195 S ICDVDT=$G(VDATE) S:'$L(ICDVDT)!(+ICDVDT'>0) ICDVDT=$$DT^XLFDT Q:$P(ICDVDT,".",1)'?7N
196 S ICD0=$G(^ICD(+ICDI,0)),ICDC=$P(ICD0,"^",1) Q:'$L(ICDC)
197 S ICDSTD=$O(^ICD("ADS",(ICDC_" "),(ICDVDT+.000001)),-1)
198 I +ICDSTD>0 D Q:+($O(ARY(0)))>0
199 . S ICDSTI=$O(^ICD("ADS",(ICDC_" "),ICDSTD,+ICDI," "),-1)
200 . S (ICDD,ICDT)=0 F S ICDD=$O(^ICD(+ICDI,68,ICDSTI,1,ICDD)) Q:+ICDD=0 D
201 . . S ICDT=ICDT+1,ARY(ICDT)=$G(^ICD(+ICDI,68,+ICDSTI,1,+ICDD,0)),ARY(0)=ICDT
202 S ICDSTD=$O(^ICD(+ICDI,68,"B"," "),-1) I +ICDSTD>0 D Q:+($O(ARY(0)))>0
203 . S ICDSTI=$O(^ICD(+ICDI,68,"B",ICDSTD,0))
204 . S (ICDD,ICDT)=0 F S ICDD=$O(^ICD(+ICDI,68,ICDSTI,1,ICDD)) Q:+ICDD=0 D
205 . . S ICDT=ICDT+1,ARY(ICDT)=$G(^ICD(+ICDI,68,+ICDSTI,1,+ICDD,0)),ARY(0)=ICDT
206 K ARY S (ICDD,ICDT)=0 F S ICDD=$O(^ICD(ICDI,1,ICDD)) Q:+ICDD=0 D
207 . S ICDT=ICDT+1,ARY(ICDT)=$G(^ICD(ICDI,1,ICDD,0)),ARY(0)=ICDT
208 Q
209TRIM(X) ; Trim Spaces
210 S X=$G(X) Q:X="" X F Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
211 F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
212 F Q:X'[" " S X=$P(X," ",1)_" "_$P(X," ",2,229)
213 Q X
214CODEN(CODE) ; Return the IEN of DRG
215 ; Input: DRG code
216 ; Output: IEN of code
217 ;
218 Q:$G(CODE)="" -1 N COD S COD=+$O(^ICD("B",CODE,0)) Q $S(COD>0:COD,1:-1)
Note: See TracBrowser for help on using the repository browser.