- 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 Jan 18, 2025@03:26:31 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