ONCATF1 ;HINES OIFO/RTK - Treatment AT THIS FACILITY stuffing (cont.); 06/23/10a
;;2.2;ONCOLOGY;**1,5,10,20**;Jul 31, 2013;Build 5
;
RAD ;Radiation @fac
N COC
S RAUP=1 D RFNR^ONCATF1
D CHKCOC I COC'=37 Q
S $P(^ONCO(165.5,D0,3.1),U,12)=$P($G(^ONCO(165.5,D0,3)),U,6)
Q
;
RADDT ;Radiation @fac date
N COC
D CHKCOC I COC'=37 Q
S $P(^ONCO(165.5,D0,3.1),U,13)=$P($G(^ONCO(165.5,D0,3)),U,4)
Q
;
DSPRAD ;Display Radiation @fac fields
N COC
D CHKCOC I (COC="00")!(COC=30)!(COC=31)!(COC=32)!(COC=33)!(COC=40)!(COC=41) D K TXNO,TXUNK,TXNUL S Y="@411" Q
.S NTX=1 W ! D RADATF^ONCNTX1 K NTX
.I $G(DRATF)=1 K DRATF,TXNUL Q
I $G(DRATF)=1 K DRATF,TXNUL S Y="@411" Q
I COC'=37 D Q
.I $G(TXNO)=1 S NTX=1 W ! D RADATF^ONCNTX1 K NTX,TXNO S Y="@411" Q
.I $G(TXUNK)=1 S NTX=1 W ! D RADATF^ONCUTX1 K NTX,TXUNK S Y="@411" Q
.I $G(TXNUL)=1 K TXNUL S Y="@411" Q
N DI,DIC,DA,DR,DIQ,ONC
S DIC="^ONCO(165.5,",DA=D0,DIQ="ONC(",DIQ(0)="E",DR="51.4;51.5"
D EN^DIQ1
W !!,$P(^DD(165.5,51.4,0),U,1),"............: "_$E(ONC(165.5,DA,51.4,"E"),1,47)
W !,$P(^DD(165.5,51.5,0),U,1),".......: "_ONC(165.5,DA,51.5,"E")
K TXNO,TXUNK,TXNUL S Y="@411" Q
;
CHEM ;Chemotherapy @fac
N COC
D CHKCOC I COC'=37 Q
S $P(^ONCO(165.5,D0,3.1),U,14)=$P($G(^ONCO(165.5,D0,3)),U,13)
Q
;
CHEMDT ;Chemotherapy @fac date
N COC
D CHKCOC I COC'=37 Q
S $P(^ONCO(165.5,D0,3.1),U,15)=$P($G(^ONCO(165.5,D0,3)),U,11)
Q
;
DSPCHEM ;Display Chemotherapy @fac fields
N COC
D CHKCOC I (COC="00")!(COC=30)!(COC=31)!(COC=32)!(COC=33)!(COC=40)!(COC=41) D K TXNO,TXUNK,TXNUL S Y="@415" Q
.S NTX=1 W ! D CHEMATF^ONCNTX1 K NTX
.I $G(DCATF)=1 K DCATF,TXNUL Q
I $G(DCATF)=1 K DCATF,TXNUL S Y="@415" Q
I COC'=37 D Q
.I $G(TXNO)=1 S NTX=1 W ! D CHEMATF^ONCNTX1 K NTX,TXNO S Y="@415" Q
.I $G(TXUNK)=1 S NTX=1 W ! D CHEMATF^ONCUTX1 K NTX,TXUNK S Y="@415" Q
.I $G(TXNUL)=1 K TXNUL S Y="@415" Q
K DIQ,ONC
S DIC="^ONCO(165.5,",DA=DA,DIQ="ONC(",DIQ(0)="E",DR="53.3;53.4"
D EN^DIQ1
W !!,$P(^DD(165.5,53.3,0),U,1),"........: "_$E(ONC(165.5,DA,53.3,"E"),1,47)
W !,$P(^DD(165.5,53.4,0),U,1),"...: "_ONC(165.5,DA,53.4,"E")
K TXNO,TXUNK,TXNUL S Y="@415" Q
;
HT ;Hormone therapy @fac
N COC
D CHKCOC I COC'=37 Q
S $P(^ONCO(165.5,D0,3.1),U,16)=$P($G(^ONCO(165.5,D0,3)),U,16)
Q
;
HTDT ;Hormone therapy @fac date
N COC
D CHKCOC I COC'=37 Q
S $P(^ONCO(165.5,D0,3.1),U,17)=$P($G(^ONCO(165.5,D0,3)),U,14)
Q
;
DSPHT ;Display Hormone Therapy @fac fields
N COC
D CHKCOC I (COC="00")!(COC=30)!(COC=31)!(COC=32)!(COC=33)!(COC=40)!(COC=41) D K TXNO,TXUNK,TXNUL S Y="@418" Q
.S NTX=1 W ! D HTATF^ONCNTX1 K NTX
.I $G(DHATF)=1 K DHATF,TXNUL Q
I $G(DHATF)=1 K DHATF,TXNUL S Y="@418" Q
I COC'=37 D Q
.I $G(TXNO)=1 S NTX=1 W ! D HTATF^ONCNTX1 K NTX,TXNO S Y="@418" Q
.I $G(TXUNK)=1 S NTX=1 W ! D HTATF^ONCUTX1 K NTX,TXUNK S Y="@418" Q
.I $G(TXNUL)=1 K TXNUL S Y="@418" Q
K DIQ,ONC
S DIC="^ONCO(165.5,",DA=DA,DIQ="ONC(",DIQ(0)="E",DR="54.3;54.4"
D EN^DIQ1
W !!,$P(^DD(165.5,54.3,0),U,1),".....: "_$E(ONC(165.5,DA,54.3,"E"),1,47)
W !,$P(^DD(165.5,54.4,0),U,1),": "_ONC(165.5,DA,54.4,"E")
K TXNO,TXUNK,TXNUL S Y="@418"
Q
;
IMM ;Immunotherapy @fac
N COC
D CHKCOC I COC'=37 Q
S $P(^ONCO(165.5,D0,3.1),U,18)=$P($G(^ONCO(165.5,D0,3)),U,19)
Q
;
IMMDT ;Immunotherapy @fac date
N COC
D CHKCOC I COC'=37 Q
S $P(^ONCO(165.5,D0,3.1),U,19)=$P($G(^ONCO(165.5,D0,3)),U,17)
Q
;
DSPIMM ;Display Immunotherapy @fac fields
N COC
D CHKCOC I (COC="00")!(COC=30)!(COC=31)!(COC=32)!(COC=33)!(COC=40)!(COC=41) D K TXNO,TXUNK,TXNUL S Y="@421" Q
.S NTX=1 W ! D IMMATF^ONCNTX1 K NTX
.I $G(DIATF)=1 K DIATF,TXNUL Q
I $G(DIATF)=1 K DIATF,TXNUL S Y="@421" Q
I COC'=37 D Q
.I $G(TXNO)=1 S NTX=1 W ! D IMMATF^ONCNTX1 K NTX,TXNO S Y="@421" Q
.I $G(TXUNK)=1 S NTX=1 W ! D IMMATF^ONCUTX1 K NTX,TXUNK S Y="@421" Q
.I $G(TXNUL)=1 K TXNUL S Y="@421" Q
K DIQ,ONC
S DIC="^ONCO(165.5,",DA=DA,DIQ="ONC(",DIQ(0)="E",DR="55.3;55.4"
D EN^DIQ1
W !!,$P(^DD(165.5,55.3,0),U,1),".......: "_ONC(165.5,DA,55.3,"E")
W !,$P(^DD(165.5,55.4,0),U,1),"..: "_ONC(165.5,DA,55.4,"E")
K TXNO,TXUNK,TXNUL S Y="@421" Q
;
HTEP ;Hema Trans/Endocrine Proc @fac
N COC
D CHKCOC I COC'=37 Q
S $P(^ONCO(165.5,D0,3.2),U,2)=$P($G(^ONCO(165.5,D0,3.1)),U,36)
Q
;
HTEPDT ;Hema Trans/Endocrine Proc @fac date
N COC
D CHKCOC I COC'=37 Q
S $P(^ONCO(165.5,D0,3.2),U,3)=$P($G(^ONCO(165.5,D0,3.1)),U,35)
Q
;
DSPHTEP ;Display Hema Trans/Endocrine Proc @fac fields
N COC
D CHKCOC I (COC="00")!(COC=30)!(COC=31)!(COC=32)!(COC=33)!(COC=40)!(COC=41) D K TXNO,TXUNK,TXNUL S Y="@42015" Q
.S NTX=1 W ! D HTEPATF^ONCNTX1 K NTX
.I $G(DEATF)=1 K DEATF,TXNUL Q
I $G(DEATF)=1 K DEATF,TXNUL S Y="@42015" Q
I COC'=37 D Q
.I $G(TXNO)=1 S NTX=1 W ! D HTEPATF^ONCNTX1 K NTX,TXNO S Y="@42015" Q
.I $G(TXUNK)=1 S NTX=1 W ! D HTEPATF^ONCUTX1 K NTX,TXUNK S Y="@42015" Q
.I $G(TXNUL)=1 K TXNUL S Y="@42015" Q
K DIQ,ONC
S DIC="^ONCO(165.5,",DA=DA,DIQ="ONC(",DIQ(0)="E",DR="153.2;153.3"
D EN^DIQ1
W !!,$P(^DD(165.5,153.2,0),U,1),".......: "_ONC(165.5,DA,153.2,"E")
W !,$P(^DD(165.5,153.3,0),U,1),"..: "_ONC(165.5,DA,153.3,"E")
K TXNO,TXUNK,TXNUL S Y="@42015" Q
;
OTH ;Other therapy @fac
N COC
D CHKCOC I COC'=37 Q
S $P(^ONCO(165.5,D0,3.1),U,20)=$P($G(^ONCO(165.5,D0,3)),U,25)
Q
;
OTHDT ;Other therapy @fac date
N COC
D CHKCOC I COC'=37 Q
S $P(^ONCO(165.5,D0,3.1),U,21)=$P($G(^ONCO(165.5,D0,3)),U,23)
Q
;
DSPOTH ;Display Other Treatment @fac fields
N COC
D CHKCOC I (COC="00")!(COC=30)!(COC=31)!(COC=32)!(COC=33)!(COC=40)!(COC=41) D K TXNO,TXUNK,TXNUL S Y="@424" Q
.S NTX=1 W ! D OTHATF^ONCNTX1 K NTX
.I $G(DOATF)=1 K DOATF,TXNUL Q
I $G(DOATF)=1 K DOATF,TXNUL S Y="@424" Q
I COC'=37 D Q
.I $G(TXNO)=1 S NTX=1 W ! D OTHATF^ONCNTX1 K NTX,TXNO S Y="@424" Q
.I $G(TXUNK)=1 S NTX=1 W ! D OTHATF^ONCUTX1 K NTX,TXUNK S Y="@424" Q
.I $G(TXNUL)=1 K TXNUL S Y="@424" Q
K DIQ,ONC
S DIC="^ONCO(165.5,",DA=DA,DIQ="ONC(",DIQ(0)="E",DR="57.3;57.4"
D EN^DIQ1
W !!,$P(^DD(165.5,57.3,0),U,1),".....: "_$E(ONC(165.5,DA,57.3,"E"),1,47)
W !,$P(^DD(165.5,57.4,0),U,1),": "_ONC(165.5,DA,57.4,"E")
K TXNO,TXUNK,TXNUL S Y="@424" Q
;
PP ;Palliative Procedure @fac
N COC
D CHKCOC I COC'=37 Q
S $P(^ONCO(165.5,D0,3.1),U,27)=$P($G(^ONCO(165.5,D0,3.1)),U,26)
Q
;
CHKCOC ;CLASS OF CASE
S COC=$E($$GET1^DIQ(165.5,DA,.04),1,2)
Q
;
RFNS ;If SURGERY OF PRIMARY (F) (165.5,58.6) and SURGERY OF PRIMARY @FAC (F)
;(165.5,58.7) are anything but 00 or 99, set REASON NO SURGERY OF
;PRIMARY (165.5,58) to 0 (Surgery performed)
I $P($G(^ONCO(165.5,D0,0)),U,16)>3221231 D RFNS23 Q
N FLAG1,FLAG2,SGRP,SPS,SPSATF,TPX
S (FLAG1,FLAG2)=1
S SPS=$P($G(^ONCO(165.5,D0,3.1)),U,29) I SPS="" S FLAG1=0
S SPSATF=$P($G(^ONCO(165.5,D0,3.1)),U,30) I SPSATF="" S FLAG2=0
S TPX=$P($G(^ONCO(165.5,D0,2)),U,1) I TPX="" W !!,"PRIMARY SITE is not defined" H 3 S Y="@0" Q
S SGRP=$P($G(^ONCO(164,TPX,0)),U,16)
I SPS'="" I (SPS=1)!(SPS="00")!($G(^ONCO(164,SGRP,"SPS",SPS,0))[99) S FLAG1=0
I SPSATF'="" I (SPSATF=1)!(SPSATF="00")!($G(^ONCO(164,SGRP,"SPS",SPSATF,0))[99) S FLAG2=0
I FLAG1=0,FLAG2=0 Q
S $P(^ONCO(165.5,D0,3),U,26)=0
I $G(SUUP)=1 K SUUP Q
W !,$P($G(^DD(165.5,58,0)),U,1)_"...: Surgery performed"
S Y="@431" Q
;
RFNS23 ;If valid RX Summ--Surg Prim Site 2023 fields then set REASON NO
; SURGERY OF PRIMARY (field #58) = 0 (Surgery Performed)
N FLAG1,FLAG2 S (FLAG1,FLAG2)=1
N ONCRXSUM S ONCRXSUM=$P($G(^ONCO(165.5,D0,3.2)),U,9)
N ONCRXHOS S ONCRXHOS=$P($G(^ONCO(165.5,D0,3.2)),U,9)
I (ONCRXSUM="A000")!(ONCRXSUM="B000")!(ONCRXSUM="A990")!(ONCRXSUM="B990") S FLAG1=0
I (ONCRXHOS="A000")!(ONCRXHOS="B000")!(ONCRXHOS="A990")!(ONCRXHOS="B990") S FLAG2=0
I FLAG1=0,FLAG2=0 Q
S $P(^ONCO(165.5,D0,3),U,26)=0
W !!,"REASON NO SURGERY OF PRIMARY...: Surgery performed"
S Y="@431" Q
Q
RFNR ;If RADIATION, set REASON FOR NO RADIATION = 0 (Radiation administered)
;I $P($G(^ONCO(165.5,D0,0)),U,16)>3171231 D RFNR18 Q
N RDTX,RDTXATF
S RDTX=$P($G(^ONCO(165.5,D0,3)),U,6)
S RDTXATF=$P($G(^ONCO(165.5,D0,3.1)),U,12)
I ((RDTX="")!(RDTX=0)!(RDTX=9))&((RDTXATF="")!(RDTXATF=0)!(RDTXATF=9)) Q
S $P(^ONCO(165.5,D0,3),U,35)=0
I $G(RAUP)=1 K RAUP Q
W !,$P($G(^DD(165.5,75,0)),U,1)_"........: Radiation administered"
S Y="@412" Q
Q
;
RFNR18 ;If RADIATION, set REASON FOR NO RADIATION = 0 (Radiation administered)
; Check new Phase fields for 2018+ cases
N RAD1504,RAD1531,RAD1532,RAD1533
S RAD1504=$P($G(^ONCO(165.5,D0,"RAD18")),U,4)
S RAD1531=$P($G(^ONCO(165.5,D0,"NCR18B")),U,1)
S RAD1532=$P($G(^ONCO(165.5,D0,"NCR18B")),U,2)
S RAD1533=$P($G(^ONCO(165.5,D0,"NCR18B")),U,3)
I ((RAD1504="")!(RAD1504=1))&((RAD1531="")!(RAD1531="00"))&((RAD1532="")!(RAD1532="00"))&((RAD1533="")!(RAD1533=0)!(RAD1533="000000")) Q
S $P(^ONCO(165.5,D0,3),U,35)=0
W !,$P($G(^DD(165.5,75,0)),U,1)_"........: Radiation administered"
S Y="@412" Q
Q
CLEANUP ;Cleanup
K D0,Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HONCATF1 9021 printed Jan 18, 2025@03:23:15 Page 2
ONCATF1 ;HINES OIFO/RTK - Treatment AT THIS FACILITY stuffing (cont.); 06/23/10a
+1 ;;2.2;ONCOLOGY;**1,5,10,20**;Jul 31, 2013;Build 5
+2 ;
RAD ;Radiation @fac
+1 NEW COC
+2 SET RAUP=1
DO RFNR^ONCATF1
+3 DO CHKCOC
IF COC'=37
QUIT
+4 SET $PIECE(^ONCO(165.5,D0,3.1),U,12)=$PIECE($GET(^ONCO(165.5,D0,3)),U,6)
+5 QUIT
+6 ;
RADDT ;Radiation @fac date
+1 NEW COC
+2 DO CHKCOC
IF COC'=37
QUIT
+3 SET $PIECE(^ONCO(165.5,D0,3.1),U,13)=$PIECE($GET(^ONCO(165.5,D0,3)),U,4)
+4 QUIT
+5 ;
DSPRAD ;Display Radiation @fac fields
+1 NEW COC
+2 DO CHKCOC
IF (COC="00")!(COC=30)!(COC=31)!(COC=32)!(COC=33)!(COC=40)!(COC=41)
Begin DoDot:1
+3 SET NTX=1
WRITE !
DO RADATF^ONCNTX1
KILL NTX
+4 IF $GET(DRATF)=1
KILL DRATF,TXNUL
QUIT
End DoDot:1
KILL TXNO,TXUNK,TXNUL
SET Y="@411"
QUIT
+5 IF $GET(DRATF)=1
KILL DRATF,TXNUL
SET Y="@411"
QUIT
+6 IF COC'=37
Begin DoDot:1
+7 IF $GET(TXNO)=1
SET NTX=1
WRITE !
DO RADATF^ONCNTX1
KILL NTX,TXNO
SET Y="@411"
QUIT
+8 IF $GET(TXUNK)=1
SET NTX=1
WRITE !
DO RADATF^ONCUTX1
KILL NTX,TXUNK
SET Y="@411"
QUIT
+9 IF $GET(TXNUL)=1
KILL TXNUL
SET Y="@411"
QUIT
End DoDot:1
QUIT
+10 NEW DI,DIC,DA,DR,DIQ,ONC
+11 SET DIC="^ONCO(165.5,"
SET DA=D0
SET DIQ="ONC("
SET DIQ(0)="E"
SET DR="51.4;51.5"
+12 DO EN^DIQ1
+13 WRITE !!,$PIECE(^DD(165.5,51.4,0),U,1),"............: "_$EXTRACT(ONC(165.5,DA,51.4,"E"),1,47)
+14 WRITE !,$PIECE(^DD(165.5,51.5,0),U,1),".......: "_ONC(165.5,DA,51.5,"E")
+15 KILL TXNO,TXUNK,TXNUL
SET Y="@411"
QUIT
+16 ;
CHEM ;Chemotherapy @fac
+1 NEW COC
+2 DO CHKCOC
IF COC'=37
QUIT
+3 SET $PIECE(^ONCO(165.5,D0,3.1),U,14)=$PIECE($GET(^ONCO(165.5,D0,3)),U,13)
+4 QUIT
+5 ;
CHEMDT ;Chemotherapy @fac date
+1 NEW COC
+2 DO CHKCOC
IF COC'=37
QUIT
+3 SET $PIECE(^ONCO(165.5,D0,3.1),U,15)=$PIECE($GET(^ONCO(165.5,D0,3)),U,11)
+4 QUIT
+5 ;
DSPCHEM ;Display Chemotherapy @fac fields
+1 NEW COC
+2 DO CHKCOC
IF (COC="00")!(COC=30)!(COC=31)!(COC=32)!(COC=33)!(COC=40)!(COC=41)
Begin DoDot:1
+3 SET NTX=1
WRITE !
DO CHEMATF^ONCNTX1
KILL NTX
+4 IF $GET(DCATF)=1
KILL DCATF,TXNUL
QUIT
End DoDot:1
KILL TXNO,TXUNK,TXNUL
SET Y="@415"
QUIT
+5 IF $GET(DCATF)=1
KILL DCATF,TXNUL
SET Y="@415"
QUIT
+6 IF COC'=37
Begin DoDot:1
+7 IF $GET(TXNO)=1
SET NTX=1
WRITE !
DO CHEMATF^ONCNTX1
KILL NTX,TXNO
SET Y="@415"
QUIT
+8 IF $GET(TXUNK)=1
SET NTX=1
WRITE !
DO CHEMATF^ONCUTX1
KILL NTX,TXUNK
SET Y="@415"
QUIT
+9 IF $GET(TXNUL)=1
KILL TXNUL
SET Y="@415"
QUIT
End DoDot:1
QUIT
+10 KILL DIQ,ONC
+11 SET DIC="^ONCO(165.5,"
SET DA=DA
SET DIQ="ONC("
SET DIQ(0)="E"
SET DR="53.3;53.4"
+12 DO EN^DIQ1
+13 WRITE !!,$PIECE(^DD(165.5,53.3,0),U,1),"........: "_$EXTRACT(ONC(165.5,DA,53.3,"E"),1,47)
+14 WRITE !,$PIECE(^DD(165.5,53.4,0),U,1),"...: "_ONC(165.5,DA,53.4,"E")
+15 KILL TXNO,TXUNK,TXNUL
SET Y="@415"
QUIT
+16 ;
HT ;Hormone therapy @fac
+1 NEW COC
+2 DO CHKCOC
IF COC'=37
QUIT
+3 SET $PIECE(^ONCO(165.5,D0,3.1),U,16)=$PIECE($GET(^ONCO(165.5,D0,3)),U,16)
+4 QUIT
+5 ;
HTDT ;Hormone therapy @fac date
+1 NEW COC
+2 DO CHKCOC
IF COC'=37
QUIT
+3 SET $PIECE(^ONCO(165.5,D0,3.1),U,17)=$PIECE($GET(^ONCO(165.5,D0,3)),U,14)
+4 QUIT
+5 ;
DSPHT ;Display Hormone Therapy @fac fields
+1 NEW COC
+2 DO CHKCOC
IF (COC="00")!(COC=30)!(COC=31)!(COC=32)!(COC=33)!(COC=40)!(COC=41)
Begin DoDot:1
+3 SET NTX=1
WRITE !
DO HTATF^ONCNTX1
KILL NTX
+4 IF $GET(DHATF)=1
KILL DHATF,TXNUL
QUIT
End DoDot:1
KILL TXNO,TXUNK,TXNUL
SET Y="@418"
QUIT
+5 IF $GET(DHATF)=1
KILL DHATF,TXNUL
SET Y="@418"
QUIT
+6 IF COC'=37
Begin DoDot:1
+7 IF $GET(TXNO)=1
SET NTX=1
WRITE !
DO HTATF^ONCNTX1
KILL NTX,TXNO
SET Y="@418"
QUIT
+8 IF $GET(TXUNK)=1
SET NTX=1
WRITE !
DO HTATF^ONCUTX1
KILL NTX,TXUNK
SET Y="@418"
QUIT
+9 IF $GET(TXNUL)=1
KILL TXNUL
SET Y="@418"
QUIT
End DoDot:1
QUIT
+10 KILL DIQ,ONC
+11 SET DIC="^ONCO(165.5,"
SET DA=DA
SET DIQ="ONC("
SET DIQ(0)="E"
SET DR="54.3;54.4"
+12 DO EN^DIQ1
+13 WRITE !!,$PIECE(^DD(165.5,54.3,0),U,1),".....: "_$EXTRACT(ONC(165.5,DA,54.3,"E"),1,47)
+14 WRITE !,$PIECE(^DD(165.5,54.4,0),U,1),": "_ONC(165.5,DA,54.4,"E")
+15 KILL TXNO,TXUNK,TXNUL
SET Y="@418"
+16 QUIT
+17 ;
IMM ;Immunotherapy @fac
+1 NEW COC
+2 DO CHKCOC
IF COC'=37
QUIT
+3 SET $PIECE(^ONCO(165.5,D0,3.1),U,18)=$PIECE($GET(^ONCO(165.5,D0,3)),U,19)
+4 QUIT
+5 ;
IMMDT ;Immunotherapy @fac date
+1 NEW COC
+2 DO CHKCOC
IF COC'=37
QUIT
+3 SET $PIECE(^ONCO(165.5,D0,3.1),U,19)=$PIECE($GET(^ONCO(165.5,D0,3)),U,17)
+4 QUIT
+5 ;
DSPIMM ;Display Immunotherapy @fac fields
+1 NEW COC
+2 DO CHKCOC
IF (COC="00")!(COC=30)!(COC=31)!(COC=32)!(COC=33)!(COC=40)!(COC=41)
Begin DoDot:1
+3 SET NTX=1
WRITE !
DO IMMATF^ONCNTX1
KILL NTX
+4 IF $GET(DIATF)=1
KILL DIATF,TXNUL
QUIT
End DoDot:1
KILL TXNO,TXUNK,TXNUL
SET Y="@421"
QUIT
+5 IF $GET(DIATF)=1
KILL DIATF,TXNUL
SET Y="@421"
QUIT
+6 IF COC'=37
Begin DoDot:1
+7 IF $GET(TXNO)=1
SET NTX=1
WRITE !
DO IMMATF^ONCNTX1
KILL NTX,TXNO
SET Y="@421"
QUIT
+8 IF $GET(TXUNK)=1
SET NTX=1
WRITE !
DO IMMATF^ONCUTX1
KILL NTX,TXUNK
SET Y="@421"
QUIT
+9 IF $GET(TXNUL)=1
KILL TXNUL
SET Y="@421"
QUIT
End DoDot:1
QUIT
+10 KILL DIQ,ONC
+11 SET DIC="^ONCO(165.5,"
SET DA=DA
SET DIQ="ONC("
SET DIQ(0)="E"
SET DR="55.3;55.4"
+12 DO EN^DIQ1
+13 WRITE !!,$PIECE(^DD(165.5,55.3,0),U,1),".......: "_ONC(165.5,DA,55.3,"E")
+14 WRITE !,$PIECE(^DD(165.5,55.4,0),U,1),"..: "_ONC(165.5,DA,55.4,"E")
+15 KILL TXNO,TXUNK,TXNUL
SET Y="@421"
QUIT
+16 ;
HTEP ;Hema Trans/Endocrine Proc @fac
+1 NEW COC
+2 DO CHKCOC
IF COC'=37
QUIT
+3 SET $PIECE(^ONCO(165.5,D0,3.2),U,2)=$PIECE($GET(^ONCO(165.5,D0,3.1)),U,36)
+4 QUIT
+5 ;
HTEPDT ;Hema Trans/Endocrine Proc @fac date
+1 NEW COC
+2 DO CHKCOC
IF COC'=37
QUIT
+3 SET $PIECE(^ONCO(165.5,D0,3.2),U,3)=$PIECE($GET(^ONCO(165.5,D0,3.1)),U,35)
+4 QUIT
+5 ;
DSPHTEP ;Display Hema Trans/Endocrine Proc @fac fields
+1 NEW COC
+2 DO CHKCOC
IF (COC="00")!(COC=30)!(COC=31)!(COC=32)!(COC=33)!(COC=40)!(COC=41)
Begin DoDot:1
+3 SET NTX=1
WRITE !
DO HTEPATF^ONCNTX1
KILL NTX
+4 IF $GET(DEATF)=1
KILL DEATF,TXNUL
QUIT
End DoDot:1
KILL TXNO,TXUNK,TXNUL
SET Y="@42015"
QUIT
+5 IF $GET(DEATF)=1
KILL DEATF,TXNUL
SET Y="@42015"
QUIT
+6 IF COC'=37
Begin DoDot:1
+7 IF $GET(TXNO)=1
SET NTX=1
WRITE !
DO HTEPATF^ONCNTX1
KILL NTX,TXNO
SET Y="@42015"
QUIT
+8 IF $GET(TXUNK)=1
SET NTX=1
WRITE !
DO HTEPATF^ONCUTX1
KILL NTX,TXUNK
SET Y="@42015"
QUIT
+9 IF $GET(TXNUL)=1
KILL TXNUL
SET Y="@42015"
QUIT
End DoDot:1
QUIT
+10 KILL DIQ,ONC
+11 SET DIC="^ONCO(165.5,"
SET DA=DA
SET DIQ="ONC("
SET DIQ(0)="E"
SET DR="153.2;153.3"
+12 DO EN^DIQ1
+13 WRITE !!,$PIECE(^DD(165.5,153.2,0),U,1),".......: "_ONC(165.5,DA,153.2,"E")
+14 WRITE !,$PIECE(^DD(165.5,153.3,0),U,1),"..: "_ONC(165.5,DA,153.3,"E")
+15 KILL TXNO,TXUNK,TXNUL
SET Y="@42015"
QUIT
+16 ;
OTH ;Other therapy @fac
+1 NEW COC
+2 DO CHKCOC
IF COC'=37
QUIT
+3 SET $PIECE(^ONCO(165.5,D0,3.1),U,20)=$PIECE($GET(^ONCO(165.5,D0,3)),U,25)
+4 QUIT
+5 ;
OTHDT ;Other therapy @fac date
+1 NEW COC
+2 DO CHKCOC
IF COC'=37
QUIT
+3 SET $PIECE(^ONCO(165.5,D0,3.1),U,21)=$PIECE($GET(^ONCO(165.5,D0,3)),U,23)
+4 QUIT
+5 ;
DSPOTH ;Display Other Treatment @fac fields
+1 NEW COC
+2 DO CHKCOC
IF (COC="00")!(COC=30)!(COC=31)!(COC=32)!(COC=33)!(COC=40)!(COC=41)
Begin DoDot:1
+3 SET NTX=1
WRITE !
DO OTHATF^ONCNTX1
KILL NTX
+4 IF $GET(DOATF)=1
KILL DOATF,TXNUL
QUIT
End DoDot:1
KILL TXNO,TXUNK,TXNUL
SET Y="@424"
QUIT
+5 IF $GET(DOATF)=1
KILL DOATF,TXNUL
SET Y="@424"
QUIT
+6 IF COC'=37
Begin DoDot:1
+7 IF $GET(TXNO)=1
SET NTX=1
WRITE !
DO OTHATF^ONCNTX1
KILL NTX,TXNO
SET Y="@424"
QUIT
+8 IF $GET(TXUNK)=1
SET NTX=1
WRITE !
DO OTHATF^ONCUTX1
KILL NTX,TXUNK
SET Y="@424"
QUIT
+9 IF $GET(TXNUL)=1
KILL TXNUL
SET Y="@424"
QUIT
End DoDot:1
QUIT
+10 KILL DIQ,ONC
+11 SET DIC="^ONCO(165.5,"
SET DA=DA
SET DIQ="ONC("
SET DIQ(0)="E"
SET DR="57.3;57.4"
+12 DO EN^DIQ1
+13 WRITE !!,$PIECE(^DD(165.5,57.3,0),U,1),".....: "_$EXTRACT(ONC(165.5,DA,57.3,"E"),1,47)
+14 WRITE !,$PIECE(^DD(165.5,57.4,0),U,1),": "_ONC(165.5,DA,57.4,"E")
+15 KILL TXNO,TXUNK,TXNUL
SET Y="@424"
QUIT
+16 ;
PP ;Palliative Procedure @fac
+1 NEW COC
+2 DO CHKCOC
IF COC'=37
QUIT
+3 SET $PIECE(^ONCO(165.5,D0,3.1),U,27)=$PIECE($GET(^ONCO(165.5,D0,3.1)),U,26)
+4 QUIT
+5 ;
CHKCOC ;CLASS OF CASE
+1 SET COC=$EXTRACT($$GET1^DIQ(165.5,DA,.04),1,2)
+2 QUIT
+3 ;
RFNS ;If SURGERY OF PRIMARY (F) (165.5,58.6) and SURGERY OF PRIMARY @FAC (F)
+1 ;(165.5,58.7) are anything but 00 or 99, set REASON NO SURGERY OF
+2 ;PRIMARY (165.5,58) to 0 (Surgery performed)
+3 IF $PIECE($GET(^ONCO(165.5,D0,0)),U,16)>3221231
DO RFNS23
QUIT
+4 NEW FLAG1,FLAG2,SGRP,SPS,SPSATF,TPX
+5 SET (FLAG1,FLAG2)=1
+6 SET SPS=$PIECE($GET(^ONCO(165.5,D0,3.1)),U,29)
IF SPS=""
SET FLAG1=0
+7 SET SPSATF=$PIECE($GET(^ONCO(165.5,D0,3.1)),U,30)
IF SPSATF=""
SET FLAG2=0
+8 SET TPX=$PIECE($GET(^ONCO(165.5,D0,2)),U,1)
IF TPX=""
WRITE !!,"PRIMARY SITE is not defined"
HANG 3
SET Y="@0"
QUIT
+9 SET SGRP=$PIECE($GET(^ONCO(164,TPX,0)),U,16)
+10 IF SPS'=""
IF (SPS=1)!(SPS="00")!($GET(^ONCO(164,SGRP,"SPS",SPS,0))[99)
SET FLAG1=0
+11 IF SPSATF'=""
IF (SPSATF=1)!(SPSATF="00")!($GET(^ONCO(164,SGRP,"SPS",SPSATF,0))[99)
SET FLAG2=0
+12 IF FLAG1=0
IF FLAG2=0
QUIT
+13 SET $PIECE(^ONCO(165.5,D0,3),U,26)=0
+14 IF $GET(SUUP)=1
KILL SUUP
QUIT
+15 WRITE !,$PIECE($GET(^DD(165.5,58,0)),U,1)_"...: Surgery performed"
+16 SET Y="@431"
QUIT
+17 ;
RFNS23 ;If valid RX Summ--Surg Prim Site 2023 fields then set REASON NO
+1 ; SURGERY OF PRIMARY (field #58) = 0 (Surgery Performed)
+2 NEW FLAG1,FLAG2
SET (FLAG1,FLAG2)=1
+3 NEW ONCRXSUM
SET ONCRXSUM=$PIECE($GET(^ONCO(165.5,D0,3.2)),U,9)
+4 NEW ONCRXHOS
SET ONCRXHOS=$PIECE($GET(^ONCO(165.5,D0,3.2)),U,9)
+5 IF (ONCRXSUM="A000")!(ONCRXSUM="B000")!(ONCRXSUM="A990")!(ONCRXSUM="B990")
SET FLAG1=0
+6 IF (ONCRXHOS="A000")!(ONCRXHOS="B000")!(ONCRXHOS="A990")!(ONCRXHOS="B990")
SET FLAG2=0
+7 IF FLAG1=0
IF FLAG2=0
QUIT
+8 SET $PIECE(^ONCO(165.5,D0,3),U,26)=0
+9 WRITE !!,"REASON NO SURGERY OF PRIMARY...: Surgery performed"
+10 SET Y="@431"
QUIT
+11 QUIT
RFNR ;If RADIATION, set REASON FOR NO RADIATION = 0 (Radiation administered)
+1 ;I $P($G(^ONCO(165.5,D0,0)),U,16)>3171231 D RFNR18 Q
+2 NEW RDTX,RDTXATF
+3 SET RDTX=$PIECE($GET(^ONCO(165.5,D0,3)),U,6)
+4 SET RDTXATF=$PIECE($GET(^ONCO(165.5,D0,3.1)),U,12)
+5 IF ((RDTX="")!(RDTX=0)!(RDTX=9))&((RDTXATF="")!(RDTXATF=0)!(RDTXATF=9))
QUIT
+6 SET $PIECE(^ONCO(165.5,D0,3),U,35)=0
+7 IF $GET(RAUP)=1
KILL RAUP
QUIT
+8 WRITE !,$PIECE($GET(^DD(165.5,75,0)),U,1)_"........: Radiation administered"
+9 SET Y="@412"
QUIT
+10 QUIT
+11 ;
RFNR18 ;If RADIATION, set REASON FOR NO RADIATION = 0 (Radiation administered)
+1 ; Check new Phase fields for 2018+ cases
+2 NEW RAD1504,RAD1531,RAD1532,RAD1533
+3 SET RAD1504=$PIECE($GET(^ONCO(165.5,D0,"RAD18")),U,4)
+4 SET RAD1531=$PIECE($GET(^ONCO(165.5,D0,"NCR18B")),U,1)
+5 SET RAD1532=$PIECE($GET(^ONCO(165.5,D0,"NCR18B")),U,2)
+6 SET RAD1533=$PIECE($GET(^ONCO(165.5,D0,"NCR18B")),U,3)
+7 IF ((RAD1504="")!(RAD1504=1))&((RAD1531="")!(RAD1531="00"))&((RAD1532="")!(RAD1532="00"))&((RAD1533="")!(RAD1533=0)!(RAD1533="000000"))
QUIT
+8 SET $PIECE(^ONCO(165.5,D0,3),U,35)=0
+9 WRITE !,$PIECE($GET(^DD(165.5,75,0)),U,1)_"........: Radiation administered"
+10 SET Y="@412"
QUIT
+11 QUIT
CLEANUP ;Cleanup
+1 KILL D0,Y
