ONCACDU1 ;HINES OIFO/GWB - NAACCR extract utilities #1 ;05/08/12
;;2.2;ONCOLOGY;**1,4,7,5,10,12,13,14,17,18**;Jul 31, 2013;Build 5
;P17 set Date Flag to Null if DX is year 2023
BDATE(ACD160) ;Date of Birth [240] 196-203
N D0,X,Y
S D0=ACD160
D DOB1^ONCOES
S X=$G(X)
Q X
;
BEHAV(IEN) ;Behavior Code (called by extract RULES)
N BEHAV
S BEHAV=$E($$HIST^ONCFUNC(IEN),5)
Q BEHAV
ICD1(IEN) ;source of item
N ONCHST,ONCBEV,ONCGR
S ONCHST=$$GET1^DIQ(165.5,IEN,7031,"I")
S ONCBEV=$$GET1^DIQ(165.5,IEN,7002,"I")
S ONCGR=$$GET1^DIQ(165.5,IEN,7003,"I")
S ACDANS=ONCHST_ONCBEV_ONCGR
Q ACDANS
EOD6(IEN) ;Extent
N ONCSUR,ONCRAD,ONCCHE,ONCHOR,ONCBRM,ONCOTH
S ACDANS=""
S DATEDX=$$GET1^DIQ(165.5,IEN,3,"I")
I DATEDX>288000,DATEDX<3040000 D
.S ONCSUR=$$GET1^DIQ(165.5,IEN,29,"I") S:(ONCSUR="")!(ONCSUR'>0) ONCSUR="000"
.S ONCRAD=$$GET1^DIQ(165.5,IEN,30,"I") S:(ONCRAD="")!(ONCRAD=0) ONCRAD="00"
.S ONCCHE=$$GET1^DIQ(165.5,IEN,30.1,"I") S:(ONCCHE="")!(ONCCHE=0) ONCCHE="00"
.S ONCHOR=$$GET1^DIQ(165.5,IEN,31,"I") S:ONCHOR="" ONCHOR="0"
.S ONCBRM=$$GET1^DIQ(165.5,IEN,32,"I") S:(ONCBRM="")!(ONCBRM=0) ONCBRM="00"
.S ONCOTH=$$GET1^DIQ(165.5,IEN,33,"I") S:(ONCOTH="")!(ONCOTH=0) ONCOTH="00"
.S ACDANS=ONCSUR_ONCRAD_ONCCHE_ONCHOR_ONCBRM_ONCOTH
Q ACDANS
ICD3(IEN) ;
N ONCHST,ONCBEV
S ONCHST=$E($$GET1^DIQ(165.5,IEN,22.3,"I"),1,4)
S ONCBEV=$E($$GET1^DIQ(165.5,IEN,22.3,"I"),5)
S ACDANS=ONCHST_ONCBEV
Q ACDANS
;
LYMPH(IEN) ;Lymph-Vascular Invasion (1297-1297)
N MPH,LV,ONCDANS,DATEDX
S DATEDX=$$GET1^DIQ(165.5,IEN,3,"I"),ONCDANS=""
I DATEDX<3100000 K DATEDX Q ONCDANS
S MPH=$$GET1^DIQ(165.5,IEN,22.3,"I")
S MPH=$E(MPH,1,4),LV=$$GET1^DIQ(165.5,IEN,149,"I")
S ONCDANS=LV
I DATEDX<3180000 S ONCDANS=$S((MPH>9589)&(MPH<9993):8,LV[0:0,LV[1:1,LV[8:8,1:9)
K LV,MPH
Q ONCDANS
;
ICD9(ACD160,ONIEN) ;COMOR/COMP 1-10 for ICD9 and Secondary Diagnosis for ICD10
N ONCDANS
S ONCDANS=$$GET1^DIQ(160,ACD160,ONIEN,"I")
S:ONCDANS'="" ONCDANS=$$GET1^DIQ(80,ONCDANS,.01,"I")
I ($E(ONCDANS,1,7)="Invalid")!($E(ONCDANS,1,3)="-1") S ONCDANS="" Q ONCDANS
I $G(EXTRACT)'=3 S ONCPHI=1
;P18 ICD-10 starts with Q,U,V,W and X are invalid
I (ONCPHI=1),(($E(ONCDANS,1)="C")!($E(ONCDANS,1)="D")!($E(ONCDANS,1)="F")!($E(ONCDANS,1)="Q")!($E(ONCDANS,1)="U")!($E(ONCDANS,1)="V")!($E(ONCDANS,1)="W")!($E(ONCDANS,1)="X")) S ONCDANS="" Q ONCDANS
I (($E(ONCDANS,1,4)="T40.")!($E(ONCDANS,1,4)="T43.")),(ONCPHI=1) S ONCDANS="" Q ONCDANS
;
I $G(ONCPHI)=0 S ONCDANS=$P(ONCDANS,".",1)_$P(ONCDANS,".",2) Q ONCDANS
;
N ONCMO1,ONCMO2,ONCI1,ONCJ1
K ^TMP($J,"ONCOMO")
F ONCI1=1:1 S ONCMO1=$P($T(COMO+ONCI1),";",3) Q:ONCMO1="" F ONCJ1=1:1 S ONCMO2=$P(ONCMO1,"^",ONCJ1) Q:ONCMO2="" D
.S ^TMP($J,"ONCOMO",ONCMO2)=""
I $G(ONCPHI),(ONCDANS'=""),($D(^TMP($J,"ONCOMO",ONCDANS))) S ONCDANS=""
K ^TMP($J,"ONCOMO")
S ONCDANS=$P(ONCDANS,".",1)_$P(ONCDANS,".",2)
Q ONCDANS
;
COMO ;ICD10 PHI Code.
;;272.4^292.0^292.2^292.81^292.82^292.83^292.84^292.85^292.89^292.9^357.6^760.72^760.73^760.74^760.75
;;F10.10^F10.20^F10.21^F10.27^F10.929^F10.950^F10.951^F10.96^F10.99^F10.231^F10.239^F10.159^F10.180^F10.181^F10.182
;;F10.282^F10.982^F10.188^F10.259^F10.280^F10.281^F10.288^F10.229^F11.10^F11.20^F11.21^F12.10^F12.20^F12.21^F12.90
;;F13.10^F13.20^F13.21^F14.10^F14.20^F14.21^F15.10^F15.20^F15.21^F16.10^F16.20^F16.21^F18.10^F19.10^F19.20^F19.21
;;291.81^291.82^291.89^142.6^K70.0^K70.10^K70.30^K70.9^357.6
;;P04.3^R78.0^R97.0^R97.1^R97.8^R75^D57.1^D57.00^D57.01^D57.02^D57.80^D57.819^D57.40^D57.419^Z63.72^Z13.89^Z21^Z71.7
;;T50.991A^T51.91^T51.1X1A^T51.1X2A^T51.1X3A^T51.1X4A^T51.2X1A^T51.2X2A^T51.2X3A^T51.2X4A^T51.9X1A^T51.9X2A^T51.9X3A
;;T51.9X4A^T51.0X1A^T51.0X2A^T51.0X3A^T51.0X4A^T51.6X1A^T51.8X1A^T51.8X2A^T51.8X3A^T51.8X4A^142.6
;;B20^B20.^B97.35^E24.2^E24.4^G31.2^G62.0^G62.2^G72.1^G72.2^K70^K86.0
;;O35.4^O35.5XX9^O98.7^O98.73^O99.31^O99.335^P04.12^P04.49^R78^R78.6^T36^T50.996S^Z20.6^Z21.^I42.6
;;G62.1^K29.00^K29.01^K29.20^K29.21^K70.10^K70.11^K70.2^K70.30^K70.31^K70.40^K70.41
;;O35.4XX0^O35.4XX1^O35.4XX2^O35.4XX3^O35.4XX4^O35.4XX5^O35.4XX9^O35.5XX0^O35.5XX1^O35.5XX2^O35.5XX3
;;O35.5XX4^O35.5XX5^O35.5XX9^O98.711^O98.712^O98.713^O98.719^O98.72^R78.1^R78.2^R78.3^R78.4^R78.5
;;O99.310^O99.311^O99.312^O99.313^O99.314^O99.315^O99.320^O99.322^O99.323^O99.324^O99.325
;;O99.330^O99.331^O99.332^O99.333^O99.334^P04.12^P04.13^P04.14^P04.15^P04.16^P04.17^P04.18^P04.19
;;P04.1A^P04.2^P04.3^P04.40^P04.41^P04.42^R75.^T40^T43
Q
BRE22(IEN) ;Breast Surgery code User define in p18
S DATEDX=$$GET1^DIQ(165.5,IEN,3,"I")
I (DATEDX<3220101)!(DATEDX>3231231) S ACDANS=""
Q ACDANS
CSF1(IEN) ;CSF1 ;P#18 default to 999 for specific Site and Histology
N ONC164,ONC164H,ONCPS,ONCS,ONCH1,ONCH1H,DATEDX S ONC164=$$GET1^DIQ(165.5,IEN,20,"I"),ONCH1=0
S DATEDX=$$GET1^DIQ(165.5,IEN,3,"I") S ACDANS=$S(DATEDX<3040000:"",1:$$GET1^DIQ(165.5,IEN,44.1,"I"))
I DATEDX>3180000 S ACDANS="" Q ACDANS
S ONCPS=$$GET1^DIQ(164,ONC164,1,"I"),ONCS=$E($$HIST^ONCFUNC(IEN),1,4),ONC164H=$E(ONCPS,2,5)
;Hodgkin and Non-Hodgkin Lymphomas
I (ONC164H<44.1)!((ONC164H>44.1)&(ONC164H<69.0))!((ONC164H>69.0)&(ONC164H<69.5))!((ONC164H>69.7)&(ONC164H<80.99)) S ONCH1H=1 D
.I (((ONCS>9589)&(ONCS<9700))!((ONCS>9701)&(ONCS<9730))!(ONCS=9735)!(ONCS=9737)!(ONCS=9738)&(ONCH1H=1)) S ACDANS=999
S ONCH1H=0
I (ONC164H<42)!((ONC164H>42.1)&(ONC164H<42.4))!((ONC164H>42.4)&(ONC164H<44.1))!((ONC164H>44.1)&(ONC164H<69))!((ONC164H>69.0)&(ONC164H<69.5))!((ONC164H>69.7)&(ONC164H<89.0)) S ONCH1H=1 D
.I ((ONCS>9810)&(ONCS<9819))!(ONCS=9823)!(ONCS=9827)!(ONCS=9837) S ACDANS=999
;Lymphoma of Ocular Adnexa and Skin of Eyelid
I ((ONCS>9589)&(ONCS<9700))!((ONCS>9701)&(ONCS<9739))!((ONCS>9810)&(ONCS<9819))!((ONCS>9819)&(ONCS<9838)) S ONCH1=1
I (ONC164="C44.1")!(ONC164=("C69.0")!(ONC164="C69.5")!(ONC164="C69.6"))&(ONCH1=1) S ACDANS=999
;Kaposi Sarcoma with 9140 Histolgy
I ((ONC164H<81.0)&(ONCS=9140)) S ACDANS=999
Q ACDANS
;
CSF11(IEN) ;P#18 default to 999 for specific Site and Histology
N ONC164,ONCPS,ONCS,ONCH1,DATEDX S ONC164=$$GET1^DIQ(165.5,IEN,20,"I"),ONCH1=0
S DATEDX=$$GET1^DIQ(165.5,IEN,3,"I") S ACDANS=$S(DATEDX<3040000:"",1:$$GET1^DIQ(165.5,IEN,44.11,"I"))
I DATEDX>3180000 S ACDANS="" Q ACDANS
S ONCPS=$$GET1^DIQ(164,ONC164,1,"I"),ONCS=$E($$HIST^ONCFUNC(IEN),1,4)
I ((ONCS>7999)&(ONCS<8714))!((ONCS>8799)&(ONCS<9137))!((ONCS>9140)&(ONCS<9509))!((ONCS>9509)&(ONCS<9515))!((ONCS>9519)&(ONCS<9583)) S ONCH1=1
I ((ONC164="C44.1")&(ONCH1=1)) S ACDANS=999
Q ACDANS
;
CSF22(IEN) ;P#18
N ONCS,DATEDX
S DATEDX=$$GET1^DIQ(165.5,IEN,3,"I") S ACDANS=$S(DATEDX<3040000:"",1:$$GET1^DIQ(165.5,IEN,44.22,"I"))
I DATEDX>3180000 S ACDANS="" Q ACDANS
S ONCS=$E($$HIST^ONCFUNC(IEN),1,4)
I ONCS=8247 S ACDANS=999
Q ACDANS
;
;
DATE(ACDANS) ;Convert date to NAACCR format CCYYMMDD
N DATE,X
S DATE=""
S X=ACDANS
D DATEOT^ONCOES
I X'="" D
.I X="00/00/0000" S DATE="" Q
.I X="88/88/8888" S DATE="" Q
.I X="99/99/9999" S DATE="" Q
.S DATE=$E(X,7,10)_$E(X,1,2)_$E(X,4,5)
.S DATE=$S($E(DATE,5,8)=9999:$E(DATE,1,4),$E(DATE,7,8)=99:$E(DATE,1,6),1:DATE)
Q DATE
;
DTFLAG(ACDANS,ITEM) ;Compute Date Flag
N FLAG,N,REC,ONCSCMA
S FLAG=""
I $P($G(^ONCO(165.5,IEN,0)),"^",16)>3221231 G FLAG
S N=ITEM
D CHKFLGS ;first check the Date Flag fields, make sure nothing entered
I ONCDTFLG'="" S FLAG=ONCDTFLG G FLAG
;patch#14
I (N=1261),((ACDANS="")!(ACDANS=9999999)!(ACDANS=8888888)!(ACDANS="0000000")) S FLAG=11 G FLAG
;patch *2.2*4
I (N=1861),(ACDANS'=""),(ACDANS'="9999999"),(ACDANS'="0000000"),(ACDANS'="8888888") G FLAG
I N=1861 I ($$GET1^DIQ(165.5,IEN,71,"I")=4)!($$GET1^DIQ(165.5,IEN,71,"I")=5) S FLAG=11 G FLAG
I ACDANS="" D
.S FLAG=$S(N=1751:12,N=1861:10,1:"")
.I N=683,$P($G(^ONCO(165.5,IEN,0)),"^",16)>3171231 S FLAG=11
.S ONCSCMA=$P($G(^ONCO(165.5,IEN,"SSD1")),"^",1)
.I ($G(ONCSCMA)'="00480")&('$$MELANOMA^ONCOU55(IEN)) Q
.I N=833,$P($G(^ONCO(165.5,IEN,0)),"^",16)>3171231 S FLAG=11 Q
.Q ;only set 833 above if Schema 00480 or Melanoma above
I ACDANS'="",((N=833)!(N=683)) S FLAG="" G FLAG
I ACDANS="9999999" D
.S FLAG=$S((N=391)!(N=439)!(N=581)!(N=1751):12,(N=448)!(N=591)!(N=601)!(N=1201)!(N=1211)!(N=1221)!(N=1231)!(N=1241)!(N=1251)!(N=1271)!(N=1281)!(N=1661)!(N=1681)!(N=1701)!(N=1861)!(N=3171)!(N=3181)!(N=3221)!(N=3231):10,1:"") Q
I ACDANS="8888888" D
.S FLAG=$S((N=448)!(N=439):11,N=391:12,(N=1211)!(N=1221)!(N=1231)!(N=1241)!(N=3221)!(N=3231):15,1:"") Q
I ACDANS="0000000" D
.S FLAG=$S((N=591)!(N=601)!(N=1201)!(N=1211)!(N=1221)!(N=1231)!(N=1241)!(N=1251)!(N=1271)!(N=1281)!(N=1661)!(N=1681)!(N=1701)!(N=1861)!(N=3171)!(N=3181)!(N=3221)!(N=3231):11,N=391:12,(N=448)!(N=439):15,1:"") Q
FLAG K ONCDTFLG,ZZFLDNUM
Q FLAG
;
CHKFLGS ;CHECK THE DATE FLAG FIELDS IF USER NEEDED TO OVERRIDE VALUE
; if the DATE FLAG field is not NULL use that value to override the
; calculated value from DTFLAG entry point above
S ONCDTFLG=""
S ZZFLDNUM=$S(N=391:999.1,N=448:999.2,N=439:999.3,N=581:999.4,N=591:999.5,N=601:999.6,N=1271:999.7,N=1201:999.8,1:"")
I ZZFLDNUM="" S ZZFLDNUM=$S(N=3171:999.9,N=3181:999.11,N=1211:999.12,N=3221:999.13,N=3231:999.14,N=1221:999.15,N=1231:999.16,N=1241:999.17,1:"")
I ZZFLDNUM="" S ZZFLDNUM=$S(N=1251:999.18,N=1281:999.19,N=1861:999.21,N=1751:999.22,N=1661:999.23,N=1681:999.24,N=1701:999.25,N=833:7018,N=683:7014,1:"")
I ZZFLDNUM="" Q
S ONCDTFLG=$$GET1^DIQ(165.5,IEN,ZZFLDNUM,"I")
Q
;
ADPCD(IEN) ;Addr Current--Postal Code [1830] (added in patch #13)
S ITEM=1830 D CHKADDS I ONCADDF'="" Q ONCADDF
S ONCADDF=$$GET1^DIQ(160,ACD160,.116,"E") S:ONCADDF=75999 ONCADDF=999999999
Q ONCADDF
;
ADDDXST(IEN) ;Addr at DX--State [80] 145-146
S ITEM=80 D CHKADDS I ONCADDF'="" Q ONCADDF ;check overrides
S XX=$S($$GET1^DIQ(165.5,IEN,16,"I")'="":$$GET1^DIQ(5,$$GET1^DIQ(165.5,IEN,16,"I"),1,"I"),1:"")
S XX=$S(XX="CANAD":"CD",XX="EU":"YY",XX="FG":"YY",XX="MX":"XX",XX="NF":"NL",XX="PH":"XX",XX="UN":"ZZ",1:XX)
Q XX
;
CHKADDS ;CHECK THE ADDRESS--STATE & COUNTRY FIELDS IF USER NEEDED TO OVERRIDE
; if the ADDRESS--STATE/COUNTRY field is not NULL use that value to
; overwrite the calculated value from the ADDDXST entry point and the
; CSTST,ADDCTRY entry points in ONCACDU2
S ONCADDF="",N=ITEM
S ZZFLDNUM=$S(N=80:999.26,N=102:999.27,N=1820:999.28,N=1830:999.289,N=1832:999.29,1:"")
I ZZFLDNUM="" Q
S ONCADDF=$$GET1^DIQ(165.5,IEN,ZZFLDNUM,"I")
K N,ZZFLDNUM Q
;
CNTY(IEN) ;COUNTY AT DX [90] 156-158
N FIPSCODE
S FIPSCODE=$$GET1^DIQ(165.5,IEN,10,"I")
I (FIPSCODE=998)!(FIPSCODE=999) G QCNTY
S FIPSCODE=$E($$GET1^DIQ(165.5,IEN,10,"I"),3,5)
QCNTY Q FIPSCODE
;
AGEDX(IEN) ;Age at Diagnosis [230] 119-121
N ACDAGE,D0,X
S D0=IEN
D AGE^ONCOCOM S ACDAGE=$S(X=""!(X<0)!(X>999):"",1:X)
Q ACDAGE
;
OCCUP(ACD160) ;Text--Usual Occupation [310] 143-182
N X,OCCUP
S X="UNKNOWN"
S OCCUP=$O(^ONCO(160,ACD160,7,0))
I OCCUP'<1 D
.N OCC
.S OCC=$P($G(^ONCO(160,ACD160,7,OCCUP,0)),U,1)
.Q:OCC=""
.S X=OCC
Q X
;
IND(ACD160) ;Text--Usual Industry [320] 183-222
N X,OCCUP
S X="UNKNOWN"
S OCCUP=$O(^ONCO(160,ACD160,7,0))
I OCCUP'<1 D
.N IND
.S IND=$P($G(^ONCO(160,ACD160,7,OCCUP,0)),U,4)
.Q:IND=""
.S X=IND
Q X
;
TOB(IEN) ;Tobacco History [340] 224-224 VACCR extract only
N X,AASTOB
S X=$P($G(^ONCO(160,ACD160,8)),U,2)
S AASTOB=$S(X="Y":"Y",X="N":0,X="U":9,1:X)
I AASTOB="Y" D
.N X S X=""
.S X=$O(^ONCO(160,ACD160,5,X),-1)
.I X'<1 I $G(^ONCO(160,ACD160,5,X,0))'="" D
..N Y S Y=^ONCO(160,ACD160,5,X,0)
..I $P(Y,U,3)'="" S AASTOB=5 Q ;Previous use
..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)
.I AASTOB="Y" S AASTOB=9
Q AASTOB
;
ALC(IEN) ;Alcohol History [350] 225-225 VACCR extract only
N X,AASALCO
S X=$P($G(^ONCO(160,ACD160,8)),U,3)
S AASALCO=$S(X="Y":"Y",X="N":0,X="U":9,1:X)
I AASALCO="Y" D
.N X S X=""
.S X=$O(^ONCO(160,ACD160,6,X),-1)
.I X'<1 I $G(^ONCO(160,ACD160,6,X,0))'="" D
..N Y S Y=^ONCO(160,ACD160,6,X,0)
..I $P(Y,U,4)'="" S AASALCO=2 Q ;Past history of alcohol use
..S AASALCO=1
.I AASALCO="Y" S AASALCO=9
Q AASALCO
;
SG(IEN,TYPE) ;TNM Stage Groups
;TNM Path Stage Group [910] 569-570
;TNM Clin Stage Group [970] 579-580
N GS
S GS=""
I TYPE="" Q GS
I TYPE="P" S GS=$$GET1^DIQ(165.5,IEN,88,"I")
I TYPE="C" S GS=$$GET1^DIQ(165.5,IEN,38,"I")
Q GS
;
CC ;Comorbid/Complication 1-10
;No longer needed. Used by NAACCR v11.3.
;[3110] 675-679
;[3120] 680-684
;[3130] 685-689
;[3140] 690-694
;[3150] 695-699
;[3160] 700-704
;[3161] 717-721
;[3162] 722-726
;[3163] 727-731
;[3164] 732-736
;S CCEX(1)="00000"
;F CCSUB=1:1:10 S CC(CCSUB)=""
;S CCSUB=0
;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)
;F CCEXSUB=1:1:10 S CCEX(CCEXSUB)=""
;I CC(1)="" Q
;I EXT="VACCR" F CCSUB=1:1:10 S CCEX(CCSUB)=$P(CC(CCSUB),".",1)_$P(CC(CCSUB),".",2) G CCEX
;S CCEXSUB=0
;S CCSUB=0 F S CCSUB=$O(CC(CCSUB)) Q:CCSUB'>0 D
;.I ($E(CC(CCSUB),1)="E")!($E(CC(CCSUB),1)="V")!((+CC(CCSUB)>99.9)&(+CC(CCSUB)<290))!(+CC(CCSUB)>319) S CCEXSUB=CCEXSUB+1,CCEX(CCEXSUB)=$P(CC(CCSUB),".",1)_$P(CC(CCSUB),".",2)
CCEX ;K CC,CCEXSUB,CCSUB,FLD
Q
;
RXCOD(IEN) ;RX Coding System--Current [1460] 888-889
N OUT
S OUT="06"
Q OUT
;
FHCT ;Family History of Cancer Text 1456-1505 VACCR extract only
K ONC S IEN160=ACD160_"," D GETS^DIQ(160,IEN160,"44*","","ONC")
S (ACDANS,FHCTIEN)=""
F S FHCTIEN=$O(ONC(160.044,FHCTIEN)) Q:FHCTIEN'>0 D
.S FHCT=ONC(160.044,FHCTIEN,.01)_"("_ONC(160.044,FHCTIEN,1)_")"
.Q:($L(ACDANS)+$L(FHCT))>50
.S ACDANS=ACDANS_FHCT_"/"
S ACDANS=$E(ACDANS,1,$L(ACDANS)-1)
K ONC,IEN160,FHCTIEN,FHCT
Q
;
PHCT ;Patient History of Cancer Text 1785-1804 VACCR extract only
S ACDANS=""
F I=148.1,148.2,148.3,148.4 S PHCTPT=$$GET1^DIQ(165.5,IEN,I,"I") D
.Q:PHCTPT=""
.S PHCT=$$GET1^DIQ(164.2,PHCTPT,.01,"I")
.Q:PHCT="NOT APPLICABLE"
.Q:($L(ACDANS)+$L(PHCT))>20
.S ACDANS=ACDANS_PHCT_"/"
S ACDANS=$E(ACDANS,1,$L(ACDANS)-1)
K I,PHCTPT,PHCT
Q
;
NL ;Name--Last [2230] 1947-1971
S ACDANS=$$STRIP^XLFSTR(ACDANS," !""""#$%&'()*+,./:;<=>?[>]^_\{|}~`")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HONCACDU1 14322 printed Apr 09, 2024@21:24:07 Page 2
ONCACDU1 ;HINES OIFO/GWB - NAACCR extract utilities #1 ;05/08/12
+1 ;;2.2;ONCOLOGY;**1,4,7,5,10,12,13,14,17,18**;Jul 31, 2013;Build 5
+2 ;P17 set Date Flag to Null if DX is year 2023
BDATE(ACD160) ;Date of Birth [240] 196-203
+1 NEW D0,X,Y
+2 SET D0=ACD160
+3 DO DOB1^ONCOES
+4 SET X=$GET(X)
+5 QUIT X
+6 ;
BEHAV(IEN) ;Behavior Code (called by extract RULES)
+1 NEW BEHAV
+2 SET BEHAV=$EXTRACT($$HIST^ONCFUNC(IEN),5)
+3 QUIT BEHAV
ICD1(IEN) ;source of item
+1 NEW ONCHST,ONCBEV,ONCGR
+2 SET ONCHST=$$GET1^DIQ(165.5,IEN,7031,"I")
+3 SET ONCBEV=$$GET1^DIQ(165.5,IEN,7002,"I")
+4 SET ONCGR=$$GET1^DIQ(165.5,IEN,7003,"I")
+5 SET ACDANS=ONCHST_ONCBEV_ONCGR
+6 QUIT ACDANS
EOD6(IEN) ;Extent
+1 NEW ONCSUR,ONCRAD,ONCCHE,ONCHOR,ONCBRM,ONCOTH
+2 SET ACDANS=""
+3 SET DATEDX=$$GET1^DIQ(165.5,IEN,3,"I")
+4 IF DATEDX>288000
IF DATEDX<3040000
Begin DoDot:1
+5 SET ONCSUR=$$GET1^DIQ(165.5,IEN,29,"I")
if (ONCSUR="")!(ONCSUR'>0)
SET ONCSUR="000"
+6 SET ONCRAD=$$GET1^DIQ(165.5,IEN,30,"I")
if (ONCRAD="")!(ONCRAD=0)
SET ONCRAD="00"
+7 SET ONCCHE=$$GET1^DIQ(165.5,IEN,30.1,"I")
if (ONCCHE="")!(ONCCHE=0)
SET ONCCHE="00"
+8 SET ONCHOR=$$GET1^DIQ(165.5,IEN,31,"I")
if ONCHOR=""
SET ONCHOR="0"
+9 SET ONCBRM=$$GET1^DIQ(165.5,IEN,32,"I")
if (ONCBRM="")!(ONCBRM=0)
SET ONCBRM="00"
+10 SET ONCOTH=$$GET1^DIQ(165.5,IEN,33,"I")
if (ONCOTH="")!(ONCOTH=0)
SET ONCOTH="00"
+11 SET ACDANS=ONCSUR_ONCRAD_ONCCHE_ONCHOR_ONCBRM_ONCOTH
End DoDot:1
+12 QUIT ACDANS
ICD3(IEN) ;
+1 NEW ONCHST,ONCBEV
+2 SET ONCHST=$EXTRACT($$GET1^DIQ(165.5,IEN,22.3,"I"),1,4)
+3 SET ONCBEV=$EXTRACT($$GET1^DIQ(165.5,IEN,22.3,"I"),5)
+4 SET ACDANS=ONCHST_ONCBEV
+5 QUIT ACDANS
+6 ;
LYMPH(IEN) ;Lymph-Vascular Invasion (1297-1297)
+1 NEW MPH,LV,ONCDANS,DATEDX
+2 SET DATEDX=$$GET1^DIQ(165.5,IEN,3,"I")
SET ONCDANS=""
+3 IF DATEDX<3100000
KILL DATEDX
QUIT ONCDANS
+4 SET MPH=$$GET1^DIQ(165.5,IEN,22.3,"I")
+5 SET MPH=$EXTRACT(MPH,1,4)
SET LV=$$GET1^DIQ(165.5,IEN,149,"I")
+6 SET ONCDANS=LV
+7 IF DATEDX<3180000
SET ONCDANS=$SELECT((MPH>9589)&(MPH<9993):8,LV[0:0,LV[1:1,LV[8:8,1:9)
+8 KILL LV,MPH
+9 QUIT ONCDANS
+10 ;
ICD9(ACD160,ONIEN) ;COMOR/COMP 1-10 for ICD9 and Secondary Diagnosis for ICD10
+1 NEW ONCDANS
+2 SET ONCDANS=$$GET1^DIQ(160,ACD160,ONIEN,"I")
+3 if ONCDANS'=""
SET ONCDANS=$$GET1^DIQ(80,ONCDANS,.01,"I")
+4 IF ($EXTRACT(ONCDANS,1,7)="Invalid")!($EXTRACT(ONCDANS,1,3)="-1")
SET ONCDANS=""
QUIT ONCDANS
+5 IF $GET(EXTRACT)'=3
SET ONCPHI=1
+6 ;P18 ICD-10 starts with Q,U,V,W and X are invalid
+7 IF (ONCPHI=1)
IF (($EXTRACT(ONCDANS,1)="C")!($EXTRACT(ONCDANS,1)="D")!($EXTRACT(ONCDANS,1)="F")!($EXTRACT(ONCDANS,1)="Q")!($EXTRACT(ONCDANS,1)="U")!($EXTRACT(ONCDANS,1)="V")!($EXTRACT(ONCDANS,1)="W")!($EXTRACT(ONCDANS,1)="X"))
SET ONCDANS=""
QUIT ONCDANS
+8 IF (($EXTRACT(ONCDANS,1,4)="T40.")!($EXTRACT(ONCDANS,1,4)="T43."))
IF (ONCPHI=1)
SET ONCDANS=""
QUIT ONCDANS
+9 ;
+10 IF $GET(ONCPHI)=0
SET ONCDANS=$PIECE(ONCDANS,".",1)_$PIECE(ONCDANS,".",2)
QUIT ONCDANS
+11 ;
+12 NEW ONCMO1,ONCMO2,ONCI1,ONCJ1
+13 KILL ^TMP($JOB,"ONCOMO")
+14 FOR ONCI1=1:1
SET ONCMO1=$PIECE($TEXT(COMO+ONCI1),";",3)
if ONCMO1=""
QUIT
FOR ONCJ1=1:1
SET ONCMO2=$PIECE(ONCMO1,"^",ONCJ1)
if ONCMO2=""
QUIT
Begin DoDot:1
+15 SET ^TMP($JOB,"ONCOMO",ONCMO2)=""
End DoDot:1
+16 IF $GET(ONCPHI)
IF (ONCDANS'="")
IF ($DATA(^TMP($JOB,"ONCOMO",ONCDANS)))
SET ONCDANS=""
+17 KILL ^TMP($JOB,"ONCOMO")
+18 SET ONCDANS=$PIECE(ONCDANS,".",1)_$PIECE(ONCDANS,".",2)
+19 QUIT ONCDANS
+20 ;
COMO ;ICD10 PHI Code.
+1 ;;272.4^292.0^292.2^292.81^292.82^292.83^292.84^292.85^292.89^292.9^357.6^760.72^760.73^760.74^760.75
+2 ;;F10.10^F10.20^F10.21^F10.27^F10.929^F10.950^F10.951^F10.96^F10.99^F10.231^F10.239^F10.159^F10.180^F10.181^F10.182
+3 ;;F10.282^F10.982^F10.188^F10.259^F10.280^F10.281^F10.288^F10.229^F11.10^F11.20^F11.21^F12.10^F12.20^F12.21^F12.90
+4 ;;F13.10^F13.20^F13.21^F14.10^F14.20^F14.21^F15.10^F15.20^F15.21^F16.10^F16.20^F16.21^F18.10^F19.10^F19.20^F19.21
+5 ;;291.81^291.82^291.89^142.6^K70.0^K70.10^K70.30^K70.9^357.6
+6 ;;P04.3^R78.0^R97.0^R97.1^R97.8^R75^D57.1^D57.00^D57.01^D57.02^D57.80^D57.819^D57.40^D57.419^Z63.72^Z13.89^Z21^Z71.7
+7 ;;T50.991A^T51.91^T51.1X1A^T51.1X2A^T51.1X3A^T51.1X4A^T51.2X1A^T51.2X2A^T51.2X3A^T51.2X4A^T51.9X1A^T51.9X2A^T51.9X3A
+8 ;;T51.9X4A^T51.0X1A^T51.0X2A^T51.0X3A^T51.0X4A^T51.6X1A^T51.8X1A^T51.8X2A^T51.8X3A^T51.8X4A^142.6
+9 ;;B20^B20.^B97.35^E24.2^E24.4^G31.2^G62.0^G62.2^G72.1^G72.2^K70^K86.0
+10 ;;O35.4^O35.5XX9^O98.7^O98.73^O99.31^O99.335^P04.12^P04.49^R78^R78.6^T36^T50.996S^Z20.6^Z21.^I42.6
+11 ;;G62.1^K29.00^K29.01^K29.20^K29.21^K70.10^K70.11^K70.2^K70.30^K70.31^K70.40^K70.41
+12 ;;O35.4XX0^O35.4XX1^O35.4XX2^O35.4XX3^O35.4XX4^O35.4XX5^O35.4XX9^O35.5XX0^O35.5XX1^O35.5XX2^O35.5XX3
+13 ;;O35.5XX4^O35.5XX5^O35.5XX9^O98.711^O98.712^O98.713^O98.719^O98.72^R78.1^R78.2^R78.3^R78.4^R78.5
+14 ;;O99.310^O99.311^O99.312^O99.313^O99.314^O99.315^O99.320^O99.322^O99.323^O99.324^O99.325
+15 ;;O99.330^O99.331^O99.332^O99.333^O99.334^P04.12^P04.13^P04.14^P04.15^P04.16^P04.17^P04.18^P04.19
+16 ;;P04.1A^P04.2^P04.3^P04.40^P04.41^P04.42^R75.^T40^T43
+17 QUIT
BRE22(IEN) ;Breast Surgery code User define in p18
+1 SET DATEDX=$$GET1^DIQ(165.5,IEN,3,"I")
+2 IF (DATEDX<3220101)!(DATEDX>3231231)
SET ACDANS=""
+3 QUIT ACDANS
CSF1(IEN) ;CSF1 ;P#18 default to 999 for specific Site and Histology
+1 NEW ONC164,ONC164H,ONCPS,ONCS,ONCH1,ONCH1H,DATEDX
SET ONC164=$$GET1^DIQ(165.5,IEN,20,"I")
SET ONCH1=0
+2 SET DATEDX=$$GET1^DIQ(165.5,IEN,3,"I")
SET ACDANS=$SELECT(DATEDX<3040000:"",1:$$GET1^DIQ(165.5,IEN,44.1,"I"))
+3 IF DATEDX>3180000
SET ACDANS=""
QUIT ACDANS
+4 SET ONCPS=$$GET1^DIQ(164,ONC164,1,"I")
SET ONCS=$EXTRACT($$HIST^ONCFUNC(IEN),1,4)
SET ONC164H=$EXTRACT(ONCPS,2,5)
+5 ;Hodgkin and Non-Hodgkin Lymphomas
+6 IF (ONC164H<44.1)!((ONC164H>44.1)&(ONC164H<69.0))!((ONC164H>69.0)&(ONC164H<69.5))!((ONC164H>69.7)&(ONC164H<80.99))
SET ONCH1H=1
Begin DoDot:1
+7 IF (((ONCS>9589)&(ONCS<9700))!((ONCS>9701)&(ONCS<9730))!(ONCS=9735)!(ONCS=9737)!(ONCS=9738)&(ONCH1H=1))
SET ACDANS=999
End DoDot:1
+8 SET ONCH1H=0
+9 IF (ONC164H<42)!((ONC164H>42.1)&(ONC164H<42.4))!((ONC164H>42.4)&(ONC164H<44.1))!((ONC164H>44.1)&(ONC164H<69))!((ONC164H>69.0)&(ONC164H<69.5))!((ONC164H>69.7)&(ONC164H<89.0))
SET ONCH1H=1
Begin DoDot:1
+10 IF ((ONCS>9810)&(ONCS<9819))!(ONCS=9823)!(ONCS=9827)!(ONCS=9837)
SET ACDANS=999
End DoDot:1
+11 ;Lymphoma of Ocular Adnexa and Skin of Eyelid
+12 IF ((ONCS>9589)&(ONCS<9700))!((ONCS>9701)&(ONCS<9739))!((ONCS>9810)&(ONCS<9819))!((ONCS>9819)&(ONCS<9838))
SET ONCH1=1
+13 IF (ONC164="C44.1")!(ONC164=("C69.0")!(ONC164="C69.5")!(ONC164="C69.6"))&(ONCH1=1)
SET ACDANS=999
+14 ;Kaposi Sarcoma with 9140 Histolgy
+15 IF ((ONC164H<81.0)&(ONCS=9140))
SET ACDANS=999
+16 QUIT ACDANS
+17 ;
CSF11(IEN) ;P#18 default to 999 for specific Site and Histology
+1 NEW ONC164,ONCPS,ONCS,ONCH1,DATEDX
SET ONC164=$$GET1^DIQ(165.5,IEN,20,"I")
SET ONCH1=0
+2 SET DATEDX=$$GET1^DIQ(165.5,IEN,3,"I")
SET ACDANS=$SELECT(DATEDX<3040000:"",1:$$GET1^DIQ(165.5,IEN,44.11,"I"))
+3 IF DATEDX>3180000
SET ACDANS=""
QUIT ACDANS
+4 SET ONCPS=$$GET1^DIQ(164,ONC164,1,"I")
SET ONCS=$EXTRACT($$HIST^ONCFUNC(IEN),1,4)
+5 IF ((ONCS>7999)&(ONCS<8714))!((ONCS>8799)&(ONCS<9137))!((ONCS>9140)&(ONCS<9509))!((ONCS>9509)&(ONCS<9515))!((ONCS>9519)&(ONCS<9583))
SET ONCH1=1
+6 IF ((ONC164="C44.1")&(ONCH1=1))
SET ACDANS=999
+7 QUIT ACDANS
+8 ;
CSF22(IEN) ;P#18
+1 NEW ONCS,DATEDX
+2 SET DATEDX=$$GET1^DIQ(165.5,IEN,3,"I")
SET ACDANS=$SELECT(DATEDX<3040000:"",1:$$GET1^DIQ(165.5,IEN,44.22,"I"))
+3 IF DATEDX>3180000
SET ACDANS=""
QUIT ACDANS
+4 SET ONCS=$EXTRACT($$HIST^ONCFUNC(IEN),1,4)
+5 IF ONCS=8247
SET ACDANS=999
+6 QUIT ACDANS
+7 ;
+8 ;
DATE(ACDANS) ;Convert date to NAACCR format CCYYMMDD
+1 NEW DATE,X
+2 SET DATE=""
+3 SET X=ACDANS
+4 DO DATEOT^ONCOES
+5 IF X'=""
Begin DoDot:1
+6 IF X="00/00/0000"
SET DATE=""
QUIT
+7 IF X="88/88/8888"
SET DATE=""
QUIT
+8 IF X="99/99/9999"
SET DATE=""
QUIT
+9 SET DATE=$EXTRACT(X,7,10)_$EXTRACT(X,1,2)_$EXTRACT(X,4,5)
+10 SET DATE=$SELECT($EXTRACT(DATE,5,8)=9999:$EXTRACT(DATE,1,4),$EXTRACT(DATE,7,8)=99:$EXTRACT(DATE,1,6),1:DATE)
End DoDot:1
+11 QUIT DATE
+12 ;
DTFLAG(ACDANS,ITEM) ;Compute Date Flag
+1 NEW FLAG,N,REC,ONCSCMA
+2 SET FLAG=""
+3 IF $PIECE($GET(^ONCO(165.5,IEN,0)),"^",16)>3221231
GOTO FLAG
+4 SET N=ITEM
+5 ;first check the Date Flag fields, make sure nothing entered
DO CHKFLGS
+6 IF ONCDTFLG'=""
SET FLAG=ONCDTFLG
GOTO FLAG
+7 ;patch#14
+8 IF (N=1261)
IF ((ACDANS="")!(ACDANS=9999999)!(ACDANS=8888888)!(ACDANS="0000000"))
SET FLAG=11
GOTO FLAG
+9 ;patch *2.2*4
+10 IF (N=1861)
IF (ACDANS'="")
IF (ACDANS'="9999999")
IF (ACDANS'="0000000")
IF (ACDANS'="8888888")
GOTO FLAG
+11 IF N=1861
IF ($$GET1^DIQ(165.5,IEN,71,"I")=4)!($$GET1^DIQ(165.5,IEN,71,"I")=5)
SET FLAG=11
GOTO FLAG
+12 IF ACDANS=""
Begin DoDot:1
+13 SET FLAG=$SELECT(N=1751:12,N=1861:10,1:"")
+14 IF N=683
IF $PIECE($GET(^ONCO(165.5,IEN,0)),"^",16)>3171231
SET FLAG=11
+15 SET ONCSCMA=$PIECE($GET(^ONCO(165.5,IEN,"SSD1")),"^",1)
+16 IF ($GET(ONCSCMA)'="00480")&('$$MELANOMA^ONCOU55(IEN))
QUIT
+17 IF N=833
IF $PIECE($GET(^ONCO(165.5,IEN,0)),"^",16)>3171231
SET FLAG=11
QUIT
+18 ;only set 833 above if Schema 00480 or Melanoma above
QUIT
End DoDot:1
+19 IF ACDANS'=""
IF ((N=833)!(N=683))
SET FLAG=""
GOTO FLAG
+20 IF ACDANS="9999999"
Begin DoDot:1
+21 SET FLAG=$SELECT((N=391)!(N=439)!(N=581)!(N=1751):12,(N=448)!(N=591)!(N=601)!(N=1201)!(N=1211)!(N=1221)!(N=1231)!(N=1241)!(N=1251)!(N=1271)!(N=1281)!(N=1661)!(N=1681)!(N=1701)!(N=1861)!(N=3171)!(N=3181)!(N=3221)!(N=3231):10,1:"")
QUIT
End DoDot:1
+22 IF ACDANS="8888888"
Begin DoDot:1
+23 SET FLAG=$SELECT((N=448)!(N=439):11,N=391:12,(N=1211)!(N=1221)!(N=1231)!(N=1241)!(N=3221)!(N=3231):15,1:"")
QUIT
End DoDot:1
+24 IF ACDANS="0000000"
Begin DoDot:1
+25 SET FLAG=$SELECT((N=591)!(N=601)!(N=1201)!(N=1211)!(N=1221)!(N=1231)!(N=1241)!(N=1251)!(N=1271)!(N=1281)!(N=1661)!(N=1681)!(N=1701)!(N=1861)!(N=3171)!(N=3181)!(N=3221)!(N=3231):11,N=391:12,(N=448)!(N=439):15,1:"")
QUIT
End DoDot:1
FLAG KILL ONCDTFLG,ZZFLDNUM
+1 QUIT FLAG
+2 ;
CHKFLGS ;CHECK THE DATE FLAG FIELDS IF USER NEEDED TO OVERRIDE VALUE
+1 ; if the DATE FLAG field is not NULL use that value to override the
+2 ; calculated value from DTFLAG entry point above
+3 SET ONCDTFLG=""
+4 SET ZZFLDNUM=$SELECT(N=391:999.1,N=448:999.2,N=439:999.3,N=581:999.4,N=591:999.5,N=601:999.6,N=1271:999.7,N=1201:999.8,1:"")
+5 IF ZZFLDNUM=""
SET ZZFLDNUM=$SELECT(N=3171:999.9,N=3181:999.11,N=1211:999.12,N=3221:999.13,N=3231:999.14,N=1221:999.15,N=1231:999.16,N=1241:999.17,1:"")
+6 IF ZZFLDNUM=""
SET ZZFLDNUM=$SELECT(N=1251:999.18,N=1281:999.19,N=1861:999.21,N=1751:999.22,N=1661:999.23,N=1681:999.24,N=1701:999.25,N=833:7018,N=683:7014,1:"")
+7 IF ZZFLDNUM=""
QUIT
+8 SET ONCDTFLG=$$GET1^DIQ(165.5,IEN,ZZFLDNUM,"I")
+9 QUIT
+10 ;
ADPCD(IEN) ;Addr Current--Postal Code [1830] (added in patch #13)
+1 SET ITEM=1830
DO CHKADDS
IF ONCADDF'=""
QUIT ONCADDF
+2 SET ONCADDF=$$GET1^DIQ(160,ACD160,.116,"E")
if ONCADDF=75999
SET ONCADDF=999999999
+3 QUIT ONCADDF
+4 ;
ADDDXST(IEN) ;Addr at DX--State [80] 145-146
+1 ;check overrides
SET ITEM=80
DO CHKADDS
IF ONCADDF'=""
QUIT ONCADDF
+2 SET XX=$SELECT($$GET1^DIQ(165.5,IEN,16,"I")'="":$$GET1^DIQ(5,$$GET1^DIQ(165.5,IEN,16,"I"),1,"I"),1:"")
+3 SET XX=$SELECT(XX="CANAD":"CD",XX="EU":"YY",XX="FG":"YY",XX="MX":"XX",XX="NF":"NL",XX="PH":"XX",XX="UN":"ZZ",1:XX)
+4 QUIT XX
+5 ;
CHKADDS ;CHECK THE ADDRESS--STATE & COUNTRY FIELDS IF USER NEEDED TO OVERRIDE
+1 ; if the ADDRESS--STATE/COUNTRY field is not NULL use that value to
+2 ; overwrite the calculated value from the ADDDXST entry point and the
+3 ; CSTST,ADDCTRY entry points in ONCACDU2
+4 SET ONCADDF=""
SET N=ITEM
+5 SET ZZFLDNUM=$SELECT(N=80:999.26,N=102:999.27,N=1820:999.28,N=1830:999.289,N=1832:999.29,1:"")
+6 IF ZZFLDNUM=""
QUIT
+7 SET ONCADDF=$$GET1^DIQ(165.5,IEN,ZZFLDNUM,"I")
+8 KILL N,ZZFLDNUM
QUIT
+9 ;
CNTY(IEN) ;COUNTY AT DX [90] 156-158
+1 NEW FIPSCODE
+2 SET FIPSCODE=$$GET1^DIQ(165.5,IEN,10,"I")
+3 IF (FIPSCODE=998)!(FIPSCODE=999)
GOTO QCNTY
+4 SET FIPSCODE=$EXTRACT($$GET1^DIQ(165.5,IEN,10,"I"),3,5)
QCNTY QUIT FIPSCODE
+1 ;
AGEDX(IEN) ;Age at Diagnosis [230] 119-121
+1 NEW ACDAGE,D0,X
+2 SET D0=IEN
+3 DO AGE^ONCOCOM
SET ACDAGE=$SELECT(X=""!(X<0)!(X>999):"",1:X)
+4 QUIT ACDAGE
+5 ;
OCCUP(ACD160) ;Text--Usual Occupation [310] 143-182
+1 NEW X,OCCUP
+2 SET X="UNKNOWN"
+3 SET OCCUP=$ORDER(^ONCO(160,ACD160,7,0))
+4 IF OCCUP'<1
Begin DoDot:1
+5 NEW OCC
+6 SET OCC=$PIECE($GET(^ONCO(160,ACD160,7,OCCUP,0)),U,1)
+7 if OCC=""
QUIT
+8 SET X=OCC
End DoDot:1
+9 QUIT X
+10 ;
IND(ACD160) ;Text--Usual Industry [320] 183-222
+1 NEW X,OCCUP
+2 SET X="UNKNOWN"
+3 SET OCCUP=$ORDER(^ONCO(160,ACD160,7,0))
+4 IF OCCUP'<1
Begin DoDot:1
+5 NEW IND
+6 SET IND=$PIECE($GET(^ONCO(160,ACD160,7,OCCUP,0)),U,4)
+7 if IND=""
QUIT
+8 SET X=IND
End DoDot:1
+9 QUIT X
+10 ;
TOB(IEN) ;Tobacco History [340] 224-224 VACCR extract only
+1 NEW X,AASTOB
+2 SET X=$PIECE($GET(^ONCO(160,ACD160,8)),U,2)
+3 SET AASTOB=$SELECT(X="Y":"Y",X="N":0,X="U":9,1:X)
+4 IF AASTOB="Y"
Begin DoDot:1
+5 NEW X
SET X=""
+6 SET X=$ORDER(^ONCO(160,ACD160,5,X),-1)
+7 IF X'<1
IF $GET(^ONCO(160,ACD160,5,X,0))'=""
Begin DoDot:2
+8 NEW Y
SET Y=^ONCO(160,ACD160,5,X,0)
+9 ;Previous use
IF $PIECE(Y,U,3)'=""
SET AASTOB=5
QUIT
+10 SET AASTOB=$SELECT($PIECE(Y,U)=1:1,$PIECE(Y,U)=2:2,$PIECE(Y,U)=3:2,$PIECE(Y,U)=4:3,$PIECE(Y,U)=5:3,$PIECE(Y,U)=7:4,1:9)
End DoDot:2
+11 IF AASTOB="Y"
SET AASTOB=9
End DoDot:1
+12 QUIT AASTOB
+13 ;
ALC(IEN) ;Alcohol History [350] 225-225 VACCR extract only
+1 NEW X,AASALCO
+2 SET X=$PIECE($GET(^ONCO(160,ACD160,8)),U,3)
+3 SET AASALCO=$SELECT(X="Y":"Y",X="N":0,X="U":9,1:X)
+4 IF AASALCO="Y"
Begin DoDot:1
+5 NEW X
SET X=""
+6 SET X=$ORDER(^ONCO(160,ACD160,6,X),-1)
+7 IF X'<1
IF $GET(^ONCO(160,ACD160,6,X,0))'=""
Begin DoDot:2
+8 NEW Y
SET Y=^ONCO(160,ACD160,6,X,0)
+9 ;Past history of alcohol use
IF $PIECE(Y,U,4)'=""
SET AASALCO=2
QUIT
+10 SET AASALCO=1
End DoDot:2
+11 IF AASALCO="Y"
SET AASALCO=9
End DoDot:1
+12 QUIT AASALCO
+13 ;
SG(IEN,TYPE) ;TNM Stage Groups
+1 ;TNM Path Stage Group [910] 569-570
+2 ;TNM Clin Stage Group [970] 579-580
+3 NEW GS
+4 SET GS=""
+5 IF TYPE=""
QUIT GS
+6 IF TYPE="P"
SET GS=$$GET1^DIQ(165.5,IEN,88,"I")
+7 IF TYPE="C"
SET GS=$$GET1^DIQ(165.5,IEN,38,"I")
+8 QUIT GS
+9 ;
CC ;Comorbid/Complication 1-10
+1 ;No longer needed. Used by NAACCR v11.3.
+2 ;[3110] 675-679
+3 ;[3120] 680-684
+4 ;[3130] 685-689
+5 ;[3140] 690-694
+6 ;[3150] 695-699
+7 ;[3160] 700-704
+8 ;[3161] 717-721
+9 ;[3162] 722-726
+10 ;[3163] 727-731
+11 ;[3164] 732-736
+12 ;S CCEX(1)="00000"
+13 ;F CCSUB=1:1:10 S CC(CCSUB)=""
+14 ;S CCSUB=0
+15 ;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)
+16 ;F CCEXSUB=1:1:10 S CCEX(CCEXSUB)=""
+17 ;I CC(1)="" Q
+18 ;I EXT="VACCR" F CCSUB=1:1:10 S CCEX(CCSUB)=$P(CC(CCSUB),".",1)_$P(CC(CCSUB),".",2) G CCEX
+19 ;S CCEXSUB=0
+20 ;S CCSUB=0 F S CCSUB=$O(CC(CCSUB)) Q:CCSUB'>0 D
+21 ;.I ($E(CC(CCSUB),1)="E")!($E(CC(CCSUB),1)="V")!((+CC(CCSUB)>99.9)&(+CC(CCSUB)<290))!(+CC(CCSUB)>319) S CCEXSUB=CCEXSUB+1,CCEX(CCEXSUB)=$P(CC(CCSUB),".",1)_$P(CC(CCSUB),".",2)
CCEX ;K CC,CCEXSUB,CCSUB,FLD
+1 QUIT
+2 ;
RXCOD(IEN) ;RX Coding System--Current [1460] 888-889
+1 NEW OUT
+2 SET OUT="06"
+3 QUIT OUT
+4 ;
FHCT ;Family History of Cancer Text 1456-1505 VACCR extract only
+1 KILL ONC
SET IEN160=ACD160_","
DO GETS^DIQ(160,IEN160,"44*","","ONC")
+2 SET (ACDANS,FHCTIEN)=""
+3 FOR
SET FHCTIEN=$ORDER(ONC(160.044,FHCTIEN))
if FHCTIEN'>0
QUIT
Begin DoDot:1
+4 SET FHCT=ONC(160.044,FHCTIEN,.01)_"("_ONC(160.044,FHCTIEN,1)_")"
+5 if ($LENGTH(ACDANS)+$LENGTH(FHCT))>50
QUIT
+6 SET ACDANS=ACDANS_FHCT_"/"
End DoDot:1
+7 SET ACDANS=$EXTRACT(ACDANS,1,$LENGTH(ACDANS)-1)
+8 KILL ONC,IEN160,FHCTIEN,FHCT
+9 QUIT
+10 ;
PHCT ;Patient History of Cancer Text 1785-1804 VACCR extract only
+1 SET ACDANS=""
+2 FOR I=148.1,148.2,148.3,148.4
SET PHCTPT=$$GET1^DIQ(165.5,IEN,I,"I")
Begin DoDot:1
+3 if PHCTPT=""
QUIT
+4 SET PHCT=$$GET1^DIQ(164.2,PHCTPT,.01,"I")
+5 if PHCT="NOT APPLICABLE"
QUIT
+6 if ($LENGTH(ACDANS)+$LENGTH(PHCT))>20
QUIT
+7 SET ACDANS=ACDANS_PHCT_"/"
End DoDot:1
+8 SET ACDANS=$EXTRACT(ACDANS,1,$LENGTH(ACDANS)-1)
+9 KILL I,PHCTPT,PHCT
+10 QUIT
+11 ;
NL ;Name--Last [2230] 1947-1971
+1 SET ACDANS=$$STRIP^XLFSTR(ACDANS," !""""#$%&'()*+,./:;<=>?[>]^_\{|}~`")
+2 QUIT
