ONCCSV2A.m

ONCCSV2A ;Hines OIFO/GWB - Collaborative Staging v2 Conversion ;06/23/10

 ;;2.2;ONCOLOGY;**1**;Jul 31, 2013;Build 8

 ;

 N EXT,LN,METS,SD,TS,HST,HST14,QUIT,S34,PS

 N SSF1,SSF2,SSF3,SSF4,SSF5,SSF6

 S PS=$P($G(^ONCO(165.5,IEN,2)),U,1)

 S HST=$$HIST^ONCFUNC(IEN)

 S HST14=$E(HST,1,4)

 S TS=$P($G(^ONCO(165.5,IEN,"CS1")),U,10)

 S EXT=$P($G(^ONCO(165.5,IEN,"CS")),U,11)

 S LN=$P($G(^ONCO(165.5,IEN,"CS")),U,12)

 S METS=$P($G(^ONCO(165.5,IEN,"CS")),U,3)

 S SSF1=$P($G(^ONCO(165.5,IEN,"CS")),U,5)

 S SSF2=$P($G(^ONCO(165.5,IEN,"CS")),U,6)

 S SSF3=$P($G(^ONCO(165.5,IEN,"CS")),U,7)

 S SSF4=$P($G(^ONCO(165.5,IEN,"CS")),U,8)

 S SSF5=$P($G(^ONCO(165.5,IEN,"CS")),U,9)

 S SSF6=$P($G(^ONCO(165.5,IEN,"CS")),U,10)

 S SD=$P($G(^ONCO(165.5,IEN,"CS3")),U,1)

 ;

 ;AdrenalGland C74.0-C74.1, C74.9

 I $E(PS,3,4)=74 D  Q

 .D 2,3,4,5,6

 ;

 ;Appendix C18.1

 ;CarcinoidAppendix C18.1 (M-8153, 8240-8242, 8246, 8249) 

 ;GISTAppendix C18.1 (M-8935-8936) 

 I (PS=67181) D  Q

 .D

 ..I (HST14=8153)!((HST14>8239)&(HST14<8243))!(HST14=8246)!(HST14=8249) Q

 ..I (HST14=8935)!(HST14=8936) Q

 ..S:SSF1="080" $P(^ONCO(165.5,IEN,"CS"),U,5)=997

 .D 2,3,4,5,6

 ;

 ;BileDuctsIntraHepat C22.0, C22.1

 ;Liver C22.0, C22.1

 I (PS=67220)!(PS=67221) D  Q

 .I (PS=67220)&((HST14>7999)&(HST14<8158)!(HST14>8161)&(HST14<8176)!(HST14>8189)&(HST14<9137)!(HST14>9140)&(HST14<9583)!(HST14=9700)!(HST14=9701)) D

 ..S:EXT=200 $P(^ONCO(165.5,IEN,"CS"),U,11)=350

 ..S:EXT=300 $P(^ONCO(165.5,IEN,"CS"),U,11)=390

 ..S:EXT=500 $P(^ONCO(165.5,IEN,"CS"),U,11)=170

 ..S:EXT=510 $P(^ONCO(165.5,IEN,"CS"),U,11)=150

 ..S:EXT=520 $P(^ONCO(165.5,IEN,"CS"),U,11)=370

 ..S:EXT=530 $P(^ONCO(165.5,IEN,"CS"),U,11)=250

 ..S:EXT=540 $P(^ONCO(165.5,IEN,"CS"),U,11)=250

 ..S:EXT=550 $P(^ONCO(165.5,IEN,"CS"),U,11)=380

 ..S:EXT=560 $P(^ONCO(165.5,IEN,"CS"),U,11)=420

 ..S:EXT=580 $P(^ONCO(165.5,IEN,"CS"),U,11)=645

 ..S:EXT=650 $P(^ONCO(165.5,IEN,"CS"),U,11)=440

 ..S:EXT=670 $P(^ONCO(165.5,IEN,"CS"),U,11)=635

 ..S:EXT=760 $P(^ONCO(165.5,IEN,"CS"),U,11)=770

 .I (PS=67221)&((HST14=8170)!(HST14=8171)!(HST14=8171)!(HST14=8172)!(HST14=8173)!(HST14=8174)!(HST14=8175)) D

 ..S:EXT=200 $P(^ONCO(165.5,IEN,"CS"),U,11)=350

 ..S:EXT=300 $P(^ONCO(165.5,IEN,"CS"),U,11)=390

 ..S:EXT=500 $P(^ONCO(165.5,IEN,"CS"),U,11)=170

 ..S:EXT=510 $P(^ONCO(165.5,IEN,"CS"),U,11)=150

 ..S:EXT=520 $P(^ONCO(165.5,IEN,"CS"),U,11)=370

 ..S:EXT=530 $P(^ONCO(165.5,IEN,"CS"),U,11)=250

 ..S:EXT=540 $P(^ONCO(165.5,IEN,"CS"),U,11)=250

 ..S:EXT=550 $P(^ONCO(165.5,IEN,"CS"),U,11)=380

 ..S:EXT=560 $P(^ONCO(165.5,IEN,"CS"),U,11)=420

 ..S:EXT=580 $P(^ONCO(165.5,IEN,"CS"),U,11)=645

 ..S:EXT=650 $P(^ONCO(165.5,IEN,"CS"),U,11)=440

 ..S:EXT=670 $P(^ONCO(165.5,IEN,"CS"),U,11)=635

 ..S:EXT=760 $P(^ONCO(165.5,IEN,"CS"),U,11)=770

 .D 3,4,5,6

 ;

 ;Bladder C67.0-C67.9

 I $E(PS,3,4)=67 D  Q

 .S:EXT=200 $P(^ONCO(165.5,IEN,"CS"),U,11)=240

 .S:EXT=400 $P(^ONCO(165.5,IEN,"CS"),U,11)=430

 .S:EXT=450 $P(^ONCO(165.5,IEN,"CS"),U,11)=810

 .D 1,2,3,4,5,6

 ;

 ;Bone C40.0-C40.3, C40.8-C40.9, C41.0-C41.4, C41.8-C41.9

 I ($E(PS,3,4)=40)!($E(PS,3,4)=41) D  Q

 .S:METS=55 $P(^ONCO(165.5,IEN,"CS"),U,3)=60

 .D 1,2,3,4,5,6

 ;

 ;Brain C70.0, C71.0-C71.9

 I (PS=67700)!($E(PS,3,4)=71) D  Q

 .S:LN=888 $P(^ONCO(165.5,IEN,"CS"),U,12)=988

 .D 2,3,4,5,6

 ;

 ;Breast C50.0-C50.6, C50.8-C50.9

 I $E(PS,3,4)=50 D  Q

 .S:EXT=720 $P(^ONCO(165.5,IEN,"CS"),U,11)=710

 .S:SSF4=888 $P(^ONCO(165.5,IEN,"CS"),U,8)=987

 .S:SSF5=888 $P(^ONCO(165.5,IEN,"CS"),U,9)=987

 .S:SSF6=888 $P(^ONCO(165.5,IEN,"CS"),U,10)=987

 ;

 ;BuccalMucosa C06.0-C06.1

 I (PS=67060)!(PS=67061) D  Q

 .S:EXT=650 $P(^ONCO(165.5,IEN,"CS"),U,11)=550

 .S:EXT=670 $P(^ONCO(165.5,IEN,"CS"),U,11)=740

 .S:EXT=730 $P(^ONCO(165.5,IEN,"CS"),U,11)=805

 .D SSF12

 ;

 ;CNSOther C70.1, C70.9, C72.0-C72.5, C72.8-C72.9

 I (PS=67701)!(PS=67709)!($E(PS,3,4)=72) D  Q

 .D 2,3,4,5,6

 ;

 ;Colon C18.0, C18.2-C18.9

 ;GISTColon C18.0, C18.2-C18.9 (M-8935-8936) 

 ;NETColon C18.0, C18.2-C18.9 (M-8153, 8240-8242, 8246, 8249) 

 I (PS=67180)!(PS=67182)!(PS=67183)!(PS=67184)!(PS=67185)!(PS=67186)!(PS=67187)!(PS=67188)!(PS=67189) D  Q

 .D

 ..I (HST14=8935)!(HST14=8936) Q

 ..I (HST14=8153)!((HST14>8239)&(HST14<8243))!(HST14=8246)!(HST14=8249) Q

 ..S:SSF1="080" $P(^ONCO(165.5,IEN,"CS"),U,5)=997

 .D 2,3,4,5,6

 ;

 ;Conjunctiva C69.0

 I PS=67690 D  Q

 .S:(TS>980)&(TS<990) $P(^ONCO(165.5,IEN,"CS1"),U,10)=980

 .S:EXT=700 $P(^ONCO(165.5,IEN,"CS"),U,11)=730

 .D 1,2,3,4,5,6

 ;

 ;CorpusAdenosarcoma C54.0-C54.3, C54.8-C54.9, C55.9

 ;(M-8933) 

 I (($E(PS,3,4)=54)!(PS=67559))&(HST14=8933) D  Q

 .S:EXT=700 $P(^ONCO(165.5,IEN,"CS"),U,11)=710

 .D 1,2,3,4,5,6

 S:$P($G(^ONCO(165.5,IEN,"CS")),U,6)="" $P(^ONCO(165.5,IEN,"CS"),U,6)=988

 ;

 ;CorpusCarcinoma C54.0-C54.3, C54.8-C54.9, C55.9

 ;(M-8000-8790,8980-8981,9700-9701) 

 I (($E(PS,3,4)=54)!(PS=67559))&((HST14>7999)&(HST14<8791)!(HST14=8980)!(HST14=8981)!(HST14=9700)!(HST14=9701)) D  Q

 .S:EXT=620 $P(^ONCO(165.5,IEN,"CS"),U,11)=645

 .S:EXT=700 $P(^ONCO(165.5,IEN,"CS"),U,11)=710

 .D 1,2,3,4,5,6

 S:$P($G(^ONCO(165.5,IEN,"CS")),U,6)="" $P(^ONCO(165.5,IEN,"CS"),U,6)=988

 ;

 ;CorpusSarcoma C54.0-C54.3, C54.8-C54.9, C55.9

 ;(M-8800-8932,8934-8974,8982-9136,9141-9582)

 I (($E(PS,3,4)=54)!(PS=67559))&((HST14>8799)&(HST14<8933)!(HST14>8933)&(HST14<8975)!(HST14>8981)&(HST14<9137)!(HST14>9140)&(HST14<9583)) D  Q

 .S:EXT=700 $P(^ONCO(165.5,IEN,"CS"),U,11)=710

 .D 1,2,3,4,5,6

 S:$P($G(^ONCO(165.5,IEN,"CS")),U,6)="" $P(^ONCO(165.5,IEN,"CS"),U,6)=988

 ;

 ;EndocrineOther C37.9, C75.0, C75.4-C75.5, C75.8-C75.9

 I (PS=67379)!(PS=67750)!(PS=67754)!(PS=67755)!(PS=67758)!(PS=67759) D  Q

 .D 2,3,4,5,6

 ;

 ;EpiglottisAnterior C10.1

 I PS=67101 D  Q

 .S:EXT=200 $P(^ONCO(165.5,IEN,"CS"),U,11)=305

 .D SSF12

 ;

 ;Esophagus C15.0-C15.5, C15.8-C15.9

 ;GISTEsophagus  C15.0-C15.5, C15.8-C15.9 (M-8935-8936) 

 I $E(PS,3,4)=15 D  Q

 .D 1,2,3,4,5,6

 ;

 ;EsophagusGEJunction C16.0, C16.1, C16.2

 ;GISTStomach C16.0-C16.6, C16.8-C16.9 (M-8935-8936)

 ;NETStomach C16.0-C16.6, C16.8-C16.9 (M-8153, 8240-8242, 8246, 8249) 

 ;Stomach C16.1-C16.6, C16.8-C16.9

 I $E(PS,3,4)=16 D  Q

 .D 1,2,3,4,5,6

 ;

 ;EyeOther C69.1-C69.4, C69.8-C69.9

 I $E(PS,3,4)=69 D  Q

 .D 1,2,3,4,5,6

 ;

 ;FallopianTube C57.0

 I PS=67570 D  Q

 .S:EXT=700 $P(^ONCO(165.5,IEN,"CS"),U,11)=680

 .S:EXT=710 $P(^ONCO(165.5,IEN,"CS"),U,11)=660

 .D 1,2,3,4,5,6

 ;

 ;FloorMouth C04.0-C04.1, C04.8-C04.9

 I $E(PS,3,4)="04" D  Q

 .S:EXT=640 $P(^ONCO(165.5,IEN,"CS"),U,11)=550

 .D SSF12

 ;

 ;Gallbladder C23.9

 I PS=67239 D  Q

 .D 1,2,3,4,5,6

 ;

 ;GenitalFemaleOther C57.7-C57.9

 I (PS=67577)!(PS=67578)!(PS=67579) D  Q

 .D 1,2,3,4,5,6

 ;

 ;GenitalMaleOther C63.0-C63.1, C63.7-C63.9

 I (PS=67630)!(PS=67631)!(PS=67637)!(PS=67639) D  Q

 .D 1,2,3,4,5,6

 ;

 ;GISTPeritoneum C48.0-C48.2, C48.8 (M-8935-8936) 

 ;Peritoneum C48.1-C48.2, C48.8

 ;PeritoneumFemaleGen C48.0-C48.2, C48.8

 I $E(PS,3,4)=48 D  Q

 .D 1,2,3,4,5,6

 ;

 ;GISTRectum C19.9, C20.9 (M-8935-8936)

 ;NETRectum C19.9, C20.9 (M-8153, 8240-8242, 8246, 8249)

 ;Rectum C19.9, C20.9

 I (PS=67199)!(PS=67209) D  Q

 .D

 ..I (HST14=8935)!(HST14=8936) Q

 ..I (HST14=8153)!((HST14>8239)&(HST14<8243))!(HST14=8246)!(HST14=8249) Q

 ..S:SSF1="080" $P(^ONCO(165.5,IEN,"CS"),U,5)=997

 .D 2,3,4,5,6

 ;

 ;GISTSmallIntestine C17.0-C17.3, C17.8-C17.9 (M-8935-8936)

 ;NETSmallIntestine C17.0-C17.3, C17.8-C17.9 (M-8153, 8240-8242, 8246,

 ;8249)

 ;SmallIntestine C17.0-C17.3, C17.8-C17.9

 I $E(PS,3,4)=17 D  Q

 .D 1,2,3,4,5,6

 ;

 ;GumLower C03.1, C06.2

 ;GumOther C03.9

 ;GumUpper C03.0

 I (PS=67031)!(PS=67062)!(PS=67039)!(PS=67030) D  Q

 .S:EXT=790 $P(^ONCO(165.5,IEN,"CS"),U,11)=805

 .D SSF12

 ;

 ;HeartMediastinum C38.0-C38.3, C38.8

 I (PS=67380)!(PS=67381)!(PS=67382)!(PS=67383)!(PS=67388) D  Q

 .D 1,2,3,4,5,6

 ;

 ;Hypopharynx C12.9, C13.0-C13.2, C13.8-C13.9

 I (PS=67129)!($E(PS,3,4)=13) D  Q

 .S:EXT=150 $P(^ONCO(165.5,IEN,"CS"),U,11)=420

 .S:EXT=510 $P(^ONCO(165.5,IEN,"CS"),U,11)=450

 .S:EXT=610 $P(^ONCO(165.5,IEN,"CS"),U,11)=560

 .S:EXT=660 $P(^ONCO(165.5,IEN,"CS"),U,11)=635

 .D SSF12

 ;

 ;IllDefinedOther

 ;C42.0-C42.4, C76.0-C76.5, C76.7-C76.8, C77.0-C77.5, C77.8-C77.9, C80.9

 I ($E(PS,3,4)=42)!($E(PS,3,4)=76)!($E(PS,3,4)=77)!(PS=67809) D  Q

 .S:EXT=888 $P(^ONCO(165.5,IEN,"CS"),U,11)=988

 .S:LN=888 $P(^ONCO(165.5,IEN,"CS"),U,12)=988

 .S:METS=88 $P(^ONCO(165.5,IEN,"CS"),U,3)=98

 .D 1,2,3,4,5,6

 ;

 ;IntracranialGland C75.1, C75.2, C75.3

 I (PS=67751)!(PS=67752)!(PS=67753) D  Q

 .D 2,3,4,5,6

 ;

 ;KidneyParenchyma C64.9

 I PS=67649 D  Q

 .S:EXT=390 $P(^ONCO(165.5,IEN,"CS"),U,11)=625

 .D 1,2,3,4,5,6

 ;

 ;KidneyRenalPelvis C65.9, C66.9

 I (PS=67659)!(PS=67669) D  Q

 .S:EXT=750 $P(^ONCO(165.5,IEN,"CS"),U,11)=690

 .D 1,2,3,4,5,6

 ;

 ;LacrimalGland C69.5

 ;LacrimalSac C69.5

 I PS=67695 D  Q

 .D 1,2,3,4,5,6

 ;

 ;LarynxGlottic C32.0

 ;LarynxOther C32.3, C32.8-C32.9

 ;LarynxSubglottic C32.2

 ;LarynxSupraglottic C32.1

 I $E(PS,3,4)=32 D  Q

 .I PS=67320 S:EXT=100 $P(^ONCO(165.5,IEN,"CS"),U,11)=130

 .I PS=67322 S:EXT=730 $P(^ONCO(165.5,IEN,"CS"),U,11)=800

 .I PS=67321 S:EXT=670 $P(^ONCO(165.5,IEN,"CS"),U,11)=690

 .D SSF12

 ;

 ;LipLower C00.1, C00.4, C00.6

 ;LipOther C00.2, C00.5, C00.8-C00.9

 ;LipUpper C00.0, C00.3

 ;MiddleEar C30.1

 I ($E(PS,3,4)="00")!(PS=67301) D  Q

 .D SSF12

 ;

 ;Lung C34.0-C34.3, C34.8-C34.9

 I $E(PS,3,4)=34 D  Q

 .S:METS=10 $P(^ONCO(165.5,IEN,"CS"),U,3)=30

 .S:METS=39 $P(^ONCO(165.5,IEN,"CS"),U,3)=23

 .D 1,2,3,4,5,6

 S:$P($G(^ONCO(165.5,IEN,"CS")),U,5)="" $P(^ONCO(165.5,IEN,"CS"),U,5)=988

 ;

 ;MouthOther C05.8-C05.9, C06.8-C06.9

 I (PS=67058)!(PS=67059)!(PS=67068)!(PS=67069) D  Q

 .S:EXT=720 $P(^ONCO(165.5,IEN,"CS"),U,11)=800

 .D SSF12

 ;

 ;NasalCavity C30.0

 I PS=67300 D  Q

 .S:EXT=710 $P(^ONCO(165.5,IEN,"CS"),U,11)=760

 .D SSF12

 ;

 ;Nasopharynx C11.0-C11.3, C11.8-C11.9

 I $E(PS,3,4)=11 D  Q

 .S:EXT=750 $P(^ONCO(165.5,IEN,"CS"),U,11)=710

 .D SSF12

 ;

 ;Orbit C69.6

 I PS=67696 D  Q

 .D 1,2,3,4,5,6

 ;

 ;Oropharynx C09.0-C09.1, C09.8-C09.9, C10.0, C10.2-C10.4, C10.8-C10.9

 I ($E(PS,3,4)="09")!(PS=67100)!(PS=67102)!(PS=67103)!(PS=67104)!(PS=67108)!(PS=67109) D  Q

 .S:EXT=410 $P(^ONCO(165.5,IEN,"CS"),U,11)=630

 .S:EXT=620 $P(^ONCO(165.5,IEN,"CS"),U,11)=710

 .S:EXT=760 $P(^ONCO(165.5,IEN,"CS"),U,11)=750

 .D SSF12

 ;

 ;Ovary C56.9

 I PS=67569 D  Q

 .D 2,3,4,5,6

 ;

 ;PalateHard C05.0

 ;PalateSoft C05.1-C05.2

 I (PS=67050)!(PS=67051)!(PS=67052) D  Q

 .I PS=67050 D

 ..S:EXT=760 $P(^ONCO(165.5,IEN,"CS"),U,11)=790

 .I (PS=67051)!(PS=67052) D

 ..S:EXT=770 $P(^ONCO(165.5,IEN,"CS"),U,11)=670

 .D SSF12

 ;

 ;ParotidGland C07.9

 I PS=67079 D  Q

 .S:EXT=720 $P(^ONCO(165.5,IEN,"CS"),U,11)=405

 .D SSF12

 ;

 ;PharyngealTonsil C11.1

 I PS=67111 D  Q

 .S:EXT=570 $P(^ONCO(165.5,IEN,"CS"),U,11)=610

 .D SSF12

 ;

 ;PharynxOther C14.0, C14.2, C14.8

 I (PS=67140)!(PS=67142)!(PS=67148) D  Q

 .D SSF12

 ;

 ;Placenta C58.9

 I PS=67589 D  Q

 .S:LN=888 $P(^ONCO(165.5,IEN,"CS"),U,12)=988

 .D 2,3,4,5,6

 ;

 ;Pleura C38.4

 I PS=67384 D  Q

 .S:EXT=100 $P(^ONCO(165.5,IEN,"CS"),U,11)=160

 .D 2,3,4,5,6

 ;

 ;Prostate C61.9

 I PS=67619 D  Q

 .S:METS=45 $P(^ONCO(165.5,IEN,"CS"),U,3)=60

 .S:SSF1="000" $P(^ONCO(165.5,IEN,"CS"),U,5)=998

 .S:(SSF1>980)&(SSF1<990) $P(^ONCO(165.5,IEN,"CS"),U,5)=980

 .S:SSF2="000" $P(^ONCO(165.5,IEN,"CS"),U,6)=998

 .S:SSF2="080" $P(^ONCO(165.5,IEN,"CS"),U,6)=997

 .S:SSF3="020" $P(^ONCO(165.5,IEN,"CS"),U,7)=200

 .S:SSF3="021" $P(^ONCO(165.5,IEN,"CS"),U,7)=210

 .S:SSF3="022" $P(^ONCO(165.5,IEN,"CS"),U,7)=220

 .S:SSF3="023" $P(^ONCO(165.5,IEN,"CS"),U,7)=230

 .S:SSF3="030" $P(^ONCO(165.5,IEN,"CS"),U,7)=300

 .S:SSF3="032" $P(^ONCO(165.5,IEN,"CS"),U,7)=320

 .S:SSF3="040" $P(^ONCO(165.5,IEN,"CS"),U,7)=400

 .S:SSF3="041" $P(^ONCO(165.5,IEN,"CS"),U,7)=410

 .S:SSF3="042" $P(^ONCO(165.5,IEN,"CS"),U,7)=420

 .S:SSF3="043" $P(^ONCO(165.5,IEN,"CS"),U,7)=430

 .S:SSF3="045" $P(^ONCO(165.5,IEN,"CS"),U,7)=485

 .S:SSF3="048" $P(^ONCO(165.5,IEN,"CS"),U,7)=480

 .S:SSF3="050" $P(^ONCO(165.5,IEN,"CS"),U,7)=500

 .S:SSF3="052" $P(^ONCO(165.5,IEN,"CS"),U,7)=520

 .S:SSF3="060" $P(^ONCO(165.5,IEN,"CS"),U,7)=600

 .S:SSF3="070" $P(^ONCO(165.5,IEN,"CS"),U,7)=700

 .S:SSF3="095" $P(^ONCO(165.5,IEN,"CS"),U,7)=950

 .S:SSF3="096" $P(^ONCO(165.5,IEN,"CS"),U,7)=960

 .S:SSF3="097" $P(^ONCO(165.5,IEN,"CS"),U,7)=970

 .S:SSF3="098" $P(^ONCO(165.5,IEN,"CS"),U,7)=980

 .S:SSF3="099" $P(^ONCO(165.5,IEN,"CS"),U,7)=990

 ;

 ;SalivaryGlandOther C08.1, C08.8-C08.9

 ;SubmandibularGland C08.0

 I $E(PS,3,4)="08" D  Q

 .S:EXT=720 $P(^ONCO(165.5,IEN,"CS"),U,11)=405

 .D SSF12

 ;

 ;SinusEthmoid C31.1

 ;SinusMaxillary C31.0

 ;SinusOther C31.2-C31.3, C31.8-C31.9

 I $E(PS,3,4)=31 D  Q

 .I PS=67311 D

 ..S:EXT=140 $P(^ONCO(165.5,IEN,"CS"),U,11)=320

 ..S:EXT=240 $P(^ONCO(165.5,IEN,"CS"),U,11)=340

 .I PS=67310 D

 ..S:EXT=650 $P(^ONCO(165.5,IEN,"CS"),U,11)=600

 .D SSF12

 ;

 ;Skin C44.0, C44.2-C44.9

 ;SkinEyelid C44.1

 I $E(PS,3,4)=44 D  Q

 .I PS=67441 D

 ..S:EXT=500 $P(^ONCO(165.5,IEN,"CS"),U,11)=150

 ..S:EXT=700 $P(^ONCO(165.5,IEN,"CS"),U,11)=620

 .D 1,2,3,4,5,6

 ;

 ;Testis C62.0-C62.1, C62.9

 I $E(PS,3,4)=62 D  Q

 .S:METS=45 $P(^ONCO(165.5,IEN,"CS"),U,3)=60

 .S:SSF5="001" $P(^ONCO(165.5,IEN,"CS"),U,9)="010"

 .S:SSF5="002" $P(^ONCO(165.5,IEN,"CS"),U,9)="020"

 .S:SSF5="003" $P(^ONCO(165.5,IEN,"CS"),U,9)="030"

 .S:SSF6=888 $P(^ONCO(165.5,IEN,"CS"),U,10)=988

 ;

 ;Thyroid C73.9

 I PS=67739 D  Q

 .S:EXT=720 $P(^ONCO(165.5,IEN,"CS"),U,11)=550

 .S:LN=140 $P(^ONCO(165.5,IEN,"CS"),U,12)=150

 .D 2,3,4,5,6

 ;

 ;TongueAnterior C02.0-C02.3, C02.8-C02.9

 ;TongueBase C01.9, C02.4

 I ($E(PS,3,4)="02")!(PS=67019) D  Q

 .I (PS=67019)!(PS=67024) D

 ..S:EXT=820 $P(^ONCO(165.5,IEN,"CS"),U,11)=805

 .D SSF12

 ;

 ;AdnexaUterineOther C57.1-C57.4

 ;AmpullaVater C24.1

 ;NETAmpulla C24.1 (M-8153, 8240-8242, 8246, 8249)

 ;Anus C21.0-C21.2, C21.8

 ;BileDuctsDistal C24.0

 ;BileDuctsPerihilar C24.0

 ;BiliaryOther C24.8-C24.9

 ;CysticDuct" C24.0

 ;Cervix C53.0-C53.1, C53.8-C53.9

 ;DigestiveOther C26.0, C26.8-C26.9

 ;PancreasBodyTail C25.1-C25.2

 ;PancreasHead C25.0

 ;PancreasOther C25.3-C25.4, C25.7-C25.9

 ;Penis C60.0-C60.2, C60.8-C60.9

 ;RespiratoryOther C39.0, C39.8-C39.9

 ;Retroperitoneum C48.0

 ;Scrotum C63.2

 ;SoftTissue C47.0-C47.6, C47.8-C47.9, C49.0-C49.6, C49.8-C49.9

 ;Trachea C33.9

 ;Urethra C68.0

 ;UrinaryOther C68.1, C68.8-C68.9

 ;Vagina C52.9

 ;Vulva C51.0-C51.2, C51.8-C51.9

 S S34=$E(PS,3,4)

 I (S34=26)!(S34=53)!(PS=67248)!(PS=67249)!(PS=67240)!(S34=21)!(PS=67241)!(PS=67571)!(PS=6752)!(PS=67573)!(PS=67574)!(S34=25)!(S34=60)!(S34=39)!(PS=67480)!(PS=67632)!(S34=47)!(S34=49)!(PS=67339)!(S34=68)!(PS=67529)!(S34=51) D  Q

 .D 1,2,3,4,5,6

 ;

 Q

 ;

