source: FOIAVistA/trunk/r/ONCOLOGY-ONC/ONCOMNI.m@ 1729

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

initial load of FOIAVistA 6/30/08 version
File size: 8.1 KB
Line 
1ONCOMNI ;HIRMFO/GWB,RTK-ALGORITHM FOR COMPUTING MIDDLE NAME/INITIAL ;12/10/99
2 ;;2.11;ONCOLOGY;**1,11,13,22,25,28**;Mar 07, 1995
3 ;
4 D SETUP^ONCOES
5 S NAME=$P(@ONCOX1,U,1),FNMI=$P(NAME,",",2),MNI=$P(FNMI," ",2)
6 I (MNI="JR")!(MNI="JR.")!(MNI="SR")!(MNI="SR.")!(MNI="MD")!(MNI="MD.")!(MNI="NMN")!(MNI="NMN.")!(MNI="NMI")!(MNI="NMI.")!(MNI="II")!(MNI="III")!(MNI="IV") S MNI=""
7 I $L(MNI)=2,$E(MNI,2)="." S MNI=$E(MNI,1)
8 S X=$E(MNI,1,14)
9 K ONCON,ONCOX,ONCOX1,NAME,FNMI,MNI
10 Q
11CHFPS ;CALCULATE VALUE OF FIELD #803 (CANCER HISTORY-1ST PRIMARY SITE)
12 I $P($G(^ONCO(165.5,D0,"NHL1")),U,4)'="" S X="" Q
13 S CHFSNM=$P($G(^ONCO(165.5,D0,0)),U,2)
14 S X="C88.8",CHFSFLG=0
15 S CHFS="" F S CHFS=$O(^ONCO(165.5,"C",CHFSNM,CHFS)) Q:CHFS'>""!(CHFSFLG>0) I $$DIV^ONCFUNC(CHFS)=DUZ(2) D
16 .I CHFS=D0 Q
17 .S CHFSFLG=CHFSFLG+1,TPX=$P($G(^ONCO(165.5,CHFS,2)),U,1) S:TPX'="" TPX=$G(^ONCO(164,TPX,0)) S:TPX'="" X=$P(TPX,U,2) Q
18 K CHFS,CHFSFLG,CHFSNM,TPX Q
19CHFPH ;CALCULATE VALUE OF FIELD #804 (CANCER HISTORY-1ST PRIMARY HISTOLOGY)
20 I $P($G(^ONCO(165.5,D0,"NHL1")),U,5)'="" S X="" Q
21 S CHFHNM=$P($G(^ONCO(165.5,D0,0)),U,2)
22 S X="8888/8",CHFHFLG=0
23 S CHFH="" F S CHFH=$O(^ONCO(165.5,"C",CHFHNM,CHFH)) Q:CHFH'>""!(CHFHFLG>0) I $$DIV^ONCFUNC(CHFH)=DUZ(2) D
24 .I CHFH=D0 Q
25 .S CHFHFLG=CHFHFLG+1,TPX=$$HIST^ONCFUNC(CHFH) S:TPX'="" TPX=$G(^ONCO(ICDFILE,TPX,0)) S:TPX'="" X=$P(TPX,U,2) Q
26 K CHFH,CHFHFLG,CHFHNM,TPX Q
27CHSPS ;CALCULATE VALUE OF FIELD #805 (CANCER HISTORY-2ND PRIMARY SITE)
28 I $P($G(^ONCO(165.5,D0,"NHL1")),U,6)'="" S X="" Q
29 S CHSSNM=$P($G(^ONCO(165.5,D0,0)),U,2)
30 S X="C88.8",CHSSFLG=0
31 S CHSS="" F S CHSS=$O(^ONCO(165.5,"C",CHSSNM,CHSS)) Q:CHSS'>""!(CHSSFLG>1) I $$DIV^ONCFUNC(CHSS)=DUZ(2) D
32 .I CHSS=D0 Q
33 .I CHSSFLG=0 S CHSSFLG=CHSSFLG+1 Q
34 .S CHSSFLG=CHSSFLG+1,TPX=$P($G(^ONCO(165.5,CHSS,2)),U,1) S:TPX'="" TPX=$G(^ONCO(164,TPX,0)) S:TPX'="" X=$P(TPX,U,2) Q
35 K CHSS,CHSSFLG,CHSSNM,TPX Q
36CHSPH ;CALCULATE VALUE OF FIELD #806 (CANCER HISTORY-2ND PRIMARY HISTOLOGY)
37 I $P($G(^ONCO(165.5,D0,"NHL1")),U,7)'="" S X="" Q
38 S CHSHNM=$P($G(^ONCO(165.5,D0,0)),U,2)
39 S X="8888/8",CHSHFLG=0
40 S CHSH="" F S CHSH=$O(^ONCO(165.5,"C",CHSHNM,CHSH)) Q:CHSH'>""!(CHSHFLG>1) I $$DIV^ONCFUNC(CHSH)=DUZ(2) D
41 .I CHSH=D0 Q
42 .I CHSHFLG=0 S CHSHFLG=CHSHFLG+1 Q
43 .S CHSHFLG=CHSHFLG+1,TPX=$$HIST^ONCFUNC(CHSH) S:TPX'="" TPX=$G(^ONCO(ICDFILE,TPX,0)) S:TPX'="" X=$P(TPX,U,2) Q
44 K CHSH,CHSHFLG,CHSHNM,TPX Q
45ARCHHLP ;AIDS RISK CATEGORY FOR HIV POSITIVE PATIENT (#822) HELP
46 W !?5,"Choose from the following codes:",!
47 W !?8,"0 Not HIV positive"
48 W !?8,"1 No known risk category"
49 W !?8,"2 Homosexual/Bisexual"
50 W !?8,"3 IV drug user"
51 W !?8,"4 Blood product recipient"
52 W !?8,"5 Heterosexual transmission"
53 W !?8,"6 Congenitally acquired"
54 W !?8,"7 Multiple categories"
55 W !?8,"8 Other/Unknown risk category"
56 W !?8,"9 Unknown if HIV positive",!
57 Q
58ARCHP ;AIDS RISK CATEGORY FOR HIV POSITIVE PATIENT (#822) OUTPUT TRANSFORM
59 I Y=0 S Y="Not HIV positive" Q
60 I Y=1 S Y="No known risk category" Q
61 I Y=2 S Y="Homosexual/Bisexual" Q
62 I Y=3 S Y="IV drug user" Q
63 I Y=4 S Y="Blood product recipient" Q
64 I Y=5 S Y="Heterosexual transmission" Q
65 I Y=6 S Y="Congenitally acquired" Q
66 I Y=7 S Y="Multiple categories" Q
67 I Y=8 S Y="Other/Unknown risk category" Q
68 I Y=9 S Y="Unknown if HIV positive" Q
69 Q
70EXNSIT ;EXTRANODAL SITE 1,2,3 (FIELDS #852,#853,#854) INPUT TRANSFORM
71 I X[U!(X="") K X Q
72 I $L(X)<3 W *7," Must be at least 3 characters " K X Q
73 I X=888!(X="C888")!(X=88.8)!(X="C88.8") S X="C888" W " None" Q
74 I X=999!(X="C999")!(X=99.9)!(X="C99.9") S X="C999" W " Unknown" Q
75 K DIC S DIC="^ONCO(164,",DIC(0)="EMQ" D ^DIC
76 I Y<0 K X Q
77 I +Y'<0 S CCD=$P($G(^ONCO(164,+Y,0)),U,2) S X=$E(CCD,1,3)_$E(CCD,5) Q
78EXNSOT ;EXTRANODAL SITE 1,2,3 (FIELDS #852,#853,#854) OUTPUT TRANSFORM
79 I Y="C888" S Y="None" Q
80 I Y="C999" S Y="Unknown" Q
81 S EXN=$E(Y,1,3)_"."_$E(Y,4)
82 F TPG=0:0 S TPG=$O(^ONCO(164,TPG)) Q:TPG'>0 D
83 .I EXN'=$P($G(^ONCO(164,TPG,0)),U,2) Q
84 .S TPGNM=$P($G(^ONCO(164,TPG,0)),U,1),EXN=EXN_" "_TPGNM Q
85 S Y=EXN K EXN,TPG,TPGNM Q
86XHP ;EXTRANODAL SITE 1,2,3 (FIELDS #852,#853,#854) EXECUTABLE HELP
87 I X'="?",X'="??" Q
88 K DIC S DIC="^ONCO(164,",DIC(0)="EMQ" D ^DIC Q
89RCSIT ;RADIATION/CHEMOTHERAPY SEQUENCE (#862) INPUT TRANSFORM
90 I X=0!(X=5)!(X=6) K X Q
91 S Y=X D RCSOT W " ",Y K Y
92 Q
93RCSOT ;RADIATION/CHEMOTHERAPY SEQUENCE (#862) OUTPUT TRANSFORM
94 I Y=1 S Y="Radiation before chemotherapy"
95 I Y=2 S Y="Chemotherapy before radiation"
96 I Y=3 S Y="Chemotherapy before and after radiation"
97 I Y=4 S Y="Radiation and chemotherapy concurrently"
98 I Y=7 S Y="Unknown if radiation and/or chemo given"
99 I Y=8 S Y="NA, no radiation and/or no chemo given"
100 I Y=9 S Y="Sequence unknown"
101 Q
102RCSHP ;RADIATION/CHEMOTHERAPY SEQUENCE (#862) HELP
103 W !," 1 Radiation before chemotherapy"
104 W !," 2 Chemotherapy before radiation"
105 W !," 3 Chemotherapy before and after radiation"
106 W !," 4 Radiation and chemotherapy concurrently"
107 W !," 7 Unknown if radiation and/or chemo given"
108 W !," 8 NA, no radiation and/or no chemo given"
109 W !," 9 Sequence unknown",!
110 Q
111 S %DT="EP",%DT(0)="-NOW" D ^%DT S X=Y K:Y<1 X K ^%DT(0)
112 I $D(X) S DTDX=$P($G(^ONCO(165.5,D0,0)),U,16) I DTDX'="" K:X<DTDX X
113FSC ;Calculate default for fields #1102,#1103
114 ;I $P($G(^ONCO(165.5,D0,"MEL1")),U,3)'="" S X="" Q
115 S PNM=$P($G(^ONCO(165.5,D0,0)),U,2),X="C88.8",FSDX="88/8888"
116 S ST=0 F S ST=$O(^ONCO(165.5,"C",PNM,ST)) Q:ST'>0 I $$DIV^ONCFUNC(ST)=DUZ(2) S LAST=ST
117 I LAST'=D0 D
118 .S Y=$P($G(^ONCO(165.5,LAST,0)),U,16) D CHDTOT^ONCOPCE S FSDX=Y
119 .S TPX=$P($G(^ONCO(165.5,LAST,2)),U,1) I TPX="" Q
120 .S TPX=$G(^ONCO(164,TPX,0)) S:TPX'="" X=$P(TPX,U,2) Q
121 I LAST=D0 F S LAST=$O(^ONCO(165.5,"C",PNM,LAST),-1) Q:LAST="" I $$DIV^ONCFUNC(LAST)=DUZ(2) D Q
122 .S Y=$P($G(^ONCO(165.5,LAST,0)),U,16) D CHDTOT^ONCOPCE S FSDX=Y
123 .S TPX=$P($G(^ONCO(165.5,LAST,2)),U,1) I TPX="" Q
124 .S TPX=$G(^ONCO(164,TPX,0)) S:TPX'="" X=$P(TPX,U,2) Q
125 K LAST,PNM,ST,TPX Q
126SSC ;Calculate default for fields #1104,#1105
127 ;I $P($G(^ONCO(165.5,D0,"MEL1")),U,5)'="" S X="" Q
128 S PNM=$P($G(^ONCO(165.5,D0,0)),U,2),X="C88.8",SSDX="88/8888",FLG=0
129 S ST=0 F S ST=$O(^ONCO(165.5,"C",PNM,ST)) Q:ST'>0 I $$DIV^ONCFUNC(ST)=DUZ(2) S LAST=ST
130 I LAST'=D0 S FLG=FLG+1
131 S SSC=LAST F S SSC=$O(^ONCO(165.5,"C",PNM,SSC),-1) Q:SSC'>""!(FLG>1) I $$DIV^ONCFUNC(SSC)=DUZ(2) D
132 .I SSC=D0 Q
133 .I FLG=0 S FLG=FLG+1 Q
134 .S FLG=FLG+1
135 .S Y=$P($G(^ONCO(165.5,SSC,0)),U,16) D CHDTOT^ONCOPCE S SSDX=Y
136 .S TPX=$P($G(^ONCO(165.5,SSC,2)),U,1) S:TPX'="" TPX=$G(^ONCO(164,TPX,0)) S:TPX'="" X=$P(TPX,U,2) Q
137 K FLG,LAST,PNM,SSC,ST,TPX Q
138NSNIT ;Number of Satellite Nodules (#1112)
139 I X'?1.2N K X Q
140 I X=0!(X="00") S X="00" W " No satellite nodules"
141 I X=96 W " 96 or more nodules"
142 I X=97 W " Satellite nodules, # unknown"
143 I X=98 W " NA, non-cutaneous melanoma"
144 I X=99 W " Unknown"
145 S X=$S($L(X)=1:"0"_X,1:X)
146 Q
147NSNOT ;Number of Satellite Nodules (#1112)
148 I Y="00" S Y="No satellite nodules" Q
149 I Y=96 S Y="96 or more nodules" Q
150 I Y=97 S Y="Satellite nodules, # unknown" Q
151 I Y=98 S Y="NA, non-cutaneous melanoma" Q
152 I Y=99 S Y="Unknown" Q
153 S Y=$S(Y="01":Y_" nodule",1:Y_" nodules")
154 Q
155BTIT ;Breslow's Thickness (#1113)
156 I X'?1.3N K X Q
157 I X=997 W " Cutaneous melanoma, thickness unk"
158 I X=998 W " NA, non-cutaneous melanoma"
159 I X=999 W " Primary site unknown"
160 S X=$S($L(X)=1:"00"_X,$L(X)=2:"0"_X,1:X)
161 Q
162BTOT ;Breslow's Thickness (#1113)
163 I Y=997 S Y="Cutaneous melanoma, thickness unk" Q
164 I Y=998 S Y="NA, non-cutaneous melanoma" Q
165 I Y=999 S Y="Primary site unknown" Q
166 S Y=Y_" mm"
167 Q
168MDIT ;Margin Distance (#1120)
169 I X'?1.3N K X Q
170 I X=997 W " Margins free, distance unknown"
171 I X=998 W " NA, surgery not performed"
172 I X=999 W " Unknown"
173 S X=$S($L(X)=1:"00"_X,$L(X)=2:"0"_X,1:X)
174 Q
175MDOT ;Margin Distance (#1120)
176 I Y=996 S Y=Y_"mm or more" Q
177 I Y=997 S Y="Margins free, distance unknown" Q
178 I Y=998 S Y="NA, surgery not performed" Q
179 I Y=999 S Y="Unknown" Q
180 S Y=Y_"mm"
181 Q
182SNPIT ;Sentinel Nodes Positive (#1125)
183 I X=0!(X>6) Q
184 S SNE=$P($G(^ONCO(165.5,D0,"MEL1")),U,25) I SNE=""!(SNE>5) Q
185 I X>SNE W !," Sentinel Nodes Positive MUST be less than/equal Sentinel Nodes Examined! " K X Q
186 Q
187NBPIT ;Number of Basins Positive (#1129)
188 I X=0!(X>6) Q
189 S NBD=$P($G(^ONCO(165.5,D0,"MEL1")),U,29) I NBD=""!(NBD>5) Q
190 I X>NBD W !," Number of Basins Positive MUST be less than/equal to Basins Detected! " K X Q
191 Q
Note: See TracBrowser for help on using the repository browser.