ONCSCHMM ;HINES OIFO/RTK - Miscellaneous schema code ;07/25/19
;;2.2;ONCOLOGY;**10,12,13,15,17,18,20**;Jul 31, 2013;Build 5
;
Q
;
SCRNLV ;Screen for Lymph-Vascular Invasion field
I $P($G(^ONCO(165.5,D0,0)),"^",16)<3180000,((Y<2)!(Y>7)) Q
D ^ONCSCHMA I ('$D(ONCSCMA))!(ONCSCMA=0) Q
I $P($G(^ONCO(165.5,D0,0)),"^",16)>3171231 D SCHMCHK
I $P($G(^ONCO(165.5,D0,0)),"^",16)>3171231 I ONCNO8S=1,(Y'=8) Q
I $P($G(^ONCO(165.5,D0,0)),"^",16)>3171231 I ONCONL8=1,(Y=8) Q
I $P($G(^ONCO(165.5,D0,0)),"^",16)>3171231 I ONCNO8S=0,ONCONL8=0,Y<100 Q
Q
SCHMCHK ;
S ONCNO8S=0,ONCONL8=0
I "00210^09210^00220^00241^00242^00381^00382^00383^00400^00410^00421^00422^00440^00450^00459^00480^00580^00600^00610^00631^00633^00640^00660^00671^00672^00700^00750^00090^00310^00360^00430^0073^00740^00760"[ONCSCMA Q ;all codes apply
I "00071^00072^00073^00074^00075^00076^00077^00080^00100^00111^00112^00121^00122^00130^00131^00132^00133^00161^00169^00170^00180^00190^09190^00200^00230^00250"[ONCSCMA S ONCNO8S=1 Q ;code 8 does not apply
I "00260^00270^00280^00290^00301^00302^00320^00330^00340^00350^00460^00470^00500^00510^00520^09520^00528^00530^00541^00542^00560^00570^00590^00620"[ONCSCMA S ONCNO8S=1 Q ;code 8 does not apply
I "00060^00118^00119^00128^00140^00150^00278^00288^00358^00370^00378^00458^00478^00551^00552^00553^00558^00559^00598^00638"[ONCSCMA S ONCONL8=1 Q
I "00650^00680^00690^00698^00710^00718^00721^00722^00723^00770^00778^00790^00795^00811^00812^00821^00822^00830^99999"[ONCSCMA S ONCONL8=1 Q ;only 8s
Q
SCRNSS ;Screen for SUMMARY STAGE 2018 (#1764) field
N Z S Z=0 N ONCHIT S ONCHIT=0 D ^ONCSCHMA I ('$D(ONCSCMA))!(ONCSCMA=0) Q
I "00381^00382^00383^00400^00410^00421^00422^00440^00450^00458^00459^00528^00541^00680^00811"[ONCSCMA S ONCHIT=1,Z=$S((Y'=0)&(Y'=8):1,1:0) I Z Q
I "00071^00072^00073^00074^00075^00076^00077^00360^00370"[ONCSCMA S ONCHIT=1,Z=$S((Y'=8):1,1:0) I Z Q
I "00060^"[ONCSCMA S ONCHIT=1,Z=$S((Y'=0)&(Y'=1)&(Y'=2)&(Y'=8):1,1:0) I Z Q
I "00721^09721^00722^09722^09724"[ONCSCMA S ONCHIT=1,Z=$S((Y'=0)&(Y'=3)&(Y'=4):1,1:0) I Z Q
I "00723^09723"[ONCSCMA S ONCHIT=1,Z=$S((Y'=3)&(Y'=4):1,1:0) I Z Q
I "00710^00790^00795^00812"[ONCSCMA S ONCHIT=1,Z=$S((Y'=0)&(Y'=3)&(Y'=4)&(Y'=8):1,1:0) I Z Q
I "00821^00822"[ONCSCMA S ONCHIT=1,Z=$S((Y'=0)&(Y'=2)&(Y'=4)&(Y'=8):1,1:0) I Z Q
I "00830^"[ONCSCMA S ONCHIT=1,Z=$S((Y'=0)&(Y'=2)&(Y'=3)&(Y'=4)&(Y'=8):1,1:0) I Z Q
I "99999^"[ONCSCMA S ONCHIT=1,Z=$S((Y=9):1,1:0) I Z Q
I ONCHIT=0 I ONCSCMA<999999 S Z=1 I Z Q
Q
SCRNFIV ;Screen for fields #3804,3811,3885,3907,3933
I $P($G(^ONCO(165.5,D0,2)),"^",1)=67421,(Y'=5) Q
I $P($G(^ONCO(165.5,D0,2)),"^",1)'=67421,(Y<10) Q
Q
SCRN555 ;Screen for fields #3857,3869,3930,3931
I $P($G(^ONCO(165.5,D0,"SSD4")),"^",21)=0,(Y'=5) Q
I $P($G(^ONCO(165.5,D0,"SSD4")),"^",21)'=0,(Y<10) Q
Q
RADPH3 ;
I $L(X)=3 Q
S X=$E("000000",1,(3-$L(X)))_X
Q
RADPH5 ;
I $L(X)=5 Q
S X=$E("000000",1,(5-$L(X)))_X
Q
RADPH6 ;
I $L(X)=6 Q
S X=$E("000000",1,(6-$L(X)))_X
Q
SPS23 ;
I '((X?1"A"3N)!(X?1"B"3N)) K X Q
Q
DEC1 ;Input transforms & decimals for SSDi's to accept XX & decimals
S X=$TR(X,"ax","AX")
I X?1N S X=X_".0" Q
I X?1"."1N S X="0"_X Q
D XX1 Q
XX1 ;
I X?1"X"1N S X="X."_$E(X,$L(X)) Q
Q
DEC2 ;
S X=$TR(X,"ax","AX")
I X?1.2N S X=X_".0" Q
I X?1"."1N S X="0"_X Q
D XX2 Q
XX2 ;
I X?1.2"X"1N S X="XX."_$E(X,$L(X)) Q
Q
DEC3 ;
S X=$TR(X,"ax","AX")
I X?1.3N S X=X_".0" Q
I X?1"."1N S X="0"_X Q
D XX3 Q
XX3 ;
I X?1.3"X"1N S X="XXX."_$E(X,$L(X)) Q
Q
DEC4 ;
S X=$TR(X,"ax","AX")
I X?1.4N S X=X_".0" Q
I X?1"."1N S X="0"_X Q
D XX4 Q
XX4 ;
I X?1.4"X"1N S X="XXXX."_$E(X,$L(X)) Q
Q
DEC5 ;
S X=$TR(X,"ax","AX")
I X?1.5N S X=X_".0" Q
I X?1"."1N S X="0"_X Q
I X?6N K X Q
D XX5 Q
XX5 ;
I X?1.5"X"1N S X="XXXXX."_$E(X,$L(X)) Q
Q
GEN2 ;
S X=$TR(X,"x","X")
I "ABCDEFGHIJKLMNOPQRSTUVWYZabcdefghijklmnopqrstuvwyz"[$E(X,1) K X Q
I X?1N S X="0"_X
Q
GEN3 ;
S X=$TR(X,"x","X")
I X?1N S X="00"_X
I X?2N S X="0"_X
Q
BTTIT ;Breslow Tumor Thickness Input Transform #3817
D DEC2
I '(X?0.2AN0.1"."1N) K X Q
I "0123456789.AX"'[$E(X,1) K X Q
I $E(X,1,2)="AX" S X="AX.0" Q
Q
ERR ;ER & PR Percent Positive or Range #3826 & #3914
S X=$TR(X,"rx","RX")
I "0123456789RX"'[$E(X,1) K X Q
I X?1N S X="00"_X W " ...",X
I X?2N S X="0"_X W " ...",X
I X?1"X"1N S X="X"_X W " ...",X
I $L(X)<3 K X Q
I $E(X,1)="R","R10^R20^R30^R40^R50^R60^R70^R80^R90^R99"'[X K X Q
I $E(X,1)="X","XX8^XX9"'[X K X Q
Q
ERTA ;ER & PR Allred Score #3828 & #3916
S X=$TR(X,"x","X")
I X?1N S X="0"_X W " ...",X
I "00^01^02^03^04^05^06^07^08^X8^X9"'[X K X Q
Q
SAR ;Sarcomatoid Features #3925
S X=$TR(X,"rx","RX")
I "0123456789RX"'[$E(X,1) K X Q
I X?1N S X="00"_X W " ...",X
I X?2N S X="0"_X W " ...",X
I X?1"X"1N S X="X"_X W " ...",X
I X?1"R"1N S X=$E(X,1)_"0"_$E(X,2) W " ...",X
I $L(X)<3 K X Q
I $E(X,1)="R","R01^R02^R03^R40^R05"'[X K X Q
I $E(X,1)="X","XX5^XX6^XX7^XX8^XX9"'[X K X Q
Q
FIGOHLP ; FIGO STAGE #3836
D ^ONCSCHMA I '$D(ONCSCMA)!(ONCSCMA=0) W !!,"No Schema Calculated!",!! Q
I ONCSCMA="00500" D O1,O1A,O1B,O2,O3,O3A,O3B,O3C,O4,O4A,O4B,O97,O98,O99 Q
I ONCSCMA="00510" D O1,O2,O3,O4,O4A,O4B,O97,O98,O99 Q
I (ONCSCMA="00520")!(ONCSCMA="09520") D O1,O1A,O1A1,O1A2,O1B,O1B1,O1B2,O1B3,O2,O2A,O2A1,O2A2,O2B,O3,O3A,O3B,O3C,O3C1,O3C2,O4,O4A,O4B,O97,O98,O99 Q
I (ONCSCMA="00528")!(ONCSCMA="00541") D O1,O1A,O1B,O2,O2A,O2B,O3,O3A,O3B,O3C,O4,O4A,O4B,O98,O99 Q
I ONCSCMA="00542" D O1,O1A,O1B,O1C,O2,O2A,O2B,O3,O3A,O3B,O3C,O4,O4A,O4B,O98,O99 Q
I ONCSCMA="00530" D O1,O1A,O1B,O2,O3,O3A,O3B,O3C,O3C1,O3C2,O4,O4A,O4B,O97,O98,O99 Q
I (ONCSCMA="00551")!(ONCSCMA="00552")!(ONCSCMA="00553") D O1,O1A,O1B,O1C,O1C1,O1C2,O1C3,O2,O2A,O2B,O3,O3A,O3A1,O3A11,O3A12,O3A2,O3B,O3C,O4,O4A,O4B,O97,O98,O99 Q
I ONCSCMA="00560" D O1,O2,O3,O4,O97,O98,O99 Q
W !?4,"No FIGO Stage Codes for this Schema",!! K ONCFGLST Q
Q
;
FIGO ;FIGO #3836
I "12349"'[$E(X,1) K X Q
I X=9 K X Q
D ^ONCSCHMA I '$D(ONCSCMA)!(ONCSCMA=0) K X Q
I ONCSCMA="00500" D Q ;Vulva
.I "1^1A^1B^2^3^3A^3B^3C^4^4A^4B^97^98^99"'[X K X Q
I ONCSCMA="00510" D Q ;Vagina
.I "1^2^3^4^4A^4B^97^98^99"'[X K X Q
I (ONCSCMA="00520")!(ONCSCMA="09520") D Q ;Cervix
.I "1^1A^1A1^1A2^1B^1B1^1B2^1B3^2^2A^2A1^2A2^2B^3^3A^3B^3C^3C1^3C2^4^4A^4B^97^98^99"'[X K X Q
I (ONCSCMA="00528")!(ONCSCMA="00541") D Q ;Corpus Sarc
.I "1^1A^1B^2^2A^2B^3^3A^3B^3C^4^4A^4B^98^99"'[X K X Q
I ONCSCMA="00542" D Q ;Corpus Adeno
.I "1^1A^1B^1C^2^2A^2B^3^3A^3B^3C^4^4A^4B^98^99"'[X K X Q
I ONCSCMA="00530" D Q ;Corpus Carc
.I "1^1A^1B^2^3^3A^3B^3C^3C1^3C2^4^4A^4B^97^98^99"'[X K X Q
I (ONCSCMA="00551")!(ONCSCMA="00552")!(ONCSCMA="00553") D Q ;Ovary,Fallopian,PPC
.I "1^1A^1B^1C^1C1^1C2^1C3^2^2A^2B^3^3A^3A1^3A11^3A12^3A2^3B^3C^4^4A^4B^97^98^99"'[X K X Q
I ONCSCMA="00560" D Q ;Placenta
.I "1^2^3^4^97^98^99"'[X K X Q
Q
FIGOOT ;
O1 W !,"1 FIGO Stage I" Q
O1A W !,"1A FIGO Stage IA" Q
O1A1 W !,"1A1 FIGO Stage IA1" Q
O1A2 W !,"1A2 FIGO Stage IA2" Q
O1B W !,"1B FIGO Stage IB" Q
O1B1 W !,"1B1 FIGO Stage IB1" Q
O1B2 W !,"1B2 FIGO Stage IB2" Q
O1B3 W !,"1B3 FIGO Stage IB3" Q
O1C W !,"1C FIGO Stage IC" Q
O1C1 W !,"1C1 FIGO Stage IC1" Q
O1C2 W !,"1C2 FIGO Stage IC2" Q
O1C3 W !,"1C3 FIGO Stage IC3" Q
O2 W !,"2 FIGO Stage II" Q
O2A W !,"2A FIGO Stage IIA" Q
O2A1 W !,"2A1 FIGO Stage IIA1" Q
O2A2 W !,"2A2 FIGO Stage IIA2" Q
O2B W !,"2B FIGO Stage IIB" Q
O3 W !,"3 FIGO Stage III" Q
O3A W !,"3A FIGO Stage IIIA" Q
O3A1 W !,"3A1 FIGO Stage IIIA1" Q
O3A11 W !,"3A11 FIGO Stage IIIAi" Q
O3A12 W !,"3A12 FIGO Stage IIIAii" Q
O3A2 W !,"3A2 FIGO Stage IIIA2" Q
O3B W !,"3B FIGO Stage IIIB" Q
O3C W !,"3C FIGO Stage IIIC" Q
O3C1 W !,"3C1 FIGO Stage IIIC1" Q
O3C2 W !,"3C2 FIGO Stage IIIC2" Q
O4 W !,"4 FIGO Stage IV" Q
O4A W !,"4A FIGO Stage IVA" Q
O4B W !,"4B FIGO Stage IVB" Q
O97 W !,"97 Carcinoma in situ (intraepithelial, noninvasive, preinvasive)" Q
O98 W !,"98 Not applicable: Information not collected for this case" Q
O99 W !,"99 Not documented in medical record" Q
Q
PROPE ;
I X'?3N K X Q
I "000^300^350^400^500^600^700^800^900^950^999"'[X K X Q
Q
QTEST ;
F GIEN=0:0 S GIEN=$O(^ONCO(164.44,GIEN)) Q:GIEN'>0 D
.F JIEN=0:0 S JIEN=$O(^ONCO(164.44,GIEN,1,JIEN)) Q:JIEN'>0 D
..W !,GIEN,?3,JIEN
..S ONCRTKID=$P($G(^ONCO(164.44,GIEN,1,JIEN,0)),"^",3)
..S ONCRTKCH=$P($G(^ONCO(164.44,GIEN,1,JIEN,0)),"^",5)
..S ONCRTKNM=$P($G(^ONCO(164.44,GIEN,1,JIEN,0)),"^",4)
..W ?6,ONCRTKID,?11,ONCRTKCH,?16,ONCRTKNM
..I ONCRTKID'="" S ONCRTK("AJCCID",ONCRTKID)=""
..I ONCRTKCH'="" S ONCRTK("AJCCCH",ONCRTKCH)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HONCSCHMM 8920 printed Dec 13, 2024@02:28:03 Page 2
ONCSCHMM ;HINES OIFO/RTK - Miscellaneous schema code ;07/25/19
+1 ;;2.2;ONCOLOGY;**10,12,13,15,17,18,20**;Jul 31, 2013;Build 5
+2 ;
+3 QUIT
+4 ;
SCRNLV ;Screen for Lymph-Vascular Invasion field
+1 IF $PIECE($GET(^ONCO(165.5,D0,0)),"^",16)<3180000
IF ((Y<2)!(Y>7))
QUIT
+2 DO ^ONCSCHMA
IF ('$DATA(ONCSCMA))!(ONCSCMA=0)
QUIT
+3 IF $PIECE($GET(^ONCO(165.5,D0,0)),"^",16)>3171231
DO SCHMCHK
+4 IF $PIECE($GET(^ONCO(165.5,D0,0)),"^",16)>3171231
IF ONCNO8S=1
IF (Y'=8)
QUIT
+5 IF $PIECE($GET(^ONCO(165.5,D0,0)),"^",16)>3171231
IF ONCONL8=1
IF (Y=8)
QUIT
+6 IF $PIECE($GET(^ONCO(165.5,D0,0)),"^",16)>3171231
IF ONCNO8S=0
IF ONCONL8=0
IF Y<100
QUIT
+7 QUIT
SCHMCHK ;
+1 SET ONCNO8S=0
SET ONCONL8=0
+2 ;all codes apply
IF "00210^09210^00220^00241^00242^00381^00382^00383^00400^00410^00421^00422^00440^00450^00459^00480^00580^00600^00610^00631^00633^00640^00660^00671^00672^00700^00750^00090^00310^00360^00430^0073^00740^00760"[ONCSCMA
QUIT
+3 ;code 8 does not apply
IF "00071^00072^00073^00074^00075^00076^00077^00080^00100^00111^00112^00121^00122^00130^00131^00132^00133^00161^00169^00170^00180^00190^09190^00200^00230^00250"[ONCSCMA
SET ONCNO8S=1
QUIT
+4 ;code 8 does not apply
IF "00260^00270^00280^00290^00301^00302^00320^00330^00340^00350^00460^00470^00500^00510^00520^09520^00528^00530^00541^00542^00560^00570^00590^00620"[ONCSCMA
SET ONCNO8S=1
QUIT
+5 IF "00060^00118^00119^00128^00140^00150^00278^00288^00358^00370^00378^00458^00478^00551^00552^00553^00558^00559^00598^00638"[ONCSCMA
SET ONCONL8=1
QUIT
+6 ;only 8s
IF "00650^00680^00690^00698^00710^00718^00721^00722^00723^00770^00778^00790^00795^00811^00812^00821^00822^00830^99999"[ONCSCMA
SET ONCONL8=1
QUIT
+7 QUIT
SCRNSS ;Screen for SUMMARY STAGE 2018 (#1764) field
+1 NEW Z
SET Z=0
NEW ONCHIT
SET ONCHIT=0
DO ^ONCSCHMA
IF ('$DATA(ONCSCMA))!(ONCSCMA=0)
QUIT
+2 IF "00381^00382^00383^00400^00410^00421^00422^00440^00450^00458^00459^00528^00541^00680^00811"[ONCSCMA
SET ONCHIT=1
SET Z=$SELECT((Y'=0)&(Y'=8):1,1:0)
IF Z
QUIT
+3 IF "00071^00072^00073^00074^00075^00076^00077^00360^00370"[ONCSCMA
SET ONCHIT=1
SET Z=$SELECT((Y'=8):1,1:0)
IF Z
QUIT
+4 IF "00060^"[ONCSCMA
SET ONCHIT=1
SET Z=$SELECT((Y'=0)&(Y'=1)&(Y'=2)&(Y'=8):1,1:0)
IF Z
QUIT
+5 IF "00721^09721^00722^09722^09724"[ONCSCMA
SET ONCHIT=1
SET Z=$SELECT((Y'=0)&(Y'=3)&(Y'=4):1,1:0)
IF Z
QUIT
+6 IF "00723^09723"[ONCSCMA
SET ONCHIT=1
SET Z=$SELECT((Y'=3)&(Y'=4):1,1:0)
IF Z
QUIT
+7 IF "00710^00790^00795^00812"[ONCSCMA
SET ONCHIT=1
SET Z=$SELECT((Y'=0)&(Y'=3)&(Y'=4)&(Y'=8):1,1:0)
IF Z
QUIT
+8 IF "00821^00822"[ONCSCMA
SET ONCHIT=1
SET Z=$SELECT((Y'=0)&(Y'=2)&(Y'=4)&(Y'=8):1,1:0)
IF Z
QUIT
+9 IF "00830^"[ONCSCMA
SET ONCHIT=1
SET Z=$SELECT((Y'=0)&(Y'=2)&(Y'=3)&(Y'=4)&(Y'=8):1,1:0)
IF Z
QUIT
+10 IF "99999^"[ONCSCMA
SET ONCHIT=1
SET Z=$SELECT((Y=9):1,1:0)
IF Z
QUIT
+11 IF ONCHIT=0
IF ONCSCMA<999999
SET Z=1
IF Z
QUIT
+12 QUIT
SCRNFIV ;Screen for fields #3804,3811,3885,3907,3933
+1 IF $PIECE($GET(^ONCO(165.5,D0,2)),"^",1)=67421
IF (Y'=5)
QUIT
+2 IF $PIECE($GET(^ONCO(165.5,D0,2)),"^",1)'=67421
IF (Y<10)
QUIT
+3 QUIT
SCRN555 ;Screen for fields #3857,3869,3930,3931
+1 IF $PIECE($GET(^ONCO(165.5,D0,"SSD4")),"^",21)=0
IF (Y'=5)
QUIT
+2 IF $PIECE($GET(^ONCO(165.5,D0,"SSD4")),"^",21)'=0
IF (Y<10)
QUIT
+3 QUIT
RADPH3 ;
+1 IF $LENGTH(X)=3
QUIT
+2 SET X=$EXTRACT("000000",1,(3-$LENGTH(X)))_X
+3 QUIT
RADPH5 ;
+1 IF $LENGTH(X)=5
QUIT
+2 SET X=$EXTRACT("000000",1,(5-$LENGTH(X)))_X
+3 QUIT
RADPH6 ;
+1 IF $LENGTH(X)=6
QUIT
+2 SET X=$EXTRACT("000000",1,(6-$LENGTH(X)))_X
+3 QUIT
SPS23 ;
+1 IF '((X?1"A"3N)!(X?1"B"3N))
KILL X
QUIT
+2 QUIT
DEC1 ;Input transforms & decimals for SSDi's to accept XX & decimals
+1 SET X=$TRANSLATE(X,"ax","AX")
+2 IF X?1N
SET X=X_".0"
QUIT
+3 IF X?1"."1N
SET X="0"_X
QUIT
+4 DO XX1
QUIT
XX1 ;
+1 IF X?1"X"1N
SET X="X."_$EXTRACT(X,$LENGTH(X))
QUIT
+2 QUIT
DEC2 ;
+1 SET X=$TRANSLATE(X,"ax","AX")
+2 IF X?1.2N
SET X=X_".0"
QUIT
+3 IF X?1"."1N
SET X="0"_X
QUIT
+4 DO XX2
QUIT
XX2 ;
+1 IF X?1.2"X"1N
SET X="XX."_$EXTRACT(X,$LENGTH(X))
QUIT
+2 QUIT
DEC3 ;
+1 SET X=$TRANSLATE(X,"ax","AX")
+2 IF X?1.3N
SET X=X_".0"
QUIT
+3 IF X?1"."1N
SET X="0"_X
QUIT
+4 DO XX3
QUIT
XX3 ;
+1 IF X?1.3"X"1N
SET X="XXX."_$EXTRACT(X,$LENGTH(X))
QUIT
+2 QUIT
DEC4 ;
+1 SET X=$TRANSLATE(X,"ax","AX")
+2 IF X?1.4N
SET X=X_".0"
QUIT
+3 IF X?1"."1N
SET X="0"_X
QUIT
+4 DO XX4
QUIT
XX4 ;
+1 IF X?1.4"X"1N
SET X="XXXX."_$EXTRACT(X,$LENGTH(X))
QUIT
+2 QUIT
DEC5 ;
+1 SET X=$TRANSLATE(X,"ax","AX")
+2 IF X?1.5N
SET X=X_".0"
QUIT
+3 IF X?1"."1N
SET X="0"_X
QUIT
+4 IF X?6N
KILL X
QUIT
+5 DO XX5
QUIT
XX5 ;
+1 IF X?1.5"X"1N
SET X="XXXXX."_$EXTRACT(X,$LENGTH(X))
QUIT
+2 QUIT
GEN2 ;
+1 SET X=$TRANSLATE(X,"x","X")
+2 IF "ABCDEFGHIJKLMNOPQRSTUVWYZabcdefghijklmnopqrstuvwyz"[$EXTRACT(X,1)
KILL X
QUIT
+3 IF X?1N
SET X="0"_X
+4 QUIT
GEN3 ;
+1 SET X=$TRANSLATE(X,"x","X")
+2 IF X?1N
SET X="00"_X
+3 IF X?2N
SET X="0"_X
+4 QUIT
BTTIT ;Breslow Tumor Thickness Input Transform #3817
+1 DO DEC2
+2 IF '(X?0.2AN0.1"."1N)
KILL X
QUIT
+3 IF "0123456789.AX"'[$EXTRACT(X,1)
KILL X
QUIT
+4 IF $EXTRACT(X,1,2)="AX"
SET X="AX.0"
QUIT
+5 QUIT
ERR ;ER & PR Percent Positive or Range #3826 & #3914
+1 SET X=$TRANSLATE(X,"rx","RX")
+2 IF "0123456789RX"'[$EXTRACT(X,1)
KILL X
QUIT
+3 IF X?1N
SET X="00"_X
WRITE " ...",X
+4 IF X?2N
SET X="0"_X
WRITE " ...",X
+5 IF X?1"X"1N
SET X="X"_X
WRITE " ...",X
+6 IF $LENGTH(X)<3
KILL X
QUIT
+7 IF $EXTRACT(X,1)="R"
IF "R10^R20^R30^R40^R50^R60^R70^R80^R90^R99"'[X
KILL X
QUIT
+8 IF $EXTRACT(X,1)="X"
IF "XX8^XX9"'[X
KILL X
QUIT
+9 QUIT
ERTA ;ER & PR Allred Score #3828 & #3916
+1 SET X=$TRANSLATE(X,"x","X")
+2 IF X?1N
SET X="0"_X
WRITE " ...",X
+3 IF "00^01^02^03^04^05^06^07^08^X8^X9"'[X
KILL X
QUIT
+4 QUIT
SAR ;Sarcomatoid Features #3925
+1 SET X=$TRANSLATE(X,"rx","RX")
+2 IF "0123456789RX"'[$EXTRACT(X,1)
KILL X
QUIT
+3 IF X?1N
SET X="00"_X
WRITE " ...",X
+4 IF X?2N
SET X="0"_X
WRITE " ...",X
+5 IF X?1"X"1N
SET X="X"_X
WRITE " ...",X
+6 IF X?1"R"1N
SET X=$EXTRACT(X,1)_"0"_$EXTRACT(X,2)
WRITE " ...",X
+7 IF $LENGTH(X)<3
KILL X
QUIT
+8 IF $EXTRACT(X,1)="R"
IF "R01^R02^R03^R40^R05"'[X
KILL X
QUIT
+9 IF $EXTRACT(X,1)="X"
IF "XX5^XX6^XX7^XX8^XX9"'[X
KILL X
QUIT
+10 QUIT
FIGOHLP ; FIGO STAGE #3836
+1 DO ^ONCSCHMA
IF '$DATA(ONCSCMA)!(ONCSCMA=0)
WRITE !!,"No Schema Calculated!",!!
QUIT
+2 IF ONCSCMA="00500"
DO O1
DO O1A
DO O1B
DO O2
DO O3
DO O3A
DO O3B
DO O3C
DO O4
DO O4A
DO O4B
DO O97
DO O98
DO O99
QUIT
+3 IF ONCSCMA="00510"
DO O1
DO O2
DO O3
DO O4
DO O4A
DO O4B
DO O97
DO O98
DO O99
QUIT
+4 IF (ONCSCMA="00520")!(ONCSCMA="09520")
DO O1
DO O1A
DO O1A1
DO O1A2
DO O1B
DO O1B1
DO O1B2
DO O1B3
DO O2
DO O2A
DO O2A1
DO O2A2
DO O2B
DO O3
DO O3A
DO O3B
DO O3C
DO O3C1
DO O3C2
DO O4
DO O4A
DO O4B
DO O97
DO O98
DO O99
QUIT
+5 IF (ONCSCMA="00528")!(ONCSCMA="00541")
DO O1
DO O1A
DO O1B
DO O2
DO O2A
DO O2B
DO O3
DO O3A
DO O3B
DO O3C
DO O4
DO O4A
DO O4B
DO O98
DO O99
QUIT
+6 IF ONCSCMA="00542"
DO O1
DO O1A
DO O1B
DO O1C
DO O2
DO O2A
DO O2B
DO O3
DO O3A
DO O3B
DO O3C
DO O4
DO O4A
DO O4B
DO O98
DO O99
QUIT
+7 IF ONCSCMA="00530"
DO O1
DO O1A
DO O1B
DO O2
DO O3
DO O3A
DO O3B
DO O3C
DO O3C1
DO O3C2
DO O4
DO O4A
DO O4B
DO O97
DO O98
DO O99
QUIT
+8 IF (ONCSCMA="00551")!(ONCSCMA="00552")!(ONCSCMA="00553")
DO O1
DO O1A
DO O1B
DO O1C
DO O1C1
DO O1C2
DO O1C3
DO O2
DO O2A
DO O2B
DO O3
DO O3A
DO O3A1
DO O3A11
DO O3A12
DO O3A2
DO O3B
DO O3C
DO O4
DO O4A
DO O4B
DO O97
DO O98
DO O99
QUIT
+9 IF ONCSCMA="00560"
DO O1
DO O2
DO O3
DO O4
DO O97
DO O98
DO O99
QUIT
+10 WRITE !?4,"No FIGO Stage Codes for this Schema",!!
KILL ONCFGLST
QUIT
+11 QUIT
+12 ;
FIGO ;FIGO #3836
+1 IF "12349"'[$EXTRACT(X,1)
KILL X
QUIT
+2 IF X=9
KILL X
QUIT
+3 DO ^ONCSCHMA
IF '$DATA(ONCSCMA)!(ONCSCMA=0)
KILL X
QUIT
+4 ;Vulva
IF ONCSCMA="00500"
Begin DoDot:1
+5 IF "1^1A^1B^2^3^3A^3B^3C^4^4A^4B^97^98^99"'[X
KILL X
QUIT
End DoDot:1
QUIT
+6 ;Vagina
IF ONCSCMA="00510"
Begin DoDot:1
+7 IF "1^2^3^4^4A^4B^97^98^99"'[X
KILL X
QUIT
End DoDot:1
QUIT
+8 ;Cervix
IF (ONCSCMA="00520")!(ONCSCMA="09520")
Begin DoDot:1
+9 IF "1^1A^1A1^1A2^1B^1B1^1B2^1B3^2^2A^2A1^2A2^2B^3^3A^3B^3C^3C1^3C2^4^4A^4B^97^98^99"'[X
KILL X
QUIT
End DoDot:1
QUIT
+10 ;Corpus Sarc
IF (ONCSCMA="00528")!(ONCSCMA="00541")
Begin DoDot:1
+11 IF "1^1A^1B^2^2A^2B^3^3A^3B^3C^4^4A^4B^98^99"'[X
KILL X
QUIT
End DoDot:1
QUIT
+12 ;Corpus Adeno
IF ONCSCMA="00542"
Begin DoDot:1
+13 IF "1^1A^1B^1C^2^2A^2B^3^3A^3B^3C^4^4A^4B^98^99"'[X
KILL X
QUIT
End DoDot:1
QUIT
+14 ;Corpus Carc
IF ONCSCMA="00530"
Begin DoDot:1
+15 IF "1^1A^1B^2^3^3A^3B^3C^3C1^3C2^4^4A^4B^97^98^99"'[X
KILL X
QUIT
End DoDot:1
QUIT
+16 ;Ovary,Fallopian,PPC
IF (ONCSCMA="00551")!(ONCSCMA="00552")!(ONCSCMA="00553")
Begin DoDot:1
+17 IF "1^1A^1B^1C^1C1^1C2^1C3^2^2A^2B^3^3A^3A1^3A11^3A12^3A2^3B^3C^4^4A^4B^97^98^99"'[X
KILL X
QUIT
End DoDot:1
QUIT
+18 ;Placenta
IF ONCSCMA="00560"
Begin DoDot:1
+19 IF "1^2^3^4^97^98^99"'[X
KILL X
QUIT
End DoDot:1
QUIT
+20 QUIT
FIGOOT ;
O1 WRITE !,"1 FIGO Stage I"
QUIT
O1A WRITE !,"1A FIGO Stage IA"
QUIT
O1A1 WRITE !,"1A1 FIGO Stage IA1"
QUIT
O1A2 WRITE !,"1A2 FIGO Stage IA2"
QUIT
O1B WRITE !,"1B FIGO Stage IB"
QUIT
O1B1 WRITE !,"1B1 FIGO Stage IB1"
QUIT
O1B2 WRITE !,"1B2 FIGO Stage IB2"
QUIT
O1B3 WRITE !,"1B3 FIGO Stage IB3"
QUIT
O1C WRITE !,"1C FIGO Stage IC"
QUIT
O1C1 WRITE !,"1C1 FIGO Stage IC1"
QUIT
O1C2 WRITE !,"1C2 FIGO Stage IC2"
QUIT
O1C3 WRITE !,"1C3 FIGO Stage IC3"
QUIT
O2 WRITE !,"2 FIGO Stage II"
QUIT
O2A WRITE !,"2A FIGO Stage IIA"
QUIT
O2A1 WRITE !,"2A1 FIGO Stage IIA1"
QUIT
O2A2 WRITE !,"2A2 FIGO Stage IIA2"
QUIT
O2B WRITE !,"2B FIGO Stage IIB"
QUIT
O3 WRITE !,"3 FIGO Stage III"
QUIT
O3A WRITE !,"3A FIGO Stage IIIA"
QUIT
O3A1 WRITE !,"3A1 FIGO Stage IIIA1"
QUIT
O3A11 WRITE !,"3A11 FIGO Stage IIIAi"
QUIT
O3A12 WRITE !,"3A12 FIGO Stage IIIAii"
QUIT
O3A2 WRITE !,"3A2 FIGO Stage IIIA2"
QUIT
O3B WRITE !,"3B FIGO Stage IIIB"
QUIT
O3C WRITE !,"3C FIGO Stage IIIC"
QUIT
O3C1 WRITE !,"3C1 FIGO Stage IIIC1"
QUIT
O3C2 WRITE !,"3C2 FIGO Stage IIIC2"
QUIT
O4 WRITE !,"4 FIGO Stage IV"
QUIT
O4A WRITE !,"4A FIGO Stage IVA"
QUIT
O4B WRITE !,"4B FIGO Stage IVB"
QUIT
O97 WRITE !,"97 Carcinoma in situ (intraepithelial, noninvasive, preinvasive)"
QUIT
O98 WRITE !,"98 Not applicable: Information not collected for this case"
QUIT
O99 WRITE !,"99 Not documented in medical record"
QUIT
+1 QUIT
PROPE ;
+1 IF X'?3N
KILL X
QUIT
+2 IF "000^300^350^400^500^600^700^800^900^950^999"'[X
KILL X
QUIT
+3 QUIT
QTEST ;
+1 FOR GIEN=0:0
SET GIEN=$ORDER(^ONCO(164.44,GIEN))
if GIEN'>0
QUIT
Begin DoDot:1
+2 FOR JIEN=0:0
SET JIEN=$ORDER(^ONCO(164.44,GIEN,1,JIEN))
if JIEN'>0
QUIT
Begin DoDot:2
+3 WRITE !,GIEN,?3,JIEN
+4 SET ONCRTKID=$PIECE($GET(^ONCO(164.44,GIEN,1,JIEN,0)),"^",3)
+5 SET ONCRTKCH=$PIECE($GET(^ONCO(164.44,GIEN,1,JIEN,0)),"^",5)
+6 SET ONCRTKNM=$PIECE($GET(^ONCO(164.44,GIEN,1,JIEN,0)),"^",4)
+7 WRITE ?6,ONCRTKID,?11,ONCRTKCH,?16,ONCRTKNM
+8 IF ONCRTKID'=""
SET ONCRTK("AJCCID",ONCRTKID)=""
+9 IF ONCRTKCH'=""
SET ONCRTK("AJCCCH",ONCRTKCH)=""
End DoDot:2
End DoDot:1
+10 QUIT
