source: FOIAVistA/trunk/r/ONCOLOGY-ONC/ONCOPCE.m@ 1452

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

initial load of FOIAVistA 6/30/08 version
File size: 8.3 KB
Line 
1ONCOPCE ;HINES OIFO/GWB PCE MAIN ROUTINE ;04/28/00
2 ;;2.11;ONCOLOGY;**6,7,11,13,16,18,19,22,26,29**;Mar 07, 1995
3 N D0,DA,DD,DIC,DIE,DINUM,DIR,DLAYGO,DO,DR,DP,DL,DQ,DM,DK,DI,DIEL,DOV
4 G:'ONCOD0P EXIT S ONCONUM=+ONCOD0P N ONCOD0P
5 G:'ONCOD0 EXIT S ONCOPA=ONCOD0 N ONCOD0
6 K PCEITC
7 S PCEITC("C16.0")="" ;Cardia, NOS
8 S PCEITC("C16.1")="" ;Fundus of stomach
9 S PCEITC("C16.2")="" ;Body of stomach
10 S PCEITC("C16.3")="" ;Gastric antrum
11 S PCEITC("C16.4")="" ;Pylorus
12 S PCEITC("C16.5")="" ;Lesser curvature of stomach, NOS
13 S PCEITC("C16.6")="" ;Greater curvature of stomach, NOS
14 S PCEITC("C16.8")="" ;Overlapping lesion of stomach
15 S PCEITC("C16.9")="" ;Stomach, NOS
16 S PCEITC("C18.0")="" ;Cecum
17 S PCEITC("C18.1")="" ;Appendix
18 S PCEITC("C18.2")="" ;Ascending
19 S PCEITC("C18.3")="" ;Hepatic flexure
20 S PCEITC("C18.4")="" ;Transverse
21 S PCEITC("C18.5")="" ;Splenic flexure
22 S PCEITC("C18.6")="" ;Descending
23 S PCEITC("C18.7")="" ;Sigmoid
24 S PCEITC("C18.8")="" ;Overlapping lesion
25 S PCEITC("C18.9")="" ;Colon, NOS
26 S PCEITC("C19.9")="" ;Rectosigmoid junction
27 S PCEITC("C20.9")="" ;Rectum
28 S PCEITC("C22.0")="" ;Liver
29 S PCEITC("C34.0")="" ;Main Bronchus
30 S PCEITC("C34.1")="" ;Upper lobe lung
31 S PCEITC("C34.2")="" ;Middle lobe lung
32 S PCEITC("C34.3")="" ;Lower lobe lung
33 S PCEITC("C34.8")="" ;Overlapping lesion of lung
34 S PCEITC("C34.9")="" ;Lung, NOS
35 S PCEITC("C38.0")="" ;Heart
36 S PCEITC("C38.1")="" ;Mediastinum, anterior
37 S PCEITC("C38.2")="" ;Mediastinum, posterior
38 S PCEITC("C38.3")="" ;Mediastinum, NOS
39 S PCEITC("C38.4")="" ;Pleura, NOS
40 S PCEITC("C38.8")="" ;Heart/Medias/Pleura, overlap
41 S PCEITC("C44.0")="" ;Skin of lip, NOS
42 S PCEITC("C44.2")="" ;External ear
43 S PCEITC("C44.3")="" ;Skin of other and unspecified parts of face
44 S PCEITC("C44.4")="" ;Skin of scalp and neck
45 S PCEITC("C44.5")="" ;Skin of trunk
46 S PCEITC("C44.6")="" ;Skin of upper limb and shoulder
47 S PCEITC("C44.7")="" ;Skin of lower limb and hip
48 S PCEITC("C44.8")="" ;Overlapping lesion
49 S PCEITC("C44.9")="" ;Skin, NOS
50 S PCEITC("C47.0")="" ;Nerves, head & neck
51 S PCEITC("C47.1")="" ;Nerves, upper limb
52 S PCEITC("C47.2")="" ;Nerves, lower limb
53 S PCEITC("C47.3")="" ;Nerves, thorax
54 S PCEITC("C47.4")="" ;Nerves, abdomen
55 S PCEITC("C47.5")="" ;Nerves, pelvis
56 S PCEITC("C47.6")="" ;Nerves, trunk
57 S PCEITC("C47.8")="" ;Nerves, overlap
58 S PCEITC("C47.9")="" ;Autonomic nervous system, NOS
59 S PCEITC("C48.0")="" ;Retroperitoneum
60 S PCEITC("C48.1")="" ;Peritoneum, specified
61 S PCEITC("C48.2")="" ;Peritoneum, NOS
62 S PCEITC("C48.8")="" ;Retroperitoneum overlap
63 S PCEITC("C49.0")="" ;Soft tissues, head & neck
64 S PCEITC("C49.1")="" ;Soft tissues, upper limb
65 S PCEITC("C49.2")="" ;Soft tissues, lower limb
66 S PCEITC("C49.3")="" ;Soft tissues, thorax
67 S PCEITC("C49.4")="" ;Soft tissues, abdomen
68 S PCEITC("C49.5")="" ;Soft tissues, pelvis
69 S PCEITC("C49.6")="" ;Soft tissues, trunk
70 S PCEITC("C49.8")="" ;Soft tissues overlap
71 S PCEITC("C49.9")="" ;Soft tissues NOS
72 S PCEITC("C50.0")="" ;Nipple
73 S PCEITC("C50.1")="" ;Central portion breast
74 S PCEITC("C50.2")="" ;Upper-inner quadrant breast
75 S PCEITC("C50.3")="" ;Lower-inner quadrant breast
76 S PCEITC("C50.4")="" ;Upper-outer quadrant breast
77 S PCEITC("C50.5")="" ;Lower-outer quadrant breast
78 S PCEITC("C50.6")="" ;Axillary tail breast
79 S PCEITC("C50.8")="" ;Overlapping lesion breast
80 S PCEITC("C50.9")="" ;Breast, NOS
81 S PCEITC("C61.9")="" ;Prostate
82 S PCEITC("C67.0")="" ;Urinary Bladder
83 S PCEITC("C67.1")="" ;Urinary Bladder
84 S PCEITC("C67.2")="" ;Urinary Bladder
85 S PCEITC("C67.3")="" ;Urinary Bladder
86 S PCEITC("C67.4")="" ;Urinary Bladder
87 S PCEITC("C67.5")="" ;Urinary Bladder
88 S PCEITC("C67.6")="" ;Urinary Bladder
89 S PCEITC("C67.7")="" ;Urinary Bladder
90 S PCEITC("C67.8")="" ;Urinary Bladder
91 S PCEITC("C67.9")="" ;Urinary Bladder
92 S PCEITC("C68.0")="" ;Urinary Bladder (Urethra)
93 S PCEITC("C70.0")="" ;Cerebral meninges
94 S PCEITC("C70.1")="" ;Spinal meninges
95 S PCEITC("C70.9")="" ;Meninges, NOS
96 S PCEITC("C71.0")="" ;Cerebrum
97 S PCEITC("C71.1")="" ;Fontal lobe
98 S PCEITC("C71.2")="" ;Temporal lobe
99 S PCEITC("C71.3")="" ;Parietal lobe
100 S PCEITC("C71.4")="" ;Occipital lobe
101 S PCEITC("C71.5")="" ;Ventricle, NOS
102 S PCEITC("C71.6")="" ;Cerebellum, NOS
103 S PCEITC("C71.7")="" ;Brain stem
104 S PCEITC("C71.8")="" ;Overlapping lesion on brain
105 S PCEITC("C71.9")="" ;Brain, NOS
106 S PCEITC("C72.0")="" ;Spinal cord
107 S PCEITC("C72.1")="" ;Cauda equina
108 S PCEITC("C72.2")="" ;Olfactory nerve
109 S PCEITC("C72.3")="" ;Optic nerve
110 S PCEITC("C72.4")="" ;Acoustic nerve
111 S PCEITC("C72.5")="" ;Cranial nerve
112 S PCEITC("C72.8")="" ;Overlapping lesion of brain and cns
113 S PCEITC("C72.9")="" ;Nervous system, NOS
114 S PCEITC("C73.9")="" ;Thyroid gland
115 S PCEITC("C75.1")="" ;Pituitary gland
116 S PCEITC("C75.2")="" ;Craniopharyngeal duct
117 S PCEITC("C75.3")="" ;Pineal gland
118 S ICDO=0,NODE2=$G(^ONCO(165.5,ONCONUM,2)),ICDOTOP=$P(NODE2,U,1)
119 S HIST=$$HIST^ONCFUNC(ONCONUM)
120 ;
121 ;Check if HISTOLOGY is relevant to NON-HODGKIN'S LYMPHOMA and if
122 ;ACCESSION YEAR = 1997
123 S HIST1234=$E(HIST,1,4),BEH=$E(HIST,5)
124 I ((HIST1234>9589)&(HIST1234<9596))!((HIST1234>9669)&(HIST1234<9718)),$P(^ONCO(165.5,ONCONUM,0),U,7)=1997 D ^ONCNPC0 G EXIT
125 ;
126 ;Check if HISTOLOGY is relevant to MELANOMA and if ACCESSION YEAR = 1999
127 S HIST123=$E(HIST,1,3),BEH=$E(HIST,5)
128 I ((HIST123>871)&(HIST123<880))!((HIST=90443)&($E(ICDOTOP,1,4)=6749)),$P(^ONCO(165.5,ONCONUM,0),U,7)=1999 D ^ONCMPC0 G EXIT
129 ;
130 ;Check for pediatric cases of rhabdomyosarcoma (Soft Tissue Sarcoma)
131 S D0=ONCOPA D DOB1^ONCOES S X1=DT,X2=X D ^%DTC S AGE=X\365.25,D0=ONCONUM
132 I AGE<21,((HIST=89003)!(HIST=89013)!(HIST=89023)!(HIST=89103)!(HIST=89203)) D ^ONCSPC0 G EXIT
133 ;
134 ;Check Primary Site
135 I ICDOTOP'="" S ICDO=$P(^ONCO(164,ICDOTOP,0),U,2)
136 I ICDO=0 G:ONCOANS'=5 EXIT W !!,?10,"There is no ICDO-TOPOGRAPHY for this primary." R Z:10 G EXIT
137 I '$D(PCEITC(ICDO)) G:ONCOANS'=5 EXIT W !!,?10,"There is currently no PCE for this primary site",!,?10,"nor is it a 1997 Non-Hodgkin's Lymphoma or 1999",!,?10,"Melanoma." R Z:10 G EXIT
138 I ($E(ICDO,2,3)=67)!($E(ICDO,2,3)=68) D ^ONCBPC0 G EXIT
139 I ($E(ICDO,2,3)=38)!($E(ICDO,2,3)=47)!($E(ICDO,2,3)=48)!($E(ICDO,2,3)=49)!($E(ICDO,2,3)=44) D ^ONCSPC0 G EXIT
140 I ICDO="C73.9" D ^ONCTPC0 G EXIT
141 I ICDO="C61.9" D ^ONCP2P0 G EXIT
142 I ($E(ICDO,2,3)=18)!($E(ICDO,2,3)=19)!($E(ICDO,2,3)=20) D ^ONCCPC0 G EXIT
143 I $E(ICDO,2,3)=50 D ^ONCBRP0 G EXIT
144 I ICDO="C22.0" D ^ONCHPC0 G EXIT
145 I ($E(ICDO,2,3)=70)!($E(ICDO,2,3)=71)!($E(ICDO,2,3)=72)!(ICDO="C75.1")!(ICDO="C75.2")!(ICDO="C75.3") D ^ONCIPC0 G EXIT
146 I $E(ICDO,2,3)=16 D ^ONCGPC0 G EXIT
147 I $E(ICDO,2,3)=34 D ^ONCLPC0 G EXIT
148 Q
149EXIT K PCEITC,NODE2,ICDOTOP,ICDO,Z,X1,X2,AGE,HIST,HIST1234,HIST123,BEH
150 Q
151DATEIT ;Date input transform
152 I X="00/00/00" W *7,!!?5,"'00/00/00' is ambiguous, enter a 4 digit year.",!! S ITFLAG="YES" K X Q
153 I X="00/00/0000" S X="0000000" S ITFLAG="YES" Q
154 I X="00000000" S X="0000000" S ITFLAG="YES" W " 00/00/0000" Q
155 I X="88/88/88" W *7,!!?5,"'88/88/88' is ambiguous, enter a 4 digit year.",!! S ITFLAG="YES" K X Q
156 I X="88/88/8888" S X=8888888 S ITFLAG="YES" Q
157 I X="88888888" S X=8888888 S ITFLAG="YES" W " 88/88/8888" Q
158 I X="99/99/99" W *7,!!?5,"'99/99/99' is ambiguous, enter a 4 digit year.",!! S ITFLAG="YES" K X Q
159 I X="99/99/9999" S X=9999999 S ITFLAG="YES" Q
160 I X="99999999" S X=9999999 S ITFLAG="YES" W " 99/99/9999" Q
161 Q
162DATEOT ;Date output transform in format MM/DD/YYYY
163 Q:Y=""
164 S Y=$S(Y="0000000":"00/00/0000",Y=9999999:"99/99/9999",Y=8888888:"88/88/8888",1:$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_($E(Y,1,3)+1700))
165 Q
166CHDTIT ;Date input transform for fields #1103 and #1105
167 I X="00/00/00" W *7,!!?5,"'00/00/00' is ambiguous, enter a 4 digit year.",!! S ITFLAG="YES" K X Q
168 I X="00/0000" S X="0000000" S ITFLAG="YES" Q
169 I (X="00000000")!(X="00/00/0000") S X="0000000" S ITFLAG="YES" W " 00/0000" Q
170 I X="99/99/99" W *7,!!?5,"'99/99/99' is ambiguous, enter a 4 digit year.",!! S ITFLAG="YES" K X Q
171 I X="99/9999" S X=9999999 S ITFLAG="YES" Q
172 I (X="99999999")!(X="99/99/9999") S X=9999999 S ITFLAG="YES" W " 99/9999" Q
173 I X="88/88/88" W *7,!!?5,"'88/88/88' is ambiguous, enter a 4 digit year.",!! S ITFLAG="YES" K X Q
174 I X="88/8888" S X="8888888" S ITFLAG="YES" Q
175 I (X="88888888")!(X="88/88/8888") S X="8888888" S ITFLAG="YES" W " 88/8888" Q
176 S %DT="EP",%DT(0)="-NOW" D ^%DT S X=Y I Y<1 K X W !!?5,"Future dates are not allowed.",! K %DT(0) Q
177 Q
178CHDTOT ;Date output transform for fields #1103 and #1105
179 Q:Y=""
180 I Y="0000000" S Y="00/0000" Q
181 I Y=9999999 S Y="99/9999" Q
182 I Y=8888888 S Y="88/8888" Q
183 S Y=$E(Y,4,5)_"/"_($E(Y,1,3)+1700)
184 Q
Note: See TracBrowser for help on using the repository browser.