ONCOSUR1 ;HINES OIFO/RTK - ONCOSUR continued ;06/23/10
;;2.2;ONCOLOGY;**1,15**;Jul 31, 2013;Build 5
;
COCIT ;CLASS OF CASE (165.5,.04) INPUT TRANSFORM
;If CLASS OF CASE is changed, delete the existing @FAC fields
N OLDCOC,PIECE
S OLDCOC=$P($G(^ONCO(165.5,D0,0)),U,4) I OLDCOC="" Q
I OLDCOC=X Q
I ((OLDCOC=2)!(OLDCOC=3)!(OLDCOC=4)!(OLDCOC=5)!(OLDCOC=6)!(OLDCOC=7)!(OLDCOC=8)!(OLDCOC=9))&((X=2)!(X=3)!(X=4)!(X=5)!(X=6)!(X=7)!(X=8)!(X=9)) Q
I ((OLDCOC=1)!(OLDCOC=10)!(OLDCOC=11)!(OLDCOC=12)!(OLDCOC=13)!(OLDCOC=19)!(OLDCOC=20))&((X=1)!(X=10)!(X=11)!(X=12)!(X=13)!(X=19)!(X=20)) Q
F PIECE=5:1:21 S $P(^ONCO(165.5,D0,3.1),U,PIECE)=""
S $P(^ONCO(165.5,D0,3.1),U,23)=""
S $P(^ONCO(165.5,D0,3.1),U,25)=""
S $P(^ONCO(165.5,D0,3.1),U,30)=""
S $P(^ONCO(165.5,D0,3.1),U,32)=""
S $P(^ONCO(165.5,D0,3.1),U,34)=""
W !
W !?3,"You have changed the CLASS OF CASE. This change may affect"
W !?3,"the validity of the @FAC (at this facility) fields. Therefore,"
W !?3,"these fields have been initialized and need to be re-entered:"
W !
Q
;
TOPIT ;PRIMARY SITE (165.5,20) INPUT TRANSFORM
;If PRIMARY SITE is changed, delete site-specific fields
N MSSG,NOS,OLDTOP
I X=67999 K X D Q
.W !!," UNKNOWN C99.9 is not allowed. It is for"
.W !," 1997 Non-Hodgkin's Lymphoma PCE use only."
.W !," (Item 12. Personal History of Any Cancer)"
.W !," Use UNKNOWN PRIMARY C80.9",!
I X=67888 K X D Q
.W !!," NA C88.8 is not allowed. It is for"
.W !," 1997 Non-Hodgkin's Lymphoma PCE use only."
.W !," (Item 12. Personal History of Any Cancer)",!
S OLDTOP=$P($G(^ONCO(165.5,D0,2)),U,1) I OLDTOP="" Q
S MSSG=0
I X=OLDTOP Q
S $P(^ONCO(165.5,D0,8),U,1)=""
S $P(^ONCO(165.5,D0,"CS3"),U,1)=""
D ^ONCOSUR2
S TOP=X,TOPCOD="",TOPNAM=""
I TOP'="" D
.S TOPNAM=$P(^ONCO(164,TOP,0),U,1)
.S TOPCOD=$P(^ONCO(164,TOP,0),U,2)
.S SITTAB=79-$L($G(SITEGP)),TOPTAB=79-$L(TOPNAM_" "_TOPCOD)
.S NOS=TOPTAB-$L($G(PATNAM)),NOS=NOS-1
.K SPACES S $P(SPACES," ",NOS)=" "
Q
;
SCIT ;SCOPE OF LN SURGERY (R) (165.5,138) INPUT TRANSFORM
N FOUND,ICD,TOP,XSC
Q:$G(NTXDD)=""
S TOP=$P($G(^ONCO(165.5,D0,2)),U,1) I TOP="" K X Q
S ICD=$P($G(^ONCO(164,TOP,0)),U,16) I ICD="" K X Q
;pre-2003 C76.0-C76.8, C80.9 cases
;see ROADS page D-cxliii
I ($G(FIELD)=138)!($G(FIELD)=138.1),($E(TOP,3,4)=76)!(TOP=67809)!(TOP=67420)!(TOP=67421)!(TOP=67423)!(TOP=67424) S ICD=67141 K FIELD
S FOUND=0
F XSC=0:0 S XSC=$O(^ONCO(164,ICD,"SC5",XSC)) Q:(XSC'>0)!(FOUND=1) D
.I $P(^ONCO(164,ICD,"SC5",XSC,0),U,2)=X S X=XSC,FOUND=1
I FOUND=0 K X Q
W " ",$P(^ONCO(164,ICD,"SC5",X,0),U,1)
I $D(X),NTXDD=1 S V=0 D NT^ONCODSR
K NTXDD
Q
;
SCOT ;SCOPE OF LN SURGERY (R) (165.5,138) OUTPUT TRANSFORM
N ICD,TOP
Q:Y=""
S TOP=$P($G(^ONCO(165.5,D0,2)),U,1) I TOP="" S Y="" Q
S ICD=$P($G(^ONCO(164,TOP,0)),U,16) I ICD="" S Y="" Q
;pre-2003 C76.0-C76.8, C80.9 cases
;see ROADS page D-cxliii
I ($G(FIELD)=138)!($G(FIELD)=138.1),($E(TOP,3,4)=76)!(TOP=67809)!(TOP=67420)!(TOP=67421)!(TOP=67423)!(TOP=67424) S ICD=67141 K FIELD
S Y=$P($G(^ONCO(164,ICD,"SC5",Y,0)),U,1)
Q
;
SCHP ;SCOPE OF LN SURGERY (R) (165.5,138) HELP
N ICD,TOP,XSC
S TOP=$P($G(^ONCO(165.5,D0,2)),U,1) I TOP="" Q
S ICD=$P($G(^ONCO(164,TOP,0)),U,16) I ICD="" Q
;pre-2003 C76.0-C76.8, C80.9 cases
;see ROADS page D-cxliii
I ($G(FIELD)=138)!($G(FIELD)=138.1),($E(TOP,3,4)=76)!(TOP=67809)!(TOP=67420)!(TOP=67421)!(TOP=67423)!(TOP=67424) S ICD=67141 K FIELD
W !?3,"Choose from:"
F XSC=0:0 S XSC=$O(^ONCO(164,ICD,"SC5",XSC)) Q:XSC'>0 W !?3,$P($G(^ONCO(164,ICD,"SC5",XSC,0)),U,2),?12,$P($G(^ONCO(164,ICD,"SC5",XSC,0)),U,1)
W !
Q
;
SOIT ;SURG PROC/OTHER SITE (R) (165.5,139) INPUT TRANSFORM
N FOUND,ICD,TOP,XSO
Q:$G(NTXDD)=""
S TOP=$P($G(^ONCO(165.5,D0,2)),U,1) I TOP="" K X Q
S ICD=$P($G(^ONCO(164,TOP,0)),U,16) I ICD="" K X Q
;pre-2003 C76.0-C76.8, C80.9 cases
;see ROADS page D-cxliii
I ($G(FIELD)=139)!($G(FIELD)=139.1),($E(TOP,3,4)=76)!(TOP=67809)!(TOP=67420)!(TOP=67421)!(TOP=67423)!(TOP=67424) S ICD=67141 K FIELD
S FOUND=0
F XSO=0:0 S XSO=$O(^ONCO(164,ICD,"SO5",XSO)) Q:(XSO'>0)!(FOUND=1) D
.I $P(^ONCO(164,ICD,"SO5",XSO,0),U,2)=X S X=XSO,FOUND=1 Q
I FOUND=0 K X Q
W " ",$P(^ONCO(164,ICD,"SO5",X,0),U,1)
I $D(X),NTXDD=1 S V=0 D NT^ONCODSR
K NTXDD
Q
;
SOOT ;SURG PROC/OTHER SITE (R) (165.5,139) OUTPUT TRANSFORM
N ICD,TOP
Q:Y=""
S TOP=$P($G(^ONCO(165.5,D0,2)),U,1) I TOP="" S Y="" Q
S ICD=$P($G(^ONCO(164,TOP,0)),U,16) I ICD="" S Y="" Q
;pre-2003 C76.0-C76.8, C80.9 cases
;see ROADS page D-cxliii
I ($G(FIELD)=139)!($G(FIELD)=139.1),($E(TOP,3,4)=76)!(TOP=67809)!(TOP=67420)!(TOP=67421)!(TOP=67423)!(TOP=67424) S ICD=67141 K FIELD
S Y=$P($G(^ONCO(164,ICD,"SO5",Y,0)),U,1)
Q
;
SOHP ;SURG PROC/OTHER SITE (R) (165.5,139) HELP
N ICD,TOP,XSO
S TOP=$P($G(^ONCO(165.5,D0,2)),U,1) I TOP="" Q
S ICD=$P($G(^ONCO(164,TOP,0)),U,16) I ICD="" Q
;pre-2003 C76.0-C76.8, C80.9 cases
;see ROADS page D-cxliii
I ($G(FIELD)=139)!($G(FIELD)=139.1),($E(TOP,3,4)=76)!(TOP=67809)!(TOP=67420)!(TOP=67421)!(TOP=67423)!(TOP=67424) S ICD=67141 K FIELD
W !?3,"Choose from:"
F XSO=0:0 S XSO=$O(^ONCO(164,ICD,"SO5",XSO)) Q:XSO'>0 W !?3,$P($G(^ONCO(164,ICD,"SO5",XSO,0)),U,2),?12,$P($G(^ONCO(164,ICD,"SO5",XSO,0)),U,1)
W !
Q
;
NRIT ;NUMBER OF LN REMOVED (R) (165.5,140) INPUT TRANSFORM
Q:$G(NTXDD)=""
S X=+X
I $L(X)=1 S X="0"_X
I X="00" W " No nodes removed"
I X=90 W " 90 or more nodes removed"
I X=95 W " No nodes removed, aspiration performed"
I X=96 W " Node removal as a sampling, number unknown"
I X=97 W " Node removal as dissection, number unknown"
I X=98 W " Nodes surgically removed, number unknown"
I X=99 W " Unknown, not stated, death cert ONLY"
I $D(X),NTXDD=1 S V=0 D NT^ONCODSR
K NTXDD
Q
;
NROT ;NUMBER OF LN REMOVED (R) (165.5,140) OUTPUT TRANSFORM
Q:Y=""
S Y=+Y
I Y=0 S Y="No nodes removed"
I ((Y>0)&(Y<90))!((Y>90)&(Y<95)) S:$L(Y)=1 Y=0_Y
I Y=90 S Y="90 or more nodes removed"
I Y=95 S Y="No nodes removed, aspiration performed"
I Y=96 S Y="Node removal as a sampling, number unknown"
I Y=97 S Y="Node removal as dissection, number unknown"
I Y=98 S Y="Nodes surgically removed, number unknown"
I Y=99 S Y="Unknown, not stated, death cert ONLY"
Q
;
RXSBIT ;
I "B000^B200^B210^B215^B240^B290^B300^B310^B320^B400^B410^B420^B500^B510^B600^B610^B620^B700^B710^B720^B760^B800^B900^B990"'[X K X Q
Q
RXRECIT ;
I "A000^A100^A200^A300^A400^A500^A600^A610^A620^A630^A640^A900^A970^A980^A990"'[X K X Q
Q
RXSBHP ;HELP
N TOP,SCDXDT,XSP,SPSIEN
S TOP=$P($G(^ONCO(165.5,D0,2)),U,1) I TOP="" W !,"No PRIMARY SITE" Q
I $E(TOP,1,4)'=6750 W !,"This field is only for BREAST sites" Q
S SCDXDT=$P($G(^ONCO(165.5,D0,0)),U,16) I SCDXDT="" Q
S (EX,CTR)=0
W !?3,"RX HOSP/SURG--SURG BREAST codes for site ",$P($G(^ONCO(164,TOP,0)),U,2)," ",$P($G(^ONCO(164,TOP,0)),U,1),": ",!
S XSP="" F S XSP=$O(^ONCO(164,67500,"RXSB","C",XSP)) Q:XSP="" S SPSIEN=$O(^ONCO(164,67500,"RXSB","C",XSP,0)) D Q:EX=U
.S CTR=CTR+1 I CTR#11=0 D P Q:EX=U
.W !?2,$P($G(^ONCO(164,67500,"RXSB",SPSIEN,0)),U,2),?8,$E($P($G(^ONCO(164,67500,"RXSB",SPSIEN,0)),U,1),1,71) I $L($P($G(^ONCO(164,67500,"RXSB",SPSIEN,0)),U,1))>71 W !?11,$E($P($G(^ONCO(164,67500,"RXSB",SPSIEN,0)),U,1),72,111)
W !
K CTR,EX,HST14,ICD,SCDXDT,SPSIEN,TOP,XSP
Q
;
RXRECHP ;HELP
N TOP,SCDXDT,XSP,SPSIEN
S TOP=$P($G(^ONCO(165.5,D0,2)),U,1) I TOP="" W !,"No PRIMARY SITE" Q
I $E(TOP,1,4)'=6750 W !,"This field is only for BREAST sites" Q
S SCDXDT=$P($G(^ONCO(165.5,D0,0)),U,16) I SCDXDT="" Q
S (EX,CTR)=0
W !?3,"RX HOSP/SURG--SURG RECONSTRUCTION codes for site ",$P($G(^ONCO(164,TOP,0)),U,2)," ",$P($G(^ONCO(164,TOP,0)),U,1),": ",!
S XSP="" F S XSP=$O(^ONCO(164,67500,"RXREC","C",XSP)) Q:XSP="" S SPSIEN=$O(^ONCO(164,67500,"RXREC","C",XSP,0)) D Q:EX=U
.S CTR=CTR+1 I CTR#20=0 D P Q:EX=U
.W !?2,$P($G(^ONCO(164,67500,"RXREC",SPSIEN,0)),U,2),?8,$E($P($G(^ONCO(164,67500,"RXREC",SPSIEN,0)),U,1),1,71) I $L($P($G(^ONCO(164,67500,"RXREC",SPSIEN,0)),U,1))>71 W !?11,$E($P($G(^ONCO(164,67500,"RXREC",SPSIEN,0)),U,1),72,111)
W !
K CTR,EX,HST14,ICD,SCDXDT,SPSIEN,TOP,XSP
Q
;
P ;
D Q:EX=U W !
.W ! K DIR S DIR(0)="E" D ^DIR I 'Y S EX=U Q
Q
CLEANUP ;Cleanup
K D0,PATNAM,SITEGP,SITTAB,TOPCOD,TOPNAM,TOPTAB,V,Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HONCOSUR1 8378 printed Sep 23, 2025@20:01:56 Page 2
ONCOSUR1 ;HINES OIFO/RTK - ONCOSUR continued ;06/23/10
+1 ;;2.2;ONCOLOGY;**1,15**;Jul 31, 2013;Build 5
+2 ;
COCIT ;CLASS OF CASE (165.5,.04) INPUT TRANSFORM
+1 ;If CLASS OF CASE is changed, delete the existing @FAC fields
+2 NEW OLDCOC,PIECE
+3 SET OLDCOC=$PIECE($GET(^ONCO(165.5,D0,0)),U,4)
IF OLDCOC=""
QUIT
+4 IF OLDCOC=X
QUIT
+5 IF ((OLDCOC=2)!(OLDCOC=3)!(OLDCOC=4)!(OLDCOC=5)!(OLDCOC=6)!(OLDCOC=7)!(OLDCOC=8)!(OLDCOC=9))&((X=2)!(X=3)!(X=4)!(X=5)!(X=6)!(X=7)!(X=8)!(X=9))
QUIT
+6 IF ((OLDCOC=1)!(OLDCOC=10)!(OLDCOC=11)!(OLDCOC=12)!(OLDCOC=13)!(OLDCOC=19)!(OLDCOC=20))&((X=1)!(X=10)!(X=11)!(X=12)!(X=13)!(X=19)!(X=20))
QUIT
+7 FOR PIECE=5:1:21
SET $PIECE(^ONCO(165.5,D0,3.1),U,PIECE)=""
+8 SET $PIECE(^ONCO(165.5,D0,3.1),U,23)=""
+9 SET $PIECE(^ONCO(165.5,D0,3.1),U,25)=""
+10 SET $PIECE(^ONCO(165.5,D0,3.1),U,30)=""
+11 SET $PIECE(^ONCO(165.5,D0,3.1),U,32)=""
+12 SET $PIECE(^ONCO(165.5,D0,3.1),U,34)=""
+13 WRITE !
+14 WRITE !?3,"You have changed the CLASS OF CASE. This change may affect"
+15 WRITE !?3,"the validity of the @FAC (at this facility) fields. Therefore,"
+16 WRITE !?3,"these fields have been initialized and need to be re-entered:"
+17 WRITE !
+18 QUIT
+19 ;
TOPIT ;PRIMARY SITE (165.5,20) INPUT TRANSFORM
+1 ;If PRIMARY SITE is changed, delete site-specific fields
+2 NEW MSSG,NOS,OLDTOP
+3 IF X=67999
KILL X
Begin DoDot:1
+4 WRITE !!," UNKNOWN C99.9 is not allowed. It is for"
+5 WRITE !," 1997 Non-Hodgkin's Lymphoma PCE use only."
+6 WRITE !," (Item 12. Personal History of Any Cancer)"
+7 WRITE !," Use UNKNOWN PRIMARY C80.9",!
End DoDot:1
QUIT
+8 IF X=67888
KILL X
Begin DoDot:1
+9 WRITE !!," NA C88.8 is not allowed. It is for"
+10 WRITE !," 1997 Non-Hodgkin's Lymphoma PCE use only."
+11 WRITE !," (Item 12. Personal History of Any Cancer)",!
End DoDot:1
QUIT
+12 SET OLDTOP=$PIECE($GET(^ONCO(165.5,D0,2)),U,1)
IF OLDTOP=""
QUIT
+13 SET MSSG=0
+14 IF X=OLDTOP
QUIT
+15 SET $PIECE(^ONCO(165.5,D0,8),U,1)=""
+16 SET $PIECE(^ONCO(165.5,D0,"CS3"),U,1)=""
+17 DO ^ONCOSUR2
+18 SET TOP=X
SET TOPCOD=""
SET TOPNAM=""
+19 IF TOP'=""
Begin DoDot:1
+20 SET TOPNAM=$PIECE(^ONCO(164,TOP,0),U,1)
+21 SET TOPCOD=$PIECE(^ONCO(164,TOP,0),U,2)
+22 SET SITTAB=79-$LENGTH($GET(SITEGP))
SET TOPTAB=79-$LENGTH(TOPNAM_" "_TOPCOD)
+23 SET NOS=TOPTAB-$LENGTH($GET(PATNAM))
SET NOS=NOS-1
+24 KILL SPACES
SET $PIECE(SPACES," ",NOS)=" "
End DoDot:1
+25 QUIT
+26 ;
SCIT ;SCOPE OF LN SURGERY (R) (165.5,138) INPUT TRANSFORM
+1 NEW FOUND,ICD,TOP,XSC
+2 if $GET(NTXDD)=""
QUIT
+3 SET TOP=$PIECE($GET(^ONCO(165.5,D0,2)),U,1)
IF TOP=""
KILL X
QUIT
+4 SET ICD=$PIECE($GET(^ONCO(164,TOP,0)),U,16)
IF ICD=""
KILL X
QUIT
+5 ;pre-2003 C76.0-C76.8, C80.9 cases
+6 ;see ROADS page D-cxliii
+7 IF ($GET(FIELD)=138)!($GET(FIELD)=138.1)
IF ($EXTRACT(TOP,3,4)=76)!(TOP=67809)!(TOP=67420)!(TOP=67421)!(TOP=67423)!(TOP=67424)
SET ICD=67141
KILL FIELD
+8 SET FOUND=0
+9 FOR XSC=0:0
SET XSC=$ORDER(^ONCO(164,ICD,"SC5",XSC))
if (XSC'>0)!(FOUND=1)
QUIT
Begin DoDot:1
+10 IF $PIECE(^ONCO(164,ICD,"SC5",XSC,0),U,2)=X
SET X=XSC
SET FOUND=1
End DoDot:1
+11 IF FOUND=0
KILL X
QUIT
+12 WRITE " ",$PIECE(^ONCO(164,ICD,"SC5",X,0),U,1)
+13 IF $DATA(X)
IF NTXDD=1
SET V=0
DO NT^ONCODSR
+14 KILL NTXDD
+15 QUIT
+16 ;
SCOT ;SCOPE OF LN SURGERY (R) (165.5,138) OUTPUT TRANSFORM
+1 NEW ICD,TOP
+2 if Y=""
QUIT
+3 SET TOP=$PIECE($GET(^ONCO(165.5,D0,2)),U,1)
IF TOP=""
SET Y=""
QUIT
+4 SET ICD=$PIECE($GET(^ONCO(164,TOP,0)),U,16)
IF ICD=""
SET Y=""
QUIT
+5 ;pre-2003 C76.0-C76.8, C80.9 cases
+6 ;see ROADS page D-cxliii
+7 IF ($GET(FIELD)=138)!($GET(FIELD)=138.1)
IF ($EXTRACT(TOP,3,4)=76)!(TOP=67809)!(TOP=67420)!(TOP=67421)!(TOP=67423)!(TOP=67424)
SET ICD=67141
KILL FIELD
+8 SET Y=$PIECE($GET(^ONCO(164,ICD,"SC5",Y,0)),U,1)
+9 QUIT
+10 ;
SCHP ;SCOPE OF LN SURGERY (R) (165.5,138) HELP
+1 NEW ICD,TOP,XSC
+2 SET TOP=$PIECE($GET(^ONCO(165.5,D0,2)),U,1)
IF TOP=""
QUIT
+3 SET ICD=$PIECE($GET(^ONCO(164,TOP,0)),U,16)
IF ICD=""
QUIT
+4 ;pre-2003 C76.0-C76.8, C80.9 cases
+5 ;see ROADS page D-cxliii
+6 IF ($GET(FIELD)=138)!($GET(FIELD)=138.1)
IF ($EXTRACT(TOP,3,4)=76)!(TOP=67809)!(TOP=67420)!(TOP=67421)!(TOP=67423)!(TOP=67424)
SET ICD=67141
KILL FIELD
+7 WRITE !?3,"Choose from:"
+8 FOR XSC=0:0
SET XSC=$ORDER(^ONCO(164,ICD,"SC5",XSC))
if XSC'>0
QUIT
WRITE !?3,$PIECE($GET(^ONCO(164,ICD,"SC5",XSC,0)),U,2),?12,$PIECE($GET(^ONCO(164,ICD,"SC5",XSC,0)),U,1)
+9 WRITE !
+10 QUIT
+11 ;
SOIT ;SURG PROC/OTHER SITE (R) (165.5,139) INPUT TRANSFORM
+1 NEW FOUND,ICD,TOP,XSO
+2 if $GET(NTXDD)=""
QUIT
+3 SET TOP=$PIECE($GET(^ONCO(165.5,D0,2)),U,1)
IF TOP=""
KILL X
QUIT
+4 SET ICD=$PIECE($GET(^ONCO(164,TOP,0)),U,16)
IF ICD=""
KILL X
QUIT
+5 ;pre-2003 C76.0-C76.8, C80.9 cases
+6 ;see ROADS page D-cxliii
+7 IF ($GET(FIELD)=139)!($GET(FIELD)=139.1)
IF ($EXTRACT(TOP,3,4)=76)!(TOP=67809)!(TOP=67420)!(TOP=67421)!(TOP=67423)!(TOP=67424)
SET ICD=67141
KILL FIELD
+8 SET FOUND=0
+9 FOR XSO=0:0
SET XSO=$ORDER(^ONCO(164,ICD,"SO5",XSO))
if (XSO'>0)!(FOUND=1)
QUIT
Begin DoDot:1
+10 IF $PIECE(^ONCO(164,ICD,"SO5",XSO,0),U,2)=X
SET X=XSO
SET FOUND=1
QUIT
End DoDot:1
+11 IF FOUND=0
KILL X
QUIT
+12 WRITE " ",$PIECE(^ONCO(164,ICD,"SO5",X,0),U,1)
+13 IF $DATA(X)
IF NTXDD=1
SET V=0
DO NT^ONCODSR
+14 KILL NTXDD
+15 QUIT
+16 ;
SOOT ;SURG PROC/OTHER SITE (R) (165.5,139) OUTPUT TRANSFORM
+1 NEW ICD,TOP
+2 if Y=""
QUIT
+3 SET TOP=$PIECE($GET(^ONCO(165.5,D0,2)),U,1)
IF TOP=""
SET Y=""
QUIT
+4 SET ICD=$PIECE($GET(^ONCO(164,TOP,0)),U,16)
IF ICD=""
SET Y=""
QUIT
+5 ;pre-2003 C76.0-C76.8, C80.9 cases
+6 ;see ROADS page D-cxliii
+7 IF ($GET(FIELD)=139)!($GET(FIELD)=139.1)
IF ($EXTRACT(TOP,3,4)=76)!(TOP=67809)!(TOP=67420)!(TOP=67421)!(TOP=67423)!(TOP=67424)
SET ICD=67141
KILL FIELD
+8 SET Y=$PIECE($GET(^ONCO(164,ICD,"SO5",Y,0)),U,1)
+9 QUIT
+10 ;
SOHP ;SURG PROC/OTHER SITE (R) (165.5,139) HELP
+1 NEW ICD,TOP,XSO
+2 SET TOP=$PIECE($GET(^ONCO(165.5,D0,2)),U,1)
IF TOP=""
QUIT
+3 SET ICD=$PIECE($GET(^ONCO(164,TOP,0)),U,16)
IF ICD=""
QUIT
+4 ;pre-2003 C76.0-C76.8, C80.9 cases
+5 ;see ROADS page D-cxliii
+6 IF ($GET(FIELD)=139)!($GET(FIELD)=139.1)
IF ($EXTRACT(TOP,3,4)=76)!(TOP=67809)!(TOP=67420)!(TOP=67421)!(TOP=67423)!(TOP=67424)
SET ICD=67141
KILL FIELD
+7 WRITE !?3,"Choose from:"
+8 FOR XSO=0:0
SET XSO=$ORDER(^ONCO(164,ICD,"SO5",XSO))
if XSO'>0
QUIT
WRITE !?3,$PIECE($GET(^ONCO(164,ICD,"SO5",XSO,0)),U,2),?12,$PIECE($GET(^ONCO(164,ICD,"SO5",XSO,0)),U,1)
+9 WRITE !
+10 QUIT
+11 ;
NRIT ;NUMBER OF LN REMOVED (R) (165.5,140) INPUT TRANSFORM
+1 if $GET(NTXDD)=""
QUIT
+2 SET X=+X
+3 IF $LENGTH(X)=1
SET X="0"_X
+4 IF X="00"
WRITE " No nodes removed"
+5 IF X=90
WRITE " 90 or more nodes removed"
+6 IF X=95
WRITE " No nodes removed, aspiration performed"
+7 IF X=96
WRITE " Node removal as a sampling, number unknown"
+8 IF X=97
WRITE " Node removal as dissection, number unknown"
+9 IF X=98
WRITE " Nodes surgically removed, number unknown"
+10 IF X=99
WRITE " Unknown, not stated, death cert ONLY"
+11 IF $DATA(X)
IF NTXDD=1
SET V=0
DO NT^ONCODSR
+12 KILL NTXDD
+13 QUIT
+14 ;
NROT ;NUMBER OF LN REMOVED (R) (165.5,140) OUTPUT TRANSFORM
+1 if Y=""
QUIT
+2 SET Y=+Y
+3 IF Y=0
SET Y="No nodes removed"
+4 IF ((Y>0)&(Y<90))!((Y>90)&(Y<95))
if $LENGTH(Y)=1
SET Y=0_Y
+5 IF Y=90
SET Y="90 or more nodes removed"
+6 IF Y=95
SET Y="No nodes removed, aspiration performed"
+7 IF Y=96
SET Y="Node removal as a sampling, number unknown"
+8 IF Y=97
SET Y="Node removal as dissection, number unknown"
+9 IF Y=98
SET Y="Nodes surgically removed, number unknown"
+10 IF Y=99
SET Y="Unknown, not stated, death cert ONLY"
+11 QUIT
+12 ;
RXSBIT ;
+1 IF "B000^B200^B210^B215^B240^B290^B300^B310^B320^B400^B410^B420^B500^B510^B600^B610^B620^B700^B710^B720^B760^B800^B900^B990"'[X
KILL X
QUIT
+2 QUIT
RXRECIT ;
+1 IF "A000^A100^A200^A300^A400^A500^A600^A610^A620^A630^A640^A900^A970^A980^A990"'[X
KILL X
QUIT
+2 QUIT
RXSBHP ;HELP
+1 NEW TOP,SCDXDT,XSP,SPSIEN
+2 SET TOP=$PIECE($GET(^ONCO(165.5,D0,2)),U,1)
IF TOP=""
WRITE !,"No PRIMARY SITE"
QUIT
+3 IF $EXTRACT(TOP,1,4)'=6750
WRITE !,"This field is only for BREAST sites"
QUIT
+4 SET SCDXDT=$PIECE($GET(^ONCO(165.5,D0,0)),U,16)
IF SCDXDT=""
QUIT
+5 SET (EX,CTR)=0
+6 WRITE !?3,"RX HOSP/SURG--SURG BREAST codes for site ",$PIECE($GET(^ONCO(164,TOP,0)),U,2)," ",$PIECE($GET(^ONCO(164,TOP,0)),U,1),": ",!
+7 SET XSP=""
FOR
SET XSP=$ORDER(^ONCO(164,67500,"RXSB","C",XSP))
if XSP=""
QUIT
SET SPSIEN=$ORDER(^ONCO(164,67500,"RXSB","C",XSP,0))
Begin DoDot:1
+8 SET CTR=CTR+1
IF CTR#11=0
DO P
if EX=U
QUIT
+9 WRITE !?2,$PIECE($GET(^ONCO(164,67500,"RXSB",SPSIEN,0)),U,2),?8,$EXTRACT($PIECE($GET(^ONCO(164,67500,"RXSB",SPSIEN,0)),U,1),1,71)
IF $LENGTH($PIECE($GET(^ONCO(164,67500,"RXSB",SPSIEN,0)),U,1))>71
WRITE !?11,$EXTRACT($PIECE($GET(^ONCO(164,67500,"RXSB",SPSIEN,0)),U,1),72,111)
End DoDot:1
if EX=U
QUIT
+10 WRITE !
+11 KILL CTR,EX,HST14,ICD,SCDXDT,SPSIEN,TOP,XSP
+12 QUIT
+13 ;
RXRECHP ;HELP
+1 NEW TOP,SCDXDT,XSP,SPSIEN
+2 SET TOP=$PIECE($GET(^ONCO(165.5,D0,2)),U,1)
IF TOP=""
WRITE !,"No PRIMARY SITE"
QUIT
+3 IF $EXTRACT(TOP,1,4)'=6750
WRITE !,"This field is only for BREAST sites"
QUIT
+4 SET SCDXDT=$PIECE($GET(^ONCO(165.5,D0,0)),U,16)
IF SCDXDT=""
QUIT
+5 SET (EX,CTR)=0
+6 WRITE !?3,"RX HOSP/SURG--SURG RECONSTRUCTION codes for site ",$PIECE($GET(^ONCO(164,TOP,0)),U,2)," ",$PIECE($GET(^ONCO(164,TOP,0)),U,1),": ",!
+7 SET XSP=""
FOR
SET XSP=$ORDER(^ONCO(164,67500,"RXREC","C",XSP))
if XSP=""
QUIT
SET SPSIEN=$ORDER(^ONCO(164,67500,"RXREC","C",XSP,0))
Begin DoDot:1
+8 SET CTR=CTR+1
IF CTR#20=0
DO P
if EX=U
QUIT
+9 WRITE !?2,$PIECE($GET(^ONCO(164,67500,"RXREC",SPSIEN,0)),U,2),?8,$EXTRACT($PIECE($GET(^ONCO(164,67500,"RXREC",SPSIEN,0)),U,1),1,71)
IF $LENGTH($PIECE($GET(^ONCO(164,67500,"RXREC",SPSIEN,0)),U,1))>71
WRITE !?11,$EXTRACT($PIECE($GET(^ONCO(164,67500,"RXREC",SPSIEN,0)),U,1),72,111)
End DoDot:1
if EX=U
QUIT
+10 WRITE !
+11 KILL CTR,EX,HST14,ICD,SCDXDT,SPSIEN,TOP,XSP
+12 QUIT
+13 ;
P ;
+1 Begin DoDot:1
+2 WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
IF 'Y
SET EX=U
QUIT
End DoDot:1
if EX=U
QUIT
WRITE !
+3 QUIT
CLEANUP ;Cleanup
+1 KILL D0,PATNAM,SITEGP,SITTAB,TOPCOD,TOPNAM,TOPTAB,V,Y
