source: FOIAVistA/tag/r/ONCOLOGY-ONC/ONCACDU2.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.4 KB
Line 
1ONCACDU2 ;Hines OIFO/GWB - UTILITY ROUTINE #1 ;09/20/2000
2 ;;2.11;Oncology;**12,18,20,21,22,24,26,27,29,30,31,32,34,36,37,38,39,41,46,47**;Mar 07, 1995;Build 19
3 ;
4HOSP1(PROC,IEN) ;Check to see if the site is breast or prostate
5 ;Inputs: PROC = Process Number to be processed
6 ; IEN = Record within File 160.16
7 ;Output; X data for field.
8 ;
9 N PTR,X,SITE
10 S X=0
11 S SITE=$$GET1^DIQ(165.5,IEN,.01,"I")
12 S SITE=$$GET1^DIQ(164.2,SITE,.01,"I")
13 I SITE="BREAST" D
14 .I PROC=1 S PTR=$$GET1^DIQ(165.5,IEN,141,"I") S:PTR'="" X=$P($G(^ONCO(164,67500,"BP5",PTR,0)),U,2) Q
15 .I PROC=2 S PTR=$$GET1^DIQ(165.5,IEN,142,"I") S:PTR'="" X=$P($G(^ONCO(164,67500,"GU5",PTR,0)),U,2) Q
16 .I PROC=3 S X=$$GET1^DIQ(165.5,IEN,143,"I") Q
17 .I PROC=4 S X=$$GET1^DIQ(165.5,IEN,144,"I")
18 ;
19 I SITE="PROSTATE" D
20 .I PROC=1 S PTR=$$GET1^DIQ(165.5,IEN,141,"I") S:PTR'="" X=$P($G(^ONCO(164,67619,"BP5",PTR,0)),U,2) Q
21 .I PROC=2 S PTR=$$GET1^DIQ(165.5,IEN,142,"I") S:PTR'="" X=$P($G(^ONCO(164,67619,"GU5",PTR,0)),U,2) Q
22 .I PROC=3 S X=$$GET1^DIQ(165.5,IEN,145,"I") Q
23 .I PROC=4 S X=$$GET1^DIQ(165.5,IEN,146,"I")
24 Q X
25 ;
26VAFLD(ACDANS) ;Convert data to valid external format
27 ;Input: ACDANS
28 ; Y=1
29 ; N=0
30 ; U=9
31 I ACDANS="N" S ACDANS=0
32 I ACDANS="Y" S ACDANS=1
33 I ACDANS="U" S ACDANS=9
34 Q ACDANS
35 ;
36VASIT() ;VISN 1452-1453
37 ;Output: X = VISN
38 N X
39 S OSPIEN=$O(^ONCO(160.1,0))
40 S X=$P($G(^ONCO(160.1,OSPIEN,1)),U,7)
41 K OSPIEN
42 Q X
43 ;
44COCO(IEN) ;COC Coding Sys--Original [2150] 1202-1203
45 N X
46 S DATEDX=$$GET1^DIQ(165.5,IEN,3,"I")
47 S X=$S(DATEDX>3021231:"08",DATEDX>2951231:"07",1:"05")
48 Q X
49 ;
50VENDOR() ;Vendor Name [2170] 1204-1213
51 N X,VERSION,EXTR,SUFFIX
52 S EXTR=$G(^ONCO(160.16,EXTRACT,0))
53 S SUFFIX=$S(EXTR["VACCR":"A",EXTR["STATE":"B",1:"")
54 S VERSION=$P($G(^ONCO(160.16,EXTRACT,0))," ",3)
55 S X="VA"_VERSION_$E($T(LOGO+3^ONCODIS),62,64)_SUFFIX
56 Q X
57 ;
58BDATE(ACD160) ;Birth Date [240] 122-129
59 N D0,X
60 S D0=ACD160
61 D DOB^ONCOES
62 S X=$G(X)
63 Q X
64 ;
65WORD(IEN,NODE,LEN) ;Get word processing data
66 N X
67 S X=""
68 I $D(^ONCO(165.5,IEN,NODE,0)) D
69 .N CNT,LINE
70 .S CNT=0
71 .S LINE=""
72 .F S CNT=$O(^ONCO(165.5,IEN,NODE,CNT)) Q:CNT<1 D Q:($L(LINE)>LEN)
73 ..Q:'$D(^ONCO(165.5,IEN,NODE,CNT,0))
74 ..S LINE=LINE_^ONCO(165.5,IEN,NODE,CNT,0)_" "
75 .S X=LINE
76 Q X
77 ;
78STAGE(IEN,TYPE) ;TNM Descriptors
79 ;TNM Path Descriptor [910] 571-571
80 ;TNM Clin Descriptor [980] 581-581
81 N LOC,X
82 S X=""
83 S LOC=$S(TYPE="P":89.1,TYPE="C":37,1:"")
84 I TYPE'="" D
85 .N STRING
86 .S STRING=$$GET1^DIQ(165.5,IEN,LOC,"E")
87 .I ($P(STRING," ")["m")&($P(STRING," ")["y") S X=6 Q
88 .I $P(STRING," ")["m" S X=3 Q
89 .I $P(STRING," ")["y" S X=4 Q
90 Q X
91 ;
92CCOUNTY(ACD160) ;County--Current
93 N ZIP,X
94 S X=""
95 S ZIP=$$GET1^DIQ(160,ACD160,.116,"E")
96 I ZIP'="" D
97 .N ZIP1,CODE,COUNTY
98 .S ZIP1=$P($P(ZIP,",",2)," ",3) S:$L(ZIP1)>5 ZIP1=$E(ZIP1,1,5)
99 .Q:$L(ZIP1)<5
100 .S CODE=$O(^VIC(5.11,"C",ZIP1,""))
101 .Q:CODE<1
102 .S COUNTY=$$GET1^DIQ(5.11,CODE,2,"I")
103 .Q:COUNTY=""
104 .S X=$$GET1^DIQ(5.1,COUNTY,2,"I")
105 Q X
106 ;
107SUB(IEN,CNT,FIELD) ;
108 ;Subsq RX 2nd Course Date [1660] 988-995
109 N X
110 S CNT=CNT-1
111 S X=""
112 I $O(^ONCO(165.5,IEN,4,0)) D
113 .N IENS,SUB,SUBFLD,ENTRY,SUBIEN
114 .S SUBIEN=0 F I=1:1 S SUBIEN=$O(^ONCO(165.5,IEN,4,SUBIEN)) Q:(I=CNT)!(SUBIEN'>0)
115 .I SUBIEN="" S X="" Q
116 .S IENS=SUBIEN_","_IEN
117 .S ENTRY=$$GET1^DIQ(165.51,IENS,FIELD,"I") I ENTRY="",FIELD'=".07",FIELD'=".08" S X="" Q
118 .S HEMA=""
119 .S HEMAPT=$$GET1^DIQ(165.51,IENS,.02,"I")
120 .S:HEMAPT'="" HEMA=$P($G(^ONCO(167,HEMAPT,0)),U,1)
121 .I $S(FIELD=".01":1,FIELD=".05":1,FIELD=".06":1,FIELD=".07":1,FIELD=".08":1,FIELD=".09":1,FIELD="37":1,1:0) D Q
122 ..I FIELD=".06" S X=$S(ENTRY="01":1,ENTRY="02":2,ENTRY="03":3,$E(ENTRY,1)=8:0,1:ENTRY) Q
123 ..I FIELD=".07" S X=$S(ENTRY="00":0,ENTRY="01":1,$E(ENTRY,1)=8:0,ENTRY=99:9,1:"") Q:X'="" S X=$S(HEMA=30:2,HEMA=40:2,1:"") Q
124 ..I FIELD=".08" S X=$S(ENTRY="01":1,ENTRY=87:7,ENTRY=88:8,$E(ENTRY,1)=8:0,ENTRY=99:9,1:ENTRY) Q:X'="" S X=$S(HEMA=10:4,HEMA=11:2,HEMA=12:3,HEMA=20:5,1:"") Q
125 ..S X=ENTRY
126 .I $$GET1^DIQ(165.5,IEN,3,"I")<2980000 S X=ENTRY Q
127 .S SUBFLD=$S(FIELD=33:"RR5",FIELD=35:"SC5",FIELD=36:"SO5",FIELD=.04:"SPS",1:"") I SUBFLD="" S X="" Q
128 .S X=$$SUB164^ONCACDU2(IEN,SUBFLD,ENTRY)
129 I FIELD=.04,$L(X)=1 S X="0"_X
130 Q X
131 ;
132SUB164(IEN,SUBFLD,ENTRY) ;ICDO TOPOGRAPHY (164)
133 N X,TOP1,TOP2
134 S X=""
135 S TOP1=$$GET1^DIQ(165.5,IEN,20,"I") D:TOP1'=""
136 .S TOP2=$$GET1^DIQ(164,TOP1,107,"I")
137 .I (TOP1=67420)!(TOP1=67421)!(TOP1=67423)!(TOP1=67424)!($E(TOP1,3,4)=76)!(TOP1=67809),($G(FIELD)=58.6)!($G(FIELD)=58.7) S TOP2=67420
138 .I ($G(FIELD)=58.2)!($G(FIELD)=50.2)!($G(FIELD)=138)!($G(FIELD)=138.1)!($G(FIELD)=139)!($G(FIELD)=139.1)!($G(FIELD)=74)!($G(FIELD)=23),($E(TOP1,3,4)=76)!(TOP1=67809)!(TOP1=67420)!(TOP1=67421)!(TOP1=67423)!(TOP1=67424) S TOP2=67141
139 .I ($G(FIELD)=58.2)!($G(FIELD)=50.2),TOP1=67422 S TOP2=67770
140 .I $G(SUBFLD)="SUA",($E(TOP1,3,4)=77) S TOP2=67141
141 .D:TOP2'=""
142 ..S X=$P($G(^ONCO(164,TOP2,SUBFLD,ENTRY,0)),U,2)
143 Q X
144 ;
145RXPRI(IEN,FIELD,SUBFLD) ;
146 ;RX Hosp--Surg Prim Site [670] 457-458
147 ;RX Hosp--Surg Site 98-02 [746] 478-479
148 ;RX Hosp--Scope Reg 98-02 [747] 480-480
149 ;RX Hosp--Surg Oth 98-02 [748] 481-481
150 ;RX Summ--Surg Prim Site [1290] 859-860
151 ;RX Summ--Surgical Approch [1310] 865-865
152 ;RX Summ--Reconstruct 1st [1330] 867-867
153 ;RX Summ--Surg Site 98-02 [1646] 939-940
154 ;RX Summ--Scope Reg 98-02 [1647] 941-941
155 ;RX Summ--Surg Oth 98-02 [1648] 942-942
156 N X,ENTRY
157 S X=""
158 S TOP1=$$GET1^DIQ(165.5,IEN,20,"I")
159 S ENTRY=$$GET1^DIQ(165.5,IEN,FIELD,"I") D:ENTRY'=""
160 .I (TOP1=67420)!(TOP1=67421)!(TOP1=67423)!(TOP1=67424)!($E(TOP1,3,4)=76)!(TOP1=67809),($G(FIELD)=58.6)!($G(FIELD)=58.7) S X=$$SUB164^ONCACDU2(IEN,SUBFLD,ENTRY) Q
161 .I $$GET1^DIQ(165.5,IEN,3,"I")<2980000,(FIELD=23)!(FIELD=74)!(FIELD=50.2)!(FIELD=58.2)!(FIELD=58.6)!(FIELD=58.7) S X=$S(FIELD=23:$$GET1^DIQ(160.4,ENTRY,.01,"I"),FIELD=74:$$GET1^DIQ(160.6,ENTRY,.01,"I"),1:ENTRY) Q
162 .S X=$$SUB164^ONCACDU2(IEN,SUBFLD,ENTRY)
163 Q X
164 ;
165LAST(ACD160) ;Get last DATE OF LAST CONTACT OR DEATH (160.04,.01)
166 S X="",DLC=0
167 S DLC=$O(^ONCO(160,ACD160,"F","AA",DLC))
168 S:DLC'="" X=$O(^ONCO(160,ACD160,"F","AA",DLC,0))
169 I X'>0 S X=""
170 Q X
171 ;
172FNODE(ACD160,FIELD) ;
173 ;Date of Last Contact [1750] 1294-1301
174 ;Vital Status [1760] 1302-1302
175 ;Quality of Survival [1780] 1304-1304
176 ;Follow-Up Source [1790] 1305-1305
177 ;Next Follow-Up Source [1800] 1306-1306
178 ;Unusual Follow-Up Method [1850] 1341-1341
179 ;Following Registry [2440] 2475-2484
180 N FNODE,X
181 S FNODE=$$LAST(ACD160),X=""
182 I FNODE'="" D
183 .N IENS
184 .S IENS=FNODE_","_ACD160_","
185 .S X=$$GET1^DIQ(160.04,IENS,FIELD,"I")
186 Q X
187 ;
188CS(IEN) ;Cancer Status [1770] 1303-1303
189 N X,Z,FNODE
190 S FNODE=0
191 S X=""
192 S FNODE=$O(^ONCO(165.5,IEN,"TS",FNODE))
193 I FNODE>0 D
194 .N IENS,PT
195 .S FNODE=$O(^ONCO(165.5,IEN,"TS"," "),-1)
196 .Q:FNODE<1
197 .S IENS=FNODE_","_IEN_","
198 .S PT=$$GET1^DIQ(165.573,IENS,.02,"I")
199 .Q:PT<1
200 .S X=$$GET1^DIQ(164.42,PT,1,"I")
201 Q X
202 ;
203CCTST(ACD160) ;
204 ;Addr Current--City [1810] 1307-1326
205 ;Follow-Up Contact--City [1842] 1357-1376
206 N X,D0,ONCOX1,OIEN,INCOM,ONCON,ONCOX
207 S X=""
208 S D0=ACD160
209 I $D(^ONCO(160,D0,0)) D SETUP1^ONCOES
210 I $D(ONCOX1) S X=$S($D(@ONCOX1):$P(@ONCOX1,U,4),1:"")
211 S X=$$STRIP^XLFSTR(X,"!""""#$%&'()*+,-./:;<=>?[>]^_\{|}~`")
212 Q X
213 ;
214CSTST(ACD160) ;
215 ;Addr Current--State [1820] 1327-1328
216 ;Follow-Up Contact--State [1844] 1377-1378
217 N X,D0,ONCOX1,ONCON,ONCOX
218 S X=""
219 S D0=ACD160
220 I $D(^ONCO(160,D0,0)) D SETUP1^ONCOES
221 I $D(ONCOX1) S X=$S($D(@ONCOX1):$P(@ONCOX1,U,5),1:"")
222 S:X'="" X=$$GET1^DIQ(5,X,1,"I")
223 S X=$S(X="CANAD":"CD",X="EU":"YY",X="MX":"XX",X="NF":"NL",X="PH":"XX",X="UN":"ZZ",1:X)
224 Q X
225 ;
226ICD(ICD) ;ICD Code
227 N X
228 S ICD=$S(ICD'="":$P($G(^ICD9(ICD,0)),U),1:"0000")
229 I ICD["." S ICD=$P(ICD,".")_$P(ICD,".",2)
230 S:$L(ICD)=3 ICD=ICD_9
231 S:$L(ICD)<4 ICD=$E("0000",1,4-$L(ICD))_ICD
232 S:$L(ICD)>4 ICD=$E(ICD,1,4)
233 I $E(ICD,4)="X"!($E(ICD,4)="-") S ICD=$E(ICD,1,3)_9
234 Q ICD
235 ;
236ICDR(ICD) ;ICD Revision Number [1920] 1392-1392
237 N ICDR
238 S ICD=$$ICD(ICD)
239 S ICDR=$S(ICD=" ":0,1:$$GET1^DIQ(160,ACD160,20,"I"))
240 S:ICDR="" ICDR=0
241 Q ICDR
242 ;
243LINK(ACD160) ;Linkage Name
244 N NAME,X
245 S DFN=ACD160 D DEM^VADPT
246 S NAME=VADM(1)
247 D KVAR^VADPT
248 S X=($A($E(NAME,1)))+($A($E(NAME,2)))
249 S X=X-128 I X<1 S X=""
250 Q X
251 ;
252PPAY(IEN) ;PRIMARY PAYER AT DX (165.5,18)
253 N X
254 S X=$$GET1^DIQ(165.5,IEN,18,"I")
255 S X=$$GET1^DIQ(160.3,$S(X'="":X,1:99),.01,"I")
256 S X=$S(X<42:X,X>47:X,1:X-1)
257 Q X
258 ;
259DS(IEN) ;RX Date--Surgery [1200] 755-762
260 N X
261 S X=$$GET1^DIQ(165.5,IEN,50,"I") I X'="" S SURGDT(X)=""
262 S X=$$GET1^DIQ(165.5,IEN,138.2,"I") I X'="" S SURGDT(X)=""
263 S X=$$GET1^DIQ(165.5,IEN,139.2,"I") I X'="" S SURGDT(X)=""
264 S SURGDT=$O(SURGDT(0))
265 S X=$$DATE^ONCACDU1(SURGDT)
266 K SURGDT
267 Q X
Note: See TracBrowser for help on using the repository browser.