1 ;SSF1 = 888 to 988

 S:$P($G(^ONCO(165.5,IEN,"CS")),U,5)=888 $P(^ONCO(165.5,IEN,"CS"),U,5)=988

 Q

 ;

2 ;SSF2 = 888 to 988

 S:$P($G(^ONCO(165.5,IEN,"CS")),U,6)=888 $P(^ONCO(165.5,IEN,"CS"),U,6)=988

 Q

 ;

3 ;SSF3 = 888 to 988

 S:$P($G(^ONCO(165.5,IEN,"CS")),U,7)=888 $P(^ONCO(165.5,IEN,"CS"),U,7)=988

 Q

 ;

4 ;SSF4 = 888 to 988

 S:$P($G(^ONCO(165.5,IEN,"CS")),U,8)=888 $P(^ONCO(165.5,IEN,"CS"),U,8)=988

 Q

 ;

5 ;SSF5 = 888 to 988

 S:$P($G(^ONCO(165.5,IEN,"CS")),U,9)=888 $P(^ONCO(165.5,IEN,"CS"),U,9)=988

 Q

 ;

6 ;SSF6 = 888 to 988

 S:$P($G(^ONCO(165.5,IEN,"CS")),U,10)=888 $P(^ONCO(165.5,IEN,"CS"),U,10)=988

 Q

 ;

