ONCSUBS ;Hines OIFO/GWB - CS SCHEMA DISCRIMINATOR (165.5,240) ;11/03/10
;;2.2;ONCOLOGY;**1,10**;Jul 31, 2013;Build 20
;
;Called from [ONCO ABSTRACT-I] INPUT TEMPLATE
;CS SCHEMA DISCRIMINATOR (165.5,240) prompt/no prompt logic
N DTDX,HT,TX
S DTDX=$P($G(^ONCO(165.5,D0,0)),U,16)
I DTDX<3040000 S Y="@623" Q
I DTDX>3171231 S Y="@623" Q
S TX=$P($G(^ONCO(165.5,D0,2)),U,1)
Q:TX=""
S HT=$$HIST^ONCFUNC(D0)
I '$D(^ONCO(164,TX,15)) S Y="@623" Q
I TX=67694,'$$MELANOMA^ONCOU55(D0) S Y="@623" Q
I TX=67695,$$MELANOMA^ONCOU55(D0) S Y="@623" Q
I $E(TX,3,4)=16 D
.I ($E(HT,1,4)=8153)!($E(HT,1,4)=8240)!($E(HT,1,4)=8241)!($E(HT,1,4)=8242)!($E(HT,1,4)=8246)!($E(HT,1,4)=8249)!($E(HT,1,4)=8935)!($E(HT,1,4)=8936) S Y="@623" Q
I (TX=67481)!(TX=67482)!(TX=67488) D
.I ($E(HT,1,4)=8935)!($E(HT,1,4)=8936) S Y="@623" Q
Q
;
IN ;CS SCHEMA DISCRIMINATOR (165.5,240) INPUT TRANSFORM
N DTDX,HT,SD,TX,XD0,HT4
S DTDX=$P($G(^ONCO(165.5,D0,0)),U,16)
S TX=$P($G(^ONCO(165.5,D0,2)),U,1) Q:TX=""
S HT=$$HIST^ONCFUNC(D0)
S HT4=$E(HT,1,4)
S SD=$P($G(^ONCO(165.5,D0,"CS3")),U,1)
I X'?3N K X Q
I '$D(^ONCO(164,TX,14,"B",X)) W !!?5,"Invalid code for this PRIMARY SITE",! K X Q
S XD0=$O(^ONCO(164,TX,14,"B",X,0))
S X=^ONCO(164,TX,14,XD0,0)
I DTDX>3091231,X=100 W " OBSOLETE code" K X Q
I SD'=X D
.W !
.W !?3,"You have changed the CS SCHEMA DISCRIMINATOR. This change may"
.W !?3,"affect the validity of the COLLABORATIVE STAGING data."
.W !?3,"Therefore, the CS fields have been initialized and need to"
.W !?3,"be re-entered."
.W !
.F PIECE=1:1:12 S $P(^ONCO(165.5,D0,"CS"),U,PIECE)=""
.F PIECE=1:1:19 S $P(^ONCO(165.5,D0,"CS1"),U,PIECE)=""
.F PIECE=1:1:18 S $P(^ONCO(165.5,D0,"CS2"),U,PIECE)=""
;for lacrimal gland c69.5
I TX=67695,X="025",((HT4>7999&HT4<8577)!(HT4>8989&HT4<8951)!(HT4>8979&HT4<8982)) D
.S $P(^ONCO(165.5,D0,2),U,20)=88
.S $P(^ONCO(165.5,D0,2),U,25)=88
.S $P(^ONCO(165.5,D0,2),U,26)=88
.S $P(^ONCO(165.5,D0,2),U,27)=88
.S $P(^ONCO(165.5,D0,2.1),U,1)=88
.S $P(^ONCO(165.5,D0,2.1),U,2)=88
.S $P(^ONCO(165.5,D0,2.1),U,3)=88
.S $P(^ONCO(165.5,D0,2.1),U,4)=88
K PIECE
Q
;
HELP ;CS SCHEMA DISCRIMINATOR (165.5,240) XECUTABLE 'HELP'
N HIEN,TX
S TX=$P($G(^ONCO(165.5,D0,2)),U,1)
Q:TX=""
I $D(^ONCO(164,TX,15)) D W ! Q
.S HIEN=0 F S HIEN=$O(^ONCO(164,TX,15,HIEN)) Q:HIEN'>0 W !?1,^ONCO(164,TX,15,HIEN,0)
Q
;
CLEANUP ;Cleanup
K D0,Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HONCSUBS 2437 printed Apr 09, 2024@21:24:57 Page 2
ONCSUBS ;Hines OIFO/GWB - CS SCHEMA DISCRIMINATOR (165.5,240) ;11/03/10
+1 ;;2.2;ONCOLOGY;**1,10**;Jul 31, 2013;Build 20
+2 ;
+3 ;Called from [ONCO ABSTRACT-I] INPUT TEMPLATE
+4 ;CS SCHEMA DISCRIMINATOR (165.5,240) prompt/no prompt logic
+5 NEW DTDX,HT,TX
+6 SET DTDX=$PIECE($GET(^ONCO(165.5,D0,0)),U,16)
+7 IF DTDX<3040000
SET Y="@623"
QUIT
+8 IF DTDX>3171231
SET Y="@623"
QUIT
+9 SET TX=$PIECE($GET(^ONCO(165.5,D0,2)),U,1)
+10 if TX=""
QUIT
+11 SET HT=$$HIST^ONCFUNC(D0)
+12 IF '$DATA(^ONCO(164,TX,15))
SET Y="@623"
QUIT
+13 IF TX=67694
IF '$$MELANOMA^ONCOU55(D0)
SET Y="@623"
QUIT
+14 IF TX=67695
IF $$MELANOMA^ONCOU55(D0)
SET Y="@623"
QUIT
+15 IF $EXTRACT(TX,3,4)=16
Begin DoDot:1
+16 IF ($EXTRACT(HT,1,4)=8153)!($EXTRACT(HT,1,4)=8240)!($EXTRACT(HT,1,4)=8241)!($EXTRACT(HT,1,4)=8242)!($EXTRACT(HT,1,4)=8246)!($EXTRACT(HT,1,4)=8249)!($EXTRACT(HT,1,4)=8935)!($EXTRACT(HT,1,4)=8936)
SET Y="@623"
QUIT
End DoDot:1
+17 IF (TX=67481)!(TX=67482)!(TX=67488)
Begin DoDot:1
+18 IF ($EXTRACT(HT,1,4)=8935)!($EXTRACT(HT,1,4)=8936)
SET Y="@623"
QUIT
End DoDot:1
+19 QUIT
+20 ;
IN ;CS SCHEMA DISCRIMINATOR (165.5,240) INPUT TRANSFORM
+1 NEW DTDX,HT,SD,TX,XD0,HT4
+2 SET DTDX=$PIECE($GET(^ONCO(165.5,D0,0)),U,16)
+3 SET TX=$PIECE($GET(^ONCO(165.5,D0,2)),U,1)
if TX=""
QUIT
+4 SET HT=$$HIST^ONCFUNC(D0)
+5 SET HT4=$EXTRACT(HT,1,4)
+6 SET SD=$PIECE($GET(^ONCO(165.5,D0,"CS3")),U,1)
+7 IF X'?3N
KILL X
QUIT
+8 IF '$DATA(^ONCO(164,TX,14,"B",X))
WRITE !!?5,"Invalid code for this PRIMARY SITE",!
KILL X
QUIT
+9 SET XD0=$ORDER(^ONCO(164,TX,14,"B",X,0))
+10 SET X=^ONCO(164,TX,14,XD0,0)
+11 IF DTDX>3091231
IF X=100
WRITE " OBSOLETE code"
KILL X
QUIT
+12 IF SD'=X
Begin DoDot:1
+13 WRITE !
+14 WRITE !?3,"You have changed the CS SCHEMA DISCRIMINATOR. This change may"
+15 WRITE !?3,"affect the validity of the COLLABORATIVE STAGING data."
+16 WRITE !?3,"Therefore, the CS fields have been initialized and need to"
+17 WRITE !?3,"be re-entered."
+18 WRITE !
+19 FOR PIECE=1:1:12
SET $PIECE(^ONCO(165.5,D0,"CS"),U,PIECE)=""
+20 FOR PIECE=1:1:19
SET $PIECE(^ONCO(165.5,D0,"CS1"),U,PIECE)=""
+21 FOR PIECE=1:1:18
SET $PIECE(^ONCO(165.5,D0,"CS2"),U,PIECE)=""
End DoDot:1
+22 ;for lacrimal gland c69.5
+23 IF TX=67695
IF X="025"
IF ((HT4>7999&HT4<8577)!(HT4>8989&HT4<8951)!(HT4>8979&HT4<8982))
Begin DoDot:1
+24 SET $PIECE(^ONCO(165.5,D0,2),U,20)=88
+25 SET $PIECE(^ONCO(165.5,D0,2),U,25)=88
+26 SET $PIECE(^ONCO(165.5,D0,2),U,26)=88
+27 SET $PIECE(^ONCO(165.5,D0,2),U,27)=88
+28 SET $PIECE(^ONCO(165.5,D0,2.1),U,1)=88
+29 SET $PIECE(^ONCO(165.5,D0,2.1),U,2)=88
+30 SET $PIECE(^ONCO(165.5,D0,2.1),U,3)=88
+31 SET $PIECE(^ONCO(165.5,D0,2.1),U,4)=88
End DoDot:1
+32 KILL PIECE
+33 QUIT
+34 ;
HELP ;CS SCHEMA DISCRIMINATOR (165.5,240) XECUTABLE 'HELP'
+1 NEW HIEN,TX
+2 SET TX=$PIECE($GET(^ONCO(165.5,D0,2)),U,1)
+3 if TX=""
QUIT
+4 IF $DATA(^ONCO(164,TX,15))
Begin DoDot:1
+5 SET HIEN=0
FOR
SET HIEN=$ORDER(^ONCO(164,TX,15,HIEN))
if HIEN'>0
QUIT
WRITE !?1,^ONCO(164,TX,15,HIEN,0)
End DoDot:1
WRITE !
QUIT
+6 QUIT
+7 ;
CLEANUP ;Cleanup
+1 KILL D0,Y
