source: FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTAPIU.m@ 677

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

initial load of FOIAVistA 6/30/08 version
File size: 8.5 KB
Line 
1ICPTAPIU ;ALB/DEK/KER - CPT UTILITIES FOR APIS ; 04/18/2004
2 ;;6.0;CPT/HCPCS;**1,6,12,14,16,19,22**;May 19, 1997
3 ;
4 ; External References
5 ; DBIA 10011 ^DIWP
6 ; DBIA 10029 ^DIWW
7 ; DBIA 10103 $$DT^XLFDT
8 ;
9CPTDIST() ; Distribution Date
10 ; Input: none (extrinsic variable)
11 ; Output: returns DISTRIBUTION DATE, date codes effective in Austin
12 Q $P($G(^DIC(81.2,1,0)),"^",2)
13 ;
14CAT(CAT,DFN) ; Return CATEGORY NAME given IEN
15 ; Input: CAT = category ien REQUIRED
16 ; DFN - not in use but included in anticipation of future need
17 ;
18 ; Output: STR = CATEGORY NAME^SOURCE (C or H)^MAJOR CATEGORY IEN^MAJOR CATEGORY NAME
19 ; STR = -1^error message, if error condition occurred
20 ;
21 N CATN,STR,MCATIEN,MCATNM
22 S (MCATIEN,MCATNM)=""
23 I $G(CAT)="" S STR="-1^NO CATEGORY SELECTED" G CATQ
24 I '$G(CAT) S STR="-1^INVALID CATEGORY FORMAT" G CATQ
25 S STR=$G(^DIC(81.1,+CAT,0))
26 I '$L(STR) S STR="-1^NO SUCH CATEGORY" G CATQ
27 I $P(STR,"^",2)="" S STR="-1^TYPE OF CATEGORY UNSPECIFIED" G CATQ
28 S CATN=$P(STR,"^")
29 I $P(STR,"^",2)="m" S MCATNM=CATN,MCATIEN=+CAT
30 I $P(STR,"^",2)="s" D
31 . S MCATIEN=$P(STR,"^",3)
32 . I MCATIEN S MCATNM=$P($G(^DIC(81.1,MCATIEN,0)),"^")
33 S STR=CATN_"^"_$P(STR,"^",6)_"^"_MCATIEN_"^"_MCATNM
34CATQ Q STR
35 ;
36NUM(Y) ; Convert CPT/HCPCS Code to Numeric
37 ; Convert HCPCS to $A() of Alpha _ Numeric Portion
38 ;
39 ; Input: Y - CPT or HCPCS code
40 ;
41 ; Output: 'plussed' value for CPT code,
42 ; numeric for HCPCS based on $A of 1st character (alpha)
43 ; concatenated with the 4-digit portion of code
44 ;
45 ; **This does not convert to ien**
46 ; This converts to a numeric that may be used for range sorting
47 ;
48 ;Q $S(Y:+Y,1:$A(Y)_$E(Y,2,5))
49 ; modified in 2002 to handle few CPT codes that end with "T"
50 ; needed to add multiplier to create higher and unique number
51 ; e.g. "Z9999"=909999 and "0001T"=8400001
52 Q $S(Y?1.N:+Y,Y?4N1A:$A($E(Y,5))*10_$E(Y,1,4),1:$A(Y)_$E(Y,2,5))
53 ;
54COPY ; API to Print Copyright Information
55 ;
56 N DIR,DIWL,DIWR,DIWF,VARR,VAXX,X
57 Q:'$D(^DIC(81.2,1)) K ^UTILITY($J,"W")
58 W !!! S DIWL=1,DIWR=80,DIWF="W"
59 F VARR=0:0 S VARR=$O(^DIC(81.2,1,1,VARR)) Q:VARR'>0 S VAXX=^(VARR,0),X=VAXX D ^DIWP
60 D:$D(VAXX) ^DIWW
61 Q
62 ;
63STATCHK(CODE,CDT) ; Check Status of CPT Code or Modifier
64 ; Input:
65 ; CODE - CPT Code/Modifier REQUIRED
66 ; CDT - Date to screen against (FileMan format, default = today)
67 ;
68 ; Output:
69 ; 2-Piece String containing the status of the code/modifier
70 ; and the IEN if the code/modifier exists, else -1.
71 ; The following are possible outputs:
72 ; 1 ^ IEN Active Code/Modifier
73 ; 0 ^ IEN Inactive Code/Modifier
74 ; 0 ^ -1 Code/Modifier not Found
75 ;
76 ; This API requires the ACT Cross-Reference
77 ; ^ICPT("ACT",<code>,<status>,<date>,<ien>)
78 ; ^DIC(81.3,"ACT",<code>,<status>,<date>,<ien>)
79 ;
80 N ICPTC,ICPTD,ICPTIEN,ICPTA,ICPTI,X,ICPTG,ICPTR,ICPTD
81 S ICPTC=$G(CODE) Q:'$L(ICPTC) "0^-1"
82 ; Case 1: Not Valid 0^-1
83 ; Fails Pattern Match for Code
84 S ICPTG=$$GBL^ICPTSUPT(ICPTC) Q:ICPTG="" "0^-1"
85 ; Case 2: Never Active 0^IEN
86 ; No In/Active Date
87 S ICPTD=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICPTSUPT($G(CDT))),ICPTD=ICPTD+.001
88 S ICPTR=$$ACT(ICPTG,ICPTC,1,ICPTD),ICPTA=$O(@(ICPTR_")"),-1)
89 I '$L(ICPTA) D Q X
90 . S ICPTA=$O(@(ICPTR_")")),X="0^-1" Q:'$L(ICPTA)
91 . S ICPTR=$$ACT(ICPTG,ICPTC,1,ICPTA)
92 . S ICPTIEN=$O(@(ICPTR_",0)")) S:+ICPTIEN<1 ICPTIEN=-1
93 . S X="0^"_ICPTIEN
94 ; Case 3: Active, Never Inactive 1^IEN
95 ; Has an Activation Date
96 ; No Inactivation Date
97 S ICPTR=$$ACT(ICPTG,ICPTC,0,ICPTD),ICPTI=$O(@(ICPTR_")"),-1)
98 I $L(ICPTA),'$L(ICPTI) D Q X
99 . S ICPTR=$$ACT(ICPTG,ICPTC,1,ICPTA),ICPTIEN=$O(@(ICPTR_",0)"))
100 . S X=$S(+ICPTIEN=0:"0^-1",1:"1^"_ICPTIEN)
101 ; Case 4: Active, but later Inactivated 0^IEN
102 ; Has an In/Activation Date
103 I $L(ICPTA),$L(ICPTI),ICPTI>ICPTA,ICPTI<ICPTD D Q X
104 . S ICPTR=$$ACT(ICPTG,ICPTC,0,ICPTI),ICPTIEN=$O(@(ICPTR_",0)"))
105 . S X=$S(+ICPTIEN=0:"0^-1",1:"0^"_ICPTIEN)
106 ; Case 5: Active, and not later Inactivated 1^IEN
107 ; Has an In/Activation Date
108 ; Has a Newer Activation Date
109 I $L(ICPTA),$L(ICPTI),ICPTI'>ICPTA D Q X
110 . S ICPTR=$$ACT(ICPTG,ICPTC,0,ICPTI),ICPTIEN=$O(@(ICPTR_",1)"))
111 . S X=$S(+$O(@(ICPTR_",0)"))=0:"0^-1",1:"1^"_ICPTIEN)
112 ; Case 6: Fails Time Test 0^-1
113 Q ("0^"_$S(+($G(ICPTIEN))>0:+($G(ICPTIEN)),1:"-1"))
114 ;
115NEXT(CODE) ; Next CPT Code or Modifier (active or inactive)
116 ; Input:
117 ; CODE = CPT Code/Modifier REQUIRED
118 ;
119 ; Output:
120 ; The Next CPT Code/Modifier, Null if none
121 ;
122 N ICPTC,ICPTG
123 S ICPTC=$G(CODE) Q:'$L(ICPTC) ""
124 S ICPTG=$$GBL^ICPTSUPT(ICPTC) Q:'$L(ICPTG) ""
125 S ICPTC=$O(@(ICPTG_"""BA"","""_ICPTC_" "")"))
126 Q $S(ICPTC="":"",1:$E(ICPTC,1,$L(ICPTC)-1))
127 ;
128PREV(CODE) ; Previous CPT Code or Modifier (active or inactive)
129 ; Input:
130 ; CODE = CPT Code/Modifier REQUIRED
131 ;
132 ; Output:
133 ; The Previous CPT Code/Modifier, Null if none
134 ;
135 N ICPTC,ICPTG
136 S ICPTC=$G(CODE) Q:'$L(ICPTC) ""
137 S ICPTG=$$GBL^ICPTSUPT(ICPTC) Q:'$L(ICPTG) ""
138 S ICPTC=$O(@(ICPTG_"""BA"","""_ICPTC_" "")"),-1)
139 Q $S(ICPTC="":"",1:$E(ICPTC,1,$L(ICPTC)-1))
140 ;
141HIST(CODE,ARY) ; Activation History
142 ; Input:
143 ; CODE - CPT Code or Modifier REQUIRED
144 ; .ARY - Array, passed by Reference REQUIRED
145 ;
146 ; Output: Mirrors ARY(0) (or, -1 on error)
147 ; ARY(0) = Number of Activation History Entries
148 ; ARY(<date>) = status where: 1 is Active
149 ; ARY("IEN") = <ien>
150 ;
151 Q:$G(CODE)="" -1
152 N ICPTC,ICPTI,ICPTN,ICPTD,ICPTG,ICPTF,ICPTO
153 S ICPTG=$$GBL^ICPTSUPT(CODE) Q:'$L(ICPTG) -1
154 S ICPTI=$O(@(ICPTG_"""BA"","""_CODE_" "",0)")) Q:'$L(ICPTI) -1
155 S ARY("IEN")=ICPTI,ICPTO="" M ICPTO=@(ICPTG_ICPTI_",60)")
156 K ICPT0("B") S ARY(0)=+($P($G(ICPTO(0)),"^",4))
157 S:+ARY(0)=0 ARY(0)=-1 K:ARY(0)=-1 ARY("IEN")
158 S (ICPTI,ICPTC)=0 F S ICPTI=$O(ICPTO(ICPTI)) Q:+ICPTI=0 D
159 . S ICPTD=$P($G(ICPTO(ICPTI,0)),"^",1) Q:+ICPTD=0
160 . S ICPTF=$P($G(ICPTO(ICPTI,0)),"^",2) Q:'$L(ICPTF)
161 . S ICPTC=ICPTC+1,ARY(0)=ICPTC,ARY(ICPTD)=ICPTF
162 Q ARY(0)
163 ;
164PERIOD(CODE,ARY) ; return Activation/Inactivation Period in ARY
165 ;
166 ; Output: ARY(0) = String: IEN^Selectable
167 ;
168 ; Where the pieces are:
169 ;
170 ; 1 Internal Entry Number of code in ^ICPT or ^DIC(81.3,
171 ; 2 0:unselectable; 1:selectable
172 ;
173 ; ARY(Activation Date) = Inactivation Date^Short Name
174 ; Where the Short Name is the Versioned text (field 1 of the 61
175 ; multiple), and the text is versioned as follows:
176 ;
177 ; Period is active - Versioned text for TODAY's date
178 ; Period is inactive - Versioned text for inactivation date
179 ;
180 ; or
181 ;
182 ; -1^0 (no period or error)
183 ;
184 I $G(CODE)="" S ARY(0)="-1^0" Q
185 N ICPTC,ICPTI,ICPTA,ICPTG,ICPTF,ICPTBA,ICPTBI,ICPTST,ICPTS,ICPTZ,ICPTV,ICPTN,ICPTCA
186 S ICPTG=$$GBL^ICPTSUPT(CODE) I ICPTG="" S ARY(0)="-1^0" Q
187 S ICPTC=$O(@(ICPTG_"""BA"","""_CODE_" "",0)")) I ICPTC="" S ARY(0)="-1^0" Q
188 S (ARY(0),ICPTC)=+ICPTC,ICPTZ=$G(@(ICPTG_ICPTC_",0)")),ICPTS=$P(ICPTZ,"^",2)
189 S $P(ARY(0),"^",2)=$S(ICPTG="^ICPT(":$P(ICPTZ,"^",6)'="L",1:$P(ICPTZ,"^",4)'="V")
190 S (ICPTA,ICPTBA)=0,ICPTG=ICPTG_ICPTC_",60,"
191 ; Versioned text for TODAY
192 S ICPTN=$$VST^ICPTCOD(ICPTC,$$DT^XLFDT,ICPTG)
193 F Q:ICPTBA D
194 . S ICPTA=$O(@(ICPTG_"""B"","_ICPTA_")"))
195 . I ICPTA="" S ICPTBA=1 Q
196 . S ICPTF=$O(@(ICPTG_"""B"","_ICPTA_",0)"))
197 . I '+ICPTF S ICPTBA=1 Q
198 . S ICPTST=$P($G(@(ICPTG_ICPTF_",0)")),"^",2)
199 . Q:'ICPTST ;outer loop looks for active
200 . ; Versioned text for activation date
201 . S ICPTV=$$VST^ICPTCOD(ICPTC,ICPTA,ICPTG),ICPTCA=1
202 . S ARY(ICPTA)="^"_ICPTS,ICPTBI=0,ICPTI=ICPTA
203 . S:$L(ICPTV) $P(ARY(ICPTA),"^",2)=ICPTV
204 . F Q:ICPTBI D
205 . . S ICPTI=$O(@(ICPTG_"""B"","_ICPTI_")"))
206 . . ; If no inactivation date for ICPTA then use TODAY's text
207 . . I ICPTI="" S ARY(ICPTA)="^"_ICPTN,(ICPTBI,ICPTBA)=1 Q
208 . . S ICPTF=$O(@(ICPTG_"""B"","_ICPTI_",0)"))
209 . . ; If no effective date ICPTF for ICPTI then use TODAY's text
210 . . I '+ICPTF S ARY(ICPTA)="^"_ICPTN,(ICPTBI,ICPTBA)=1 Q
211 . . S ICPTST=$P($G(@(ICPTG_ICPTF_",0)")),"^",2)
212 . . ; If Status ICPTST not Inactive then use TODAY's text
213 . . I ICPTST S ARY(ICPTA)="^"_ICPTN,ICPTBI=1 Q
214 . . ; Versioned text for inactive date
215 . . S ICPTV=$$VST^ICPTCOD(ICPTC,ICPTI,ICPTG)
216 . . S $P(ARY(ICPTA),"^")=ICPTI
217 . . S:$L(ICPTV) $P(ARY(ICPTA),"^",2)=ICPTV
218 . . S ICPTCA=0,ICPTBI=1,ICPTA=ICPTI
219 Q
220 ;
221ACT(ICPTG,ICPTC,ICPTS,ICPTD) ; return "ACT" root
222 Q ICPTG_"""ACT"","""_ICPTC_" "","_ICPTS_","_ICPTD
Note: See TracBrowser for help on using the repository browser.