SSF12 ;SSF1 989 to 980

 ;SSF1 981-988 to 980

 ;SSF2 888 to 987

 S:(SSF1>980)&(SSF1<990) $P(^ONCO(165.5,IEN,"CS"),U,5)=980

 S:SSF2=888 $P(^ONCO(165.5,IEN,"CS"),U,6)=987

 Q

 ;

CLEANUP ;Cleanup

 K IEN

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---ONCCSV2A   15713     printed  Apr 09, 2024@21:28:22                                                                                                                                                                                                   Page 2

ONCCSV2A  ;Hines OIFO/GWB - Collaborative Staging v2 Conversion ;06/23/10

 +1       ;;2.2;ONCOLOGY;**1**;Jul 31, 2013;Build 8

 +2       ;

 +3        NEW EXT,LN,METS,SD,TS,HST,HST14,QUIT,S34,PS

 +4        NEW SSF1,SSF2,SSF3,SSF4,SSF5,SSF6

 +5        SET PS=$PIECE($GET(^ONCO(165.5,IEN,2)),U,1)

 +6        SET HST=$$HIST^ONCFUNC(IEN)

 +7        SET HST14=$EXTRACT(HST,1,4)

 +8        SET TS=$PIECE($GET(^ONCO(165.5,IEN,"CS1")),U,10)

 +9        SET EXT=$PIECE($GET(^ONCO(165.5,IEN,"CS")),U,11)

 +10       SET LN=$PIECE($GET(^ONCO(165.5,IEN,"CS")),U,12)

 +11       SET METS=$PIECE($GET(^ONCO(165.5,IEN,"CS")),U,3)

 +12       SET SSF1=$PIECE($GET(^ONCO(165.5,IEN,"CS")),U,5)

 +13       SET SSF2=$PIECE($GET(^ONCO(165.5,IEN,"CS")),U,6)

 +14       SET SSF3=$PIECE($GET(^ONCO(165.5,IEN,"CS")),U,7)

 +15       SET SSF4=$PIECE($GET(^ONCO(165.5,IEN,"CS")),U,8)

 +16       SET SSF5=$PIECE($GET(^ONCO(165.5,IEN,"CS")),U,9)

 +17       SET SSF6=$PIECE($GET(^ONCO(165.5,IEN,"CS")),U,10)

 +18       SET SD=$PIECE($GET(^ONCO(165.5,IEN,"CS3")),U,1)

 +19      ;

 +20      ;AdrenalGland C74.0-C74.1, C74.9

 +21       IF $EXTRACT(PS,3,4)=74

               Begin DoDot:1

 +22               DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +23      ;

 +24      ;Appendix C18.1

 +25      ;CarcinoidAppendix C18.1 (M-8153, 8240-8242, 8246, 8249) 

 +26      ;GISTAppendix C18.1 (M-8935-8936) 

 +27       IF (PS=67181)

               Begin DoDot:1

 +28               Begin DoDot:2

 +29                   IF (HST14=8153)!((HST14>8239)&(HST14<8243))!(HST14=8246)!(HST14=8249)

                           QUIT 

 +30                   IF (HST14=8935)!(HST14=8936)

                           QUIT 

 +31                   if SSF1="080"

                           SET $PIECE(^ONCO(165.5,IEN,"CS"),U,5)=997

                   End DoDot:2

 +32               DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +33      ;

 +34      ;BileDuctsIntraHepat C22.0, C22.1

 +35      ;Liver C22.0, C22.1

 +36       IF (PS=67220)!(PS=67221)

               Begin DoDot:1

 +37               IF (PS=67220)&((HST14>7999)&(HST14<8158)!(HST14>8161)&(HST14<8176)!(HST14>8189)&(HST14<9137)!(HST14>9140)&(HST14<9583)!(HST14=9700)!(HST14=9701))

                       Begin DoDot:2

 +38                       if EXT=200

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=350

 +39                       if EXT=300

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=390

 +40                       if EXT=500

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=170

 +41                       if EXT=510

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=150

 +42                       if EXT=520

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=370

 +43                       if EXT=530

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=250

 +44                       if EXT=540

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=250

 +45                       if EXT=550

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=380

 +46                       if EXT=560

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=420

 +47                       if EXT=580

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=645

 +48                       if EXT=650

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=440

 +49                       if EXT=670

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=635

 +50                       if EXT=760

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=770

                       End DoDot:2

 +51               IF (PS=67221)&((HST14=8170)!(HST14=8171)!(HST14=8171)!(HST14=8172)!(HST14=8173)!(HST14=8174)!(HST14=8175))

                       Begin DoDot:2

 +52                       if EXT=200

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=350

 +53                       if EXT=300

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=390

 +54                       if EXT=500

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=170

 +55                       if EXT=510

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=150

 +56                       if EXT=520

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=370

 +57                       if EXT=530

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=250

 +58                       if EXT=540

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=250

 +59                       if EXT=550

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=380

 +60                       if EXT=560

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=420

 +61                       if EXT=580

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=645

 +62                       if EXT=650

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=440

 +63                       if EXT=670

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=635

 +64                       if EXT=760

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=770

                       End DoDot:2

 +65               DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +66      ;

 +67      ;Bladder C67.0-C67.9

 +68       IF $EXTRACT(PS,3,4)=67

               Begin DoDot:1

 +69               if EXT=200

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=240

 +70               if EXT=400

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=430

 +71               if EXT=450

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=810

 +72               DO 1

                   DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +73      ;

 +74      ;Bone C40.0-C40.3, C40.8-C40.9, C41.0-C41.4, C41.8-C41.9

 +75       IF ($EXTRACT(PS,3,4)=40)!($EXTRACT(PS,3,4)=41)

               Begin DoDot:1

 +76               if METS=55

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,3)=60

 +77               DO 1

                   DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +78      ;

 +79      ;Brain C70.0, C71.0-C71.9

 +80       IF (PS=67700)!($EXTRACT(PS,3,4)=71)

               Begin DoDot:1

 +81               if LN=888

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,12)=988

 +82               DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +83      ;

 +84      ;Breast C50.0-C50.6, C50.8-C50.9

 +85       IF $EXTRACT(PS,3,4)=50

               Begin DoDot:1

 +86               if EXT=720

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=710

 +87               if SSF4=888

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,8)=987

 +88               if SSF5=888

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,9)=987

 +89               if SSF6=888

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,10)=987

               End DoDot:1

               QUIT 

 +90      ;

 +91      ;BuccalMucosa C06.0-C06.1

 +92       IF (PS=67060)!(PS=67061)

               Begin DoDot:1

 +93               if EXT=650

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=550

 +94               if EXT=670

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=740

 +95               if EXT=730

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=805

 +96               DO SSF12

               End DoDot:1

               QUIT 

 +97      ;

 +98      ;CNSOther C70.1, C70.9, C72.0-C72.5, C72.8-C72.9

 +99       IF (PS=67701)!(PS=67709)!($EXTRACT(PS,3,4)=72)

               Begin DoDot:1

 +100              DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +101     ;

 +102     ;Colon C18.0, C18.2-C18.9

 +103     ;GISTColon C18.0, C18.2-C18.9 (M-8935-8936) 

 +104     ;NETColon C18.0, C18.2-C18.9 (M-8153, 8240-8242, 8246, 8249) 

 +105      IF (PS=67180)!(PS=67182)!(PS=67183)!(PS=67184)!(PS=67185)!(PS=67186)!(PS=67187)!(PS=67188)!(PS=67189)

               Begin DoDot:1

 +106              Begin DoDot:2

 +107                  IF (HST14=8935)!(HST14=8936)

                           QUIT 

 +108                  IF (HST14=8153)!((HST14>8239)&(HST14<8243))!(HST14=8246)!(HST14=8249)

                           QUIT 

 +109                  if SSF1="080"

                           SET $PIECE(^ONCO(165.5,IEN,"CS"),U,5)=997

                   End DoDot:2

 +110              DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +111     ;

 +112     ;Conjunctiva C69.0

 +113      IF PS=67690

               Begin DoDot:1

 +114              if (TS>980)&(TS<990)

                       SET $PIECE(^ONCO(165.5,IEN,"CS1"),U,10)=980

 +115              if EXT=700

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=730

 +116              DO 1

                   DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +117     ;

 +118     ;CorpusAdenosarcoma C54.0-C54.3, C54.8-C54.9, C55.9

 +119     ;(M-8933) 

 +120      IF (($EXTRACT(PS,3,4)=54)!(PS=67559))&(HST14=8933)

               Begin DoDot:1

 +121              if EXT=700

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=710

 +122              DO 1

                   DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +123      if $PIECE($GET(^ONCO(165.5,IEN,"CS")),U,6)=""

               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,6)=988

 +124     ;

 +125     ;CorpusCarcinoma C54.0-C54.3, C54.8-C54.9, C55.9

 +126     ;(M-8000-8790,8980-8981,9700-9701) 

 +127      IF (($EXTRACT(PS,3,4)=54)!(PS=67559))&((HST14>7999)&(HST14<8791)!(HST14=8980)!(HST14=8981)!(HST14=9700)!(HST14=9701))

               Begin DoDot:1

 +128              if EXT=620

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=645

 +129              if EXT=700

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=710

 +130              DO 1

                   DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +131      if $PIECE($GET(^ONCO(165.5,IEN,"CS")),U,6)=""

               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,6)=988

 +132     ;

 +133     ;CorpusSarcoma C54.0-C54.3, C54.8-C54.9, C55.9

 +134     ;(M-8800-8932,8934-8974,8982-9136,9141-9582)

 +135      IF (($EXTRACT(PS,3,4)=54)!(PS=67559))&((HST14>8799)&(HST14<8933)!(HST14>8933)&(HST14<8975)!(HST14>8981)&(HST14<9137)!(HST14>9140)&(HST14<9583))

               Begin DoDot:1

 +136              if EXT=700

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=710

 +137              DO 1

                   DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +138      if $PIECE($GET(^ONCO(165.5,IEN,"CS")),U,6)=""

               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,6)=988

 +139     ;

 +140     ;EndocrineOther C37.9, C75.0, C75.4-C75.5, C75.8-C75.9

 +141      IF (PS=67379)!(PS=67750)!(PS=67754)!(PS=67755)!(PS=67758)!(PS=67759)

               Begin DoDot:1

 +142              DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +143     ;

 +144     ;EpiglottisAnterior C10.1

 +145      IF PS=67101

               Begin DoDot:1

 +146              if EXT=200

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=305

 +147              DO SSF12

               End DoDot:1

               QUIT 

 +148     ;

 +149     ;Esophagus C15.0-C15.5, C15.8-C15.9

 +150     ;GISTEsophagus  C15.0-C15.5, C15.8-C15.9 (M-8935-8936) 

 +151      IF $EXTRACT(PS,3,4)=15

               Begin DoDot:1

 +152              DO 1

                   DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +153     ;

 +154     ;EsophagusGEJunction C16.0, C16.1, C16.2

 +155     ;GISTStomach C16.0-C16.6, C16.8-C16.9 (M-8935-8936)

 +156     ;NETStomach C16.0-C16.6, C16.8-C16.9 (M-8153, 8240-8242, 8246, 8249) 

 +157     ;Stomach C16.1-C16.6, C16.8-C16.9

 +158      IF $EXTRACT(PS,3,4)=16

               Begin DoDot:1

 +159              DO 1

                   DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +160     ;

 +161     ;EyeOther C69.1-C69.4, C69.8-C69.9

 +162      IF $EXTRACT(PS,3,4)=69

               Begin DoDot:1

 +163              DO 1

                   DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +164     ;

 +165     ;FallopianTube C57.0

 +166      IF PS=67570

               Begin DoDot:1

 +167              if EXT=700

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=680

 +168              if EXT=710

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=660

 +169              DO 1

                   DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +170     ;

 +171     ;FloorMouth C04.0-C04.1, C04.8-C04.9

 +172      IF $EXTRACT(PS,3,4)="04"

               Begin DoDot:1

 +173              if EXT=640

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=550

 +174              DO SSF12

               End DoDot:1

               QUIT 

 +175     ;

 +176     ;Gallbladder C23.9

 +177      IF PS=67239

               Begin DoDot:1

 +178              DO 1

                   DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +179     ;

 +180     ;GenitalFemaleOther C57.7-C57.9

 +181      IF (PS=67577)!(PS=67578)!(PS=67579)

               Begin DoDot:1

 +182              DO 1

                   DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +183     ;

 +184     ;GenitalMaleOther C63.0-C63.1, C63.7-C63.9

 +185      IF (PS=67630)!(PS=67631)!(PS=67637)!(PS=67639)

               Begin DoDot:1

 +186              DO 1

                   DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +187     ;

 +188     ;GISTPeritoneum C48.0-C48.2, C48.8 (M-8935-8936) 

 +189     ;Peritoneum C48.1-C48.2, C48.8

 +190     ;PeritoneumFemaleGen C48.0-C48.2, C48.8

 +191      IF $EXTRACT(PS,3,4)=48

               Begin DoDot:1

 +192              DO 1

                   DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +193     ;

 +194     ;GISTRectum C19.9, C20.9 (M-8935-8936)

 +195     ;NETRectum C19.9, C20.9 (M-8153, 8240-8242, 8246, 8249)

 +196     ;Rectum C19.9, C20.9

 +197      IF (PS=67199)!(PS=67209)

               Begin DoDot:1

 +198              Begin DoDot:2

 +199                  IF (HST14=8935)!(HST14=8936)

                           QUIT 

 +200                  IF (HST14=8153)!((HST14>8239)&(HST14<8243))!(HST14=8246)!(HST14=8249)

                           QUIT 

 +201                  if SSF1="080"

                           SET $PIECE(^ONCO(165.5,IEN,"CS"),U,5)=997

                   End DoDot:2

 +202              DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +203     ;

 +204     ;GISTSmallIntestine C17.0-C17.3, C17.8-C17.9 (M-8935-8936)

 +205     ;NETSmallIntestine C17.0-C17.3, C17.8-C17.9 (M-8153, 8240-8242, 8246,

 +206     ;8249)

 +207     ;SmallIntestine C17.0-C17.3, C17.8-C17.9

 +208      IF $EXTRACT(PS,3,4)=17

               Begin DoDot:1

 +209              DO 1

                   DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +210     ;

 +211     ;GumLower C03.1, C06.2

 +212     ;GumOther C03.9

 +213     ;GumUpper C03.0

 +214      IF (PS=67031)!(PS=67062)!(PS=67039)!(PS=67030)

               Begin DoDot:1

 +215              if EXT=790

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=805

 +216              DO SSF12

               End DoDot:1

               QUIT 

 +217     ;

 +218     ;HeartMediastinum C38.0-C38.3, C38.8

 +219      IF (PS=67380)!(PS=67381)!(PS=67382)!(PS=67383)!(PS=67388)

               Begin DoDot:1

 +220              DO 1

                   DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +221     ;

 +222     ;Hypopharynx C12.9, C13.0-C13.2, C13.8-C13.9

 +223      IF (PS=67129)!($EXTRACT(PS,3,4)=13)

               Begin DoDot:1

 +224              if EXT=150

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=420

 +225              if EXT=510

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=450

 +226              if EXT=610

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=560

 +227              if EXT=660

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=635

 +228              DO SSF12

               End DoDot:1

               QUIT 

 +229     ;

 +230     ;IllDefinedOther

 +231     ;C42.0-C42.4, C76.0-C76.5, C76.7-C76.8, C77.0-C77.5, C77.8-C77.9, C80.9

 +232      IF ($EXTRACT(PS,3,4)=42)!($EXTRACT(PS,3,4)=76)!($EXTRACT(PS,3,4)=77)!(PS=67809)

               Begin DoDot:1

 +233              if EXT=888

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=988

 +234              if LN=888

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,12)=988

 +235              if METS=88

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,3)=98

 +236              DO 1

                   DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +237     ;

 +238     ;IntracranialGland C75.1, C75.2, C75.3

 +239      IF (PS=67751)!(PS=67752)!(PS=67753)

               Begin DoDot:1

 +240              DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +241     ;

 +242     ;KidneyParenchyma C64.9

 +243      IF PS=67649

               Begin DoDot:1

 +244              if EXT=390

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=625

 +245              DO 1

                   DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +246     ;

 +247     ;KidneyRenalPelvis C65.9, C66.9

 +248      IF (PS=67659)!(PS=67669)

               Begin DoDot:1

 +249              if EXT=750

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=690

 +250              DO 1

                   DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +251     ;

 +252     ;LacrimalGland C69.5

 +253     ;LacrimalSac C69.5

 +254      IF PS=67695

               Begin DoDot:1

 +255              DO 1

                   DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +256     ;

 +257     ;LarynxGlottic C32.0

 +258     ;LarynxOther C32.3, C32.8-C32.9

 +259     ;LarynxSubglottic C32.2

 +260     ;LarynxSupraglottic C32.1

 +261      IF $EXTRACT(PS,3,4)=32

               Begin DoDot:1

 +262              IF PS=67320

                       if EXT=100

                           SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=130

 +263              IF PS=67322

                       if EXT=730

                           SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=800

 +264              IF PS=67321

                       if EXT=670

                           SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=690

 +265              DO SSF12

               End DoDot:1

               QUIT 

 +266     ;

 +267     ;LipLower C00.1, C00.4, C00.6

 +268     ;LipOther C00.2, C00.5, C00.8-C00.9

 +269     ;LipUpper C00.0, C00.3

 +270     ;MiddleEar C30.1

 +271      IF ($EXTRACT(PS,3,4)="00")!(PS=67301)

               Begin DoDot:1

 +272              DO SSF12

               End DoDot:1

               QUIT 

 +273     ;

 +274     ;Lung C34.0-C34.3, C34.8-C34.9

 +275      IF $EXTRACT(PS,3,4)=34

               Begin DoDot:1

 +276              if METS=10

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,3)=30

 +277              if METS=39

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,3)=23

 +278              DO 1

                   DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +279      if $PIECE($GET(^ONCO(165.5,IEN,"CS")),U,5)=""

               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,5)=988

 +280     ;

 +281     ;MouthOther C05.8-C05.9, C06.8-C06.9

 +282      IF (PS=67058)!(PS=67059)!(PS=67068)!(PS=67069)

               Begin DoDot:1

 +283              if EXT=720

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=800

 +284              DO SSF12

               End DoDot:1

               QUIT 

 +285     ;

 +286     ;NasalCavity C30.0

 +287      IF PS=67300

               Begin DoDot:1

 +288              if EXT=710

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=760

 +289              DO SSF12

               End DoDot:1

               QUIT 

 +290     ;

 +291     ;Nasopharynx C11.0-C11.3, C11.8-C11.9

 +292      IF $EXTRACT(PS,3,4)=11

               Begin DoDot:1

 +293              if EXT=750

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=710

 +294              DO SSF12

               End DoDot:1

               QUIT 

 +295     ;

 +296     ;Orbit C69.6

 +297      IF PS=67696

               Begin DoDot:1

 +298              DO 1

                   DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +299     ;

 +300     ;Oropharynx C09.0-C09.1, C09.8-C09.9, C10.0, C10.2-C10.4, C10.8-C10.9

 +301      IF ($EXTRACT(PS,3,4)="09")!(PS=67100)!(PS=67102)!(PS=67103)!(PS=67104)!(PS=67108)!(PS=67109)

               Begin DoDot:1

 +302              if EXT=410

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=630

 +303              if EXT=620

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=710

 +304              if EXT=760

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=750

 +305              DO SSF12

               End DoDot:1

               QUIT 

 +306     ;

 +307     ;Ovary C56.9

 +308      IF PS=67569

               Begin DoDot:1

 +309              DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +310     ;

 +311     ;PalateHard C05.0

 +312     ;PalateSoft C05.1-C05.2

 +313      IF (PS=67050)!(PS=67051)!(PS=67052)

               Begin DoDot:1

 +314              IF PS=67050

                       Begin DoDot:2

 +315                      if EXT=760

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=790

                       End DoDot:2

 +316              IF (PS=67051)!(PS=67052)

                       Begin DoDot:2

 +317                      if EXT=770

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=670

                       End DoDot:2

 +318              DO SSF12

               End DoDot:1

               QUIT 

 +319     ;

 +320     ;ParotidGland C07.9

 +321      IF PS=67079

               Begin DoDot:1

 +322              if EXT=720

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=405

 +323              DO SSF12

               End DoDot:1

               QUIT 

 +324     ;

 +325     ;PharyngealTonsil C11.1

 +326      IF PS=67111

               Begin DoDot:1

 +327              if EXT=570

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=610

 +328              DO SSF12

               End DoDot:1

               QUIT 

 +329     ;

 +330     ;PharynxOther C14.0, C14.2, C14.8

 +331      IF (PS=67140)!(PS=67142)!(PS=67148)

               Begin DoDot:1

 +332              DO SSF12

               End DoDot:1

               QUIT 

 +333     ;

 +334     ;Placenta C58.9

 +335      IF PS=67589

               Begin DoDot:1

 +336              if LN=888

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,12)=988

 +337              DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +338     ;

 +339     ;Pleura C38.4

 +340      IF PS=67384

               Begin DoDot:1

 +341              if EXT=100

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=160

 +342              DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +343     ;

 +344     ;Prostate C61.9

 +345      IF PS=67619

               Begin DoDot:1

 +346              if METS=45

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,3)=60

 +347              if SSF1="000"

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,5)=998

 +348              if (SSF1>980)&(SSF1<990)

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,5)=980

 +349              if SSF2="000"

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,6)=998

 +350              if SSF2="080"

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,6)=997

 +351              if SSF3="020"

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,7)=200

 +352              if SSF3="021"

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,7)=210

 +353              if SSF3="022"

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,7)=220

 +354              if SSF3="023"

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,7)=230

 +355              if SSF3="030"

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,7)=300

 +356              if SSF3="032"

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,7)=320

 +357              if SSF3="040"

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,7)=400

 +358              if SSF3="041"

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,7)=410

 +359              if SSF3="042"

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,7)=420

 +360              if SSF3="043"

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,7)=430

 +361              if SSF3="045"

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,7)=485

 +362              if SSF3="048"

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,7)=480

 +363              if SSF3="050"

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,7)=500

 +364              if SSF3="052"

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,7)=520

 +365              if SSF3="060"

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,7)=600

 +366              if SSF3="070"

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,7)=700

 +367              if SSF3="095"

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,7)=950

 +368              if SSF3="096"

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,7)=960

 +369              if SSF3="097"

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,7)=970

 +370              if SSF3="098"

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,7)=980

 +371              if SSF3="099"

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,7)=990

               End DoDot:1

               QUIT 

 +372     ;

 +373     ;SalivaryGlandOther C08.1, C08.8-C08.9

 +374     ;SubmandibularGland C08.0

 +375      IF $EXTRACT(PS,3,4)="08"

               Begin DoDot:1

 +376              if EXT=720

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=405

 +377              DO SSF12

               End DoDot:1

               QUIT 

 +378     ;

 +379     ;SinusEthmoid C31.1

 +380     ;SinusMaxillary C31.0

 +381     ;SinusOther C31.2-C31.3, C31.8-C31.9

 +382      IF $EXTRACT(PS,3,4)=31

               Begin DoDot:1

 +383              IF PS=67311

                       Begin DoDot:2

 +384                      if EXT=140

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=320

 +385                      if EXT=240

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=340

                       End DoDot:2

 +386              IF PS=67310

                       Begin DoDot:2

 +387                      if EXT=650

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=600

                       End DoDot:2

 +388              DO SSF12

               End DoDot:1

               QUIT 

 +389     ;

 +390     ;Skin C44.0, C44.2-C44.9

 +391     ;SkinEyelid C44.1

 +392      IF $EXTRACT(PS,3,4)=44

               Begin DoDot:1

 +393              IF PS=67441

                       Begin DoDot:2

 +394                      if EXT=500

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=150

 +395                      if EXT=700

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=620

                       End DoDot:2

 +396              DO 1

                   DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +397     ;

 +398     ;Testis C62.0-C62.1, C62.9

 +399      IF $EXTRACT(PS,3,4)=62

               Begin DoDot:1

 +400              if METS=45

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,3)=60

 +401              if SSF5="001"

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,9)="010"

 +402              if SSF5="002"

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,9)="020"

 +403              if SSF5="003"

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,9)="030"

 +404              if SSF6=888

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,10)=988

               End DoDot:1

               QUIT 

 +405     ;

 +406     ;Thyroid C73.9

 +407      IF PS=67739

               Begin DoDot:1

 +408              if EXT=720

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=550

 +409              if LN=140

                       SET $PIECE(^ONCO(165.5,IEN,"CS"),U,12)=150

 +410              DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +411     ;

 +412     ;TongueAnterior C02.0-C02.3, C02.8-C02.9

 +413     ;TongueBase C01.9, C02.4

 +414      IF ($EXTRACT(PS,3,4)="02")!(PS=67019)

               Begin DoDot:1

 +415              IF (PS=67019)!(PS=67024)

                       Begin DoDot:2

 +416                      if EXT=820

                               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=805

                       End DoDot:2

 +417              DO SSF12

               End DoDot:1

               QUIT 

 +418     ;

 +419     ;AdnexaUterineOther C57.1-C57.4

 +420     ;AmpullaVater C24.1

 +421     ;NETAmpulla C24.1 (M-8153, 8240-8242, 8246, 8249)

 +422     ;Anus C21.0-C21.2, C21.8

 +423     ;BileDuctsDistal C24.0

 +424     ;BileDuctsPerihilar C24.0

 +425     ;BiliaryOther C24.8-C24.9

 +426     ;CysticDuct" C24.0

 +427     ;Cervix C53.0-C53.1, C53.8-C53.9

 +428     ;DigestiveOther C26.0, C26.8-C26.9

 +429     ;PancreasBodyTail C25.1-C25.2

 +430     ;PancreasHead C25.0

 +431     ;PancreasOther C25.3-C25.4, C25.7-C25.9

 +432     ;Penis C60.0-C60.2, C60.8-C60.9

 +433     ;RespiratoryOther C39.0, C39.8-C39.9

 +434     ;Retroperitoneum C48.0

 +435     ;Scrotum C63.2

 +436     ;SoftTissue C47.0-C47.6, C47.8-C47.9, C49.0-C49.6, C49.8-C49.9

 +437     ;Trachea C33.9

 +438     ;Urethra C68.0

 +439     ;UrinaryOther C68.1, C68.8-C68.9

 +440     ;Vagina C52.9

 +441     ;Vulva C51.0-C51.2, C51.8-C51.9

 +442      SET S34=$EXTRACT(PS,3,4)

 +443      IF (S34=26)!(S34=53)!(PS=67248)!(PS=67249)!(PS=67240)!(S34=21)!(PS=67241)!(PS=67571)!(PS=6752)!(PS=67573)!(PS=67574)!(S34=25)!(S34=60)!(S34=39)!(PS=67480)!(PS=67632)!(S34=47)!(S34=49)!(PS=67339)!(S34=68)!(PS=67529)!(S34=51)

               Begin DoDot:1

 +444              DO 1

                   DO 2

                   DO 3

                   DO 4

                   DO 5

                   DO 6

               End DoDot:1

               QUIT 

 +445     ;

 +446      QUIT 

 +447     ;

