source: FOIAVistA/trunk/r/ONCOLOGY-ONC/ONCACDU1.m@ 1549

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

initial load of FOIAVistA 6/30/08 version

File size: 5.3 KB
Line 
1ONCACDU1 ;Hines OIFO/GWB - NAACCR extract utilities #1;06/23/00
2 ;;2.11;Oncology;**12,14,16,20,21,22,24,26,27,28,33,36,37,42,45,46**;Mar 07, 1995;Build 39
3 ;
4BEHAV(IEN) ;Behavior Code (called by extract RULES)
5 N BEHAV
6 S BEHAV=$E($$HIST^ONCFUNC(IEN),5)
7 Q BEHAV
8 ;
9DATE(FMDT) ;Convert date to NAACCR format mmddyyyy
10 N DATE
11 S DATE=""
12 I FMDT'="" D
13 .N MM,DD,YYYY,YYYMMDD,MMDDCCYY
14 .S YYYMMDD=FMDT
15 .I YYYMMDD="0000000" S DATE="00000000" Q
16 .I YYYMMDD="8888888" S DATE="88888888" Q
17 .I YYYMMDD="9999999" S DATE="99999999" Q
18 .D
19 ..S YYYY=($E(YYYMMDD,1,3)+1700)
20 ..I YYYY=1900,$E(YYYMMDD,4,7)="0000" S YYYY="0000"
21 .S MM=$S($E(YYYMMDD,4,5)'="00":$E(YYYMMDD,4,5),1:99)
22 .S DD=$S($E(YYYMMDD,6,7)'="00":$E(YYYMMDD,6,7),1:99)
23 .S MMDDCCYY=MM_DD_YYYY
24 .S DATE=MMDDCCYY
25 Q DATE
26 ;
27CNTY(IEN) ;County at DX [90] 83-85
28 N COUNTYPT,COUNTYNM,COUNTYIE,STATE,FIPSCODE
29 S FIPSCODE=""
30 S COUNTYPT=$$GET1^DIQ(165.5,IEN,10,"I") ;Pointer to COUNTY (5.1)
31 I COUNTYPT="" G QCNTY
32 S FIPSCODE=$$GET1^DIQ(5.1,COUNTYPT,2,"I") ;SEER COUNTY CODE (5.1,2)
33 G:FIPSCODE'="" QCNTY ;QUIT if FIPSCODE found
34 S COUNTYNM=$$GET1^DIQ(165.5,IEN,10,"E") ;COUNTY (5.1) name
35 S STATE=$$GET1^DIQ(5.1,COUNTYPT,1,"I") ;Pointer to STATE (5)
36 S COUNTYIE=$O(^DIC(5,STATE,1,"B",COUNTYNM,0))
37 I COUNTYIE'="" S FIPSCODE=$P($G(^DIC(5,STATE,1,COUNTYIE,0)),U,3)
38 S:FIPSCODE="" FIPSCODE=999
39QCNTY Q FIPSCODE
40 ;
41AGEDX(IEN) ;Age at Diagnosis [230] 119-121
42 N ACDAGE,D0,X
43 S D0=IEN
44 D AGE^ONCOCOM S ACDAGE=$S(X=""!(X<0)!(X>999):"",1:X)
45 Q ACDAGE
46 ;
47OCCUP(ACD160) ;Text--Usual Occupation [310] 143-182
48 N X,OCCUP
49 S X="UNKNOWN"
50 S OCCUP=$O(^ONCO(160,ACD160,7,0))
51 I OCCUP'<1 D
52 .N OCC
53 .S OCC=$P($G(^ONCO(160,ACD160,7,OCCUP,0)),U,1)
54 .Q:OCC<1
55 .S X=$$GET1^DIQ(61.6,OCC,.01,"I")
56 Q X
57 ;
58IND(ACD160) ;Text--Usual Industry [320] 183-222
59 N X,OCCUP
60 S X="UNKNOWN"
61 S OCCUP=$O(^ONCO(160,ACD160,7,0))
62 I OCCUP'<1 D
63 .N IND
64 .S IND=$P($G(^ONCO(160,ACD160,7,OCCUP,0)),U,4)
65 .Q:IND=""
66 .S X=IND
67 Q X
68 ;
69TOB(IEN) ;Tobacco History [340] 224-224 VACCR extract only
70 N X,AASTOB
71 S X=$P($G(^ONCO(160,ACD160,8)),U,2)
72 S AASTOB=$S(X="Y":"Y",X="N":0,X="U":9,1:X)
73 I AASTOB="Y" D
74 .N X S X=""
75 .S X=$O(^ONCO(160,ACD160,5,X),-1)
76 .I X'<1 I $G(^ONCO(160,ACD160,5,X,0))'="" D
77 ..N Y S Y=^ONCO(160,ACD160,5,X,0)
78 ..I $P(Y,U,3)'="" S AASTOB=5 Q ;Previous use
79 ..S AASTOB=$S($P(Y,U)=1:1,$P(Y,U)=2:2,$P(Y,U)=3:2,$P(Y,U)=4:3,$P(Y,U)=5:3,$P(Y,U)=7:4,1:9)
80 .I AASTOB="Y" S AASTOB=9
81 Q AASTOB
82 ;
83ALC(IEN) ;Alcohol History [350] 225-225 VACCR extract only
84 N X,AASALCO
85 S X=$P($G(^ONCO(160,ACD160,8)),U,3)
86 S AASALCO=$S(X="Y":"Y",X="N":0,X="U":9,1:X)
87 I AASALCO="Y" D
88 .N X S X=""
89 .S X=$O(^ONCO(160,ACD160,6,X),-1)
90 .I X'<1 I $G(^ONCO(160,ACD160,6,X,0))'="" D
91 ..N Y S Y=^ONCO(160,ACD160,6,X,0)
92 ..I $P(Y,U,4)'="" S AASALCO=2 Q ;Past history of alcohol use
93 ..S AASALCO=1
94 .I AASALCO="Y" S AASALCO=9
95 Q AASALCO
96 ;
97SG(IEN,TYPE) ;TNM Stage Groups
98 ;TNM Path Stage Group [910] 569-570
99 ;TNM Clin Stage Group [970] 579-580
100 N GS
101 S GS=""
102 I TYPE="" Q GS
103 I TYPE="P" S GS=$$GET1^DIQ(165.5,IEN,88,"I")
104 I TYPE="C" S GS=$$GET1^DIQ(165.5,IEN,38,"I")
105 I GS'="" S GS=$S("^0^0A^0S^1^1A^1B^1S^1C^2^2A^2B^2C^3^3A^3B^3C^4^4A^4B^4C^OC^88^99^"[("^"_GS_"^"):GS,GS="1A1":"A1",GS="1A2":"A2",GS="1B1":"B1",GS="1B2":"B2",1:"99")
106 Q GS
107 ;
108CC ;Comorbid/Complication 1-10
109 ;[3110] 675-679
110 ;[3120] 680-684
111 ;[3130] 685-689
112 ;[3140] 690-694
113 ;[3150] 695-699
114 ;[3160] 700-704
115 ;[3161] 717-721
116 ;[3162] 722-726
117 ;[3163] 727-731
118 ;[3164] 732-736
119 S CCEX(1)="00000"
120 F CCSUB=1:1:10 S CC(CCSUB)=""
121 S CCSUB=0
122 F FLD=25:.1:25.9 S CC=$$GET1^DIQ(160,ACD160,FLD,"I") S:CC'="" CC=$$GET1^DIQ(80,CC,.01,"I") S CCSUB=CCSUB+1,CC(CCSUB)=$P(CC," ",1)
123 F CCEXSUB=1:1:10 S CCEX(CCEXSUB)=""
124 I CC(1)="" Q
125 I EXT="VACCR" F CCSUB=1:1:10 S CCEX(CCSUB)=$P(CC(CCSUB),".",1)_$P(CC(CCSUB),".",2) G CCEX
126 S CCEXSUB=0
127 S CCSUB=0 F S CCSUB=$O(CC(CCSUB)) Q:CCSUB'>0 D
128 .I ($E(CC(CCSUB),1)="E")!($E(CC(CCSUB),1)="V")!(+CC(CCSUB)>99.9) S CCEXSUB=CCEXSUB+1,CCEX(CCEXSUB)=$P(CC(CCSUB),".",1)_$P(CC(CCSUB),".",2)
129CCEX Q
130 ;
131RXCOD(IEN) ;RX Coding System--Current [1460] 888-889
132 N OUT
133 S OUT="06"
134 Q OUT
135 ;
136ZIP(ACD160) ;Addr Current--Postal Code [1830] 1329-1337
137 N X,D0,ONCOX1,OIEN,ONCOM,ONCON,ONCOT,ONCOX
138 S X=""
139 S D0=ACD160
140 I $D(^ONCO(160,D0,0)) D SETUP1^ONCOES
141 I $D(ONCOX1) S X=$S($D(@ONCOX1):$P(@ONCOX1,U,6),1:"")
142 Q X
143 ;
144FHCT ;Family History of Cancer Text 1456-1505 VACCR extract only
145 K ONC S IEN160=ACD160_"," D GETS^DIQ(160,IEN160,"44*","","ONC")
146 S (ACDANS,FHCTIEN)=""
147 F S FHCTIEN=$O(ONC(160.044,FHCTIEN)) Q:FHCTIEN'>0 D
148 .S FHCT=ONC(160.044,FHCTIEN,.01)_"("_ONC(160.044,FHCTIEN,1)_")"
149 .Q:($L(ACDANS)+$L(FHCT))>50
150 .S ACDANS=ACDANS_FHCT_"/"
151 S ACDANS=$E(ACDANS,1,$L(ACDANS)-1)
152 K ONC,IEN160,FHCTIEN,FHCT
153 Q
154 ;
155PHCT ;Patient History of Cancer Text 1785-1804 VACCR extract only
156 S ACDANS=""
157 F I=148.1,148.2,148.3,148.4 S PHCTPT=$$GET1^DIQ(165.5,IEN,I,"I") D
158 .Q:PHCTPT=""
159 .S PHCT=$$GET1^DIQ(164.2,PHCTPT,.01,"I")
160 .Q:PHCT="NOT APPLICABLE"
161 .Q:($L(ACDANS)+$L(PHCT))>20
162 .S ACDANS=ACDANS_PHCT_"/"
163 S ACDANS=$E(ACDANS,1,$L(ACDANS)-1)
164 K I,PHCTPT,PHCT
165 Q
166 ;
167NL ;Name--Last [2230] 1947-1971
168 S ACDANS=$$STRIP^XLFSTR(ACDANS," !""""#$%&'()*+,./:;<=>?[>]^_\{|}~`")
169 Q
170 ;
171ALIAS(ACD160) ;Name--Alias [2280] 2006-2020
172 N X,DO,ONCOX,XD0,XD1
173 S X=""
174 S D0=ACD160
175 I $D(^ONCO(160,D0,0)) D
176 .D SETUP^ONCOES
177 .Q:$P(ONCOX,";",2)'="DPT(" S XD0=$P(ONCOX,";")
178 .S XD1=0 F S XD1=$O(^DPT(XD0,.01,XD1)) Q:XD1'>0 S X=$P(^(XD1,0),U) Q
179 Q X
Note: See TracBrowser for help on using the repository browser.