- 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 Jan 18, 2025@03:25:48 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