source: WorldVistAEHR/trunk/r/ONCOLOGY-ONC/ONCOCC.m@ 1800

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

initial load of WorldVistAEHR
File size: 8.1 KB
RevLine 
[613]1ONCOCC ;HINES OIFO/GWB - CLASS OF CASE 5 OR 8 ;06/03/96
2 ;;2.11;ONCOLOGY;**5,13,16,19,20,22,24,26,30,33,36,37,39,47**;Mar 07, 1995;Build 19
3 ;
4 S DTDX=$P($G(^ONCO(165.5,D0,0)),U,16)
5 S TPG=$P($G(^ONCO(165.5,D0,2)),U,1)
6 S SGRP="" I TPG'="" S SGRP=$P($G(^ONCO(164,TPG,0)),U,16)
7 F P=5,9,12,15,18,24 S $P(^ONCO(165.5,D0,3),U,P)=""
8 K ^ONCO(165.5,DA,6) S $P(^ONCO(165.5,DA,3),U,7)=0
9 K ^ONCO(165.5,DA,14),^ONCO(165.5,DA,15),^ONCO(165.5,DA,16),^ONCO(165.5,DA,17),^ONCO(165.5,DA,18),^ONCO(165.5,DA,20),^ONCO(165.5,DA,21)
10 I COC=5 D COC5
11 I COC=8 D COC8
12 D SCT Q
13 ;
14COC5 S $P(^ONCO(165.5,D0,3),U,35)=9
15 S $P(^ONCO(165.5,D0,3),U,27)=$S(DTDX>2951231:"00",1:0)
16 S $P(^ONCO(165.5,D0,3.1),U,5)=$S(DTDX>2951231:"00",1:0)
17 S $P(^ONCO(165.5,D0,3.1),U,29)=1
18 S $P(^ONCO(165.5,D0,3.1),U,30)=1
19 S $P(^ONCO(165.5,D0,3),U,34)=1
20 S $P(^ONCO(165.5,D0,3.1),U,28)=0
21 S $P(^ONCO(165.5,D0,3.1),U,39)=0
22 S $P(^ONCO(165.5,D0,0),U,10)=6
23 S $P(^ONCO(165.5,D0,3),U,26)=9
24 S $P(^ONCO(165.5,D0,3),U,28)=8
25 S TPG=$P($G(^ONCO(165.5,DA,2)),U,1)
26 I ($E(TPG,3,4)=76)!(TPG=67809)!(TPG=67420)!(TPG=67421)!(TPG=67423)!(TPG=67424) S $P(^ONCO(165.5,DA,3),U,28)=9
27 S MO=$$HIST^ONCFUNC(DA)
28 S HIST14=$E(MO,1,4)
29 I (HIST14=9750)!((HIST14>9759)&(HIST14<9765))!((HIST14>9799)&(HIST14<9821))!(HIST14=9826)!((HIST14>9830)&(HIST14<9921))!((HIST14>9930)&(HIST14<9965))!((HIST14>9979)&(HIST14<9990)) S $P(^ONCO(165.5,DA,3),U,28)=9
30 I $$LYMPHOMA^ONCFUNC(DA),($E(TPG,3,4)=77) S $P(^ONCO(165.5,DA,3),U,28)=9
31 S $P(^ONCO(165.5,D0,3.1),U,31)=0
32 S $P(^ONCO(165.5,D0,3.1),U,32)=0
33 S $P(^ONCO(165.5,D0,3.1),U,33)=0
34 S $P(^ONCO(165.5,D0,3.1),U,34)=0
35 S $P(^ONCO(165.5,D0,3),U,33)=$S(DTDX>2971231:1,1:9)
36 F P=6,10,25 S $P(^ONCO(165.5,D0,3),U,P)=0
37 F P=12,20 S $P(^ONCO(165.5,D0,3.1),U,P)=0
38 S $P(^ONCO(165.5,DA,"THY1"),U,43)=$S(DTDX>2971231:0,1:"")
39 S $P(^ONCO(165.5,DA,3),U,13)="00"
40 S $P(^ONCO(165.5,DA,3.1),U,14)="00"
41 S $P(^ONCO(165.5,DA,3),U,16)="00"
42 S $P(^ONCO(165.5,DA,3.1),U,16)="00"
43 S $P(^ONCO(165.5,DA,3),U,19)="00"
44 S $P(^ONCO(165.5,DA,3.1),U,18)="00"
45 S $P(^ONCO(165.5,DA,3.1),U,36)=1
46 S $P(^ONCO(165.5,DA,3),U,20)=$S(DTDX>2971231:0,1:"")
47 S $P(^ONCO(165.5,DA,3),U,21)=$S(DTDX>2971231:1,1:"")
48 S $P(^ONCO(165.5,DA,3),U,22)=$S(DTDX>2971231:0,1:"")
49 S $P(^ONCO(165.5,DA,3),U,29)=$S(DTDX>2971231:0,1:"")
50 S $P(^ONCO(165.5,DA,3),U,39)=$S(DTDX>2971231:1,1:"")
51 S $P(^ONCO(165.5,DA,3.1),U,3)=$S(DTDX>2971231:0,1:"")
52 S $P(^ONCO(165.5,DA,3.1),U,1)=$S(DTDX>2971231:1,1:"")
53 S $P(^ONCO(165.5,DA,"THY1"),U,36)="0000000"
54 S $P(^ONCO(165.5,DA,"BLA2"),U,16)="0000000"
55 S $P(^ONCO(165.5,DA,"BLA2"),U,18)=1
56 S $P(^ONCO(165.5,DA,3),U,5)=""
57 F PP=1,4,11,14,17,23,31 S $P(^ONCO(165.5,DA,3),U,PP)="0000000"
58 F PP=6,8,13:2:19,21:1:25,35,38 S $P(^ONCO(165.5,DA,3.1),U,PP)="0000000"
59 K ^ONCO(165.5,"ATX",DA)
60 S ^ONCO(165.5,"ATX",DA,"0000000S1")=""
61 S ^ONCO(165.5,"ATX",DA,"0000000S2")=""
62 S ^ONCO(165.5,"ATX",DA,"0000000S3")=""
63 S ^ONCO(165.5,"ATX",DA,"0000000R")=""
64 S ^ONCO(165.5,"ATX",DA,"0000000C")=""
65 S ^ONCO(165.5,"ATX",DA,"0000000H")=""
66 S ^ONCO(165.5,"ATX",DA,"0000000B")=""
67 S ^ONCO(165.5,"ATX",DA,"0000000E")=""
68 S ^ONCO(165.5,"ATX",DA,"0000000O")=""
69 Q
70 ;
71COC8 ;CLASS OF CASE (165.5,.04) value 8 (Death cert) used by central
72 ;registries only
73 Q
74 ;
75SCT I $D(^ONCO(165.5,D0,4)) S SCTIEN=0 F S SCTIEN=$O(^ONCO(165.5,D0,4,SCTIEN)) Q:SCTIEN'>0 D
76 .S $P(^ONCO(165.5,D0,4,SCTIEN,0),U,4)="00"
77 .I COC=5 D
78 ..F P=11,12,13,14,15,16,17 S $P(^ONCO(165.5,D0,4,SCTIEN,0),U,P)="0000000"
79 ..S $P(^ONCO(165.5,D0,4,SCTIEN,0),U,5)=0
80 ..S $P(^ONCO(165.5,D0,4,SCTIEN,0),U,6)="00"
81 ..S $P(^ONCO(165.5,D0,4,SCTIEN,0),U,7)="00"
82 ..S $P(^ONCO(165.5,D0,4,SCTIEN,0),U,9)=0
83 ..S $P(^ONCO(165.5,D0,4,SCTIEN,0),U,10)=0
84 ..S $P(^ONCO(165.5,D0,4,SCTIEN,3),U,19)=0
85 K BRM,FLD,P,REC,RFNR,RFNC,RFNHT,RR
86 K SA,SC,SM,SO,SPS,SCTIEN,SGRP,TPG
87 Q
88 ;
89SATFDFR ;SURGERY OF PRIMARY @FAC (R) (165.5,50.2) default
90 N SPS S SPS=$P($G(^ONCO(165.5,D0,3)),U,38)
91 D SGROUP I TPG="" Q
92 I (SPS="00")!(SPS=1)!($G(^ONCO(164,SGRP,"SPS",SPS,0))["Unknown") S Y="@427" Q
93 S SPSDF="" I (COC=1)!(COC=2) D Q
94 .S SPSDF=$P($G(^ONCO(164,SGRP,"SPS",SPS,0)),U,1)
95 .S DTDX=$P($G(^ONCO(165.5,D0,0)),U,16) S:DTDX<2980000 SPSDF=""
96 Q
97 ;
98SATFDEF ;SURGERY OF PRIMARY @FAC (F) (165.5,58.7) default
99 N SPS S SPS=$P($G(^ONCO(165.5,D0,3.1)),U,29)
100 I SPS="" Q
101 D SGROUP I TPG="" Q
102 I (SPS="00")!(SPS=1)!($G(^ONCO(164,SGRP,"SPS",SPS,0))["Unknown") S Y="@43" Q
103 S (SPSDF,SPSDTDF)="" I (COC=1)!(COC=2) D Q
104 .S SPSDF=$P($G(^ONCO(164,SGRP,"SPS",SPS,0)),U,1)
105 .S SPSDTDF=$$GET1^DIQ(165.5,D0,50,"E")
106 .S DTDX=$P($G(^ONCO(165.5,D0,0)),U,16) S:DTDX<2980000 (SPSDF,SPSDTDF)=""
107 Q
108 ;
109RATFDEF ;RADIATION @FACILITY (165.5,51.4) default
110 S RD=$P($G(^ONCO(165.5,D0,3)),U,6)
111 S RADDF="",RADDTDF="" I (COC=1)!(COC=2) D Q
112 .I RD'="" D
113 ..S XX=$F(^DD(165.5,51.2,0),RD_":")
114 ..S YY=$F(^DD(165.5,51.2,0),";",XX)
115 ..S RADDF=$E(^DD(165.5,51.2,0),XX,YY-2)
116 .S RADDTDF=$P($G(^ONCO(165.5,D0,3)),U,4)
117 Q
118 ;
119CATFDEF ;CHEMOTHERAPY @FAC (165.5,53.3) default
120 S CH=$P($G(^ONCO(165.5,D0,3)),U,13)
121 S CHEMDF="",CHMDTDF="" I (COC=1)!(COC=2) D Q
122 .I CH'="" D
123 ..S XX=$F(^DD(165.5,53.2,0),CH_":")
124 ..S YY=$F(^DD(165.5,53.2,0),";",XX)
125 ..S CHEMDF=$E(^DD(165.5,53.2,0),XX,YY-2)
126 .S CHMDTDF=$P($G(^ONCO(165.5,D0,3)),U,11)
127 Q
128 ;
129HATFDEF ;HORMONE THERAPY @FAC (165.5,54.3) default
130 S HT=$P($G(^ONCO(165.5,D0,3)),U,16)
131 S HTDF="",HTDTDF="" I (COC=1)!(COC=2) D Q
132 .I HT'="" D
133 ..S XX=$F(^DD(165.5,54.2,0),HT_":")
134 ..S YY=$F(^DD(165.5,54.2,0),";",XX)
135 ..S HTDF=$E(^DD(165.5,54.2,0),XX,YY-2)
136 .S HTDTDF=$P($G(^ONCO(165.5,D0,3)),U,14)
137 Q
138 ;
139IATFDEF ;IMMUNOTHERAPY @FAC (165.5,55.3) default
140 S IMM=$P($G(^ONCO(165.5,D0,3)),U,19)
141 S IMMDF="",IMMDTDF="" I (COC=1)!(COC=2) D Q
142 .I IMM'="" D
143 ..S XX=$F(^DD(165.5,55.2,0),IMM_":")
144 ..S YY=$F(^DD(165.5,55.2,0),";",XX)
145 ..S IMMDF=$E(^DD(165.5,55.2,0),XX,YY-2)
146 .S IMMDTDF=$P($G(^ONCO(165.5,D0,3)),U,17)
147 Q
148 ;
149OATFDEF ;OTHER TREATMENT @FAC (165.5,57.3) default
150 S OTH=$P($G(^ONCO(165.5,D0,3)),U,25)
151 S OTHDF="",OTHDTDF="" I (COC=1)!(COC=2) D Q
152 .I OTH'="" D
153 ..S XX=$F(^DD(165.5,57.2,0),OTH_":")
154 ..S YY=$F(^DD(165.5,57.2,0),";",XX)
155 ..S OTHDF=$E(^DD(165.5,57.2,0),XX,YY-2)
156 .S OTHDTDF=$P($G(^ONCO(165.5,D0,3)),U,23)
157 Q
158 ;
159PATFDEF ;PALLIATIVE PROCEDURE @FAC (165.5,13) default
160 S PP=$P($G(^ONCO(165.5,D0,3.1)),U,26)
161 S PPDF="" I (COC=1)!(COC=2) D Q
162 .I PP'="" D
163 ..S XX=$F(^DD(165.5,12,0),PP_":")
164 ..S YY=$F(^DD(165.5,12,0),";",XX)
165 ..S PPDF=$E(^DD(165.5,12,0),XX,YY-2)
166 Q
167 ;
168SCOPER ;SCOPE OF LN SURGERY @FAC (R) (165.5,138.1) default
169 N SCOPE S SCOPE=$P($G(^ONCO(165.5,D0,3)),U,40) I SCOPE="" Q
170 D SGROUP I TPG="" Q
171 S SCPDF="" I (COC=1)!(COC=2) D Q
172 .S SCPDF=$P($G(^ONCO(164,SGRP,"SC5",SCOPE,0)),U,1)
173 Q
174 ;
175SCOPE ;SCOPE OF LN SURGERY @FAC (F) (165.5,138.5) default
176 ;SCOPE OF LN SURGERY @FAC DATE (165.5,138.3) default
177 N SCOPE S SCOPE=$P($G(^ONCO(165.5,D0,3.1)),U,31) I SCOPE="" Q
178 S (SCPDF,SCPDTDF)="" I (COC=1)!(COC=2) D Q
179 .I SCOPE'="" D
180 ..S XX=$F(^DD(165.5,138.5,0),SCOPE_":")
181 ..S YY=$F(^DD(165.5,138.5,0),";",XX)
182 ..S SCPDF=$E(^DD(165.5,138.5,0),XX,YY-2)
183 .S SCPDTDF=$P($G(^ONCO(165.5,D0,3.1)),U,22)
184 Q
185 ;
186NUMN ;NUMBER OF LN REMOVED @FAC (R) (165.5,140.1) default
187 N NODES S NODES=$P($G(^ONCO(165.5,D0,3)),U,42)
188 S NUMDF="" I (COC=1)!(COC=2) D Q
189 .S NUMDF=NODES
190 .I NUMDF="00" S NUMDF=NUMDF_" No nodes removed"
191 .I NUMDF="90" S NUMDF=NUMDF_" 90 or more nodes removed"
192 .I NUMDF="95" S NUMDF=NUMDF_" No nodes removed, aspiration performed"
193 .I NUMDF="96" S NUMDF=NUMDF_" Node removal as a sampling, number unknown"
194 .I NUMDF="97" S NUMDF=NUMDF_" Node removal as dissection, number unknown"
195 .I NUMDF="98" S NUMDF=NUMDF_" Nodes surgically removed, number unknown"
196 .I NUMDF="99" S NUMDF=NUMDF_" Unknown, not stated, death cert ONLY"
197 Q
198 ;
199SOSNR ;SURG PROC/OTHER SITE @FAC (R) (165.5,139.1) default
200 N SOSN S SOSN=$P($G(^ONCO(165.5,D0,3)),U,41) I SOSN="" Q
201 D SGROUP I TPG="" Q
202 S SOSNDF="" I (COC=1)!(COC=2) D Q
203 .S SOSNDF=$P($G(^ONCO(164,SGRP,"SO5",SOSN,0)),U,1)
204 Q
205 ;
206SOSN ;SURG PROC/OTHER SITE @FAC (F) (165.5,139.5) default
207 N SOSN S SOSN=$P($G(^ONCO(165.5,D0,3.1)),U,33) I SOSN="" Q
208 S (SOSNDF,SOSNDTDF)="" I (COC=1)!(COC=2) D Q
209 .I SOSN'="" D
210 ..S XX=$F(^DD(165.5,139.5,0),SOSN_":")
211 ..S YY=$F(^DD(165.5,139.5,0),";",XX)
212 ..S SOSNDF=$E(^DD(165.5,139.5,0),XX,YY-2)
213 .S SOSNDTDF=$P($G(^ONCO(165.5,D0,3.1)),U,24)
214 Q
215 ;
216SGROUP S TPG=$P($G(^ONCO(165.5,D0,2)),U,1) I TPG="" Q
217 S SGRP=$P($G(^ONCO(164,TPG,0)),U,16)
218 Q
Note: See TracBrowser for help on using the repository browser.