ONCCSV2 ;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)
;
;HemeRetic (M-9731-9992)
S QUIT="YES"
I ((HST14>9730)&(HST14<9993)) D I $G(QUIT)="YES" Q
.I ((HST14=9731)!(HST14=9732)!(HST14=9733)!(HST14=9734)!(HST14=9820)!(HST14=9826)!(HST14=9832)!(HST14=9833)!(HST14=9834)!(HST14=9835)!(HST14=9836))&((PS=67441)!(PS=67690)!(PS=67695)!(PS=67696)) S QUIT="NO" Q
.I ((HST14=9823)!(HST14=9827)!(HST14=9837))&((PS'=67420)&(PS'=67421)&(PS'=67424)) S QUIT="NO" Q
.S:TS=888 $P(^ONCO(165.5,IEN,"CS1"),U,10)=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
;
;KaposiSarcoma (M-9140)
I HST14=9140 D Q
.S:TS=888 $P(^ONCO(165.5,IEN,"CS1"),U,10)=988
.S:METS=88 $P(^ONCO(165.5,IEN,"CS"),U,3)=98
.D 2,3,4,5,6
;
;LymphomaOcularAdnexa C44.1, C69.0, C69.5-C69.6
;(M-9590-9699, 9702-9738, 9811-9818, 9820-9837)
I ((PS=67441)!(PS=67690)!(PS=67695)!(PS=67696))&((HST14>9589)&(HST14<9700))!((HST14>9701)&(HST14<9739))!((HST14>9810)&(HST14<9819))!((HST14>9819)&(HST14<9838)) D Q
.S:TS=888 $P(^ONCO(165.5,IEN,"CS1"),U,10)=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
.S:SSF1=888 $P(^ONCO(165.5,IEN,"CS"),U,5)=999
.S:SSF2=888 $P(^ONCO(165.5,IEN,"CS"),U,6)=999
.S:SSF3=888 $P(^ONCO(165.5,IEN,"CS"),U,7)=999
.D 4,5,6
;
;Lymphoma
;(M-9590-9699, 9702-9729, 9735, 9737, 9738, 9811-9818)
;(M-9823, 9827, 9837 EXCEPT C42.0, C42.1, C42.4)
S QUIT="YES"
I ((HST14>9589)&(HST14<9700))!((HST14>9701)&(HST14<9730))!(HST14=9735)!(HST14=9737)!(HST14=9738)!((HST14>9810)&(HST14<9819))!(HST14=9823)!(HST14=9827)!(HST14=9837) D I $G(QUIT)="YES" Q
.I ((HST14=9823)!(HST14=9827)!(HST14=9837))&((PS=67420)!(PS=67421)!(PS=67424)) S QUIT="NO" Q
.S:LN=888 $P(^ONCO(165.5,IEN,"CS"),U,12)=988
.S:METS=88 $P(^ONCO(165.5,IEN,"CS"),U,3)=98
.S:SSF1=888 $P(^ONCO(165.5,IEN,"CS"),U,5)=999
.S:SSF2=888 $P(^ONCO(165.5,IEN,"CS"),U,6)=999
.S:SSF3=888 $P(^ONCO(165.5,IEN,"CS"),U,7)=999
.D 4,5,6
;
;MelanomaBuccalMucosa C06.0-C06.1
;MelanomaEpiglottisAnterior C10.1
;MelanomaFloorMouth C04.0-C04.1, C04.8-C04.9
;MelanomaGumLower C03.1, C06.2
;MelanomaGumOther C03.9
;MelanomaGumUpper C03.0
;MelanomaHypopharynx C12.9, C13.0-C13.2, C13.8-C13.9
;MelanomaLarynxGlottic C32.0
;MelanomaLarynxOther C32.3, C32.8-C32.9
;MelanomaLarynxSubglottic C32.2
;MelanomaLarynxSupraglottic C32.1
;MelanomaLipLower C00.1, C00.4, C00.6
;MelanomaLipOther C00.2, C00.5, C00.8-C00.9
;MelanomaLipUpper C00.0, C00.3
;MelanomaMouthOther C05.8-C05.9, C06.8-C06.9
;MelanomaNasalCavity C30.0
;MelanomaNasopharynx C11.0-C11.3, C11.8-C11.9
;MelanomaOropharynx C09.0-C09.1, C09.8-C09.9, C10.0, C10.2-C10.4, C10.8-C10.9
;MelanomaPalateHard C05.0
;MelanomaPalateSoft C05.1-C05.2
;MelanomaPharynxOther C14.0, C14.2-C14.8
;MelanomaSinusEthmoid C31.1
;MelanomaSinusMaxillary C31.0
;MelanomaSinusOther C31.2-C31.3, C31.8-C31.9
;MelanomaTongueAnterior C02.0-C02.3, C02.8-C02.9
;MelanomaTongueBase C01.9, C02.4
S S34=$E(PS,3,4)
I $$MELANOMA^ONCOU55(IEN),(S34="00")!(S34="01")!(S34="02")!(S34="03")!(S34="04")!(S34="05")!(S34="06")!(S34="09")!(S34=10)!(S34=11)!(S34=12)!(S34=13)!(S34=14)!(S34=31)!(S34=32)!(PS=67300) D Q
.I (PS=67060)!(PS=67061) D
..S:EXT=200 $P(^ONCO(165.5,IEN,"CS"),U,11)=610
..S:EXT=670 $P(^ONCO(165.5,IEN,"CS"),U,11)=700
..S:EXT=730 $P(^ONCO(165.5,IEN,"CS"),U,11)=790
.;
.I PS=67101 D
..S:EXT=360 $P(^ONCO(165.5,IEN,"CS"),U,11)=365
.;
.I $E(PS,3,4)="04" D
..S:EXT=640 $P(^ONCO(165.5,IEN,"CS"),U,11)=740
..S:EXT=770 $P(^ONCO(165.5,IEN,"CS"),U,11)=700
.;
.I (PS=67031)!(PS=67062)!(PS=67039)!(PS=67030) D
..S:EXT=790 $P(^ONCO(165.5,IEN,"CS"),U,11)=800
.;
.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=660 $P(^ONCO(165.5,IEN,"CS"),U,11)=635
.;
.I PS=67321 D
..S:EXT=650 $P(^ONCO(165.5,IEN,"CS"),U,11)=605
..S:EXT=660 $P(^ONCO(165.5,IEN,"CS"),U,11)=605
..S:EXT=680 $P(^ONCO(165.5,IEN,"CS"),U,11)=530
.;
.I $E(PS,3,4)="00" D
..S:EXT=200 $P(^ONCO(165.5,IEN,"CS"),U,11)=520
.;
.I (PS=67058)!(PS=67059)!(PS=67068)!(PS=67069) D
..S:EXT=200 $P(^ONCO(165.5,IEN,"CS"),U,11)=510
..S:EXT=720 $P(^ONCO(165.5,IEN,"CS"),U,11)=750
.;
.I PS=67300 D
..S:EXT=650 $P(^ONCO(165.5,IEN,"CS"),U,11)=750
.;
.I $E(PS,3,4)=11 D
..S:EXT=750 $P(^ONCO(165.5,IEN,"CS"),U,11)=790
.;
.I ($E(PS,3,4)="09")!(PS=67100)!(PS=67102)!(PS=67103)!(PS=67104)!(PS=67108)!(PS=67109) D
..S:EXT=720 $P(^ONCO(165.5,IEN,"CS"),U,11)=690
..S:EXT=760 $P(^ONCO(165.5,IEN,"CS"),U,11)=690
.;
.I PS=67050 D
..S:EXT=760 $P(^ONCO(165.5,IEN,"CS"),U,11)=730
.;
.I (PS=67051)!(PS=67052) D
..S:EXT=770 $P(^ONCO(165.5,IEN,"CS"),U,11)=675
..S:EXT=780 $P(^ONCO(165.5,IEN,"CS"),U,11)=680
.;
.I PS=67311 D
..S:EXT=240 $P(^ONCO(165.5,IEN,"CS"),U,11)=270
..S:EXT=300 $P(^ONCO(165.5,IEN,"CS"),U,11)=170
..S:EXT=620 $P(^ONCO(165.5,IEN,"CS"),U,11)=750
..S:EXT=630 $P(^ONCO(165.5,IEN,"CS"),U,11)=750
.;
.I (PS=67020)!(PS=67021)!(PS=67022)!(PS=67023)!(PS=67028)!(PS=67029) D
..S:EXT=740 $P(^ONCO(165.5,IEN,"CS"),U,11)=770
.D SSF12
;
;MelanomaChoroid C69.3
;MelanomaCiliaryBody C69.4
;MelanomaIris C69.4
I $$MELANOMA^ONCOU55(IEN),((PS=67693)!(PS=67694)) D Q
.S:(TS>980)&(TS<990) $P(^ONCO(165.5,IEN,"CS1"),U,10)=980
.S:(SSF1>980)&(SSF1<990) $P(^ONCO(165.5,IEN,"CS"),U,5)=980
.S:SSF1=990 $P(^ONCO(165.5,IEN,"CS"),U,5)=999
.D 2,3,4,5,6
;
;MelanomaConjunctiva C69.0
I $$MELANOMA^ONCOU55(IEN),PS=67690 D Q
.S:EXT=150 $P(^ONCO(165.5,IEN,"CS"),U,11)=330
.S:(SSF1>980)&(SSF1<990) $P(^ONCO(165.5,IEN,"CS"),U,5)=980
.S:SSF1=990 $P(^ONCO(165.5,IEN,"CS"),U,5)=999
.D 2,3,4,5,6
S:$P($G(^ONCO(165.5,IEN,"CS")),U,5)="" $P(^ONCO(165.5,IEN,"CS"),U,5)=988
;
;MelanomaEyeOther C69.1, C69.2, C69.5, C69.8-C69.9
I $$MELANOMA^ONCOU55(IEN),((PS=67691)!(PS=67692)!(PS=67695)!(PS=67698)!(PS=67699)) D Q
.D 1,2,3,4,5,6
;
;MelanomaSkin C44.0-C44.9, C51.0-C51.2, C51.8-C51.9, C60.0-C60.2, C60.8-C60.9, C63.2
I $$MELANOMA^ONCOU55(IEN),($E(PS,3,4)=44)!($E(PS,3,4)=51)!($E(PS,3,4)=60)!(PS=67632) D Q
.S:METS=40 $P(^ONCO(165.5,IEN,"CS"),U,3)=60
.S:(SSF1>980)&(SSF1<990) $P(^ONCO(165.5,IEN,"CS"),U,5)=980
.S:SSF1=990 $P(^ONCO(165.5,IEN,"CS"),U,5)=999
.D 5,6
;
;MerkelCellPenis C60.0-C60.2, C60.8-C60.9 (M-8247)
;MerkelCellScrotum C63.2 (M-8247)
;MerkelCellSkin C44.0, C44.2-C44.9 (M-8247)
;MerkelCellVulva C51.0-C51.2, C51.8-C51.9 (M-8247)
I HST14=8247,($E(PS,3,4)=60)!(PS=67632)!(PS=67440)!(PS=67442)!(PS=67443)!(PS=67444)!(PS=67445)!(PS=67446)!(PS=67447)!(PS=67448)!(PS=67449)!($E(PS,3,4)=51) D Q
.D 1,2,3,4,5,6
;
;MycosisFungoides
;C44.0-C44.9, C51.0-C51.2, C51.8-C51.9, C60.0-C60.2, C60.8-C60.9, C63.2
;(M-9700-9701)
I (HST14=9700)!(HST14=9701),($E(PS,3,4)=44)!($E(PS,3,4)=51)!($E(PS,3,4)=60)!(PS=67632) D Q
.D 2,3,4,5,6
;
;Retinoblastoma C69.0-C69.6, C69.8-C69.9 (M-9510-9514)
I (HST14=9510)!(HST14=9511)!(HST14=9512)!(HST14=9513)!(HST14=9514),$E(PS,3,4)=69 D Q
.S:METS=40 $P(^ONCO(165.5,IEN,"CS"),U,3)=80
.S:METS=55 $P(^ONCO(165.5,IEN,"CS"),U,3)=80
.S:SSF1="000" $P(^ONCO(165.5,IEN,"CS"),U,5)=970
.S:SSF1="030" $P(^ONCO(165.5,IEN,"CS"),U,5)=300
.S:SSF1="041" $P(^ONCO(165.5,IEN,"CS"),U,5)=410
.S:SSF1="043" $P(^ONCO(165.5,IEN,"CS"),U,5)=430
.S:SSF1="044" $P(^ONCO(165.5,IEN,"CS"),U,5)=440
.S:SSF1="046" $P(^ONCO(165.5,IEN,"CS"),U,5)=460
.S:SSF1="047" $P(^ONCO(165.5,IEN,"CS"),U,5)=470
.S:SSF1="048" $P(^ONCO(165.5,IEN,"CS"),U,5)=440
.S:SSF1="049" $P(^ONCO(165.5,IEN,"CS"),U,5)=490
.S:SSF1="054" $P(^ONCO(165.5,IEN,"CS"),U,5)=540
.S:SSF1="056" $P(^ONCO(165.5,IEN,"CS"),U,5)=560
.S:SSF1="057" $P(^ONCO(165.5,IEN,"CS"),U,5)=570
.S:SSF1="059" $P(^ONCO(165.5,IEN,"CS"),U,5)=590
.S:SSF1="072" $P(^ONCO(165.5,IEN,"CS"),U,5)=765
.S:SSF1="095" $P(^ONCO(165.5,IEN,"CS"),U,5)=950
.S:SSF1="096" $P(^ONCO(165.5,IEN,"CS"),U,5)=960
.D 2,3,4,5,6
;
D ^ONCCSV2A
;
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 ---[H[J[2J[HONCCSV2 9609 printed Dec 13, 2024@02:22:46 Page 2
ONCCSV2 ;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 ;HemeRetic (M-9731-9992)
+21 SET QUIT="YES"
+22 IF ((HST14>9730)&(HST14<9993))
Begin DoDot:1
+23 IF ((HST14=9731)!(HST14=9732)!(HST14=9733)!(HST14=9734)!(HST14=9820)!(HST14=9826)!(HST14=9832)!(HST14=9833)!(HST14=9834)!(HST14=9835)!(HST14=9836))&((PS=67441)!(PS=67690)!(PS=67695)!(PS=67696))
SET QUIT="NO"
QUIT
+24 IF ((HST14=9823)!(HST14=9827)!(HST14=9837))&((PS'=67420)&(PS'=67421)&(PS'=67424))
SET QUIT="NO"
QUIT
+25 if TS=888
SET $PIECE(^ONCO(165.5,IEN,"CS1"),U,10)=988
+26 if LN=888
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,12)=988
+27 if METS=88
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,3)=98
+28 DO 1
DO 2
DO 3
DO 4
DO 5
DO 6
End DoDot:1
IF $GET(QUIT)="YES"
QUIT
+29 ;
+30 ;KaposiSarcoma (M-9140)
+31 IF HST14=9140
Begin DoDot:1
+32 if TS=888
SET $PIECE(^ONCO(165.5,IEN,"CS1"),U,10)=988
+33 if METS=88
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,3)=98
+34 DO 2
DO 3
DO 4
DO 5
DO 6
End DoDot:1
QUIT
+35 ;
+36 ;LymphomaOcularAdnexa C44.1, C69.0, C69.5-C69.6
+37 ;(M-9590-9699, 9702-9738, 9811-9818, 9820-9837)
+38 IF ((PS=67441)!(PS=67690)!(PS=67695)!(PS=67696))&((HST14>9589)&(HST14<9700))!((HST14>9701)&(HST14<9739))!((HST14>9810)&(HST14<9819))!((HST14>9819)&(HST14<9838))
Begin DoDot:1
+39 if TS=888
SET $PIECE(^ONCO(165.5,IEN,"CS1"),U,10)=988
+40 if LN=888
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,12)=988
+41 if METS=88
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,3)=98
+42 if SSF1=888
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,5)=999
+43 if SSF2=888
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,6)=999
+44 if SSF3=888
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,7)=999
+45 DO 4
DO 5
DO 6
End DoDot:1
QUIT
+46 ;
+47 ;Lymphoma
+48 ;(M-9590-9699, 9702-9729, 9735, 9737, 9738, 9811-9818)
+49 ;(M-9823, 9827, 9837 EXCEPT C42.0, C42.1, C42.4)
+50 SET QUIT="YES"
+51 IF ((HST14>9589)&(HST14<9700))!((HST14>9701)&(HST14<9730))!(HST14=9735)!(HST14=9737)!(HST14=9738)!((HST14>9810)&(HST14<9819))!(HST14=9823)!(HST14=9827)!(HST14=9837)
Begin DoDot:1
+52 IF ((HST14=9823)!(HST14=9827)!(HST14=9837))&((PS=67420)!(PS=67421)!(PS=67424))
SET QUIT="NO"
QUIT
+53 if LN=888
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,12)=988
+54 if METS=88
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,3)=98
+55 if SSF1=888
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,5)=999
+56 if SSF2=888
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,6)=999
+57 if SSF3=888
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,7)=999
+58 DO 4
DO 5
DO 6
End DoDot:1
IF $GET(QUIT)="YES"
QUIT
+59 ;
+60 ;MelanomaBuccalMucosa C06.0-C06.1
+61 ;MelanomaEpiglottisAnterior C10.1
+62 ;MelanomaFloorMouth C04.0-C04.1, C04.8-C04.9
+63 ;MelanomaGumLower C03.1, C06.2
+64 ;MelanomaGumOther C03.9
+65 ;MelanomaGumUpper C03.0
+66 ;MelanomaHypopharynx C12.9, C13.0-C13.2, C13.8-C13.9
+67 ;MelanomaLarynxGlottic C32.0
+68 ;MelanomaLarynxOther C32.3, C32.8-C32.9
+69 ;MelanomaLarynxSubglottic C32.2
+70 ;MelanomaLarynxSupraglottic C32.1
+71 ;MelanomaLipLower C00.1, C00.4, C00.6
+72 ;MelanomaLipOther C00.2, C00.5, C00.8-C00.9
+73 ;MelanomaLipUpper C00.0, C00.3
+74 ;MelanomaMouthOther C05.8-C05.9, C06.8-C06.9
+75 ;MelanomaNasalCavity C30.0
+76 ;MelanomaNasopharynx C11.0-C11.3, C11.8-C11.9
+77 ;MelanomaOropharynx C09.0-C09.1, C09.8-C09.9, C10.0, C10.2-C10.4, C10.8-C10.9
+78 ;MelanomaPalateHard C05.0
+79 ;MelanomaPalateSoft C05.1-C05.2
+80 ;MelanomaPharynxOther C14.0, C14.2-C14.8
+81 ;MelanomaSinusEthmoid C31.1
+82 ;MelanomaSinusMaxillary C31.0
+83 ;MelanomaSinusOther C31.2-C31.3, C31.8-C31.9
+84 ;MelanomaTongueAnterior C02.0-C02.3, C02.8-C02.9
+85 ;MelanomaTongueBase C01.9, C02.4
+86 SET S34=$EXTRACT(PS,3,4)
+87 IF $$MELANOMA^ONCOU55(IEN)
IF (S34="00")!(S34="01")!(S34="02")!(S34="03")!(S34="04")!(S34="05")!(S34="06")!(S34="09")!(S34=10)!(S34=11)!(S34=12)!(S34=13)!(S34=14)!(S34=31)!(S34=32)!(PS=67300)
Begin DoDot:1
+88 IF (PS=67060)!(PS=67061)
Begin DoDot:2
+89 if EXT=200
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=610
+90 if EXT=670
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=700
+91 if EXT=730
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=790
End DoDot:2
+92 ;
+93 IF PS=67101
Begin DoDot:2
+94 if EXT=360
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=365
End DoDot:2
+95 ;
+96 IF $EXTRACT(PS,3,4)="04"
Begin DoDot:2
+97 if EXT=640
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=740
+98 if EXT=770
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=700
End DoDot:2
+99 ;
+100 IF (PS=67031)!(PS=67062)!(PS=67039)!(PS=67030)
Begin DoDot:2
+101 if EXT=790
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=800
End DoDot:2
+102 ;
+103 IF (PS=67129)!($EXTRACT(PS,3,4)=13)
Begin DoDot:2
+104 if EXT=150
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=420
+105 if EXT=510
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=450
+106 if EXT=660
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=635
End DoDot:2
QUIT
+107 ;
+108 IF PS=67321
Begin DoDot:2
+109 if EXT=650
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=605
+110 if EXT=660
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=605
+111 if EXT=680
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=530
End DoDot:2
+112 ;
+113 IF $EXTRACT(PS,3,4)="00"
Begin DoDot:2
+114 if EXT=200
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=520
End DoDot:2
+115 ;
+116 IF (PS=67058)!(PS=67059)!(PS=67068)!(PS=67069)
Begin DoDot:2
+117 if EXT=200
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=510
+118 if EXT=720
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=750
End DoDot:2
+119 ;
+120 IF PS=67300
Begin DoDot:2
+121 if EXT=650
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=750
End DoDot:2
+122 ;
+123 IF $EXTRACT(PS,3,4)=11
Begin DoDot:2
+124 if EXT=750
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=790
End DoDot:2
+125 ;
+126 IF ($EXTRACT(PS,3,4)="09")!(PS=67100)!(PS=67102)!(PS=67103)!(PS=67104)!(PS=67108)!(PS=67109)
Begin DoDot:2
+127 if EXT=720
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=690
+128 if EXT=760
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=690
End DoDot:2
+129 ;
+130 IF PS=67050
Begin DoDot:2
+131 if EXT=760
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=730
End DoDot:2
+132 ;
+133 IF (PS=67051)!(PS=67052)
Begin DoDot:2
+134 if EXT=770
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=675
+135 if EXT=780
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=680
End DoDot:2
+136 ;
+137 IF PS=67311
Begin DoDot:2
+138 if EXT=240
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=270
+139 if EXT=300
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=170
+140 if EXT=620
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=750
+141 if EXT=630
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=750
End DoDot:2
+142 ;
+143 IF (PS=67020)!(PS=67021)!(PS=67022)!(PS=67023)!(PS=67028)!(PS=67029)
Begin DoDot:2
+144 if EXT=740
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=770
End DoDot:2
+145 DO SSF12
End DoDot:1
QUIT
+146 ;
+147 ;MelanomaChoroid C69.3
+148 ;MelanomaCiliaryBody C69.4
+149 ;MelanomaIris C69.4
+150 IF $$MELANOMA^ONCOU55(IEN)
IF ((PS=67693)!(PS=67694))
Begin DoDot:1
+151 if (TS>980)&(TS<990)
SET $PIECE(^ONCO(165.5,IEN,"CS1"),U,10)=980
+152 if (SSF1>980)&(SSF1<990)
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,5)=980
+153 if SSF1=990
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,5)=999
+154 DO 2
DO 3
DO 4
DO 5
DO 6
End DoDot:1
QUIT
+155 ;
+156 ;MelanomaConjunctiva C69.0
+157 IF $$MELANOMA^ONCOU55(IEN)
IF PS=67690
Begin DoDot:1
+158 if EXT=150
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,11)=330
+159 if (SSF1>980)&(SSF1<990)
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,5)=980
+160 if SSF1=990
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,5)=999
+161 DO 2
DO 3
DO 4
DO 5
DO 6
End DoDot:1
QUIT
+162 if $PIECE($GET(^ONCO(165.5,IEN,"CS")),U,5)=""
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,5)=988
+163 ;
+164 ;MelanomaEyeOther C69.1, C69.2, C69.5, C69.8-C69.9
+165 IF $$MELANOMA^ONCOU55(IEN)
IF ((PS=67691)!(PS=67692)!(PS=67695)!(PS=67698)!(PS=67699))
Begin DoDot:1
+166 DO 1
DO 2
DO 3
DO 4
DO 5
DO 6
End DoDot:1
QUIT
+167 ;
+168 ;MelanomaSkin C44.0-C44.9, C51.0-C51.2, C51.8-C51.9, C60.0-C60.2, C60.8-C60.9, C63.2
+169 IF $$MELANOMA^ONCOU55(IEN)
IF ($EXTRACT(PS,3,4)=44)!($EXTRACT(PS,3,4)=51)!($EXTRACT(PS,3,4)=60)!(PS=67632)
Begin DoDot:1
+170 if METS=40
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,3)=60
+171 if (SSF1>980)&(SSF1<990)
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,5)=980
+172 if SSF1=990
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,5)=999
+173 DO 5
DO 6
End DoDot:1
QUIT
+174 ;
+175 ;MerkelCellPenis C60.0-C60.2, C60.8-C60.9 (M-8247)
+176 ;MerkelCellScrotum C63.2 (M-8247)
+177 ;MerkelCellSkin C44.0, C44.2-C44.9 (M-8247)
+178 ;MerkelCellVulva C51.0-C51.2, C51.8-C51.9 (M-8247)
+179 IF HST14=8247
IF ($EXTRACT(PS,3,4)=60)!(PS=67632)!(PS=67440)!(PS=67442)!(PS=67443)!(PS=67444)!(PS=67445)!(PS=67446)!(PS=67447)!(PS=67448)!(PS=67449)!($EXTRACT(PS,3,4)=51)
Begin DoDot:1
+180 DO 1
DO 2
DO 3
DO 4
DO 5
DO 6
End DoDot:1
QUIT
+181 ;
+182 ;MycosisFungoides
+183 ;C44.0-C44.9, C51.0-C51.2, C51.8-C51.9, C60.0-C60.2, C60.8-C60.9, C63.2
+184 ;(M-9700-9701)
+185 IF (HST14=9700)!(HST14=9701)
IF ($EXTRACT(PS,3,4)=44)!($EXTRACT(PS,3,4)=51)!($EXTRACT(PS,3,4)=60)!(PS=67632)
Begin DoDot:1
+186 DO 2
DO 3
DO 4
DO 5
DO 6
End DoDot:1
QUIT
+187 ;
+188 ;Retinoblastoma C69.0-C69.6, C69.8-C69.9 (M-9510-9514)
+189 IF (HST14=9510)!(HST14=9511)!(HST14=9512)!(HST14=9513)!(HST14=9514)
IF $EXTRACT(PS,3,4)=69
Begin DoDot:1
+190 if METS=40
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,3)=80
+191 if METS=55
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,3)=80
+192 if SSF1="000"
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,5)=970
+193 if SSF1="030"
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,5)=300
+194 if SSF1="041"
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,5)=410
+195 if SSF1="043"
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,5)=430
+196 if SSF1="044"
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,5)=440
+197 if SSF1="046"
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,5)=460
+198 if SSF1="047"
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,5)=470
+199 if SSF1="048"
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,5)=440
+200 if SSF1="049"
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,5)=490
+201 if SSF1="054"
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,5)=540
+202 if SSF1="056"
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,5)=560
+203 if SSF1="057"
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,5)=570
+204 if SSF1="059"
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,5)=590
+205 if SSF1="072"
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,5)=765
+206 if SSF1="095"
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,5)=950
+207 if SSF1="096"
SET $PIECE(^ONCO(165.5,IEN,"CS"),U,5)=960
+208 DO 2
DO 3
DO 4
DO 5
DO 6
End DoDot:1
QUIT
+209 ;
+210 DO ^ONCCSV2A
+211 ;
+212 QUIT
+213 ;
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
