ONCOCOM ;HINES OIFO/GWB - 'COMPUTED-FIELD' expressions ;03/01/11
;;2.2;ONCOLOGY;**1,4,10,14,15**;Jul 31, 2013;Build 5
;
CC ;'COMPUTED-FIELD' EXPRESSION for CLASS CATEGORY (160,69)
N CC,PRI
S CC=0
S PRI=0 F S PRI=$O(^ONCO(165.5,"C",D0,PRI)) Q:PRI'>0 D Q:CC=1
.S CC=$$GET1^DIQ(165.5,PRI,.042,"I")
S X=CC
Q
;
ARF ;'COMPUTED-FIELD' EXPRESSION for ANALYTIC REQUIRING FOLLOWUP (160,69.1)
N CC,CCPTR,PRI
S CC=0
S PRI=0 F S PRI=$O(^ONCO(165.5,"C",D0,PRI)) Q:PRI'>0 D Q:CC=1
.S CCPTR=$P($G(^ONCO(165.5,PRI,0)),"^",4) Q:CCPTR=""
.I CCPTR>1,CCPTR<10 S CC=1
S X=CC
Q
ARFPRI ;'COMPUTED-FIELD' EXPRESSION for ANALYTIC PRMRY REQ FOLLOWUP (165.5,.043)
N CC,CCPTR,PRI
S CC=0
S CCPTR=$P($G(^ONCO(165.5,D0,0)),U,4) I CCPTR>1,CCPTR<10 S CC=1
S X=CC
Q
;
SDA ;List all primaries for a patient
S XD0=$P(^ONCO(165.5,D0,0),U,2) G CX
;
SDP ;List all primaries except current primary
S XD0=$P(^ONCO(165.5,D0,0),U,2) G:XD0="" EX
N J S J=0
F XD1=0:0 S XD1=$O(^ONCO(165.5,"C",XD0,XD1)) Q:XD1'>0 I $$DIV^ONCFUNC(XD1)=DUZ(2),$D(^ONCO(165.5,XD1,0)),XD1'=D0 S J=J+1 D ^ONCOCOML
G:J>0 EX W ?24,"None" G EX
;
SDD ;List all primaries for a patient
Q:'$D(^ONCO(160,D0)) S XD0=D0
CX ;Entry point with XD0 defined, not D0
N J,XD1 W !
S J=0,XD1=0 F S XD1=$O(^ONCO(165.5,"C",XD0,XD1)) Q:XD1'>0 I $D(^ONCO(165.5,XD1,0)),$$DIV^ONCFUNC(XD1)=DUZ(2) S J=J+1 D ^ONCOCOML
Q
;
CLS ;Class of Case (ANALYTIC/NON-ANALYTIC)
;Computed field (165.5, .042) CASE-CLASS
S XD0=D0,X=$S($D(^ONCO(165.5,XD0,0)):$P(^(0),U,4),1:""),X=$S(X="":"",X<23:"Analytic",1:"Non-Analytic")
K XD0 Q
;
CLS2 ;Class of Case (CLASS OF CASE 10 THRU 22) Navigate from 160 to 165.5
;Computed field (165.5, )
F XD0=0:0 S XD0=$O(^ONCO(165.5,"C",D0,XD0)) Q:XD0'>0 D
.S X=$S($D(^ONCO(165.5,XD0,0)):$P(^(0),U,4),1:""),X=$S(X="":"",((X<2)!(X>9)):"NO! Not 10 thru 22",1:"YES! In the 10 - 22 range")
K XD0 Q
;
DFC ;'COMPUTED-FIELD' EXPRESSION for FIRST COURSE OF TREATMENT DATE (165.5,49)
I '$D(^ONCO(165.5,"ATX",D0)) S X="" Q
S TDT=0 F S TDT=$O(^ONCO(165.5,"ATX",D0,TDT)) Q:TDT="" Q:($E(TDT,1,7)'="0000000")&($E(TDT,1,7)'=9999999)&($E(TDT,1,7)'=8888888)&($E(TDT,8,9)'="S2")&($E(TDT,8,9)'="S3")
I TDT="" S TDT=0 F S TDT=$O(^ONCO(165.5,"ATX",D0,TDT)) Q:TDT="" Q:$E(TDT,1,7)=9999999
I TDT="" S TDT=0 F S TDT=$O(^ONCO(165.5,"ATX",D0,TDT)) Q:TDT="" Q:$E(TDT,1,7)="0000000"
I TDT="" S TDT="9999999X"
S X=$E(TDT,1,7)
D DATEOT^ONCOES
K TDT Q
;
DRXS ;'COMPUTED-FIELD' EXPRESSION for DATE INITIAL RX SEER (165.5,49.9)
I '$D(^ONCO(165.5,"ATX",D0)) S X="" Q
S TDT=0 F S TDT=$O(^ONCO(165.5,"ATX",D0,TDT)) Q:TDT="" Q:($E(TDT,1,7)'="0000000")&($E(TDT,1,7)'=9999999)&($E(TDT,1,7)'=8888888)&($E(TDT,8,9)'="S2")&($E(TDT,8,9)'="S3")&($E(TDT,8)'="N")
I TDT="" S TDT=0 F S TDT=$O(^ONCO(165.5,"ATX",D0,TDT)) Q:TDT="" Q:$E(TDT,1,7)=9999999
I TDT="" S TDT=0 F S TDT=$O(^ONCO(165.5,"ATX",D0,TDT)) Q:TDT="" Q:$E(TDT,1,7)="0000000"
I TDT="" S TDT="9999999X"
S X=$E(TDT,1,7)
D DATEOT^ONCOES
K TDT Q
;
DDX ;COMPUTED-FIELD FOR DATE-DATE DX (165.5,49.1)
N ONCTDT,ONCDTDX,X1,X2
S (X,ONCDTDX)=""
I '$D(^ONCO(165.5,"ATX",D0)) Q
S ONCTDT=0
F S ONCTDT=$O(^ONCO(165.5,"ATX",D0,ONCTDT)) Q:ONCTDT="" Q:($E(ONCTDT,1,7)'="0000000")&($E(ONCTDT,1,7)'=9999999)&($E(ONCTDT,1,7)'=8888888)&($E(ONCTDT,8,9)'="S2")&($E(ONCTDT,8,9)'="S3")
I ONCTDT="" S ONCTDT=0 F S ONCTDT=$O(^ONCO(165.5,"ATX",D0,ONCTDT)) Q:ONCTDT="" Q:$E(ONCTDT,1,7)=9999999
I ONCTDT="" S ONCTDT=0 F S ONCTDT=$O(^ONCO(165.5,"ATX",D0,ONCTDT)) Q:ONCTDT="" Q:$E(ONCTDT,1,7)="0000000"
S ONCTDT=$E(ONCTDT,1,7)
S ONCDTDX=$$GET1^DIQ(165.5,D0,3,"I")
S X1=ONCTDT,X2=ONCDTDX D ^%DTC
Q
;
DSTS ;DATE SYSTEMIC TREATMENT STARTED (165.5,152)
S DSTS=""
K DSTSDT
S X=$$GET1^DIQ(165.5,D0,53,"I") I X'="" S DSTSDT(X)=""
S X=$$GET1^DIQ(165.5,D0,54,"I") I X'="" S DSTSDT(X)=""
S X=$$GET1^DIQ(165.5,D0,55,"I") I X'="" S DSTSDT(X)=""
S X=$$GET1^DIQ(165.5,D0,153.1,"I") I X'="" S DSTSDT(X)=""
S DSTS=0 F S DSTS=$O(DSTSDT(DSTS)) Q:DSTS="" Q:($E(DSTS,1,7)'="0000000")&($E(DSTS,1,7)'=9999999)
I DSTS="" S DSTS=0 F S DSTS=$O(DSTSDT(DSTS)) Q:DSTS="" Q:$E(DSTS,1,7)=9999999
I DSTS="" S DSTS=0 F S DSTS=$O(DSTSDT(DSTS)) Q:DSTS="" Q:$E(DSTS,1,7)="0000000"
S X=DSTS
D DATEOT^ONCOES
K DSTS,DSTSDT
Q
;
DD ;Y=date in FM format (2yrmoda); convert to da/mo/yr
S Y=$S(Y="":"",1:$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_(1700+$E(Y,1,3))) ;_$S(Y#1:" "_$E(Y_0,9,10)_":"_$E(Y_"0000",11,12),1:"")
Q
;
AGE ;AGE AT DIAGNOSIS
S DOD=$P(^ONCO(165.5,D0,0),U,16)
I DOD="" S AGE="" G AGEOUT
I ($E(DOD,1,3)="000")!($E(DOD,1,3)=888)!($E(DOD,1,3)=999) S AGE=999 G AGEOUT
S XD0=D0,D0=$P(^ONCO(165.5,XD0,0),U,2) D DOB1^ONCOES S DOB=X,D0=XD0
I DOB="" S AGE="" G AGEOUT
S AGE=$E(DOD,1,3)-$E(DOB,1,3)-($E(DOD,4,7)<$E(DOB,4,7))
;
AGEOUT S X=AGE K DOD,XD0,DOB,AGE
Q
;
DEC ;AGE DX DECADE
D AGE Q:X="" S AG=X,X=$S(AG<20:"0-20",AG<30:"20-29",AG<40:"30-39",AG<50:"40-49",AG<60:"50-59",AG<70:"60-69",AG<80:"70-79",1:"80-99")
K AG Q
XD0 S XD0=$S($D(^ONCO(165.5,D0,0)):$P(^(0),U,2),1:"") ;XD0=internal 160
Q
;
PID ;PATIENT NAME,SSN,DOB
S X="" D PAT G EX:OD0="" S ONCONM=$P(VP0,U),SN=$P(VP0,U,9),XD=$P(VP0,U,3),ONCOPID=$E(ONCONM)_$E(SN,6,9)
Q
SID ;PID# (A1234)
PID5 S XD0=$P(^ONCO(165.5,D0,0),U,2) D PAT,PID S X=$E(ONCONM)_$E(SN,6,9) G EX
;
PID0 S XD0=D0 D PAT,PID S X=$E(ONCONM)_$E(SN,6,9) G EX
;
MS ;Derive MARITAL STATUS AT DX (165.5,11) from MARITAL STATUS (2,.05)
S XD0=$P(^ONCO(165.5,D0,0),U,2) G:XD0="" EX
D PAT G:OD0="" EX
S MS=$P(VP0,U,5) G:MS="" ADX
S MC=+MS
S X1=$S(MC=3:1,MC=6:1,MC=2:2,MC=5:3,MC=1:4,MC=4:5,1:9)
S $P(^ONCO(165.5,D0,1),U,5)=X1
;
ADX ;Derive PATIENT ADDRESS AT DX (165.5,8) from STREET ADDRESS 1 (2,.111)
;Derive PATIENT ADDRESS AT DX (165.5,8) from STREET ADDRESS [LINE 1]
;(2,.111) and STREET ADDRESS [LINE 2] (2,.112)
;Derive PATIENT ADDRESS AT DX - SUPP (165.5,8.2) from STREET ADDRESS
;[LINE 3] (2,.113)
;Derive CITY/TOWN AT DX (165.5,8.1) from CITY (2,.114)
;Derive STATE AT DX (165.5,16) from STATE (2,.115)
;Derive POSTAL CODE AT DX (165.5,9) from ZIP CODE (2,.116)
;Derive COUNTY AT DX (165.5,10) from STATE (2,.116)_COUNTY (2,.117)
S X11=$G(@(GLR_".11)"))
S ADX=$P(X11,U,1)
S:$P(X11,U,2)'="" ADX=ADX_" "_$P(X11,U,2)
S ADXSUPP=$P(X11,U,3)
S $P(^ONCO(165.5,D0,1),U,1)=ADX
S $P(^ONCO(165.5,D0,1),U,13)=ADXSUPP
S CITY=$P(X11,U,4)
S STATE=$P(X11,U,5)
S ZIP=$P(X11,U,6)
S COUNTYPNT=$P(X11,U,7)
S COUNTY=""
I STATE'="",COUNTYPNT'="" S COUNTY=$P(^DIC(5,STATE,1,COUNTYPNT,0),U,3)
S:CITY'="" $P(^ONCO(165.5,D0,1),U,12)=CITY
S:STATE'="" $P(^ONCO(165.5,D0,1),U,4)=STATE
S:ZIP'="" $P(^ONCO(165.5,D0,1),U,2)=ZIP
S:(STATE'="")&(COUNTY'="") $P(^ONCO(165.5,D0,1),U,3)=STATE_COUNTY
K ADX,ADXSUPP,CITY,COUNTY,COUNTYPNT,GLR,MS,OD0,OF,STATE,VP0,VPR,X1,X11
K XD0,ZIP
Q
;
PAT ;Patient pointer
S OD0=$S($D(^ONCO(160,XD0,0)):$P(^(0),U),1:"") Q:OD0=""
S OF=$P(OD0,";",2)
S OD0=$P(OD0,";",1)
S GLR=U_OF_OD0_","
S VPR=U_OF_OD0_",0)"
S VP0=$S($D(@VPR):^(0),1:"")
Q
;
ONCPRI ;ICD0-TOPOGRAPHY LIST (160,49)
S XD0=0
F S XD0=$O(^ONCO(165.5,"C",D0,XD0)) Q:XD0'>0 I $$DIV^ONCFUNC(XD0)=DUZ(2) D
.Q:'$D(^ONCO(165.5,XD0,2))
.S TOPIEN=$P(^ONCO(165.5,XD0,2),U,1)
.Q:TOPIEN=""
.S TOPNAME=$P(^ONCO(164,TOPIEN,0),U,1)
.S TOPCODE=$P(^ONCO(164,TOPIEN,0),U,2)
.S TOP(TOPCODE)=TOPNAME
I $D(TOP) S TOPCODE="" W ! F S TOPCODE=$O(TOP(TOPCODE)) Q:TOPCODE="" W ?5,TOP(TOPCODE),!
S X="" K XD0,TOPIEN,TOP,TOPCODE Q
ACOS ;'COMPUTED-FIELD' EXPRESSION for ACOS # (165.5,67)
S OSP=$O(^ONCO(160.1,"C",DUZ(2),0))
I OSP="" S OSP=$O(^ONCO(160.1,0))
S ACOS=$P(^ONCO(160.1,OSP,0),U,4)
S ACOS=$$GET1^DIQ(160.19,ACOS,.01,"I")
S X=ACOS K OSP,ACOS
Q
;
HM ;'COMPUTED-FIELD' EXPRESSION for HISTO-MORPHOLOGY (165.5,27)
N MO,GRADE
S X=""
S MO=$$GET1^DIQ(165.5,D0,22.3,"I")
I MO'="" D
.S GRADE=$$GET1^DIQ(165.5,D0,24,"I")
.S X=$E(MO,1,4)_"/"_$E(MO,5)_GRADE
Q
;
ET ;'COMPUTED-FIELD' EXPRESSION for ELAPSED DAYS TO COMPLETION (165.5,157)
N AS,DATE1,DATE2
S AS=$P($G(^ONCO(165.5,D0,7)),U,2)
I AS="A" S X="NA (Accession only)" Q
S DATE1=$P($G(^ONCO(165.5,D0,7)),U,1)
S DATE2=$P($G(^ONCO(165.5,D0,0)),U,35)
I (DATE2="")!(DATE2="0000000")!(DATE2=9999999) S X="Unknown (No Date of First Contact)" Q
I (DATE1="")!(DATE1="0000000")!(DATE1=9999999)!(DATE1=8888888) S X="Unknown (No Date Case Completed)" Q
I DATE1<DATE2 S X="Unknown (Dt 1st Cont > Dt Case Complt)" Q
S X1=DATE1
S X2=DATE2
D ^%DTC
I %Y=0 S X="Unknown (Dates imprecise)" Q
Q
;
EM ;'COMPUTED-FIELD' EXPRESSION for ELAPSED MONTHS TO COMPLETION (165.5,157.1)
N AS,DATE1,DATE2,DAYS,MONTHS,MONTHYEAR,YEARS
S AS=$P($G(^ONCO(165.5,D0,7)),U,2)
I AS="A" S X="NA (Accession only)" Q
S DATE1=$P($G(^ONCO(165.5,D0,7)),U,1)
S:DATE1'="" DATE1=$E(DATE1,1,5)_"00"
S DATE2=$P($G(^ONCO(165.5,D0,0)),U,35)
S:DATE2'="" DATE2=$E(DATE2,1,5)_"00"
I (DATE2="")!(DATE2="0000000")!(DATE2=9999999) S X="Unknown (No Date of First Contact)" Q
I $E(DATE2,4,7)="0000" S X="Unknown (Date of First Contact has no month)" Q
I (DATE1="")!(DATE1="0000000")!(DATE1=9999999)!(DATE1=8888888) S X="Unknown (No Date Case Completed)" Q
I DATE1<DATE2 S X="Unknown (Dt 1st Cont > Dt Case Complt)" Q
D DTDIFF^ONCDTUTL(DATE1,DATE2,.DAYS,.MONTHS,.YEARS)
S MONTHYEAR=YEARS*12
S X=MONTHS+MONTHYEAR
S XX=YEARS_$S(YEARS=1:" Year/",1:" Years/")_MONTHS_$S(MONTHS=1:" Month/",1:" Months/")_DAYS_$S(DAYS=1:" Day",1:" Days")
Q
;
DCD ;INPUT TRANSFORM for DATE OF CONCLUSIVE DX (165.5,193)
N DCDX,X1,X2,%Y
S DCDX=X
S X2=$P($G(^ONCO(165.5,D0,0)),U,16)
S X1=X
I (X2="")!(X2="0000000")!(X2=8888888)!(X2=9999999) Q
I X2>X1 W !!,"DATE DX after DATE OF CONCLUSIVE DX",! K X Q
D ^%DTC
I %Y=0 G DCDEX
I X<61 W !!," DATE OF CONCLUSIVE DX must be greater than 60 days after DATE DX",! K X Q
DCDEX S X=DCDX
Q
;
TNMCA ;
; code for Computed Field TNM COMPLETED PERCENTAGE (#165.5,#158)
Q
EX ;Exit
K OD0,X1,X2,XD0,XD1,VP0,Y
Q
;
CLEANUP ;Cleanup
K D0,MC,ONCONM,ONCOPID,SN,TOPNAME,XD,XX
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HONCOCOM 10099 printed Oct 16, 2024@18:25:18 Page 2
ONCOCOM ;HINES OIFO/GWB - 'COMPUTED-FIELD' expressions ;03/01/11
+1 ;;2.2;ONCOLOGY;**1,4,10,14,15**;Jul 31, 2013;Build 5
+2 ;
CC ;'COMPUTED-FIELD' EXPRESSION for CLASS CATEGORY (160,69)
+1 NEW CC,PRI
+2 SET CC=0
+3 SET PRI=0
FOR
SET PRI=$ORDER(^ONCO(165.5,"C",D0,PRI))
if PRI'>0
QUIT
Begin DoDot:1
+4 SET CC=$$GET1^DIQ(165.5,PRI,.042,"I")
End DoDot:1
if CC=1
QUIT
+5 SET X=CC
+6 QUIT
+7 ;
ARF ;'COMPUTED-FIELD' EXPRESSION for ANALYTIC REQUIRING FOLLOWUP (160,69.1)
+1 NEW CC,CCPTR,PRI
+2 SET CC=0
+3 SET PRI=0
FOR
SET PRI=$ORDER(^ONCO(165.5,"C",D0,PRI))
if PRI'>0
QUIT
Begin DoDot:1
+4 SET CCPTR=$PIECE($GET(^ONCO(165.5,PRI,0)),"^",4)
if CCPTR=""
QUIT
+5 IF CCPTR>1
IF CCPTR<10
SET CC=1
End DoDot:1
if CC=1
QUIT
+6 SET X=CC
+7 QUIT
ARFPRI ;'COMPUTED-FIELD' EXPRESSION for ANALYTIC PRMRY REQ FOLLOWUP (165.5,.043)
+1 NEW CC,CCPTR,PRI
+2 SET CC=0
+3 SET CCPTR=$PIECE($GET(^ONCO(165.5,D0,0)),U,4)
IF CCPTR>1
IF CCPTR<10
SET CC=1
+4 SET X=CC
+5 QUIT
+6 ;
SDA ;List all primaries for a patient
+1 SET XD0=$PIECE(^ONCO(165.5,D0,0),U,2)
GOTO CX
+2 ;
SDP ;List all primaries except current primary
+1 SET XD0=$PIECE(^ONCO(165.5,D0,0),U,2)
if XD0=""
GOTO EX
+2 NEW J
SET J=0
+3 FOR XD1=0:0
SET XD1=$ORDER(^ONCO(165.5,"C",XD0,XD1))
if XD1'>0
QUIT
IF $$DIV^ONCFUNC(XD1)=DUZ(2)
IF $DATA(^ONCO(165.5,XD1,0))
IF XD1'=D0
SET J=J+1
DO ^ONCOCOML
+4 if J>0
GOTO EX
WRITE ?24,"None"
GOTO EX
+5 ;
SDD ;List all primaries for a patient
+1 if '$DATA(^ONCO(160,D0))
QUIT
SET XD0=D0
CX ;Entry point with XD0 defined, not D0
+1 NEW J,XD1
WRITE !
+2 SET J=0
SET XD1=0
FOR
SET XD1=$ORDER(^ONCO(165.5,"C",XD0,XD1))
if XD1'>0
QUIT
IF $DATA(^ONCO(165.5,XD1,0))
IF $$DIV^ONCFUNC(XD1)=DUZ(2)
SET J=J+1
DO ^ONCOCOML
+3 QUIT
+4 ;
CLS ;Class of Case (ANALYTIC/NON-ANALYTIC)
+1 ;Computed field (165.5, .042) CASE-CLASS
+2 SET XD0=D0
SET X=$SELECT($DATA(^ONCO(165.5,XD0,0)):$PIECE(^(0),U,4),1:"")
SET X=$SELECT(X="":"",X<23:"Analytic",1:"Non-Analytic")
+3 KILL XD0
QUIT
+4 ;
CLS2 ;Class of Case (CLASS OF CASE 10 THRU 22) Navigate from 160 to 165.5
+1 ;Computed field (165.5, )
+2 FOR XD0=0:0
SET XD0=$ORDER(^ONCO(165.5,"C",D0,XD0))
if XD0'>0
QUIT
Begin DoDot:1
+3 SET X=$SELECT($DATA(^ONCO(165.5,XD0,0)):$PIECE(^(0),U,4),1:"")
SET X=$SELECT(X="":"",((X<2)!(X>9)):"NO! Not 10 thru 22",1:"YES! In the 10 - 22 range")
End DoDot:1
+4 KILL XD0
QUIT
+5 ;
DFC ;'COMPUTED-FIELD' EXPRESSION for FIRST COURSE OF TREATMENT DATE (165.5,49)
+1 IF '$DATA(^ONCO(165.5,"ATX",D0))
SET X=""
QUIT
+2 SET TDT=0
FOR
SET TDT=$ORDER(^ONCO(165.5,"ATX",D0,TDT))
if TDT=""
QUIT
if ($EXTRACT(TDT,1,7)'="0000000")&($EXTRACT(TDT,1,7)'=9999999)&($EXTRACT(TDT,1,7)'=8888888)&($EXTRACT(TDT,8,9)'="S2")&($EXTRACT(TDT,8,9)'="S3")
QUIT
+3 IF TDT=""
SET TDT=0
FOR
SET TDT=$ORDER(^ONCO(165.5,"ATX",D0,TDT))
if TDT=""
QUIT
if $EXTRACT(TDT,1,7)=9999999
QUIT
+4 IF TDT=""
SET TDT=0
FOR
SET TDT=$ORDER(^ONCO(165.5,"ATX",D0,TDT))
if TDT=""
QUIT
if $EXTRACT(TDT,1,7)="0000000"
QUIT
+5 IF TDT=""
SET TDT="9999999X"
+6 SET X=$EXTRACT(TDT,1,7)
+7 DO DATEOT^ONCOES
+8 KILL TDT
QUIT
+9 ;
DRXS ;'COMPUTED-FIELD' EXPRESSION for DATE INITIAL RX SEER (165.5,49.9)
+1 IF '$DATA(^ONCO(165.5,"ATX",D0))
SET X=""
QUIT
+2 SET TDT=0
FOR
SET TDT=$ORDER(^ONCO(165.5,"ATX",D0,TDT))
if TDT=""
QUIT
if ($EXTRACT(TDT,1,7)'="0000000")&($EXTRACT(TDT,1,7)'=9999999)&($EXTRACT(TDT,1,7)'=8888888)&($EXTRACT(TDT,8,9)'="S2")&($EXTRACT(TDT,8,9)'="S3")&($EXTRACT(TDT,8)'="N")
QUIT
+3 IF TDT=""
SET TDT=0
FOR
SET TDT=$ORDER(^ONCO(165.5,"ATX",D0,TDT))
if TDT=""
QUIT
if $EXTRACT(TDT,1,7)=9999999
QUIT
+4 IF TDT=""
SET TDT=0
FOR
SET TDT=$ORDER(^ONCO(165.5,"ATX",D0,TDT))
if TDT=""
QUIT
if $EXTRACT(TDT,1,7)="0000000"
QUIT
+5 IF TDT=""
SET TDT="9999999X"
+6 SET X=$EXTRACT(TDT,1,7)
+7 DO DATEOT^ONCOES
+8 KILL TDT
QUIT
+9 ;
DDX ;COMPUTED-FIELD FOR DATE-DATE DX (165.5,49.1)
+1 NEW ONCTDT,ONCDTDX,X1,X2
+2 SET (X,ONCDTDX)=""
+3 IF '$DATA(^ONCO(165.5,"ATX",D0))
QUIT
+4 SET ONCTDT=0
+5 FOR
SET ONCTDT=$ORDER(^ONCO(165.5,"ATX",D0,ONCTDT))
if ONCTDT=""
QUIT
if ($EXTRACT(ONCTDT,1,7)'="0000000")&($EXTRACT(ONCTDT,1,7)'=9999999)&($EXTRACT(ONCTDT,1,7)'=8888888)&($EXTRACT(ONCTDT,8,9)'="S2")&($EXTRACT(ONCTDT,8,9)'="S3")
QUIT
+6 IF ONCTDT=""
SET ONCTDT=0
FOR
SET ONCTDT=$ORDER(^ONCO(165.5,"ATX",D0,ONCTDT))
if ONCTDT=""
QUIT
if $EXTRACT(ONCTDT,1,7)=9999999
QUIT
+7 IF ONCTDT=""
SET ONCTDT=0
FOR
SET ONCTDT=$ORDER(^ONCO(165.5,"ATX",D0,ONCTDT))
if ONCTDT=""
QUIT
if $EXTRACT(ONCTDT,1,7)="0000000"
QUIT
+8 SET ONCTDT=$EXTRACT(ONCTDT,1,7)
+9 SET ONCDTDX=$$GET1^DIQ(165.5,D0,3,"I")
+10 SET X1=ONCTDT
SET X2=ONCDTDX
DO ^%DTC
+11 QUIT
+12 ;
DSTS ;DATE SYSTEMIC TREATMENT STARTED (165.5,152)
+1 SET DSTS=""
+2 KILL DSTSDT
+3 SET X=$$GET1^DIQ(165.5,D0,53,"I")
IF X'=""
SET DSTSDT(X)=""
+4 SET X=$$GET1^DIQ(165.5,D0,54,"I")
IF X'=""
SET DSTSDT(X)=""
+5 SET X=$$GET1^DIQ(165.5,D0,55,"I")
IF X'=""
SET DSTSDT(X)=""
+6 SET X=$$GET1^DIQ(165.5,D0,153.1,"I")
IF X'=""
SET DSTSDT(X)=""
+7 SET DSTS=0
FOR
SET DSTS=$ORDER(DSTSDT(DSTS))
if DSTS=""
QUIT
if ($EXTRACT(DSTS,1,7)'="0000000")&($EXTRACT(DSTS,1,7)'=9999999)
QUIT
+8 IF DSTS=""
SET DSTS=0
FOR
SET DSTS=$ORDER(DSTSDT(DSTS))
if DSTS=""
QUIT
if $EXTRACT(DSTS,1,7)=9999999
QUIT
+9 IF DSTS=""
SET DSTS=0
FOR
SET DSTS=$ORDER(DSTSDT(DSTS))
if DSTS=""
QUIT
if $EXTRACT(DSTS,1,7)="0000000"
QUIT
+10 SET X=DSTS
+11 DO DATEOT^ONCOES
+12 KILL DSTS,DSTSDT
+13 QUIT
+14 ;
DD ;Y=date in FM format (2yrmoda); convert to da/mo/yr
+1 ;_$S(Y#1:" "_$E(Y_0,9,10)_":"_$E(Y_"0000",11,12),1:"")
SET Y=$SELECT(Y="":"",1:$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_(1700+$EXTRACT(Y,1,3)))
+2 QUIT
+3 ;
AGE ;AGE AT DIAGNOSIS
+1 SET DOD=$PIECE(^ONCO(165.5,D0,0),U,16)
+2 IF DOD=""
SET AGE=""
GOTO AGEOUT
+3 IF ($EXTRACT(DOD,1,3)="000")!($EXTRACT(DOD,1,3)=888)!($EXTRACT(DOD,1,3)=999)
SET AGE=999
GOTO AGEOUT
+4 SET XD0=D0
SET D0=$PIECE(^ONCO(165.5,XD0,0),U,2)
DO DOB1^ONCOES
SET DOB=X
SET D0=XD0
+5 IF DOB=""
SET AGE=""
GOTO AGEOUT
+6 SET AGE=$EXTRACT(DOD,1,3)-$EXTRACT(DOB,1,3)-($EXTRACT(DOD,4,7)<$EXTRACT(DOB,4,7))
+7 ;
AGEOUT SET X=AGE
KILL DOD,XD0,DOB,AGE
+1 QUIT
+2 ;
DEC ;AGE DX DECADE
+1 DO AGE
if X=""
QUIT
SET AG=X
SET X=$SELECT(AG<20:"0-20",AG<30:"20-29",AG<40:"30-39",AG<50:"40-49",AG<60:"50-59",AG<70:"60-69",AG<80:"70-79",1:"80-99")
+2 KILL AG
QUIT
XD0 ;XD0=internal 160
SET XD0=$SELECT($DATA(^ONCO(165.5,D0,0)):$PIECE(^(0),U,2),1:"")
+1 QUIT
+2 ;
PID ;PATIENT NAME,SSN,DOB
+1 SET X=""
DO PAT
if OD0=""
GOTO EX
SET ONCONM=$PIECE(VP0,U)
SET SN=$PIECE(VP0,U,9)
SET XD=$PIECE(VP0,U,3)
SET ONCOPID=$EXTRACT(ONCONM)_$EXTRACT(SN,6,9)
+2 QUIT
SID ;PID# (A1234)
PID5 SET XD0=$PIECE(^ONCO(165.5,D0,0),U,2)
DO PAT
DO PID
SET X=$EXTRACT(ONCONM)_$EXTRACT(SN,6,9)
GOTO EX
+1 ;
PID0 SET XD0=D0
DO PAT
DO PID
SET X=$EXTRACT(ONCONM)_$EXTRACT(SN,6,9)
GOTO EX
+1 ;
MS ;Derive MARITAL STATUS AT DX (165.5,11) from MARITAL STATUS (2,.05)
+1 SET XD0=$PIECE(^ONCO(165.5,D0,0),U,2)
if XD0=""
GOTO EX
+2 DO PAT
if OD0=""
GOTO EX
+3 SET MS=$PIECE(VP0,U,5)
if MS=""
GOTO ADX
+4 SET MC=+MS
+5 SET X1=$SELECT(MC=3:1,MC=6:1,MC=2:2,MC=5:3,MC=1:4,MC=4:5,1:9)
+6 SET $PIECE(^ONCO(165.5,D0,1),U,5)=X1
+7 ;
ADX ;Derive PATIENT ADDRESS AT DX (165.5,8) from STREET ADDRESS 1 (2,.111)
+1 ;Derive PATIENT ADDRESS AT DX (165.5,8) from STREET ADDRESS [LINE 1]
+2 ;(2,.111) and STREET ADDRESS [LINE 2] (2,.112)
+3 ;Derive PATIENT ADDRESS AT DX - SUPP (165.5,8.2) from STREET ADDRESS
+4 ;[LINE 3] (2,.113)
+5 ;Derive CITY/TOWN AT DX (165.5,8.1) from CITY (2,.114)
+6 ;Derive STATE AT DX (165.5,16) from STATE (2,.115)
+7 ;Derive POSTAL CODE AT DX (165.5,9) from ZIP CODE (2,.116)
+8 ;Derive COUNTY AT DX (165.5,10) from STATE (2,.116)_COUNTY (2,.117)
+9 SET X11=$GET(@(GLR_".11)"))
+10 SET ADX=$PIECE(X11,U,1)
+11 if $PIECE(X11,U,2)'=""
SET ADX=ADX_" "_$PIECE(X11,U,2)
+12 SET ADXSUPP=$PIECE(X11,U,3)
+13 SET $PIECE(^ONCO(165.5,D0,1),U,1)=ADX
+14 SET $PIECE(^ONCO(165.5,D0,1),U,13)=ADXSUPP
+15 SET CITY=$PIECE(X11,U,4)
+16 SET STATE=$PIECE(X11,U,5)
+17 SET ZIP=$PIECE(X11,U,6)
+18 SET COUNTYPNT=$PIECE(X11,U,7)
+19 SET COUNTY=""
+20 IF STATE'=""
IF COUNTYPNT'=""
SET COUNTY=$PIECE(^DIC(5,STATE,1,COUNTYPNT,0),U,3)
+21 if CITY'=""
SET $PIECE(^ONCO(165.5,D0,1),U,12)=CITY
+22 if STATE'=""
SET $PIECE(^ONCO(165.5,D0,1),U,4)=STATE
+23 if ZIP'=""
SET $PIECE(^ONCO(165.5,D0,1),U,2)=ZIP
+24 if (STATE'="")&(COUNTY'="")
SET $PIECE(^ONCO(165.5,D0,1),U,3)=STATE_COUNTY
+25 KILL ADX,ADXSUPP,CITY,COUNTY,COUNTYPNT,GLR,MS,OD0,OF,STATE,VP0,VPR,X1,X11
+26 KILL XD0,ZIP
+27 QUIT
+28 ;
PAT ;Patient pointer
+1 SET OD0=$SELECT($DATA(^ONCO(160,XD0,0)):$PIECE(^(0),U),1:"")
if OD0=""
QUIT
+2 SET OF=$PIECE(OD0,";",2)
+3 SET OD0=$PIECE(OD0,";",1)
+4 SET GLR=U_OF_OD0_","
+5 SET VPR=U_OF_OD0_",0)"
+6 SET VP0=$SELECT($DATA(@VPR):^(0),1:"")
+7 QUIT
+8 ;
ONCPRI ;ICD0-TOPOGRAPHY LIST (160,49)
+1 SET XD0=0
+2 FOR
SET XD0=$ORDER(^ONCO(165.5,"C",D0,XD0))
if XD0'>0
QUIT
IF $$DIV^ONCFUNC(XD0)=DUZ(2)
Begin DoDot:1
+3 if '$DATA(^ONCO(165.5,XD0,2))
QUIT
+4 SET TOPIEN=$PIECE(^ONCO(165.5,XD0,2),U,1)
+5 if TOPIEN=""
QUIT
+6 SET TOPNAME=$PIECE(^ONCO(164,TOPIEN,0),U,1)
+7 SET TOPCODE=$PIECE(^ONCO(164,TOPIEN,0),U,2)
+8 SET TOP(TOPCODE)=TOPNAME
End DoDot:1
+9 IF $DATA(TOP)
SET TOPCODE=""
WRITE !
FOR
SET TOPCODE=$ORDER(TOP(TOPCODE))
if TOPCODE=""
QUIT
WRITE ?5,TOP(TOPCODE),!
+10 SET X=""
KILL XD0,TOPIEN,TOP,TOPCODE
QUIT
ACOS ;'COMPUTED-FIELD' EXPRESSION for ACOS # (165.5,67)
+1 SET OSP=$ORDER(^ONCO(160.1,"C",DUZ(2),0))
+2 IF OSP=""
SET OSP=$ORDER(^ONCO(160.1,0))
+3 SET ACOS=$PIECE(^ONCO(160.1,OSP,0),U,4)
+4 SET ACOS=$$GET1^DIQ(160.19,ACOS,.01,"I")
+5 SET X=ACOS
KILL OSP,ACOS
+6 QUIT
+7 ;
HM ;'COMPUTED-FIELD' EXPRESSION for HISTO-MORPHOLOGY (165.5,27)
+1 NEW MO,GRADE
+2 SET X=""
+3 SET MO=$$GET1^DIQ(165.5,D0,22.3,"I")
+4 IF MO'=""
Begin DoDot:1
+5 SET GRADE=$$GET1^DIQ(165.5,D0,24,"I")
+6 SET X=$EXTRACT(MO,1,4)_"/"_$EXTRACT(MO,5)_GRADE
End DoDot:1
+7 QUIT
+8 ;
ET ;'COMPUTED-FIELD' EXPRESSION for ELAPSED DAYS TO COMPLETION (165.5,157)
+1 NEW AS,DATE1,DATE2
+2 SET AS=$PIECE($GET(^ONCO(165.5,D0,7)),U,2)
+3 IF AS="A"
SET X="NA (Accession only)"
QUIT
+4 SET DATE1=$PIECE($GET(^ONCO(165.5,D0,7)),U,1)
+5 SET DATE2=$PIECE($GET(^ONCO(165.5,D0,0)),U,35)
+6 IF (DATE2="")!(DATE2="0000000")!(DATE2=9999999)
SET X="Unknown (No Date of First Contact)"
QUIT
+7 IF (DATE1="")!(DATE1="0000000")!(DATE1=9999999)!(DATE1=8888888)
SET X="Unknown (No Date Case Completed)"
QUIT
+8 IF DATE1<DATE2
SET X="Unknown (Dt 1st Cont > Dt Case Complt)"
QUIT
+9 SET X1=DATE1
+10 SET X2=DATE2
+11 DO ^%DTC
+12 IF %Y=0
SET X="Unknown (Dates imprecise)"
QUIT
+13 QUIT
+14 ;
EM ;'COMPUTED-FIELD' EXPRESSION for ELAPSED MONTHS TO COMPLETION (165.5,157.1)
+1 NEW AS,DATE1,DATE2,DAYS,MONTHS,MONTHYEAR,YEARS
+2 SET AS=$PIECE($GET(^ONCO(165.5,D0,7)),U,2)
+3 IF AS="A"
SET X="NA (Accession only)"
QUIT
+4 SET DATE1=$PIECE($GET(^ONCO(165.5,D0,7)),U,1)
+5 if DATE1'=""
SET DATE1=$EXTRACT(DATE1,1,5)_"00"
+6 SET DATE2=$PIECE($GET(^ONCO(165.5,D0,0)),U,35)
+7 if DATE2'=""
SET DATE2=$EXTRACT(DATE2,1,5)_"00"
+8 IF (DATE2="")!(DATE2="0000000")!(DATE2=9999999)
SET X="Unknown (No Date of First Contact)"
QUIT
+9 IF $EXTRACT(DATE2,4,7)="0000"
SET X="Unknown (Date of First Contact has no month)"
QUIT
+10 IF (DATE1="")!(DATE1="0000000")!(DATE1=9999999)!(DATE1=8888888)
SET X="Unknown (No Date Case Completed)"
QUIT
+11 IF DATE1<DATE2
SET X="Unknown (Dt 1st Cont > Dt Case Complt)"
QUIT
+12 DO DTDIFF^ONCDTUTL(DATE1,DATE2,.DAYS,.MONTHS,.YEARS)
+13 SET MONTHYEAR=YEARS*12
+14 SET X=MONTHS+MONTHYEAR
+15 SET XX=YEARS_$SELECT(YEARS=1:" Year/",1:" Years/")_MONTHS_$SELECT(MONTHS=1:" Month/",1:" Months/")_DAYS_$SELECT(DAYS=1:" Day",1:" Days")
+16 QUIT
+17 ;
DCD ;INPUT TRANSFORM for DATE OF CONCLUSIVE DX (165.5,193)
+1 NEW DCDX,X1,X2,%Y
+2 SET DCDX=X
+3 SET X2=$PIECE($GET(^ONCO(165.5,D0,0)),U,16)
+4 SET X1=X
+5 IF (X2="")!(X2="0000000")!(X2=8888888)!(X2=9999999)
QUIT
+6 IF X2>X1
WRITE !!,"DATE DX after DATE OF CONCLUSIVE DX",!
KILL X
QUIT
+7 DO ^%DTC
+8 IF %Y=0
GOTO DCDEX
+9 IF X<61
WRITE !!," DATE OF CONCLUSIVE DX must be greater than 60 days after DATE DX",!
KILL X
QUIT
DCDEX SET X=DCDX
+1 QUIT
+2 ;
TNMCA ;
+1 ; code for Computed Field TNM COMPLETED PERCENTAGE (#165.5,#158)
+2 QUIT
EX ;Exit
+1 KILL OD0,X1,X2,XD0,XD1,VP0,Y
+2 QUIT
+3 ;
CLEANUP ;Cleanup
+1 KILL D0,MC,ONCONM,ONCOPID,SN,TOPNAME,XD,XX