1         ;SSF1 = 888 to 988

 +1        if $PIECE($GET(^ONCO(165.5,IEN,"CS")),U,5)=888

               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,5)=988

 +2        QUIT 

 +3       ;

2         ;SSF2 = 888 to 988

 +1        if $PIECE($GET(^ONCO(165.5,IEN,"CS")),U,6)=888

               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,6)=988

 +2        QUIT 

 +3       ;

3         ;SSF3 = 888 to 988

 +1        if $PIECE($GET(^ONCO(165.5,IEN,"CS")),U,7)=888

               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,7)=988

 +2        QUIT 

 +3       ;

4         ;SSF4 = 888 to 988

 +1        if $PIECE($GET(^ONCO(165.5,IEN,"CS")),U,8)=888

               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,8)=988

 +2        QUIT 

 +3       ;

5         ;SSF5 = 888 to 988

 +1        if $PIECE($GET(^ONCO(165.5,IEN,"CS")),U,9)=888

               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,9)=988

 +2        QUIT 

 +3       ;

6         ;SSF6 = 888 to 988

 +1        if $PIECE($GET(^ONCO(165.5,IEN,"CS")),U,10)=888

               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,10)=988

 +2        QUIT 

 +3       ;

SSF12     ;SSF1 989 to 980

 +1       ;SSF1 981-988 to 980

 +2       ;SSF2 888 to 987

 +3        if (SSF1>980)&(SSF1<990)

               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,5)=980

 +4        if SSF2=888

               SET $PIECE(^ONCO(165.5,IEN,"CS"),U,6)=987

 +5        QUIT 

 +6       ;

CLEANUP   ;Cleanup

 +1        KILL IEN