ONCOPCE ;HINES OIFO/GWB PCE MAIN ROUTINE ;08/15/11
;;2.2;ONCOLOGY;**1**;Jul 31, 2013;Build 8
;
N D0,DA,DATEDX,DD,DIC,DIE,DINUM,DIR,DLAYGO,DO,DR,DP,DL,DQ,DM,DK,DI,DIEL
N DOV,ITFLAG,ONCONUM,ONCOPA,%DT
G:'ONCOD0P EXIT S ONCONUM=+ONCOD0P N ONCOD0P
G:'ONCOD0 EXIT S ONCOPA=ONCOD0 N ONCOD0
S DATEDX=$P($G(^ONCO(165.5,ONCONUM,0)),U,16)
I DATEDX>3111231 D ^ONCPM Q
I DATEDX<3120000 D
.W !!,?10,"DATE DX earlier than 2012. Performance Measures not collected."
.W !,?10,"Checking for PCE eligibility..."
K PCEITC
S PCEITC("C16.0")="" ;Cardia, NOS
S PCEITC("C16.1")="" ;Fundus of stomach
S PCEITC("C16.2")="" ;Body of stomach
S PCEITC("C16.3")="" ;Gastric antrum
S PCEITC("C16.4")="" ;Pylorus
S PCEITC("C16.5")="" ;Lesser curvature of stomach, NOS
S PCEITC("C16.6")="" ;Greater curvature of stomach, NOS
S PCEITC("C16.8")="" ;Overlapping lesion of stomach
S PCEITC("C16.9")="" ;Stomach, NOS
S PCEITC("C18.0")="" ;Cecum
S PCEITC("C18.1")="" ;Appendix
S PCEITC("C18.2")="" ;Ascending
S PCEITC("C18.3")="" ;Hepatic flexure
S PCEITC("C18.4")="" ;Transverse
S PCEITC("C18.5")="" ;Splenic flexure
S PCEITC("C18.6")="" ;Descending
S PCEITC("C18.7")="" ;Sigmoid
S PCEITC("C18.8")="" ;Overlapping lesion
S PCEITC("C18.9")="" ;Colon, NOS
S PCEITC("C19.9")="" ;Rectosigmoid junction
S PCEITC("C20.9")="" ;Rectum
S PCEITC("C22.0")="" ;Liver
S PCEITC("C34.0")="" ;Main Bronchus
S PCEITC("C34.1")="" ;Upper lobe lung
S PCEITC("C34.2")="" ;Middle lobe lung
S PCEITC("C34.3")="" ;Lower lobe lung
S PCEITC("C34.8")="" ;Overlapping lesion of lung
S PCEITC("C34.9")="" ;Lung, NOS
S PCEITC("C38.0")="" ;Heart
S PCEITC("C38.1")="" ;Mediastinum, anterior
S PCEITC("C38.2")="" ;Mediastinum, posterior
S PCEITC("C38.3")="" ;Mediastinum, NOS
S PCEITC("C38.4")="" ;Pleura, NOS
S PCEITC("C38.8")="" ;Heart/Medias/Pleura, overlap
S PCEITC("C44.0")="" ;Skin of lip, NOS
S PCEITC("C44.2")="" ;External ear
S PCEITC("C44.3")="" ;Skin of other and unspecified parts of face
S PCEITC("C44.4")="" ;Skin of scalp and neck
S PCEITC("C44.5")="" ;Skin of trunk
S PCEITC("C44.6")="" ;Skin of upper limb and shoulder
S PCEITC("C44.7")="" ;Skin of lower limb and hip
S PCEITC("C44.8")="" ;Overlapping lesion
S PCEITC("C44.9")="" ;Skin, NOS
S PCEITC("C47.0")="" ;Nerves, head & neck
S PCEITC("C47.1")="" ;Nerves, upper limb
S PCEITC("C47.2")="" ;Nerves, lower limb
S PCEITC("C47.3")="" ;Nerves, thorax
S PCEITC("C47.4")="" ;Nerves, abdomen
S PCEITC("C47.5")="" ;Nerves, pelvis
S PCEITC("C47.6")="" ;Nerves, trunk
S PCEITC("C47.8")="" ;Nerves, overlap
S PCEITC("C47.9")="" ;Autonomic nervous system, NOS
S PCEITC("C48.0")="" ;Retroperitoneum
S PCEITC("C48.1")="" ;Peritoneum, specified
S PCEITC("C48.2")="" ;Peritoneum, NOS
S PCEITC("C48.8")="" ;Retroperitoneum overlap
S PCEITC("C49.0")="" ;Soft tissues, head & neck
S PCEITC("C49.1")="" ;Soft tissues, upper limb
S PCEITC("C49.2")="" ;Soft tissues, lower limb
S PCEITC("C49.3")="" ;Soft tissues, thorax
S PCEITC("C49.4")="" ;Soft tissues, abdomen
S PCEITC("C49.5")="" ;Soft tissues, pelvis
S PCEITC("C49.6")="" ;Soft tissues, trunk
S PCEITC("C49.8")="" ;Soft tissues overlap
S PCEITC("C49.9")="" ;Soft tissues NOS
S PCEITC("C50.0")="" ;Nipple
S PCEITC("C50.1")="" ;Central portion breast
S PCEITC("C50.2")="" ;Upper-inner quadrant breast
S PCEITC("C50.3")="" ;Lower-inner quadrant breast
S PCEITC("C50.4")="" ;Upper-outer quadrant breast
S PCEITC("C50.5")="" ;Lower-outer quadrant breast
S PCEITC("C50.6")="" ;Axillary tail breast
S PCEITC("C50.8")="" ;Overlapping lesion breast
S PCEITC("C50.9")="" ;Breast, NOS
S PCEITC("C61.9")="" ;Prostate
S PCEITC("C67.0")="" ;Urinary Bladder
S PCEITC("C67.1")="" ;Urinary Bladder
S PCEITC("C67.2")="" ;Urinary Bladder
S PCEITC("C67.3")="" ;Urinary Bladder
S PCEITC("C67.4")="" ;Urinary Bladder
S PCEITC("C67.5")="" ;Urinary Bladder
S PCEITC("C67.6")="" ;Urinary Bladder
S PCEITC("C67.7")="" ;Urinary Bladder
S PCEITC("C67.8")="" ;Urinary Bladder
S PCEITC("C67.9")="" ;Urinary Bladder
S PCEITC("C68.0")="" ;Urinary Bladder (Urethra)
S PCEITC("C70.0")="" ;Cerebral meninges
S PCEITC("C70.1")="" ;Spinal meninges
S PCEITC("C70.9")="" ;Meninges, NOS
S PCEITC("C71.0")="" ;Cerebrum
S PCEITC("C71.1")="" ;Frontal lobe
S PCEITC("C71.2")="" ;Temporal lobe
S PCEITC("C71.3")="" ;Parietal lobe
S PCEITC("C71.4")="" ;Occipital lobe
S PCEITC("C71.5")="" ;Ventricle, NOS
S PCEITC("C71.6")="" ;Cerebellum, NOS
S PCEITC("C71.7")="" ;Brain stem
S PCEITC("C71.8")="" ;Overlapping lesion on brain
S PCEITC("C71.9")="" ;Brain, NOS
S PCEITC("C72.0")="" ;Spinal cord
S PCEITC("C72.1")="" ;Cauda equina
S PCEITC("C72.2")="" ;Olfactory nerve
S PCEITC("C72.3")="" ;Optic nerve
S PCEITC("C72.4")="" ;Acoustic nerve
S PCEITC("C72.5")="" ;Cranial nerve
S PCEITC("C72.8")="" ;Overlapping lesion of brain and cns
S PCEITC("C72.9")="" ;Nervous system, NOS
S PCEITC("C73.9")="" ;Thyroid gland
S PCEITC("C75.1")="" ;Pituitary gland
S PCEITC("C75.2")="" ;Craniopharyngeal duct
S PCEITC("C75.3")="" ;Pineal gland
S ICDO=0,NODE2=$G(^ONCO(165.5,ONCONUM,2)),ICDOTOP=$P(NODE2,U,1)
S HIST=$$HIST^ONCFUNC(ONCONUM)
;
;Check if HISTOLOGY is relevant to NON-HODGKIN'S LYMPHOMA and if
;ACCESSION YEAR = 1997
S HIST1234=$E(HIST,1,4),BEH=$E(HIST,5)
I ((HIST1234>9589)&(HIST1234<9596))!((HIST1234>9669)&(HIST1234<9718)),$P(^ONCO(165.5,ONCONUM,0),U,7)=1997 D ^ONCNPC0 G EXIT
;
;Check if HISTOLOGY is relevant to MELANOMA and if ACCESSION YEAR = 1999
S HIST123=$E(HIST,1,3),BEH=$E(HIST,5)
I ((HIST123>871)&(HIST123<880))!((HIST=90443)&($E(ICDOTOP,1,4)=6749)),$P(^ONCO(165.5,ONCONUM,0),U,7)=1999 D ^ONCMPC0 G EXIT
;
;Check for pediatric cases of rhabdomyosarcoma (Soft Tissue Sarcoma)
S D0=ONCOPA D DOB1^ONCOES S X1=DT,X2=X D ^%DTC S AGE=X\365.25,D0=ONCONUM
I AGE<21,((HIST=89003)!(HIST=89013)!(HIST=89023)!(HIST=89103)!(HIST=89203)) D ^ONCSPC0 G EXIT
;
;Check Primary Site
I ICDOTOP'="" S ICDO=$P(^ONCO(164,ICDOTOP,0),U,2)
I ICDO=0 G:ONCOANS'=5 EXIT W !!,?10,"There is no ICDO-TOPOGRAPHY for this primary." R Z:10 G EXIT
I '$D(PCEITC(ICDO)) G:ONCOANS'=5 EXIT W !!,?10,"There is currently no PCE for this primary site",!,?10,"nor is it a 1997 Non-Hodgkin's Lymphoma or 1999",!,?10,"Melanoma." R Z:10 G EXIT
I ($E(ICDO,2,3)=67)!($E(ICDO,2,3)=68) D ^ONCBPC0 G EXIT
I ($E(ICDO,2,3)=38)!($E(ICDO,2,3)=47)!($E(ICDO,2,3)=48)!($E(ICDO,2,3)=49)!($E(ICDO,2,3)=44) D ^ONCSPC0 G EXIT
I ICDO="C73.9" D ^ONCTPC0 G EXIT
I ICDO="C61.9" D ^ONCP2P0 G EXIT
I ($E(ICDO,2,3)=18)!($E(ICDO,2,3)=19)!($E(ICDO,2,3)=20) D ^ONCCPC0 G EXIT
I $E(ICDO,2,3)=50 D ^ONCBRP0 G EXIT
I ICDO="C22.0" D ^ONCHPC0 G EXIT
I ($E(ICDO,2,3)=70)!($E(ICDO,2,3)=71)!($E(ICDO,2,3)=72)!(ICDO="C75.1")!(ICDO="C75.2")!(ICDO="C75.3") D ^ONCIPC0 G EXIT
I $E(ICDO,2,3)=16 D ^ONCGPC0 G EXIT
I $E(ICDO,2,3)=34 D ^ONCLPC0 G EXIT
Q
EXIT K PCEITC,NODE2,ICDOTOP,ICDO,Z,X1,X2,AGE,HIST,HIST1234,HIST123,BEH
Q
DATEIT ;Date input transform
I X="00/00/00" W *7,!!?5,"'00/00/00' is ambiguous, enter a 4 digit year.",!! S ITFLAG="YES" K X Q
I X="00/00/0000" S X="0000000" S ITFLAG="YES" Q
I X="00000000" S X="0000000" S ITFLAG="YES" W " 00/00/0000" Q
I X="88/88/88" W *7,!!?5,"'88/88/88' is ambiguous, enter a 4 digit year.",!! S ITFLAG="YES" K X Q
I X="88/88/8888" S X=8888888 S ITFLAG="YES" Q
I X="88888888" S X=8888888 S ITFLAG="YES" W " 88/88/8888" Q
I X="99/99/99" W *7,!!?5,"'99/99/99' is ambiguous, enter a 4 digit year.",!! S ITFLAG="YES" K X Q
I X="99/99/9999" S X=9999999 S ITFLAG="YES" Q
I X="99999999" S X=9999999 S ITFLAG="YES" W " 99/99/9999" Q
Q
DATEOT ;Date output transform in format MM/DD/YYYY
Q:Y=""
S Y=$S(Y="0000000":"00/00/0000",Y=9999999:"99/99/9999",Y=8888888:"88/88/8888",1:$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_($E(Y,1,3)+1700))
Q
CHDTIT ;Date input transform for fields #1103 and #1105
I X="00/00/00" W *7,!!?5,"'00/00/00' is ambiguous, enter a 4 digit year.",!! S ITFLAG="YES" K X Q
I X="00/0000" S X="0000000" S ITFLAG="YES" Q
I (X="00000000")!(X="00/00/0000") S X="0000000" S ITFLAG="YES" W " 00/0000" Q
I X="99/99/99" W *7,!!?5,"'99/99/99' is ambiguous, enter a 4 digit year.",!! S ITFLAG="YES" K X Q
I X="99/9999" S X=9999999 S ITFLAG="YES" Q
I (X="99999999")!(X="99/99/9999") S X=9999999 S ITFLAG="YES" W " 99/9999" Q
I X="88/88/88" W *7,!!?5,"'88/88/88' is ambiguous, enter a 4 digit year.",!! S ITFLAG="YES" K X Q
I X="88/8888" S X="8888888" S ITFLAG="YES" Q
I (X="88888888")!(X="88/88/8888") S X="8888888" S ITFLAG="YES" W " 88/8888" Q
S %DT="EP",%DT(0)="-NOW" D ^%DT S X=Y I Y<1 K X W !!?5,"Future dates are not allowed.",! K %DT(0) Q
Q
CHDTOT ;Date output transform for fields #1103 and #1105
Q:Y=""
I Y="0000000" S Y="00/0000" Q
I Y=9999999 S Y="99/9999" Q
I Y=8888888 S Y="88/8888" Q
S Y=$E(Y,4,5)_"/"_($E(Y,1,3)+1700)
Q
;
CLEANUP ;Cleanup
K ONCOANS,Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HONCOPCE 8993 printed Apr 09, 2024@21:28:33 Page 2
ONCOPCE ;HINES OIFO/GWB PCE MAIN ROUTINE ;08/15/11
+1 ;;2.2;ONCOLOGY;**1**;Jul 31, 2013;Build 8
+2 ;
+3 NEW D0,DA,DATEDX,DD,DIC,DIE,DINUM,DIR,DLAYGO,DO,DR,DP,DL,DQ,DM,DK,DI,DIEL
+4 NEW DOV,ITFLAG,ONCONUM,ONCOPA,%DT
+5 if 'ONCOD0P
GOTO EXIT
SET ONCONUM=+ONCOD0P
NEW ONCOD0P
+6 if 'ONCOD0
GOTO EXIT
SET ONCOPA=ONCOD0
NEW ONCOD0
+7 SET DATEDX=$PIECE($GET(^ONCO(165.5,ONCONUM,0)),U,16)
+8 IF DATEDX>3111231
DO ^ONCPM
QUIT
+9 IF DATEDX<3120000
Begin DoDot:1
+10 WRITE !!,?10,"DATE DX earlier than 2012. Performance Measures not collected."
+11 WRITE !,?10,"Checking for PCE eligibility..."
End DoDot:1
+12 KILL PCEITC
+13 ;Cardia, NOS
SET PCEITC("C16.0")=""
+14 ;Fundus of stomach
SET PCEITC("C16.1")=""
+15 ;Body of stomach
SET PCEITC("C16.2")=""
+16 ;Gastric antrum
SET PCEITC("C16.3")=""
+17 ;Pylorus
SET PCEITC("C16.4")=""
+18 ;Lesser curvature of stomach, NOS
SET PCEITC("C16.5")=""
+19 ;Greater curvature of stomach, NOS
SET PCEITC("C16.6")=""
+20 ;Overlapping lesion of stomach
SET PCEITC("C16.8")=""
+21 ;Stomach, NOS
SET PCEITC("C16.9")=""
+22 ;Cecum
SET PCEITC("C18.0")=""
+23 ;Appendix
SET PCEITC("C18.1")=""
+24 ;Ascending
SET PCEITC("C18.2")=""
+25 ;Hepatic flexure
SET PCEITC("C18.3")=""
+26 ;Transverse
SET PCEITC("C18.4")=""
+27 ;Splenic flexure
SET PCEITC("C18.5")=""
+28 ;Descending
SET PCEITC("C18.6")=""
+29 ;Sigmoid
SET PCEITC("C18.7")=""
+30 ;Overlapping lesion
SET PCEITC("C18.8")=""
+31 ;Colon, NOS
SET PCEITC("C18.9")=""
+32 ;Rectosigmoid junction
SET PCEITC("C19.9")=""
+33 ;Rectum
SET PCEITC("C20.9")=""
+34 ;Liver
SET PCEITC("C22.0")=""
+35 ;Main Bronchus
SET PCEITC("C34.0")=""
+36 ;Upper lobe lung
SET PCEITC("C34.1")=""
+37 ;Middle lobe lung
SET PCEITC("C34.2")=""
+38 ;Lower lobe lung
SET PCEITC("C34.3")=""
+39 ;Overlapping lesion of lung
SET PCEITC("C34.8")=""
+40 ;Lung, NOS
SET PCEITC("C34.9")=""
+41 ;Heart
SET PCEITC("C38.0")=""
+42 ;Mediastinum, anterior
SET PCEITC("C38.1")=""
+43 ;Mediastinum, posterior
SET PCEITC("C38.2")=""
+44 ;Mediastinum, NOS
SET PCEITC("C38.3")=""
+45 ;Pleura, NOS
SET PCEITC("C38.4")=""
+46 ;Heart/Medias/Pleura, overlap
SET PCEITC("C38.8")=""
+47 ;Skin of lip, NOS
SET PCEITC("C44.0")=""
+48 ;External ear
SET PCEITC("C44.2")=""
+49 ;Skin of other and unspecified parts of face
SET PCEITC("C44.3")=""
+50 ;Skin of scalp and neck
SET PCEITC("C44.4")=""
+51 ;Skin of trunk
SET PCEITC("C44.5")=""
+52 ;Skin of upper limb and shoulder
SET PCEITC("C44.6")=""
+53 ;Skin of lower limb and hip
SET PCEITC("C44.7")=""
+54 ;Overlapping lesion
SET PCEITC("C44.8")=""
+55 ;Skin, NOS
SET PCEITC("C44.9")=""
+56 ;Nerves, head & neck
SET PCEITC("C47.0")=""
+57 ;Nerves, upper limb
SET PCEITC("C47.1")=""
+58 ;Nerves, lower limb
SET PCEITC("C47.2")=""
+59 ;Nerves, thorax
SET PCEITC("C47.3")=""
+60 ;Nerves, abdomen
SET PCEITC("C47.4")=""
+61 ;Nerves, pelvis
SET PCEITC("C47.5")=""
+62 ;Nerves, trunk
SET PCEITC("C47.6")=""
+63 ;Nerves, overlap
SET PCEITC("C47.8")=""
+64 ;Autonomic nervous system, NOS
SET PCEITC("C47.9")=""
+65 ;Retroperitoneum
SET PCEITC("C48.0")=""
+66 ;Peritoneum, specified
SET PCEITC("C48.1")=""
+67 ;Peritoneum, NOS
SET PCEITC("C48.2")=""
+68 ;Retroperitoneum overlap
SET PCEITC("C48.8")=""
+69 ;Soft tissues, head & neck
SET PCEITC("C49.0")=""
+70 ;Soft tissues, upper limb
SET PCEITC("C49.1")=""
+71 ;Soft tissues, lower limb
SET PCEITC("C49.2")=""
+72 ;Soft tissues, thorax
SET PCEITC("C49.3")=""
+73 ;Soft tissues, abdomen
SET PCEITC("C49.4")=""
+74 ;Soft tissues, pelvis
SET PCEITC("C49.5")=""
+75 ;Soft tissues, trunk
SET PCEITC("C49.6")=""
+76 ;Soft tissues overlap
SET PCEITC("C49.8")=""
+77 ;Soft tissues NOS
SET PCEITC("C49.9")=""
+78 ;Nipple
SET PCEITC("C50.0")=""
+79 ;Central portion breast
SET PCEITC("C50.1")=""
+80 ;Upper-inner quadrant breast
SET PCEITC("C50.2")=""
+81 ;Lower-inner quadrant breast
SET PCEITC("C50.3")=""
+82 ;Upper-outer quadrant breast
SET PCEITC("C50.4")=""
+83 ;Lower-outer quadrant breast
SET PCEITC("C50.5")=""
+84 ;Axillary tail breast
SET PCEITC("C50.6")=""
+85 ;Overlapping lesion breast
SET PCEITC("C50.8")=""
+86 ;Breast, NOS
SET PCEITC("C50.9")=""
+87 ;Prostate
SET PCEITC("C61.9")=""
+88 ;Urinary Bladder
SET PCEITC("C67.0")=""
+89 ;Urinary Bladder
SET PCEITC("C67.1")=""
+90 ;Urinary Bladder
SET PCEITC("C67.2")=""
+91 ;Urinary Bladder
SET PCEITC("C67.3")=""
+92 ;Urinary Bladder
SET PCEITC("C67.4")=""
+93 ;Urinary Bladder
SET PCEITC("C67.5")=""
+94 ;Urinary Bladder
SET PCEITC("C67.6")=""
+95 ;Urinary Bladder
SET PCEITC("C67.7")=""
+96 ;Urinary Bladder
SET PCEITC("C67.8")=""
+97 ;Urinary Bladder
SET PCEITC("C67.9")=""
+98 ;Urinary Bladder (Urethra)
SET PCEITC("C68.0")=""
+99 ;Cerebral meninges
SET PCEITC("C70.0")=""
+100 ;Spinal meninges
SET PCEITC("C70.1")=""
+101 ;Meninges, NOS
SET PCEITC("C70.9")=""
+102 ;Cerebrum
SET PCEITC("C71.0")=""
+103 ;Frontal lobe
SET PCEITC("C71.1")=""
+104 ;Temporal lobe
SET PCEITC("C71.2")=""
+105 ;Parietal lobe
SET PCEITC("C71.3")=""
+106 ;Occipital lobe
SET PCEITC("C71.4")=""
+107 ;Ventricle, NOS
SET PCEITC("C71.5")=""
+108 ;Cerebellum, NOS
SET PCEITC("C71.6")=""
+109 ;Brain stem
SET PCEITC("C71.7")=""
+110 ;Overlapping lesion on brain
SET PCEITC("C71.8")=""
+111 ;Brain, NOS
SET PCEITC("C71.9")=""
+112 ;Spinal cord
SET PCEITC("C72.0")=""
+113 ;Cauda equina
SET PCEITC("C72.1")=""
+114 ;Olfactory nerve
SET PCEITC("C72.2")=""
+115 ;Optic nerve
SET PCEITC("C72.3")=""
+116 ;Acoustic nerve
SET PCEITC("C72.4")=""
+117 ;Cranial nerve
SET PCEITC("C72.5")=""
+118 ;Overlapping lesion of brain and cns
SET PCEITC("C72.8")=""
+119 ;Nervous system, NOS
SET PCEITC("C72.9")=""
+120 ;Thyroid gland
SET PCEITC("C73.9")=""
+121 ;Pituitary gland
SET PCEITC("C75.1")=""
+122 ;Craniopharyngeal duct
SET PCEITC("C75.2")=""
+123 ;Pineal gland
SET PCEITC("C75.3")=""
+124 SET ICDO=0
SET NODE2=$GET(^ONCO(165.5,ONCONUM,2))
SET ICDOTOP=$PIECE(NODE2,U,1)
+125 SET HIST=$$HIST^ONCFUNC(ONCONUM)
+126 ;
+127 ;Check if HISTOLOGY is relevant to NON-HODGKIN'S LYMPHOMA and if
+128 ;ACCESSION YEAR = 1997
+129 SET HIST1234=$EXTRACT(HIST,1,4)
SET BEH=$EXTRACT(HIST,5)
+130 IF ((HIST1234>9589)&(HIST1234<9596))!((HIST1234>9669)&(HIST1234<9718))
IF $PIECE(^ONCO(165.5,ONCONUM,0),U,7)=1997
DO ^ONCNPC0
GOTO EXIT
+131 ;
+132 ;Check if HISTOLOGY is relevant to MELANOMA and if ACCESSION YEAR = 1999
+133 SET HIST123=$EXTRACT(HIST,1,3)
SET BEH=$EXTRACT(HIST,5)
+134 IF ((HIST123>871)&(HIST123<880))!((HIST=90443)&($EXTRACT(ICDOTOP,1,4)=6749))
IF $PIECE(^ONCO(165.5,ONCONUM,0),U,7)=1999
DO ^ONCMPC0
GOTO EXIT
+135 ;
+136 ;Check for pediatric cases of rhabdomyosarcoma (Soft Tissue Sarcoma)
+137 SET D0=ONCOPA
DO DOB1^ONCOES
SET X1=DT
SET X2=X
DO ^%DTC
SET AGE=X\365.25
SET D0=ONCONUM
+138 IF AGE<21
IF ((HIST=89003)!(HIST=89013)!(HIST=89023)!(HIST=89103)!(HIST=89203))
DO ^ONCSPC0
GOTO EXIT
+139 ;
+140 ;Check Primary Site
+141 IF ICDOTOP'=""
SET ICDO=$PIECE(^ONCO(164,ICDOTOP,0),U,2)
+142 IF ICDO=0
if ONCOANS'=5
GOTO EXIT
WRITE !!,?10,"There is no ICDO-TOPOGRAPHY for this primary."
READ Z:10
GOTO EXIT
+143 IF '$DATA(PCEITC(ICDO))
if ONCOANS'=5
GOTO EXIT
WRITE !!,?10,"There is currently no PCE for this primary site",!,?10,"nor is it a 1997 Non-Hodgkin's Lymphoma or 1999",!,?10,"Melanoma."
READ Z:10
GOTO EXIT
+144 IF ($EXTRACT(ICDO,2,3)=67)!($EXTRACT(ICDO,2,3)=68)
DO ^ONCBPC0
GOTO EXIT
+145 IF ($EXTRACT(ICDO,2,3)=38)!($EXTRACT(ICDO,2,3)=47)!($EXTRACT(ICDO,2,3)=48)!($EXTRACT(ICDO,2,3)=49)!($EXTRACT(ICDO,2,3)=44)
DO ^ONCSPC0
GOTO EXIT
+146 IF ICDO="C73.9"
DO ^ONCTPC0
GOTO EXIT
+147 IF ICDO="C61.9"
DO ^ONCP2P0
GOTO EXIT
+148 IF ($EXTRACT(ICDO,2,3)=18)!($EXTRACT(ICDO,2,3)=19)!($EXTRACT(ICDO,2,3)=20)
DO ^ONCCPC0
GOTO EXIT
+149 IF $EXTRACT(ICDO,2,3)=50
DO ^ONCBRP0
GOTO EXIT
+150 IF ICDO="C22.0"
DO ^ONCHPC0
GOTO EXIT
+151 IF ($EXTRACT(ICDO,2,3)=70)!($EXTRACT(ICDO,2,3)=71)!($EXTRACT(ICDO,2,3)=72)!(ICDO="C75.1")!(ICDO="C75.2")!(ICDO="C75.3")
DO ^ONCIPC0
GOTO EXIT
+152 IF $EXTRACT(ICDO,2,3)=16
DO ^ONCGPC0
GOTO EXIT
+153 IF $EXTRACT(ICDO,2,3)=34
DO ^ONCLPC0
GOTO EXIT
+154 QUIT
EXIT KILL PCEITC,NODE2,ICDOTOP,ICDO,Z,X1,X2,AGE,HIST,HIST1234,HIST123,BEH
+1 QUIT
DATEIT ;Date input transform
+1 IF X="00/00/00"
WRITE *7,!!?5,"'00/00/00' is ambiguous, enter a 4 digit year.",!!
SET ITFLAG="YES"
KILL X
QUIT
+2 IF X="00/00/0000"
SET X="0000000"
SET ITFLAG="YES"
QUIT
+3 IF X="00000000"
SET X="0000000"
SET ITFLAG="YES"
WRITE " 00/00/0000"
QUIT
+4 IF X="88/88/88"
WRITE *7,!!?5,"'88/88/88' is ambiguous, enter a 4 digit year.",!!
SET ITFLAG="YES"
KILL X
QUIT
+5 IF X="88/88/8888"
SET X=8888888
SET ITFLAG="YES"
QUIT
+6 IF X="88888888"
SET X=8888888
SET ITFLAG="YES"
WRITE " 88/88/8888"
QUIT
+7 IF X="99/99/99"
WRITE *7,!!?5,"'99/99/99' is ambiguous, enter a 4 digit year.",!!
SET ITFLAG="YES"
KILL X
QUIT
+8 IF X="99/99/9999"
SET X=9999999
SET ITFLAG="YES"
QUIT
+9 IF X="99999999"
SET X=9999999
SET ITFLAG="YES"
WRITE " 99/99/9999"
QUIT
+10 QUIT
DATEOT ;Date output transform in format MM/DD/YYYY
+1 if Y=""
QUIT
+2 SET Y=$SELECT(Y="0000000":"00/00/0000",Y=9999999:"99/99/9999",Y=8888888:"88/88/8888",1:$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_($EXTRACT(Y,1,3)+1700))
+3 QUIT
CHDTIT ;Date input transform for fields #1103 and #1105
+1 IF X="00/00/00"
WRITE *7,!!?5,"'00/00/00' is ambiguous, enter a 4 digit year.",!!
SET ITFLAG="YES"
KILL X
QUIT
+2 IF X="00/0000"
SET X="0000000"
SET ITFLAG="YES"
QUIT
+3 IF (X="00000000")!(X="00/00/0000")
SET X="0000000"
SET ITFLAG="YES"
WRITE " 00/0000"
QUIT
+4 IF X="99/99/99"
WRITE *7,!!?5,"'99/99/99' is ambiguous, enter a 4 digit year.",!!
SET ITFLAG="YES"
KILL X
QUIT
+5 IF X="99/9999"
SET X=9999999
SET ITFLAG="YES"
QUIT
+6 IF (X="99999999")!(X="99/99/9999")
SET X=9999999
SET ITFLAG="YES"
WRITE " 99/9999"
QUIT
+7 IF X="88/88/88"
WRITE *7,!!?5,"'88/88/88' is ambiguous, enter a 4 digit year.",!!
SET ITFLAG="YES"
KILL X
QUIT
+8 IF X="88/8888"
SET X="8888888"
SET ITFLAG="YES"
QUIT
+9 IF (X="88888888")!(X="88/88/8888")
SET X="8888888"
SET ITFLAG="YES"
WRITE " 88/8888"
QUIT
+10 SET %DT="EP"
SET %DT(0)="-NOW"
DO ^%DT
SET X=Y
IF Y<1
KILL X
WRITE !!?5,"Future dates are not allowed.",!
KILL %DT(0)
QUIT
+11 QUIT
CHDTOT ;Date output transform for fields #1103 and #1105
+1 if Y=""
QUIT
+2 IF Y="0000000"
SET Y="00/0000"
QUIT
+3 IF Y=9999999
SET Y="99/9999"
QUIT
+4 IF Y=8888888
SET Y="88/8888"
QUIT
+5 SET Y=$EXTRACT(Y,4,5)_"/"_($EXTRACT(Y,1,3)+1700)
+6 QUIT
+7 ;
CLEANUP ;Cleanup
+1 KILL ONCOANS,Y
