ONCATF ;HINES OIFO/GWB - Treatment @FAC (at this facility) stuffing ;06/15/11
;;2.2;ONCOLOGY;**1,20**;Jul 31, 2013;Build 5
;
NCDS ;SURG DX/STAGING PROC @FAC (165.5,58.4)
N COC D CHKCOC I (COC="00")!(COC=10)!(COC=11)!(COC=12)!(COC=13)!(COC=14)!(COC=34)!(COC=35) D
.S $P(^ONCO(165.5,D0,3.1),U,5)=$P($G(^ONCO(165.5,D0,3)),U,27)
Q
;
NCDSDT ;SURG DX/STAGING PROC @FAC DATE (165.5,58.5)
N COC D CHKCOC I (COC="00")!(COC=10)!(COC=11)!(COC=12)!(COC=13)!(COC=14)!(COC=34)!(COC=35) D
.S $P(^ONCO(165.5,D0,3.1),U,6)=$P($G(^ONCO(165.5,D0,3)),U,31)
Q
;
DSPNCDS ;Display SURG DX/STAGING PROC @FAC (165.5,58.4)
;N COC D CHKCOC I (COC=20)!(COC=21)!(COC=22)!(COC=31)!(COC=32)!(COC=33)!(COC=36)!(COC=37) D K TXNO,TXUNK,TXNUL S Y="@36" Q
N COC D CHKCOC I (COC=31)!(COC=32)!(COC=33)!(COC=36)!(COC=37) D K TXNO,TXUNK,TXNUL S Y="@36" Q ;Patch 56 change
.S NTX=1 W ! D NCDSATF^ONCNTX1 K NTX
.I $G(DNCATF)=1 K DNCATF,TXNUL Q
I $G(DNCATF)=1 K DNCATF,TXNUL S Y="@36" Q
I (COC="00")!(COC=10)!(COC=11)!(COC=12)!(COC=13)!(COC=14)!(COC=34)!(COC=35) G DIQ1
I $G(TXNO)=1 S NTX=1 W ! D NCDSATF^ONCNTX1 K NTX,TXNO S Y="@36" Q
I $G(TXUNK)=1 S NTX=1 W ! D NCDSATF^ONCUTX1 K NTX,TXUNK S Y="@36" Q
I $G(TXNUL)=1 K TXNUL S Y="@36"
Q
;
DIQ1 N DI,DIC,DA,DR,DIQ,ONC
S DA=D0,DIC="^ONCO(165.5,",DIQ="ONC(",DIQ(0)="E",DR="58.4;58.5"
D EN^DIQ1
W !!,$P(^DD(165.5,58.4,0),U,1),".....: "_$E(ONC(165.5,DA,58.4,"E"),1,47)
W !,$P(^DD(165.5,58.5,0),U,1),": "_ONC(165.5,DA,58.5,"E")
K TXNO,TXUNK,TXNUL S Y="@36"
Q
;
SPSR ;SURGERY OF PRIMARY @FAC (R) (165.5,50.2)
D CHKCOC I COC'=37 Q
S $P(^ONCO(165.5,D0,3.1),U,7)=$P($G(^ONCO(165.5,D0,3)),U,38)
Q
;
DSPSPSR ;Display SURGERY OF PRIMARY @FAC (R) (165.5,50.2)
D CHKCOC I (COC="00")!(COC=30)!(COC=31)!(COC=32)!(COC=33)!(COC=40)!(COC=41) D K TXNO,TXUNK,TXNUL S Y="@427" Q
.S NTX=1 W ! D SURATFR^ONCNTX1 K NTX
.I $G(DSATF)=1 K DSATF,TXNUL Q
I $G(DSATF)=1 K DSATF,TXNUL S Y="@427" Q
I COC'=37 D Q
.I $G(TXNO)=1 S NTX=1 W ! D SURATFR^ONCNTX1 K NTX,TXNO S Y="@427" Q
.I $G(TXUNK)=1 S NTX=1 W ! D SURATFR^ONCUTX1 K NTX,TXUNK S Y="@427" Q
.I $G(TXNUL)=1 K TXNUL S Y="@427" Q
N DI,DIC,DA,DR,DIQ,ONC
S DA=D0,DIC="^ONCO(165.5,",DIQ="ONC(",DIQ(0)="E"
S DR=50.2
D EN^DIQ1
I $G(DSATF)'=1 D
.W !!,$P(^DD(165.5,50.2,0),U,1),"....: "_$E(ONC(165.5,DA,50.2,"E"),1,48)
K DSATF,TXNO,TXUNK,TXNUL S Y="@427"
Q
;
SPS ;SURGERY OF PRIMARY @FAC (F) (165.5,58.7)
N SUUP
S SUUP=1 D RFNS^ONCATF1
D CHKCOC I COC'=37 Q
S $P(^ONCO(165.5,D0,3.1),U,30)=$P($G(^ONCO(165.5,D0,3.1)),U,29)
Q
;
SPSDT ;MOST DEFINITIVE SURG @FAC DATE (165.5,50.3)
D CHKCOC I COC'=37 Q
S $P(^ONCO(165.5,D0,3.1),U,8)=$P($G(^ONCO(165.5,D0,3)),U,1)
Q
;
DSPSPS ;Display SURGERY OF PRIMARY @FAC (F) (165.5,58.7)
D CHKCOC I (COC="00")!(COC=30)!(COC=31)!(COC=32)!(COC=33)!(COC=40)!(COC=41) D K TXNO,TXUNK,TXNUL S Y="@43" Q
.S NTX=1 W ! D SURATF^ONCNTX1 K NTX
.I $G(DSATF)=1 K DSATF,TXNUL Q
I $G(DSATF)=1 K DSATF,TXNUL S Y="@43" Q
I COC'=37 D Q
.I $G(TXNO)=1 S NTX=1 W ! D SURATF^ONCNTX1 K NTX,TXNO S Y="@43" Q
.I $G(TXUNK)=1 S NTX=1 W ! D SURATF^ONCUTX1 K NTX,TXUNK S Y="@43" Q
.I $G(TXNUL)=1 K TXNUL S Y="@43" Q
N DI,DIC,DA,DR,DIQ,ONC
S DA=D0,DIC="^ONCO(165.5,",DIQ="ONC(",DIQ(0)="E"
S DR="58.7;50.3"
D EN^DIQ1
I $G(DSATF)'=1 D
.;W !!,"SURGERY OF PRIMARY @FAC.....(F): "_$E(ONC(165.5,DA,58.7,"E"),1,48)
.W !!,"RX HOSP--SURG PRIMSITE 03-2022...: "_$E(ONC(165.5,DA,58.7,"E"),1,48)
.W !,"MOST DEFINITIVE SURG @FAC DATE.: "_ONC(165.5,DA,50.3,"E") Q
K DSATF,TXNO,TXUNK,TXNUL S Y="@43"
Q
;
SCPR ;SCOPE OF LN SURGERY @FAC (R) (165.5,138.1)
D CHKCOC I COC'=37 Q
S $P(^ONCO(165.5,D0,3.1),U,9)=$P($G(^ONCO(165.5,D0,3)),U,40)
Q
;
SCP ;SCOPE OF LN SURGERY @FAC (F) (165.5,138.5)
D CHKCOC I COC'=37 Q
S $P(^ONCO(165.5,D0,3.1),U,32)=$P($G(^ONCO(165.5,D0,3.1)),U,31)
Q
;
SCPDT ;SCOPE OF LN SURGERY @FAC DATE (165.5,138.3)
D CHKCOC I COC'=37 Q
S $P(^ONCO(165.5,D0,3.1),U,23)=$P($G(^ONCO(165.5,D0,3.1)),U,22)
Q
;
NUMND ;NUMBER OF LN REMOVED @FAC (R) (165.5,140.1)
D CHKCOC I COC'=37 Q
S $P(^ONCO(165.5,D0,3.1),U,11)=$P($G(^ONCO(165.5,D0,3)),U,42)
Q
;
DSPSCPR ;Display SCOPE OF LN SURGERY @FAC (R) (165.5,138.1)
D CHKCOC I (COC="00")!(COC=30)!(COC=31)!(COC=32)!(COC=33)!(COC=40)!(COC=41) D K TXNO,TXUNK,TXNUL S Y="@139" Q
.S NTX=1 W ! D NODATFR^ONCNTX1 K NTX
.I $G(DSCATF)=1 K DSCATF,TXNUL Q
I $G(DSCATF)=1 K DSCATF,TXNUL S Y="@139" Q
I COC'=37 D Q
.I $G(TXNO)=1 S NTX=1 W ! D NODATFR^ONCNTX1 K NTX,TXNO S Y="@139" Q
.I $G(TXUNK)=1 S NTX=1 W ! D NODATFR^ONCUTX1 K NTX,TXUNK S Y="@139" Q
.I $G(TXNUL)=1 K TXNUL S Y="@139" Q
N DI,DIC,DA,DR,DIQ,ONC
S DA=D0,DIC="^ONCO(165.5,",DIQ="ONC(",DIQ(0)="E"
S DR="138.1;140.1"
D EN^DIQ1
I $G(DSCATF)'=1 D
.W !!,$P(^DD(165.5,138.1,0),U,1),"...: "_$E(ONC(165.5,DA,138.1,"E"),1,48)
.W !,$P(^DD(165.5,140.1,0),U,1),"..: "_ONC(165.5,DA,140.1,"E")
K DSCATF,TXNO,TXUNK,TXNUL S Y="@139" Q
;
DSPSCP ;Display SCOPE OF LN SURGERY @FAC (F) (165.5,138.5)
D CHKCOC I (COC="00")!(COC=30)!(COC=31)!(COC=32)!(COC=33)!(COC=40)!(COC=41) D K TXNO,TXUNK,TXNUL S Y="@46" Q
.I $D(NTX),NTX=1 D Q
..W ! D NODEATF^ONCNTX1
..I $G(DSCATF)=1 K DSCATF,TXNUL Q
.S NTX=1 W ! D NODEATF^ONCNTX1 K NTX
.I $G(DSCATF)=1 K DSCATF,TXNUL Q
I $G(DSCATF)=1 K DSCATF,TXNUL S Y="@46" Q
I COC'=37 D Q
.I $D(NTX),NTX=1 D Q
..I $G(TXNO)=1 W ! D NODEATF^ONCNTX1 K TXNO S Y="@46" Q
..I $G(TXUNK)=1 W ! D NODEATF^ONCUTX1 K TXUNK S Y="@46" Q
.I $G(TXNO)=1 S NTX=1 W ! D NODEATF^ONCNTX1 K NTX,TXNO S Y="@46" Q
.I $G(TXUNK)=1 S NTX=1 W ! D NODEATF^ONCUTX1 K NTX,TXUNK S Y="@46" Q
.I $G(TXNUL)=1 K TXNUL S Y="@46" Q
N DI,DIC,DA,DR,DIQ,ONC
S DA=D0,DIC="^ONCO(165.5,",DIQ="ONC(",DIQ(0)="E"
S DR="138.5;138.3"
D EN^DIQ1
I $G(DSCATF)'=1 D
.W !!,$P(^DD(165.5,138.5,0),U,1),"....: "_$E(ONC(165.5,DA,138.5,"E"),1,48)
.W !,$P(^DD(165.5,138.3,0),U,1),".: "_ONC(165.5,DA,138.3,"E")
K DSCATF,TXNO,TXUNK,TXNUL S Y="@46" Q
;
SOSNR ;SURG PROC/OTHER SITE @FAC (R) (165.5,139)
D CHKCOC I COC'=37 Q
S $P(^ONCO(165.5,D0,3.1),U,10)=$P($G(^ONCO(165.5,D0,3)),U,41)
Q
;
SOSN ;SURG PROC/OTHER SITE @FAC (F) (165.5,139.5)
D CHKCOC I COC'=37 Q
S $P(^ONCO(165.5,D0,3.1),U,34)=$P($G(^ONCO(165.5,D0,3.1)),U,33)
Q
;
SOSNDT ;SURG PROC/OTHER SITE @FAC DATE (165.5,139.3)
D CHKCOC I COC'=37 Q
S $P(^ONCO(165.5,D0,3.1),U,25)=$P($G(^ONCO(165.5,D0,3.1)),U,24)
Q
;
DSPSOSR ;Display SURG PPROC/OTHER SITE @FAC (R) (165.5,139.1)
D CHKCOC I (COC="00")!(COC=30)!(COC=31)!(COC=32)!(COC=33)!(COC=40)!(COC=41) D K TXNO,TXUNK,TXNUL S Y="@428" Q
.S NTX=1 W ! D SOSATFR^ONCNTX1 K NTX
.I $G(DSOATF)=1 K DSOATF,TXNUL Q
I $G(DSOATF)=1 K DSOATF,TXNUL S Y="@428" Q
I COC'=37 D Q
.I $G(TXNO)=1 S NTX=1 W ! D SOSATFR^ONCNTX1 K NTX,TXNO S Y="@428" Q
.I $G(TXUNK)=1 S NTX=1 W ! D SOSATFR^ONCUTX1 K NTX,TXUNK S Y="@428" Q
.I $G(TXNUL)=1 K TXNUL S Y="@428" Q
N DI,DIC,DA,DR,DIQ,ONC
S DA=D0,DIC="^ONCO(165.5,",DIQ="ONC(",DIQ(0)="E"
S DR=139.1
D EN^DIQ1
I $G(DSOATF)'=1 D
.W !,$P(^DD(165.5,139.1,0),U,1),": "_ONC(165.5,DA,139.1,"E") Q
K DSOATF,TXNO,TXUNK,TXNUL S Y="@428" Q
;
DSPSOSN ;Display SURG PPROC/OTHER SITE @FAC (F) (165.5,139.5)
D CHKCOC I (COC="00")!(COC=30)!(COC=31)!(COC=32)!(COC=33)!(COC=40)!(COC=41) D K TXNO,TXUNK,TXNUL S Y="@48" Q
.S NTX=1 W ! D SOSNATF^ONCNTX1 K NTX
.I $G(DSOATF)=1 K DSOATF,TXNUL Q
I $G(DSOATF)=1 K DSOATF,TXNUL S Y="@48" Q
I COC'=37 D Q
.I $G(TXNO)=1 S NTX=1 W ! D SOSNATF^ONCNTX1 K NTX,TXNO S Y="@48" Q
.I $G(TXUNK)=1 S NTX=1 W ! D SOSNATF^ONCUTX1 K NTX,TXUNK S Y="@48" Q
.I $G(TXNUL)=1 K TXNUL S Y="@48" Q
N DI,DIC,DA,DR,DIQ,ONC
S DA=D0,DIC="^ONCO(165.5,",DIQ="ONC(",DIQ(0)="E"
S DR="139.5;139.3"
D EN^DIQ1
I $G(DSOATF)'=1 D
.W !!,$P(^DD(165.5,139.5,0),U,1),": "_$E(ONC(165.5,DA,139.5,"E"),1,48)
.W !,$P(^DD(165.5,139.3,0),U,1),": "_ONC(165.5,DA,139.3,"E") Q
K DSOATF,TXNO,TXUNK,TXNUL S Y="@48" Q
;
CHKCOC ;CLASS OF CASE
S COC=$E($$GET1^DIQ(165.5,DA,.04),1,2)
Q
;
CLEANUP ;Cleanup
K D0,Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HONCATF 8068 printed Dec 13, 2024@02:22:04 Page 2
ONCATF ;HINES OIFO/GWB - Treatment @FAC (at this facility) stuffing ;06/15/11
+1 ;;2.2;ONCOLOGY;**1,20**;Jul 31, 2013;Build 5
+2 ;
NCDS ;SURG DX/STAGING PROC @FAC (165.5,58.4)
+1 NEW COC
DO CHKCOC
IF (COC="00")!(COC=10)!(COC=11)!(COC=12)!(COC=13)!(COC=14)!(COC=34)!(COC=35)
Begin DoDot:1
+2 SET $PIECE(^ONCO(165.5,D0,3.1),U,5)=$PIECE($GET(^ONCO(165.5,D0,3)),U,27)
End DoDot:1
+3 QUIT
+4 ;
NCDSDT ;SURG DX/STAGING PROC @FAC DATE (165.5,58.5)
+1 NEW COC
DO CHKCOC
IF (COC="00")!(COC=10)!(COC=11)!(COC=12)!(COC=13)!(COC=14)!(COC=34)!(COC=35)
Begin DoDot:1
+2 SET $PIECE(^ONCO(165.5,D0,3.1),U,6)=$PIECE($GET(^ONCO(165.5,D0,3)),U,31)
End DoDot:1
+3 QUIT
+4 ;
DSPNCDS ;Display SURG DX/STAGING PROC @FAC (165.5,58.4)
+1 ;N COC D CHKCOC I (COC=20)!(COC=21)!(COC=22)!(COC=31)!(COC=32)!(COC=33)!(COC=36)!(COC=37) D K TXNO,TXUNK,TXNUL S Y="@36" Q
+2 ;Patch 56 change
NEW COC
DO CHKCOC
IF (COC=31)!(COC=32)!(COC=33)!(COC=36)!(COC=37)
Begin DoDot:1
+3 SET NTX=1
WRITE !
DO NCDSATF^ONCNTX1
KILL NTX
+4 IF $GET(DNCATF)=1
KILL DNCATF,TXNUL
QUIT
End DoDot:1
KILL TXNO,TXUNK,TXNUL
SET Y="@36"
QUIT
+5 IF $GET(DNCATF)=1
KILL DNCATF,TXNUL
SET Y="@36"
QUIT
+6 IF (COC="00")!(COC=10)!(COC=11)!(COC=12)!(COC=13)!(COC=14)!(COC=34)!(COC=35)
GOTO DIQ1
+7 IF $GET(TXNO)=1
SET NTX=1
WRITE !
DO NCDSATF^ONCNTX1
KILL NTX,TXNO
SET Y="@36"
QUIT
+8 IF $GET(TXUNK)=1
SET NTX=1
WRITE !
DO NCDSATF^ONCUTX1
KILL NTX,TXUNK
SET Y="@36"
QUIT
+9 IF $GET(TXNUL)=1
KILL TXNUL
SET Y="@36"
+10 QUIT
+11 ;
DIQ1 NEW DI,DIC,DA,DR,DIQ,ONC
+1 SET DA=D0
SET DIC="^ONCO(165.5,"
SET DIQ="ONC("
SET DIQ(0)="E"
SET DR="58.4;58.5"
+2 DO EN^DIQ1
+3 WRITE !!,$PIECE(^DD(165.5,58.4,0),U,1),".....: "_$EXTRACT(ONC(165.5,DA,58.4,"E"),1,47)
+4 WRITE !,$PIECE(^DD(165.5,58.5,0),U,1),": "_ONC(165.5,DA,58.5,"E")
+5 KILL TXNO,TXUNK,TXNUL
SET Y="@36"
+6 QUIT
+7 ;
SPSR ;SURGERY OF PRIMARY @FAC (R) (165.5,50.2)
+1 DO CHKCOC
IF COC'=37
QUIT
+2 SET $PIECE(^ONCO(165.5,D0,3.1),U,7)=$PIECE($GET(^ONCO(165.5,D0,3)),U,38)
+3 QUIT
+4 ;
DSPSPSR ;Display SURGERY OF PRIMARY @FAC (R) (165.5,50.2)
+1 DO CHKCOC
IF (COC="00")!(COC=30)!(COC=31)!(COC=32)!(COC=33)!(COC=40)!(COC=41)
Begin DoDot:1
+2 SET NTX=1
WRITE !
DO SURATFR^ONCNTX1
KILL NTX
+3 IF $GET(DSATF)=1
KILL DSATF,TXNUL
QUIT
End DoDot:1
KILL TXNO,TXUNK,TXNUL
SET Y="@427"
QUIT
+4 IF $GET(DSATF)=1
KILL DSATF,TXNUL
SET Y="@427"
QUIT
+5 IF COC'=37
Begin DoDot:1
+6 IF $GET(TXNO)=1
SET NTX=1
WRITE !
DO SURATFR^ONCNTX1
KILL NTX,TXNO
SET Y="@427"
QUIT
+7 IF $GET(TXUNK)=1
SET NTX=1
WRITE !
DO SURATFR^ONCUTX1
KILL NTX,TXUNK
SET Y="@427"
QUIT
+8 IF $GET(TXNUL)=1
KILL TXNUL
SET Y="@427"
QUIT
End DoDot:1
QUIT
+9 NEW DI,DIC,DA,DR,DIQ,ONC
+10 SET DA=D0
SET DIC="^ONCO(165.5,"
SET DIQ="ONC("
SET DIQ(0)="E"
+11 SET DR=50.2
+12 DO EN^DIQ1
+13 IF $GET(DSATF)'=1
Begin DoDot:1
+14 WRITE !!,$PIECE(^DD(165.5,50.2,0),U,1),"....: "_$EXTRACT(ONC(165.5,DA,50.2,"E"),1,48)
End DoDot:1
+15 KILL DSATF,TXNO,TXUNK,TXNUL
SET Y="@427"
+16 QUIT
+17 ;
SPS ;SURGERY OF PRIMARY @FAC (F) (165.5,58.7)
+1 NEW SUUP
+2 SET SUUP=1
DO RFNS^ONCATF1
+3 DO CHKCOC
IF COC'=37
QUIT
+4 SET $PIECE(^ONCO(165.5,D0,3.1),U,30)=$PIECE($GET(^ONCO(165.5,D0,3.1)),U,29)
+5 QUIT
+6 ;
SPSDT ;MOST DEFINITIVE SURG @FAC DATE (165.5,50.3)
+1 DO CHKCOC
IF COC'=37
QUIT
+2 SET $PIECE(^ONCO(165.5,D0,3.1),U,8)=$PIECE($GET(^ONCO(165.5,D0,3)),U,1)
+3 QUIT
+4 ;
DSPSPS ;Display SURGERY OF PRIMARY @FAC (F) (165.5,58.7)
+1 DO CHKCOC
IF (COC="00")!(COC=30)!(COC=31)!(COC=32)!(COC=33)!(COC=40)!(COC=41)
Begin DoDot:1
+2 SET NTX=1
WRITE !
DO SURATF^ONCNTX1
KILL NTX
+3 IF $GET(DSATF)=1
KILL DSATF,TXNUL
QUIT
End DoDot:1
KILL TXNO,TXUNK,TXNUL
SET Y="@43"
QUIT
+4 IF $GET(DSATF)=1
KILL DSATF,TXNUL
SET Y="@43"
QUIT
+5 IF COC'=37
Begin DoDot:1
+6 IF $GET(TXNO)=1
SET NTX=1
WRITE !
DO SURATF^ONCNTX1
KILL NTX,TXNO
SET Y="@43"
QUIT
+7 IF $GET(TXUNK)=1
SET NTX=1
WRITE !
DO SURATF^ONCUTX1
KILL NTX,TXUNK
SET Y="@43"
QUIT
+8 IF $GET(TXNUL)=1
KILL TXNUL
SET Y="@43"
QUIT
End DoDot:1
QUIT
+9 NEW DI,DIC,DA,DR,DIQ,ONC
+10 SET DA=D0
SET DIC="^ONCO(165.5,"
SET DIQ="ONC("
SET DIQ(0)="E"
+11 SET DR="58.7;50.3"
+12 DO EN^DIQ1
+13 IF $GET(DSATF)'=1
Begin DoDot:1
+14 ;W !!,"SURGERY OF PRIMARY @FAC.....(F): "_$E(ONC(165.5,DA,58.7,"E"),1,48)
+15 WRITE !!,"RX HOSP--SURG PRIMSITE 03-2022...: "_$EXTRACT(ONC(165.5,DA,58.7,"E"),1,48)
+16 WRITE !,"MOST DEFINITIVE SURG @FAC DATE.: "_ONC(165.5,DA,50.3,"E")
QUIT
End DoDot:1
+17 KILL DSATF,TXNO,TXUNK,TXNUL
SET Y="@43"
+18 QUIT
+19 ;
SCPR ;SCOPE OF LN SURGERY @FAC (R) (165.5,138.1)
+1 DO CHKCOC
IF COC'=37
QUIT
+2 SET $PIECE(^ONCO(165.5,D0,3.1),U,9)=$PIECE($GET(^ONCO(165.5,D0,3)),U,40)
+3 QUIT
+4 ;
SCP ;SCOPE OF LN SURGERY @FAC (F) (165.5,138.5)
+1 DO CHKCOC
IF COC'=37
QUIT
+2 SET $PIECE(^ONCO(165.5,D0,3.1),U,32)=$PIECE($GET(^ONCO(165.5,D0,3.1)),U,31)
+3 QUIT
+4 ;
SCPDT ;SCOPE OF LN SURGERY @FAC DATE (165.5,138.3)
+1 DO CHKCOC
IF COC'=37
QUIT
+2 SET $PIECE(^ONCO(165.5,D0,3.1),U,23)=$PIECE($GET(^ONCO(165.5,D0,3.1)),U,22)
+3 QUIT
+4 ;
NUMND ;NUMBER OF LN REMOVED @FAC (R) (165.5,140.1)
+1 DO CHKCOC
IF COC'=37
QUIT
+2 SET $PIECE(^ONCO(165.5,D0,3.1),U,11)=$PIECE($GET(^ONCO(165.5,D0,3)),U,42)
+3 QUIT
+4 ;
DSPSCPR ;Display SCOPE OF LN SURGERY @FAC (R) (165.5,138.1)
+1 DO CHKCOC
IF (COC="00")!(COC=30)!(COC=31)!(COC=32)!(COC=33)!(COC=40)!(COC=41)
Begin DoDot:1
+2 SET NTX=1
WRITE !
DO NODATFR^ONCNTX1
KILL NTX
+3 IF $GET(DSCATF)=1
KILL DSCATF,TXNUL
QUIT
End DoDot:1
KILL TXNO,TXUNK,TXNUL
SET Y="@139"
QUIT
+4 IF $GET(DSCATF)=1
KILL DSCATF,TXNUL
SET Y="@139"
QUIT
+5 IF COC'=37
Begin DoDot:1
+6 IF $GET(TXNO)=1
SET NTX=1
WRITE !
DO NODATFR^ONCNTX1
KILL NTX,TXNO
SET Y="@139"
QUIT
+7 IF $GET(TXUNK)=1
SET NTX=1
WRITE !
DO NODATFR^ONCUTX1
KILL NTX,TXUNK
SET Y="@139"
QUIT
+8 IF $GET(TXNUL)=1
KILL TXNUL
SET Y="@139"
QUIT
End DoDot:1
QUIT
+9 NEW DI,DIC,DA,DR,DIQ,ONC
+10 SET DA=D0
SET DIC="^ONCO(165.5,"
SET DIQ="ONC("
SET DIQ(0)="E"
+11 SET DR="138.1;140.1"
+12 DO EN^DIQ1
+13 IF $GET(DSCATF)'=1
Begin DoDot:1
+14 WRITE !!,$PIECE(^DD(165.5,138.1,0),U,1),"...: "_$EXTRACT(ONC(165.5,DA,138.1,"E"),1,48)
+15 WRITE !,$PIECE(^DD(165.5,140.1,0),U,1),"..: "_ONC(165.5,DA,140.1,"E")
End DoDot:1
+16 KILL DSCATF,TXNO,TXUNK,TXNUL
SET Y="@139"
QUIT
+17 ;
DSPSCP ;Display SCOPE OF LN SURGERY @FAC (F) (165.5,138.5)
+1 DO CHKCOC
IF (COC="00")!(COC=30)!(COC=31)!(COC=32)!(COC=33)!(COC=40)!(COC=41)
Begin DoDot:1
+2 IF $DATA(NTX)
IF NTX=1
Begin DoDot:2
+3 WRITE !
DO NODEATF^ONCNTX1
+4 IF $GET(DSCATF)=1
KILL DSCATF,TXNUL
QUIT
End DoDot:2
QUIT
+5 SET NTX=1
WRITE !
DO NODEATF^ONCNTX1
KILL NTX
+6 IF $GET(DSCATF)=1
KILL DSCATF,TXNUL
QUIT
End DoDot:1
KILL TXNO,TXUNK,TXNUL
SET Y="@46"
QUIT
+7 IF $GET(DSCATF)=1
KILL DSCATF,TXNUL
SET Y="@46"
QUIT
+8 IF COC'=37
Begin DoDot:1
+9 IF $DATA(NTX)
IF NTX=1
Begin DoDot:2
+10 IF $GET(TXNO)=1
WRITE !
DO NODEATF^ONCNTX1
KILL TXNO
SET Y="@46"
QUIT
+11 IF $GET(TXUNK)=1
WRITE !
DO NODEATF^ONCUTX1
KILL TXUNK
SET Y="@46"
QUIT
End DoDot:2
QUIT
+12 IF $GET(TXNO)=1
SET NTX=1
WRITE !
DO NODEATF^ONCNTX1
KILL NTX,TXNO
SET Y="@46"
QUIT
+13 IF $GET(TXUNK)=1
SET NTX=1
WRITE !
DO NODEATF^ONCUTX1
KILL NTX,TXUNK
SET Y="@46"
QUIT
+14 IF $GET(TXNUL)=1
KILL TXNUL
SET Y="@46"
QUIT
End DoDot:1
QUIT
+15 NEW DI,DIC,DA,DR,DIQ,ONC
+16 SET DA=D0
SET DIC="^ONCO(165.5,"
SET DIQ="ONC("
SET DIQ(0)="E"
+17 SET DR="138.5;138.3"
+18 DO EN^DIQ1
+19 IF $GET(DSCATF)'=1
Begin DoDot:1
+20 WRITE !!,$PIECE(^DD(165.5,138.5,0),U,1),"....: "_$EXTRACT(ONC(165.5,DA,138.5,"E"),1,48)
+21 WRITE !,$PIECE(^DD(165.5,138.3,0),U,1),".: "_ONC(165.5,DA,138.3,"E")
End DoDot:1
+22 KILL DSCATF,TXNO,TXUNK,TXNUL
SET Y="@46"
QUIT
+23 ;
SOSNR ;SURG PROC/OTHER SITE @FAC (R) (165.5,139)
+1 DO CHKCOC
IF COC'=37
QUIT
+2 SET $PIECE(^ONCO(165.5,D0,3.1),U,10)=$PIECE($GET(^ONCO(165.5,D0,3)),U,41)
+3 QUIT
+4 ;
SOSN ;SURG PROC/OTHER SITE @FAC (F) (165.5,139.5)
+1 DO CHKCOC
IF COC'=37
QUIT
+2 SET $PIECE(^ONCO(165.5,D0,3.1),U,34)=$PIECE($GET(^ONCO(165.5,D0,3.1)),U,33)
+3 QUIT
+4 ;
SOSNDT ;SURG PROC/OTHER SITE @FAC DATE (165.5,139.3)
+1 DO CHKCOC
IF COC'=37
QUIT
+2 SET $PIECE(^ONCO(165.5,D0,3.1),U,25)=$PIECE($GET(^ONCO(165.5,D0,3.1)),U,24)
+3 QUIT
+4 ;
DSPSOSR ;Display SURG PPROC/OTHER SITE @FAC (R) (165.5,139.1)
+1 DO CHKCOC
IF (COC="00")!(COC=30)!(COC=31)!(COC=32)!(COC=33)!(COC=40)!(COC=41)
Begin DoDot:1
+2 SET NTX=1
WRITE !
DO SOSATFR^ONCNTX1
KILL NTX
+3 IF $GET(DSOATF)=1
KILL DSOATF,TXNUL
QUIT
End DoDot:1
KILL TXNO,TXUNK,TXNUL
SET Y="@428"
QUIT
+4 IF $GET(DSOATF)=1
KILL DSOATF,TXNUL
SET Y="@428"
QUIT
+5 IF COC'=37
Begin DoDot:1
+6 IF $GET(TXNO)=1
SET NTX=1
WRITE !
DO SOSATFR^ONCNTX1
KILL NTX,TXNO
SET Y="@428"
QUIT
+7 IF $GET(TXUNK)=1
SET NTX=1
WRITE !
DO SOSATFR^ONCUTX1
KILL NTX,TXUNK
SET Y="@428"
QUIT
+8 IF $GET(TXNUL)=1
KILL TXNUL
SET Y="@428"
QUIT
End DoDot:1
QUIT
+9 NEW DI,DIC,DA,DR,DIQ,ONC
+10 SET DA=D0
SET DIC="^ONCO(165.5,"
SET DIQ="ONC("
SET DIQ(0)="E"
+11 SET DR=139.1
+12 DO EN^DIQ1
+13 IF $GET(DSOATF)'=1
Begin DoDot:1
+14 WRITE !,$PIECE(^DD(165.5,139.1,0),U,1),": "_ONC(165.5,DA,139.1,"E")
QUIT
End DoDot:1
+15 KILL DSOATF,TXNO,TXUNK,TXNUL
SET Y="@428"
QUIT
+16 ;
DSPSOSN ;Display SURG PPROC/OTHER SITE @FAC (F) (165.5,139.5)
+1 DO CHKCOC
IF (COC="00")!(COC=30)!(COC=31)!(COC=32)!(COC=33)!(COC=40)!(COC=41)
Begin DoDot:1
+2 SET NTX=1
WRITE !
DO SOSNATF^ONCNTX1
KILL NTX
+3 IF $GET(DSOATF)=1
KILL DSOATF,TXNUL
QUIT
End DoDot:1
KILL TXNO,TXUNK,TXNUL
SET Y="@48"
QUIT
+4 IF $GET(DSOATF)=1
KILL DSOATF,TXNUL
SET Y="@48"
QUIT
+5 IF COC'=37
Begin DoDot:1
+6 IF $GET(TXNO)=1
SET NTX=1
WRITE !
DO SOSNATF^ONCNTX1
KILL NTX,TXNO
SET Y="@48"
QUIT
+7 IF $GET(TXUNK)=1
SET NTX=1
WRITE !
DO SOSNATF^ONCUTX1
KILL NTX,TXUNK
SET Y="@48"
QUIT
+8 IF $GET(TXNUL)=1
KILL TXNUL
SET Y="@48"
QUIT
End DoDot:1
QUIT
+9 NEW DI,DIC,DA,DR,DIQ,ONC
+10 SET DA=D0
SET DIC="^ONCO(165.5,"
SET DIQ="ONC("
SET DIQ(0)="E"
+11 SET DR="139.5;139.3"
+12 DO EN^DIQ1
+13 IF $GET(DSOATF)'=1
Begin DoDot:1
+14 WRITE !!,$PIECE(^DD(165.5,139.5,0),U,1),": "_$EXTRACT(ONC(165.5,DA,139.5,"E"),1,48)
+15 WRITE !,$PIECE(^DD(165.5,139.3,0),U,1),": "_ONC(165.5,DA,139.3,"E")
QUIT
End DoDot:1
+16 KILL DSOATF,TXNO,TXUNK,TXNUL
SET Y="@48"
QUIT
+17 ;
CHKCOC ;CLASS OF CASE
+1 SET COC=$EXTRACT($$GET1^DIQ(165.5,DA,.04),1,2)
+2 QUIT
+3 ;
CLEANUP ;Cleanup
+1 KILL D0,Y
