source: WorldVistAEHR/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTCOD.m@ 1432

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

initial load of WorldVistAEHR
File size: 8.5 KB
RevLine 
[613]1ICPTCOD ;ALB/DEK/KER - CPT CODE APIS ; 04/18/2004
2 ;;6.0;CPT/HCPCS;**6,12,13,14,16,19**;May 19, 1997;Build 1
3 ;
4 ; External References
5 ; DBIA 10103 $$DT^XLFDT
6 ;
7 Q
8CPT(CODE,CDT,SRC,DFN) ; returns basic info on CPT/HCPCS code
9 ;
10 ; Input: CODE CPT/HCPCS or IEN (Required)
11 ; CDT Date (default = TODAY)
12 ; SRC Screen source
13 ; If '$G(SRC), check Level I and II codes only
14 ; If $G(SRC), check Level I, II, and III codes
15 ; DFN Not in use, future need
16 ;
17 ; Output: Returns a 10 piece string delimited ^
18 ;
19 ; 1 IEN of code in ^ICPT
20 ; 2 CPT Code (.01 field)
21 ; 3 Versioned Short Name (from #61 multiple)
22 ; 4 Category IEN (#3 field)
23 ; 5 Source (#6 field) C:CPT; H:HCPCS; L:VA LOCAL
24 ; 6 Effective Date (from #60 multiple)
25 ; 7 Status (from #60 multiple)
26 ; 8 Inactivation Date (from #60 multiple)
27 ; 9 Activation Date (from #60 multiple)
28 ; 10 Message (CODE TEXT MAY BE INACCURATE)
29 ;
30 ; or
31 ;
32 ; -1^Error Description
33 ;
34 N DATA,EFF,STR,VCPT
35 I $G(CODE)="" S STR="-1^NO CODE SELECTED" G CPTQ
36 S CODE=$G(CODE),CODE=$S(CODE?1.N:+CODE,1:$$CODEN(CODE))
37 I CODE<1!'$D(^ICPT(CODE)) S STR="-1^NO SUCH ENTRY" G CPTQ
38 I '$G(SRC),$P(^ICPT(CODE,0),"^",6)="L" S STR="-1^VA LOCAL CODE SELECTED" G CPTQ
39 S DATA=$G(^ICPT(CODE,0))
40 I '$L(DATA) S STR="-1^NO DATA" G CPTQ
41 S CDT=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICPTSUPT(CDT))
42 S VCPT=$$VSTCP(CODE,CDT)
43 S STR=CODE_"^"_DATA,$P(STR,"^",5)=$P(STR,"^",7),STR=$P(STR,"^",1,5)
44 S EFF=$$EFF^ICPTSUPT(81,CODE,CDT) S:EFF<1 $P(EFF,"^",2)=0
45 S STR=STR_"^"_EFF_"^"_$$MSG^ICPTSUPT(CDT) S:$L(VCPT) $P(STR,"^",3)=VCPT
46CPTQ Q STR
47 ;
48CPTD(CODE,OUTARR,DFN,CDT) ; Returns CPT description
49 ;
50 ; Input: CODE CPT/HCPCS code or IEN (Required)
51 ; OUTARR Output Array Name for description
52 ; e.g. "ABC" or "ABC("TEST")"
53 ; Default = ^TMP("ICPTD",$J)
54 ; DFN Not in use, future need
55 ; CDT Date (default = TODAY)
56 ;
57 ; Output: # Number of lines in description
58 ;
59 ; @OUTARR(1:n) - Versioned Description (lines 1-n) (from the 62 multiple)
60 ; @OUTARR(n+1) - blank
61 ; @OUTARR(n+1) - a message stating: CODE TEXT MAY BE INACCURATE
62 ;
63 ; or
64 ;
65 ; -1^Error Description
66 ;
67 ; ** NOTE - User must initialize ^TMP("ICPTD",$J), if used **
68 ;
69 N ARR,END,I,N,CTV
70 I $G(CODE)="" S N="-1^NO CODE SELECTED" G CPTDQ
71 I $G(OUTARR)="" S OUTARR="^TMP(""ICPTD"",$J,"
72 I OUTARR'["(" S OUTARR=OUTARR_"("
73 I OUTARR[")" S OUTARR=$P(OUTARR,")")
74 S END=$E(OUTARR,$L(OUTARR)) I END'="("&(END'=",") S OUTARR=OUTARR_","
75 I OUTARR="^TMP(""ICPTD"",$J," K ^TMP("ICPTD",$J)
76 S CODE=$S(CODE?1.N:+CODE,1:$$CODEN(CODE)),I=0,N=0
77 I CODE<1!'$D(^ICPT(CODE)) S N="-1^NO SUCH CODE" G CPTDQ
78 S CDT=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICPTSUPT(CDT))
79 D VLTCP(+CODE,CDT,.CTV) S (N,I)=0 F S I=$O(CTV(I)) Q:+I=0 D
80 . S N=N+1,ARR=OUTARR_N_")",@ARR=$$TRIM($G(CTV(I)))
81 I +N>0 S N=N+1,ARR=OUTARR_N_")",@ARR=" ",N=N+1,ARR=OUTARR_N_")",@ARR=$$MSG^ICPTSUPT(CDT,1)
82 I +N'>0 S N="-1^VERSIONED DESCRIPTION NOT FOUND FOR MODIFIER "_$P($G(^DIC(81.3,+CODE,0)),"^",1)
83CPTDQ Q N
84 ;
85CODM(CODE,OUTARR,SRC,CDT,DFN) ; returns list of modifiers for a code
86 ;
87 ; Input: CODE CPT/HCPCS code, Internal or External Format (Required)
88 ; ARY Array Name for list returned
89 ; e.g. "ABC" or "ABC("TEST")"
90 ; Default = ^TMP("ICPTM",$J)
91 ; SRC Source Screen
92 ; If 0 or Null, check Level I/II code/modifiers
93 ; If >0, check Level I/II/III code/modifiers
94 ; CDT Date (default = TODAY)
95 ; DFN Not in use, future need
96 ;
97 ; Output: # Number of modifiers that apply
98 ;
99 ; OUTARR Array in the format:
100 ;
101 ; ARY(Mod) = Versioned Name^Mod IEN
102 ;
103 ; Where
104 ; Mod is the .01 field)
105 ; Versioned Name is 1 field of the 61 multiple
106 ;
107 ; or
108 ;
109 ; -1^Error Description
110 ;
111 ; ** NOTE - User must initialize ^TMP("ICPTM",$J) array if used **
112 ;
113 N ARR,CODI,CODA,BR,END,ER,MD,MDST,MI,MN,STR,CODEC,ACTMD,MVST
114 S CDT=$G(CDT)
115 I $G(CODE)="" S STR="-1^NO CPT SELECTED" G CODMQ
116 I $G(OUTARR)="" S OUTARR="^TMP(""ICPTM"",$J,"
117 S STR=0,CODI=$S(CODE?1.N:+CODE,1:$$CODEN(CODE))
118 I CODI<1!'$D(^ICPT(CODI,0)) S STR="-1^NO SUCH CODE" G CODMQ
119 I '$G(SRC),$P(^ICPT(CODI,0),"^",6)="L" S STR="-1^VA LOCAL CODE SELECTED" G CODMQ
120 S CODEC=$$CODEC(CODI),CODA=$$NUM^ICPTAPIU(CODEC)
121 I OUTARR'["(" S OUTARR=OUTARR_"("
122 I OUTARR[")" S OUTARR=$P(OUTARR,")")
123 S END=$E(OUTARR,$L(OUTARR)) I END'="("&(END'=",") S OUTARR=OUTARR_","
124 I OUTARR="^TMP(""ICPTM"",$J," K ^TMP("ICPTM",$J)
125 S:$G(CDT)]"" CDT=$$DTBR^ICPTSUPT(CDT)
126 S BR="" F S BR=$O(^DIC(81.3,"M",BR)) Q:BR>CODA!'BR D
127 .S ER="" F S ER=$O(^DIC(81.3,"M",BR,ER)) Q:'ER I CODA'>ER D
128 ..S MI=0 F S MI=$O(^DIC(81.3,"M",BR,ER,MI)) Q:'MI D
129 ...S MDST=$G(^DIC(81.3,MI,0)) Q:'$L(MDST)
130 ...I '$G(SRC) Q:$P(MDST,"^",4)="V"
131 ...I $G(CDT) S ACTMD="",ACTMD=$$MOD^ICPTMOD(MI,"I",CDT,$G(SRC)) Q:($P(ACTMD,"^")=-1)!($P(ACTMD,"^",7)=0)
132 ...S MD=$P(MDST,"^",1,2),MN=$P(MD,"^")
133 ...I $L(MN)'=2 Q
134 ...S MVST=$$VSTCM^ICPTMOD(MI,CDT)
135 ...S ARR=OUTARR_""""_MN_""")",@ARR=MVST_"^"_MI,STR=STR+1
136 I 'STR S STR=0
137CODMQ Q STR
138 ;
139CODEN(CODE) ; Rreturn the IEN of a CPT/HCPCS code
140 ;
141 ; Input: CPT/HCPCS code
142 ; Output: ien of code
143 ;
144 I $G(CODE)="" Q -1
145 N COD
146 S COD=+$O(^ICPT("B",CODE,0))
147 Q $S(COD>0:COD,1:-1)
148 ;
149CODEC(CODE) ; Return the CPT/HCPCS Code
150 ;
151 ; Input: IEN of CPT/HCPCS code
152 ; Output: CPT/HCPCS code
153 ;
154 I $G(CODE)="" Q -1
155 N Y
156 S Y=$P($G(^ICPT(CODE,0)),"^")
157 Q $S(Y="":-1,1:Y)
158 ;
159VALCPT(CODE,CDT,SRC,DFN) ;check if CPT code is valid for selection
160 ;
161 ; Input:
162 ;
163 ; CODE - CPT or HCPCS code, ien or .01 format, REQUIRED
164 ; CTD - Date, default = today
165 ; SRC - SCREEN SOURCE
166 ; '$G(SRC) level 1, Level 2 only
167 ; $G(SRC) include level 3
168 ; DFN - not in use, future need
169 ;
170 ; Output: STR: 1 if valid code for selection
171 ; -1^error message if not selectable
172 ;
173 N STR
174 S CODE=$G(CODE),SRC=$G(SRC),DFN=$G(DFN)
175 S CDT=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICPTSUPT(CDT)) ;date business rules
176 S STR=$$CPT(CODE,CDT,SRC,DFN)
177 I STR<0 G VALCPTQ
178 I '$P(STR,"^",7) S STR="-1^INACTIVE CODE"
179 I STR>0 S STR=1
180VALCPTQ Q STR
181 ;
182 ;
183 Q
184VST(IEN,VDATE,TYPE) ; Versioned Short Text
185 Q:TYPE["ICPT(" $$VSTCP($G(IEN),$G(VDATE))
186 Q:TYPE["DIC(81.3" $$VSTCM^ICPTMOD($G(IEN),$G(VDATE))
187 Q ""
188VSTCP(IEN,VDATE) ; Versioned Short Text (CPT Procedure)
189 N CPT0,CPTC,CPTI,CPTSTD,CPTSTI,CPTVDT,CPTTXT
190 S CPTI=+($G(IEN)) Q:+CPTI'>0 "" Q:'$D(^ICPT(+CPTI)) ""
191 S CPTVDT=$G(VDATE) S:'$L(CPTVDT)!(+CPTVDT'>0) CPTVDT=$$DT^XLFDT Q:CPTVDT\1'?7N ""
192 S CPT0=$G(^ICPT(+CPTI,0)),CPTC=$P(CPT0,"^",1) Q:'$L(CPTC) ""
193 S CPTSTD=$O(^ICPT("AST",(CPTC_" "),(CPTVDT+.000001)),-1)
194 I +CPTSTD>0 D Q:$L($G(CPTTXT)) $G(CPTTXT)
195 . S CPTSTI=$O(^ICPT("AST",(CPTC_" "),CPTSTD,+CPTI," "),-1),CPTTXT=$$TRIM($P($G(^ICPT(+CPTI,61,+CPTSTI,0)),"^",2))
196 S CPTSTD=$O(^ICPT(+CPTI,61,"B",0)) I +CPTSTD>0 D Q:$L($G(CPTTXT)) $G(CPTTXT)
197 . S CPTSTI=$O(^ICPT(+CPTI,61,"B",CPTSTD,0)),CPTTXT=$$TRIM($P($G(^ICPT(+CPTI,61,+CPTSTI,0)),"^",2))
198 Q $$TRIM($P(CPT0,"^",2))
199VLTCP(IEN,VDATE,ARY) ; Versioned Description - Long Text (CPT Procedure)
200 N CPT0,CPTC,CPTI,CPTSTD,CPTSTI,CPTVDT,CPTTXT,CPTD,CPTT,CPTE
201 S CPTI=+($G(IEN)) Q:+CPTI'>0 Q:'$D(^ICPT(+CPTI))
202 S CPTVDT=$G(VDATE) S:'$L(CPTVDT)!(+CPTVDT'>0) CPTVDT=$$DT^XLFDT Q:CPTVDT\1'?7N
203 S CPT0=$G(^ICPT(+CPTI,0)),CPTC=$P(CPT0,"^",1) Q:'$L(CPTC)
204 S CPTSTD=$O(^ICPT("ADS",(CPTC_" "),(CPTVDT+.000001)),-1)
205 I +CPTSTD>0 D Q:+($O(ARY(0)))>0
206 . S CPTSTI=$O(^ICPT("ADS",(CPTC_" "),CPTSTD,+CPTI," "),-1)
207 . S (CPTD,CPTT)=0 F S CPTD=$O(^ICPT(+CPTI,62,CPTSTI,1,CPTD)) Q:+CPTD=0 D
208 . . S CPTT=CPTT+1,ARY(CPTT)=$$TRIM($G(^ICPT(+CPTI,62,+CPTSTI,1,+CPTD,0))),ARY(0)=CPTT
209 S CPTSTD=$O(^ICPT(+CPTI,62,"B",0)) I +CPTSTD>0 D Q:+($O(ARY(0)))>0
210 . S CPTSTI=$O(^ICPT(+CPTI,62,"B",CPTSTD,0))
211 . S (CPTD,CPTT)=0 F S CPTD=$O(^ICPT(+CPTI,62,CPTSTI,1,CPTD)) Q:+CPTD=0 D
212 . . S CPTT=CPTT+1,ARY(CPTT)=$$TRIM($G(^ICPT(+CPTI,62,+CPTSTI,1,+CPTD,0))),ARY(0)=CPTT
213 K ARY S (CPTD,CPTT)=0 F S CPTD=$O(^ICPT(CPTI,"D",CPTD)) Q:+CPTD=0 D
214 . S CPTT=CPTT+1,ARY(CPTT)=$$TRIM($G(^ICPT(CPTI,"D",CPTD,0))),ARY(0)=CPTT
215 Q
216TRIM(X) ; Trim Spaces
217 S X=$G(X) Q:X="" X F Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
218 F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
219 F Q:X'[" " S X=$P(X," ",1)_" "_$P(X," ",2,229)
220 Q X
Note: See TracBrowser for help on using the repository browser.