ONCODXD ;HINES OIFO/RTK,GWB - DATE DX (165.5,3) INPUT TRANSFORM ;4/9/97
;;2.2;ONCOLOGY;**1,13**;Jul 31, 2013;Build 7
;
DTDXIT ;Check that date entered is BEFORE or EQUAL to all other DATE fields
S DTXFLAG=1,C=0,MULT="" K LIST,SBCT,SUBR,RADT D CHKDTS
;next 2 lines to delete AJCC ID if Date DX changes from 2018-2020 to 2021+
I (($E(X,1,3)<321)&($E($P($G(^ONCO(165.5,D0,0)),"^",16),1,3)>320)) S $P(^ONCO(165.5,D0,"AJCC8"),"^",1)=""
I (($E(X,1,3)>320)&($E($P($G(^ONCO(165.5,D0,0)),"^",16),1,3)<321)) S $P(^ONCO(165.5,D0,"AJCC8"),"^",1)=""
I DTXFLAG=1 D KLL Q
K X W !?4,"The DATE DX must be BEFORE or EQUAL TO certain date fields. The date"
W !?4,"you have entered is unacceptable because it is AFTER the"
W !?4,"following date field(s):",!
F RTK=0:0 S RTK=$O(LIST(RTK)) Q:RTK'>"" D
.S INDT=$P(LIST(RTK),U,2) D DT
.W !?4,EXDT," - ",$P(LIST(RTK),U,1) Q
F RTK=0:0 S RTK=$O(SBCT(RTK)) Q:RTK'>"" D
.S INDT=$P(SBCT(RTK),U,2) D DT
.W !?4,EXDT," - SUBSEQUENT COURSE TREATMENT ",$P(SBCT(RTK),U,3)
.W " - ",$P(SBCT(RTK),U,1) Q
F RTK=0:0 S RTK=$O(SUBR(RTK)) Q:RTK'>"" D
.S INDT=$P(SUBR(RTK),U,2) D DT
.W !?4,EXDT," - SUBSEQUENT RECURRENCE ",$P(SUBR(RTK),U,3)
.W " - ",$P(SUBR(RTK),U,1) Q
F RTK=0:0 S RTK=$O(RADT(RTK)) Q:RTK'>"" D
.S INDT=$P(RADT(RTK),U,2) D DT
.W !?4,EXDT," - RADIATION TREATMENT ",$P(RADT(RTK),U,3)
.W " - ",$P(RADT(RTK),U,1) Q
W !
;
KLL I DTXFLAG=1,X<3040000 D
.F PIECE=1:1:12 S $P(^ONCO(165.5,D0,"CS"),U,PIECE)=""
.F PIECE=1:1:11 S $P(^ONCO(165.5,D0,"CS1"),U,PIECE)=""
K C,DTXFLAG,EXDT,FLD,FLDNM,INDT,LIST,MULT,NODE0,NODE1,NODE22
K NODE3,NODE31,NODE5,NODE7,NODEBL1,NODEBL2,NODENH2,NODEST2,NODETH1
K RADT,RADTZND,RDZ,RTK,SBCT,SBCTZND,SRZ,SUBR,SUBRZND,SZ Q
;
CHKDTS ; Check it against all other DATE fields
S NODE0=$G(^ONCO(165.5,D0,0)),NODE1=$G(^ONCO(165.5,D0,1))
S NODE3=$G(^ONCO(165.5,D0,3)),NODE31=$G(^ONCO(165.5,D0,3.1))
S NODE5=$G(^ONCO(165.5,D0,5)),NODE7=$G(^ONCO(165.5,D0,7))
S NODENH2=$G(^ONCO(165.5,D0,"NHL2")),NODE22=$G(^ONCO(165.5,D0,2.2))
S NODEBL1=$G(^ONCO(165.5,D0,"BLA1")),NODEBL2=$G(^ONCO(165.5,D0,"BLA2"))
S NODETH1=$G(^ONCO(165.5,D0,"THY1")),NODEST2=$G(^ONCO(165.5,D0,"STS2"))
;
S FLD=$P(NODE1,U,10),FLDNM=$P($G(^DD(165.5,17,0)),U,1) D EDCHK
S FLD=$P(NODE3,U,1),FLDNM=$P($G(^DD(165.5,50,0)),U,1) D EDCHK
S FLD=$P(NODE3,U,4),FLDNM=$P($G(^DD(165.5,51,0)),U,1) D EDCHK
S FLD=$P(NODE3,U,11),FLDNM=$P($G(^DD(165.5,53,0)),U,1) D EDCHK
S FLD=$P(NODE3,U,14),FLDNM=$P($G(^DD(165.5,54,0)),U,1) D EDCHK
S FLD=$P(NODE3,U,17),FLDNM=$P($G(^DD(165.5,55,0)),U,1) D EDCHK
S FLD=$P(NODE3,U,23),FLDNM=$P($G(^DD(165.5,57,0)),U,1) D EDCHK
S FLD=$P(NODE7,U,9),FLDNM=$P($G(^DD(165.5,64,0)),U,1) D EDCHK
S FLD=$P(NODE5,U,1),FLDNM=$P($G(^DD(165.5,70,0)),U,1) D EDCHK
S FLD=$P(NODE7,U,1),FLDNM=$P($G(^DD(165.5,90,0)),U,1) D EDCHK
S FLD=$P(NODEBL1,U,24),FLDNM=$P($G(^DD(165.5,323,0)),U,1) D EDCHK
S FLD=$P(NODEBL2,U,16),FLDNM=$P($G(^DD(165.5,361,0)),U,1) D EDCHK
S FLD=$P(NODEBL2,U,22),FLDNM=$P($G(^DD(165.5,367,0)),U,1) D EDCHK
S FLD=$P(NODETH1,U,36),FLDNM=$P($G(^DD(165.5,435,0)),U,1) D EDCHK
S FLD=$P(NODEST2,U,12),FLDNM=$P($G(^DD(165.5,541,0)),U,1) D EDCHK
S FLD=$P(NODEST2,U,38),FLDNM=$P($G(^DD(165.5,567,0)),U,1) D EDCHK
S FLD=$P(NODENH2,U,20),FLDNM=$P($G(^DD(165.5,865,0)),U,1) D EDCHK
F SBCT=0:0 S SBCT=$O(^ONCO(165.5,D0,4,SBCT)) Q:SBCT'>0 D
.S SBCTZND=$G(^ONCO(165.5,D0,4,SBCT,0)),SZ=SBCTZND,MULT="SCT"
.S FLD=$P(SZ,U,1),FLDNM=$P($G(^DD(165.51,.01,0)),U,1) D EDCHK
.S FLD=$P(SZ,U,11),FLDNM=$P($G(^DD(165.51,.041,0)),U,1) D EDCHK
.S FLD=$P(SZ,U,12),FLDNM=$P($G(^DD(165.51,.051,0)),U,1) D EDCHK
.S FLD=$P(SZ,U,13),FLDNM=$P($G(^DD(165.51,.061,0)),U,1) D EDCHK
.S FLD=$P(SZ,U,14),FLDNM=$P($G(^DD(165.51,.071,0)),U,1) D EDCHK
.S FLD=$P(SZ,U,15),FLDNM=$P($G(^DD(165.51,.081,0)),U,1) D EDCHK
.S FLD=$P(SZ,U,16),FLDNM=$P($G(^DD(165.51,.091,0)),U,1) D EDCHK
F SUBR=0:0 S SUBR=$O(^ONCO(165.5,D0,23,SUBR)) Q:SUBR'>0 D
.S SUBRZND=$G(^ONCO(165.5,D0,23,SUBR,0)),SRZ=SUBRZND,MULT="SR"
.S FLD=$P(SRZ,U,1),FLDNM=$P($G(^DD(165.572,.01,0)),U,1) D EDCHK
Q
;
EDCHK ; If its a legitimate date check it against the date entered for DT DX
; If its a partial date (no month or no day) just check year or year/mo
I FLD=""!(FLD="0000000")!(FLD=9999999) Q
I $E(FLD,4,7)="0000" D Q ;no DAY or MONTH
.I $E(X,1,3)>$E(FLD,1,3) D ERRDATE Q
I $E(FLD,6,7)="00" D Q ;MONTH but no DAY
.I $E(X,1,5)>$E(FLD,1,5) D ERRDATE Q
I X>FLD D ERRDATE Q
Q
;
ERRDATE ; Set DTXFLAG=0 and add FLDNM to the LIST of fields it must be before
S DTXFLAG=0,C=C+1
I MULT="SCT" S SBCT(C)=FLDNM_U_FLD_U_SBCT Q
I MULT="SR" S SUBR(C)=FLDNM_U_FLD_U_SUBR Q
I MULT="RDT" S RADT(C)=FLDNM_U_FLD_U_RADT Q
S LIST(C)=FLDNM_U_FLD
Q
;
DT ; CHANGE INTERNAL DATE TO EXTERNAL DATE FORMAT
S EXDT=$E(INDT,4,5)_"/"_$E(INDT,6,7)_"/"_($E(INDT,1,3)+1700)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HONCODXD 4877 printed Dec 13, 2024@02:24:53 Page 2
ONCODXD ;HINES OIFO/RTK,GWB - DATE DX (165.5,3) INPUT TRANSFORM ;4/9/97
+1 ;;2.2;ONCOLOGY;**1,13**;Jul 31, 2013;Build 7
+2 ;
DTDXIT ;Check that date entered is BEFORE or EQUAL to all other DATE fields
+1 SET DTXFLAG=1
SET C=0
SET MULT=""
KILL LIST,SBCT,SUBR,RADT
DO CHKDTS
+2 ;next 2 lines to delete AJCC ID if Date DX changes from 2018-2020 to 2021+
+3 IF (($EXTRACT(X,1,3)<321)&($EXTRACT($PIECE($GET(^ONCO(165.5,D0,0)),"^",16),1,3)>320))
SET $PIECE(^ONCO(165.5,D0,"AJCC8"),"^",1)=""
+4 IF (($EXTRACT(X,1,3)>320)&($EXTRACT($PIECE($GET(^ONCO(165.5,D0,0)),"^",16),1,3)<321))
SET $PIECE(^ONCO(165.5,D0,"AJCC8"),"^",1)=""
+5 IF DTXFLAG=1
DO KLL
QUIT
+6 KILL X
WRITE !?4,"The DATE DX must be BEFORE or EQUAL TO certain date fields. The date"
+7 WRITE !?4,"you have entered is unacceptable because it is AFTER the"
+8 WRITE !?4,"following date field(s):",!
+9 FOR RTK=0:0
SET RTK=$ORDER(LIST(RTK))
if RTK'>""
QUIT
Begin DoDot:1
+10 SET INDT=$PIECE(LIST(RTK),U,2)
DO DT
+11 WRITE !?4,EXDT," - ",$PIECE(LIST(RTK),U,1)
QUIT
End DoDot:1
+12 FOR RTK=0:0
SET RTK=$ORDER(SBCT(RTK))
if RTK'>""
QUIT
Begin DoDot:1
+13 SET INDT=$PIECE(SBCT(RTK),U,2)
DO DT
+14 WRITE !?4,EXDT," - SUBSEQUENT COURSE TREATMENT ",$PIECE(SBCT(RTK),U,3)
+15 WRITE " - ",$PIECE(SBCT(RTK),U,1)
QUIT
End DoDot:1
+16 FOR RTK=0:0
SET RTK=$ORDER(SUBR(RTK))
if RTK'>""
QUIT
Begin DoDot:1
+17 SET INDT=$PIECE(SUBR(RTK),U,2)
DO DT
+18 WRITE !?4,EXDT," - SUBSEQUENT RECURRENCE ",$PIECE(SUBR(RTK),U,3)
+19 WRITE " - ",$PIECE(SUBR(RTK),U,1)
QUIT
End DoDot:1
+20 FOR RTK=0:0
SET RTK=$ORDER(RADT(RTK))
if RTK'>""
QUIT
Begin DoDot:1
+21 SET INDT=$PIECE(RADT(RTK),U,2)
DO DT
+22 WRITE !?4,EXDT," - RADIATION TREATMENT ",$PIECE(RADT(RTK),U,3)
+23 WRITE " - ",$PIECE(RADT(RTK),U,1)
QUIT
End DoDot:1
+24 WRITE !
+25 ;
KLL IF DTXFLAG=1
IF X<3040000
Begin DoDot:1
+1 FOR PIECE=1:1:12
SET $PIECE(^ONCO(165.5,D0,"CS"),U,PIECE)=""
+2 FOR PIECE=1:1:11
SET $PIECE(^ONCO(165.5,D0,"CS1"),U,PIECE)=""
End DoDot:1
+3 KILL C,DTXFLAG,EXDT,FLD,FLDNM,INDT,LIST,MULT,NODE0,NODE1,NODE22
+4 KILL NODE3,NODE31,NODE5,NODE7,NODEBL1,NODEBL2,NODENH2,NODEST2,NODETH1
+5 KILL RADT,RADTZND,RDZ,RTK,SBCT,SBCTZND,SRZ,SUBR,SUBRZND,SZ
QUIT
+6 ;
CHKDTS ; Check it against all other DATE fields
+1 SET NODE0=$GET(^ONCO(165.5,D0,0))
SET NODE1=$GET(^ONCO(165.5,D0,1))
+2 SET NODE3=$GET(^ONCO(165.5,D0,3))
SET NODE31=$GET(^ONCO(165.5,D0,3.1))
+3 SET NODE5=$GET(^ONCO(165.5,D0,5))
SET NODE7=$GET(^ONCO(165.5,D0,7))
+4 SET NODENH2=$GET(^ONCO(165.5,D0,"NHL2"))
SET NODE22=$GET(^ONCO(165.5,D0,2.2))
+5 SET NODEBL1=$GET(^ONCO(165.5,D0,"BLA1"))
SET NODEBL2=$GET(^ONCO(165.5,D0,"BLA2"))
+6 SET NODETH1=$GET(^ONCO(165.5,D0,"THY1"))
SET NODEST2=$GET(^ONCO(165.5,D0,"STS2"))
+7 ;
+8 SET FLD=$PIECE(NODE1,U,10)
SET FLDNM=$PIECE($GET(^DD(165.5,17,0)),U,1)
DO EDCHK
+9 SET FLD=$PIECE(NODE3,U,1)
SET FLDNM=$PIECE($GET(^DD(165.5,50,0)),U,1)
DO EDCHK
+10 SET FLD=$PIECE(NODE3,U,4)
SET FLDNM=$PIECE($GET(^DD(165.5,51,0)),U,1)
DO EDCHK
+11 SET FLD=$PIECE(NODE3,U,11)
SET FLDNM=$PIECE($GET(^DD(165.5,53,0)),U,1)
DO EDCHK
+12 SET FLD=$PIECE(NODE3,U,14)
SET FLDNM=$PIECE($GET(^DD(165.5,54,0)),U,1)
DO EDCHK
+13 SET FLD=$PIECE(NODE3,U,17)
SET FLDNM=$PIECE($GET(^DD(165.5,55,0)),U,1)
DO EDCHK
+14 SET FLD=$PIECE(NODE3,U,23)
SET FLDNM=$PIECE($GET(^DD(165.5,57,0)),U,1)
DO EDCHK
+15 SET FLD=$PIECE(NODE7,U,9)
SET FLDNM=$PIECE($GET(^DD(165.5,64,0)),U,1)
DO EDCHK
+16 SET FLD=$PIECE(NODE5,U,1)
SET FLDNM=$PIECE($GET(^DD(165.5,70,0)),U,1)
DO EDCHK
+17 SET FLD=$PIECE(NODE7,U,1)
SET FLDNM=$PIECE($GET(^DD(165.5,90,0)),U,1)
DO EDCHK
+18 SET FLD=$PIECE(NODEBL1,U,24)
SET FLDNM=$PIECE($GET(^DD(165.5,323,0)),U,1)
DO EDCHK
+19 SET FLD=$PIECE(NODEBL2,U,16)
SET FLDNM=$PIECE($GET(^DD(165.5,361,0)),U,1)
DO EDCHK
+20 SET FLD=$PIECE(NODEBL2,U,22)
SET FLDNM=$PIECE($GET(^DD(165.5,367,0)),U,1)
DO EDCHK
+21 SET FLD=$PIECE(NODETH1,U,36)
SET FLDNM=$PIECE($GET(^DD(165.5,435,0)),U,1)
DO EDCHK
+22 SET FLD=$PIECE(NODEST2,U,12)
SET FLDNM=$PIECE($GET(^DD(165.5,541,0)),U,1)
DO EDCHK
+23 SET FLD=$PIECE(NODEST2,U,38)
SET FLDNM=$PIECE($GET(^DD(165.5,567,0)),U,1)
DO EDCHK
+24 SET FLD=$PIECE(NODENH2,U,20)
SET FLDNM=$PIECE($GET(^DD(165.5,865,0)),U,1)
DO EDCHK
+25 FOR SBCT=0:0
SET SBCT=$ORDER(^ONCO(165.5,D0,4,SBCT))
if SBCT'>0
QUIT
Begin DoDot:1
+26 SET SBCTZND=$GET(^ONCO(165.5,D0,4,SBCT,0))
SET SZ=SBCTZND
SET MULT="SCT"
+27 SET FLD=$PIECE(SZ,U,1)
SET FLDNM=$PIECE($GET(^DD(165.51,.01,0)),U,1)
DO EDCHK
+28 SET FLD=$PIECE(SZ,U,11)
SET FLDNM=$PIECE($GET(^DD(165.51,.041,0)),U,1)
DO EDCHK
+29 SET FLD=$PIECE(SZ,U,12)
SET FLDNM=$PIECE($GET(^DD(165.51,.051,0)),U,1)
DO EDCHK
+30 SET FLD=$PIECE(SZ,U,13)
SET FLDNM=$PIECE($GET(^DD(165.51,.061,0)),U,1)
DO EDCHK
+31 SET FLD=$PIECE(SZ,U,14)
SET FLDNM=$PIECE($GET(^DD(165.51,.071,0)),U,1)
DO EDCHK
+32 SET FLD=$PIECE(SZ,U,15)
SET FLDNM=$PIECE($GET(^DD(165.51,.081,0)),U,1)
DO EDCHK
+33 SET FLD=$PIECE(SZ,U,16)
SET FLDNM=$PIECE($GET(^DD(165.51,.091,0)),U,1)
DO EDCHK
End DoDot:1
+34 FOR SUBR=0:0
SET SUBR=$ORDER(^ONCO(165.5,D0,23,SUBR))
if SUBR'>0
QUIT
Begin DoDot:1
+35 SET SUBRZND=$GET(^ONCO(165.5,D0,23,SUBR,0))
SET SRZ=SUBRZND
SET MULT="SR"
+36 SET FLD=$PIECE(SRZ,U,1)
SET FLDNM=$PIECE($GET(^DD(165.572,.01,0)),U,1)
DO EDCHK
End DoDot:1
+37 QUIT
+38 ;
EDCHK ; If its a legitimate date check it against the date entered for DT DX
+1 ; If its a partial date (no month or no day) just check year or year/mo
+2 IF FLD=""!(FLD="0000000")!(FLD=9999999)
QUIT
+3 ;no DAY or MONTH
IF $EXTRACT(FLD,4,7)="0000"
Begin DoDot:1
+4 IF $EXTRACT(X,1,3)>$EXTRACT(FLD,1,3)
DO ERRDATE
QUIT
End DoDot:1
QUIT
+5 ;MONTH but no DAY
IF $EXTRACT(FLD,6,7)="00"
Begin DoDot:1
+6 IF $EXTRACT(X,1,5)>$EXTRACT(FLD,1,5)
DO ERRDATE
QUIT
End DoDot:1
QUIT
+7 IF X>FLD
DO ERRDATE
QUIT
+8 QUIT
+9 ;
ERRDATE ; Set DTXFLAG=0 and add FLDNM to the LIST of fields it must be before
+1 SET DTXFLAG=0
SET C=C+1
+2 IF MULT="SCT"
SET SBCT(C)=FLDNM_U_FLD_U_SBCT
QUIT
+3 IF MULT="SR"
SET SUBR(C)=FLDNM_U_FLD_U_SUBR
QUIT
+4 IF MULT="RDT"
SET RADT(C)=FLDNM_U_FLD_U_RADT
QUIT
+5 SET LIST(C)=FLDNM_U_FLD
+6 QUIT
+7 ;
DT ; CHANGE INTERNAL DATE TO EXTERNAL DATE FORMAT
+1 SET EXDT=$EXTRACT(INDT,4,5)_"/"_$EXTRACT(INDT,6,7)_"/"_($EXTRACT(INDT,1,3)+1700)
+2 QUIT
