ONCFUNC ;HINES OIFO/GWB - OncoTrax functions ;05/03/12
;;2.2;ONCOLOGY;**1,7,13**;Jul 31, 2013;Build 7
;
;
SHN() ;STATE HOSPITAL NUMBER (160.1,1.03)
N OSP,SHN
S OSP=$O(^ONCO(160.1,"C",DUZ(2),0))
I OSP="" S OSP=$O(^ONCO(160.1,0))
S SHN=$$GET1^DIQ(160.1,OSP,1.03,"I")
Q SHN
;
STCO70(IEN) ;GEOLOCATION ID 1970/80/90
N ONCST,ONCCO,ONCCE,ONCCB,ONCDX
S ONCST="",ONCCO="",ONCCT="",ONCCB=""
S ONCST=$$GET1^DIQ(165.5,IEN,7000,"I")
S:ONCST'="" ONCST=$$GET1^DIQ(5,ONCST,2,"I")
S:ONCST="" ONCST=" "
S ONCDX=$$GET1^DIQ(165.5,IEN,3,"I")
S ONCCO=$S(ONCDX>3160000:$$CNTY^ONCACDU1(IEN),1:"")
S:ONCCO="" ONCCO=" "
S ONCCT=$$GET1^DIQ(165.5,IEN,147,"I")
S:ONCCT="" ONCCT=" "
S:ONCCB="" ONCCB=" "
S ACDANS=ONCST_ONCCO_ONCCT_ONCCB
Q ACDANS
;
STCO00(IEN) ;GEOLOCATION ID 2000
N ONCST,ONCCO,ONCCT,ONCCB,ONCDX
S ONCST="",ONCCO="",ONCCT="",ONCCB=""
S ONCST=$$GET1^DIQ(165.5,IEN,7023,"I")
S:ONCST'="" ONCST=$$GET1^DIQ(5,ONCST,2,"I")
S:ONCST="" ONCST=" "
S ONCDX=$$GET1^DIQ(165.5,IEN,3,"I")
S ONCCO=$S(ONCDX>3160000:$$CNTY^ONCACDU1(IEN),1:"")
S:ONCCO="" ONCCO=" "
S:ONCCT="" ONCCT=" "
S:ONCCB="" ONCCB=" "
S ACDANS=ONCST_ONCCO_ONCCT_ONCCB
Q ACDANS
;
STCO10(IEN) ;GEOLOCATION ID 2010
N ONCST,ONCCO,ONCCT,ONCCB,ONCDX
S ONCST="",ONCCO="",ONCCE="",ONCCB=""
S ONCST=$$GET1^DIQ(165.5,IEN,7001,"I")
S:ONCST'="" ONCST=$$GET1^DIQ(5,ONCST,2,"I")
S:ONCST="" ONCST=" "
S ONCDX=$$GET1^DIQ(165.5,IEN,3,"I")
S ONCCO=$S(ONCDX>3160000:$$CNTY^ONCACDU1(IEN),1:"")
S:ONCCO="" ONCCO=" "
S ONCCT=$$GET1^DIQ(165.5,IEN,147,"I")
S:ONCCT="" ONCCT=" "
S:ONCCB="" ONCCB=" "
S ACDANS=ONCST_ONCCO_ONCCT_ONCCB
Q ACDANS
;
STCO20(IEN) ;GEOLOCATION ID 2020
N ONCST,ONCCO,ONCCT,ONCCB,ONCDX
S ONCST="",ONCCO="",ONCCT="",ONCCB=""
S ONCST=$$GET1^DIQ(165.5,IEN,7001,"I")
S:ONCST'="" ONCST=$$GET1^DIQ(5,ONCST,2,"I")
S:ONCST="" ONCST=" "
S ONCDX=$$GET1^DIQ(165.5,IEN,3,"I")
S ONCCO=$S(ONCDX>3160000:$$CNTY^ONCACDU1(IEN),1:"")
S:ONCCO="" ONCCO=" "
S:ONCCT="" ONCCT=" "
S:ONCCB="" ONCCB=" "
S ACDANS=ONCST_ONCCO_ONCCT_ONCCB
Q ACDANS
;
IIN() ;INSTITUTION ID NUMBER (160.1,27)
N IIN,OSP
S OSP=$O(^ONCO(160.1,"C",DUZ(2),0))
I OSP="" S OSP=$O(^ONCO(160.1,0))
S IIN=$$GET1^DIQ(160.1,OSP,27,"I")
S IIN=$$GET1^DIQ(160.19,IIN,.01,"I")
Q IIN
;
FLNAME(NAME) ;COMPUTED EXPRESSION for FIRST-LAST (160,.012)
N DFN,FIRST,LAST,MIDDLE,PL,SUFFIX,TNAME
S TNAME=NAME,DFN=D0
S LAST=$P(TNAME,","),TNAME=$P(TNAME,",",2)
S FIRST=$P(TNAME," "),MIDDLE=$P(TNAME," ",2)
S SUFFIX=$P(TNAME," ",3)
I MIDDLE["""" S MIDDLE=""
S TNAME=FIRST_" "_MIDDLE_" "_LAST_" "_SUFFIX
SP I $F(TNAME," ") S PL=$F(TNAME," "),TNAME=$E(TNAME,1,PL-2)_$E(TNAME,PL,$L(TNAME)) G SP
Q TNAME
;
DIV(IEN) ;DIVISION (165.5,2000)
N DIV
S DIV=$G(^ONCO(165.5,IEN,"DIV"))
Q DIV
;
SUSDIV(IEN,SUSIEN) ;DIVISION (160,30)
N DIV
S DIV=$P($G(^ONCO(160,IEN,"SUS",SUSIEN,0)),U,4)
Q DIV
;
PFTD(IEN) ;Primaries for this division
N PFTD,PRI
S PFTD="N"
S PRI=0 F S PRI=$O(^ONCO(165.5,"C",IEN,PRI)) Q:PRI'>0 I $P($G(^ONCO(165.5,PRI,"DIV")),U,1)=DUZ(2) S PFTD="Y"
Q PFTD
;
PRICNT ;TOTAL PRIMARIES FOR PATIENT (160,17)
S PRI=0,PRICNT=0 F S PRI=$O(^ONCO(165.5,"C",D0,PRI)) Q:PRI'>0 I $P($G(^ONCO(165.5,PRI,"DIV")),U,1)=DUZ(2) D
.S PRICNT=PRICNT+1
S X=PRICNT
K PRI,PRICNT
Q
;
DIDIV(IEN) ;Disease Index DIVISION screen
;Supported by IAs #417 and #2028
N DIVMATCH
S DIVMATCH="N"
S VIPNT=$P($G(^AUPNVPOV(D0,0)),U,3) G:VIPNT="" DIDIVEX
S HLPNT=$P($G(^AUPNVSIT(VIPNT,0)),U,22) G:HLPNT="" DIDIVEX
S MCPNT=$P($G(^SC(HLPNT,0)),U,15) G:MCPNT="" DIDIVEX
S INPNT=$P($G(^DG(40.8,MCPNT,0)),U,7)
I (INPNT=DUZ(2))!(AFLDIV[INPNT) S DIVMATCH="Y"
DIDIVEX K HLPNT,INPNT,MCPNT,VIPNT
Q DIVMATCH
;
HIST(IEN,HSTFLD,HISTNAM,ICDFILE,ICDNUM) ;
;Histology ICD-O-2 (165.5,22) or Histology ICD-O-3 (165.5,22.3)
N HISTICD,HNODE,ONCDTDX
S ONCDTDX=$P($G(^ONCO(165.5,IEN,0)),U,16)
S ICDNUM=3 I ONCDTDX<3010000 S ICDNUM=2
S HNODE=$S(ICDNUM=3:2.2,1:2),ICDFILE=$S(ICDNUM=3:169.3,1:164.1)
S HSTFLD=$S(ICDNUM=3:22.3,1:22)
S HISTICD=$P($G(^ONCO(165.5,IEN,HNODE)),U,3)
S HISTNAM=""
I HISTICD'="" S HISTNAM=$P($G(^ONCO(ICDFILE,HISTICD,0)),U,1)
Q HISTICD
;
MORP(IEN) ;MorpH (73-91) ICD-O-1 extract
N ONC731,ONC702,ONC703,ONCXX
S ONC731=$$GET1^DIQ(165.5,IEN,7031,"I")
S ONC702=$$GET1^DIQ(165.5,IEN,7002,"I")
S ONC703=$$GET1^DIQ(165.5,IEN,7003,"I")
S ONCXX=ONC731_ONC702_ONC703
Q ONCXX
;
LYMPHOMA(IEN) ;Hodgkin and non-Hodgkin Lymphomas
N LYMPHOMA
S LYMPHOMA=0
S ONCDTDX=$P($G(^ONCO(165.5,IEN,0)),U,16)
S HSTICD=$$HIST^ONCFUNC(IEN)
S HST123=$E(HSTICD,1,3)
I ONCDTDX<3010000,(HST123>958)&(HST123<972) S LYMPHOMA=1
I ONCDTDX>3001231,(HST123>958)&(HST123<973) S LYMPHOMA=1
I ONCDTDX>3091231,(HSTICD=97353)!(HSTICD=97373)!(HSTICD=97383) S LYMPHOMA=1
K HST123,HSTICD,ONCDTDX
Q LYMPHOMA
;
LYMPH(IEN) ;Lymphomas
N LYMPHOMA
S LYMPHOMA=0
S ONCDTDX=$P($G(^ONCO(165.5,IEN,0)),U,16)
S HSTICD=$$HIST^ONCFUNC(IEN)
S HST14=$E(HSTICD,1,4)
I ONCDTDX<3100000 D
.I ((HST14>9589)&(HST14<9597))!((HST14>9649)&(HST14<9720))!((HST14>9726)&(HST14<9730)) S LYMPHOMA=1
I ONCDTDX>3091221 D
.I ((HST14>9589)&(HST14<9727))!((HST14>9727)&(HST14<9733))!((HST14>9733)&(HST14<9741))!((HST14>9749)&(HST14<9763))!((HST14>9810)&(HST14<9832))!(HST14=9940)!(HST14=9980)!(HST14=9971) S LYMPHOMA=1
K HST14,HSTICD,ONCDTDX
Q LYMPHOMA
;
HEMATO(IEN) ;Hematopoietic, reticuloendothelial, immunoproliferative or
; myeloproliferative disease
N HEMATO
S HEMATO=0
S ONCDTDX=$P($G(^ONCO(165.5,IEN,0)),U,16)
S HSTICD=$$HIST^ONCFUNC(IEN)
S HST14=$E(HSTICD,1,4)
I ONCDTDX<3100000 D
.I (HST14=9750)!((HST14>9759)&(HST14<9765))!((HST14>9799)&(HST14<9821))!(HST14=9826)!((HST14>9830)&(HST14<9921))!((HST14>9930)&(HST14<9965))!((HST14>9979)&(HST14<9990)) S HEMATO=1
I ONCDTDX>3091221 D
.I (HST14=9727)!(HST14=9733)!(HST14=9741)!(HST14=9742)!((HST14>9763)&(HST14<9810))!(HST14=9832)!((HST14>9839)&(HST14<9932))!(HST14=9945)!(HST14=9946)!((HST14>9949)&(HST14<9968))!((HST14>9974)&(HST14<9993)) S HEMATO=1
K HST14,HSTICD,ONCDTDX
Q HEMATO
;
CC ;COMORBIDITY/COMPLICATION #1-10 (160,25-25.9) screen
;
;Use ICD API (#3990) instead of direct global read.
N ONCICDY,ONCFLAG,ONC80I
S ONCFLAG=0
S ONC80I=$G(^ICD9(+Y,0))
S ONCICDY=$$ICDDX^ICDEXC(ONC80I,,1) Q:ONCICDY=-1
I $E($P(ONCICDY,U,2),1)="V",+($E($P(ONCICDY,U,2),2,9)>7.1)&+($E($P(ONCICDY,U,2),2,9)<7.4) S ONCFLAG=1
I $E($P(ONCICDY,U,2),1)="V",+($E($P(ONCICDY,U,2),2,9)>9.91)&+($E($P(ONCICDY,U,2),2,9)<16) S ONCFLAG=1
I $E($P(ONCICDY,U,2),1)="V",+($E($P(ONCICDY,U,2),2,9)>21.9)&+($E($P(ONCICDY,U,2),2,9)<23.2) S ONCFLAG=1
I $E($P(ONCICDY,U,2),1)="V",+($E($P(ONCICDY,U,2),2,9)>25.3)&+($E($P(ONCICDY,U,2),2,9)<25.5) S ONCFLAG=1
I $E($P(ONCICDY,U,2),1)="V",+($E($P(ONCICDY,U,2),2,9)>43.89)&+($E($P(ONCICDY,U,2),2,9)<46) S ONCFLAG=1
I $E($P(ONCICDY,U,2),1)="V",+($E($P(ONCICDY,U,2),2,9)>50.4)&+($E($P(ONCICDY,U,2),2,9)<50.8) S ONCFLAG=1
I $E($P(ONCICDY,U,2),1)'="V",$E($P(ONCICDY,U,2),1)="E",($E($P(ONCICDY,U,2),2,9)>869.9)&($E($P(ONCICDY,U,2),2,9)<880) S ONCFLAG=1
I $E($P(ONCICDY,U,2),1)'="V",$E($P(ONCICDY,U,2),1)="E",($E($P(ONCICDY,U,2),2,9)>929.9)&($E($P(ONCICDY,U,2),2,9)<950) S ONCFLAG=1
I $E($P(ONCICDY,U,2),1)'="V",$E($P(ONCICDY,U,2),1)'="E",($P(ONCICDY,U,2)<140)!($P(ONCICDY,U,2)>239.9) S ONCFLAG=1
I ($P(ONCICDY,U,1)="-1")!($P(ONCICDY,U,1)>499999) S ONCFLAG=0
I ONCFLAG=1 Q
Q
SDIAG ;Secondary Diagnosis 1 - 10
;Use ICD API (#3990) instead of direct global read.
N ONCICDY,ONCFLAG,ONC80I
S ONCFLAG=0
S ONC80I=$G(^ICD9(Y,0))
S ONCICDY=$$ICDDX^ICDEXC(ONC80I,,30) Q:ONCICDY=-1
I ($P(ONCICDY,U,1)>499999) S ONCFLAG=1
I ($P(ONCICDY,U,1)="-1") S ONCFLAG=0
I ONCFLAG=1 Q
Q
;
SDOT ;ICD CODE OUTPUT TRANSFORM
N ONCICD,CODE,SPACE
I Y'="" S ONCICD=$$GET1^DIQ(80,Y,.01),ONCICD=$$ICDDX^ICDEX(ONCICD) S:($P(ONCICD,U,1)=-1) Y=-1 S:(Y'=-1) CODE=$P(ONCICD,U,2),SPACE=$S($L(CODE)=4:" ",$L(CODE)=5:" ",1:" "),(X,Y)=CODE_SPACE_$P(ONCICD,U,4)
Q
;
DSTS(IEN) ;DATE SYSTEMIC THERAPY STARTED
N X
S X=$$GET1^DIQ(165.5,IEN,53,"I") I X'="" S DSTSDT(X)=""
S X=$$GET1^DIQ(165.5,IEN,54,"I") I X'="" S DSTSDT(X)=""
S X=$$GET1^DIQ(165.5,IEN,55,"I") I X'="" S DSTSDT(X)=""
S DSTS=$O(DSTSDT(0))
S X=$$DATE^ONCACDU1(DSTS)
K DSTS,DSTSDT
Q X
;
DUPPRI ;Check for duplicate primaries belonging to another DIVISION
K TMP
S XD1=0
F S XD1=$O(^ONCO(165.5,"C",XD0,XD1)) Q:XD1'>0 D
.S PS=$$GET1^DIQ(165.5,XD1,20,"I")
.S SN=$$GET1^DIQ(165.5,XD1,.06,"I")
.S DIV=$$GET1^DIQ(165.5,XD1,2000,"I")
.S TMP(PS_U_SN,DIV)=XD1
.S TMP(PS_U_SN)=$G(TMP(PS_U_SN))+1
S PSSN="" F S PSSN=$O(TMP(PSSN)) Q:PSSN'>0 I TMP(PSSN)>1 D
.S DIV="" F S DIV=$O(TMP(PSSN,DIV)) Q:DIV'>0 I DIV=DUZ(2) D Q
..W !
..W !," NOTE: This patient has more than one primary with the same"
..W !," SEQUENCE NUMBER and PRIMARY SITE. These primaries"
..W !," belong to different divisions. You may wish to notify"
..W !," the other division of any significant changes for this patient."
..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)) S J=J+1 D ^ONCOCOML
..K DIR S DIR(0)="E" D ^DIR
K DIR,DIV,J,PS,PSSN,SN,TMP,XD0,XD1
;
CLEANUP ;Cleanup
K AFLDIV,D0,Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HONCFUNC 9343 printed Dec 13, 2024@02:22:54 Page 2
ONCFUNC ;HINES OIFO/GWB - OncoTrax functions ;05/03/12
+1 ;;2.2;ONCOLOGY;**1,7,13**;Jul 31, 2013;Build 7
+2 ;
+3 ;
SHN() ;STATE HOSPITAL NUMBER (160.1,1.03)
+1 NEW OSP,SHN
+2 SET OSP=$ORDER(^ONCO(160.1,"C",DUZ(2),0))
+3 IF OSP=""
SET OSP=$ORDER(^ONCO(160.1,0))
+4 SET SHN=$$GET1^DIQ(160.1,OSP,1.03,"I")
+5 QUIT SHN
+6 ;
STCO70(IEN) ;GEOLOCATION ID 1970/80/90
+1 NEW ONCST,ONCCO,ONCCE,ONCCB,ONCDX
+2 SET ONCST=""
SET ONCCO=""
SET ONCCT=""
SET ONCCB=""
+3 SET ONCST=$$GET1^DIQ(165.5,IEN,7000,"I")
+4 if ONCST'=""
SET ONCST=$$GET1^DIQ(5,ONCST,2,"I")
+5 if ONCST=""
SET ONCST=" "
+6 SET ONCDX=$$GET1^DIQ(165.5,IEN,3,"I")
+7 SET ONCCO=$SELECT(ONCDX>3160000:$$CNTY^ONCACDU1(IEN),1:"")
+8 if ONCCO=""
SET ONCCO=" "
+9 SET ONCCT=$$GET1^DIQ(165.5,IEN,147,"I")
+10 if ONCCT=""
SET ONCCT=" "
+11 if ONCCB=""
SET ONCCB=" "
+12 SET ACDANS=ONCST_ONCCO_ONCCT_ONCCB
+13 QUIT ACDANS
+14 ;
STCO00(IEN) ;GEOLOCATION ID 2000
+1 NEW ONCST,ONCCO,ONCCT,ONCCB,ONCDX
+2 SET ONCST=""
SET ONCCO=""
SET ONCCT=""
SET ONCCB=""
+3 SET ONCST=$$GET1^DIQ(165.5,IEN,7023,"I")
+4 if ONCST'=""
SET ONCST=$$GET1^DIQ(5,ONCST,2,"I")
+5 if ONCST=""
SET ONCST=" "
+6 SET ONCDX=$$GET1^DIQ(165.5,IEN,3,"I")
+7 SET ONCCO=$SELECT(ONCDX>3160000:$$CNTY^ONCACDU1(IEN),1:"")
+8 if ONCCO=""
SET ONCCO=" "
+9 if ONCCT=""
SET ONCCT=" "
+10 if ONCCB=""
SET ONCCB=" "
+11 SET ACDANS=ONCST_ONCCO_ONCCT_ONCCB
+12 QUIT ACDANS
+13 ;
STCO10(IEN) ;GEOLOCATION ID 2010
+1 NEW ONCST,ONCCO,ONCCT,ONCCB,ONCDX
+2 SET ONCST=""
SET ONCCO=""
SET ONCCE=""
SET ONCCB=""
+3 SET ONCST=$$GET1^DIQ(165.5,IEN,7001,"I")
+4 if ONCST'=""
SET ONCST=$$GET1^DIQ(5,ONCST,2,"I")
+5 if ONCST=""
SET ONCST=" "
+6 SET ONCDX=$$GET1^DIQ(165.5,IEN,3,"I")
+7 SET ONCCO=$SELECT(ONCDX>3160000:$$CNTY^ONCACDU1(IEN),1:"")
+8 if ONCCO=""
SET ONCCO=" "
+9 SET ONCCT=$$GET1^DIQ(165.5,IEN,147,"I")
+10 if ONCCT=""
SET ONCCT=" "
+11 if ONCCB=""
SET ONCCB=" "
+12 SET ACDANS=ONCST_ONCCO_ONCCT_ONCCB
+13 QUIT ACDANS
+14 ;
STCO20(IEN) ;GEOLOCATION ID 2020
+1 NEW ONCST,ONCCO,ONCCT,ONCCB,ONCDX
+2 SET ONCST=""
SET ONCCO=""
SET ONCCT=""
SET ONCCB=""
+3 SET ONCST=$$GET1^DIQ(165.5,IEN,7001,"I")
+4 if ONCST'=""
SET ONCST=$$GET1^DIQ(5,ONCST,2,"I")
+5 if ONCST=""
SET ONCST=" "
+6 SET ONCDX=$$GET1^DIQ(165.5,IEN,3,"I")
+7 SET ONCCO=$SELECT(ONCDX>3160000:$$CNTY^ONCACDU1(IEN),1:"")
+8 if ONCCO=""
SET ONCCO=" "
+9 if ONCCT=""
SET ONCCT=" "
+10 if ONCCB=""
SET ONCCB=" "
+11 SET ACDANS=ONCST_ONCCO_ONCCT_ONCCB
+12 QUIT ACDANS
+13 ;
IIN() ;INSTITUTION ID NUMBER (160.1,27)
+1 NEW IIN,OSP
+2 SET OSP=$ORDER(^ONCO(160.1,"C",DUZ(2),0))
+3 IF OSP=""
SET OSP=$ORDER(^ONCO(160.1,0))
+4 SET IIN=$$GET1^DIQ(160.1,OSP,27,"I")
+5 SET IIN=$$GET1^DIQ(160.19,IIN,.01,"I")
+6 QUIT IIN
+7 ;
FLNAME(NAME) ;COMPUTED EXPRESSION for FIRST-LAST (160,.012)
+1 NEW DFN,FIRST,LAST,MIDDLE,PL,SUFFIX,TNAME
+2 SET TNAME=NAME
SET DFN=D0
+3 SET LAST=$PIECE(TNAME,",")
SET TNAME=$PIECE(TNAME,",",2)
+4 SET FIRST=$PIECE(TNAME," ")
SET MIDDLE=$PIECE(TNAME," ",2)
+5 SET SUFFIX=$PIECE(TNAME," ",3)
+6 IF MIDDLE[""""
SET MIDDLE=""
+7 SET TNAME=FIRST_" "_MIDDLE_" "_LAST_" "_SUFFIX
SP IF $FIND(TNAME," ")
SET PL=$FIND(TNAME," ")
SET TNAME=$EXTRACT(TNAME,1,PL-2)_$EXTRACT(TNAME,PL,$LENGTH(TNAME))
GOTO SP
+1 QUIT TNAME
+2 ;
DIV(IEN) ;DIVISION (165.5,2000)
+1 NEW DIV
+2 SET DIV=$GET(^ONCO(165.5,IEN,"DIV"))
+3 QUIT DIV
+4 ;
SUSDIV(IEN,SUSIEN) ;DIVISION (160,30)
+1 NEW DIV
+2 SET DIV=$PIECE($GET(^ONCO(160,IEN,"SUS",SUSIEN,0)),U,4)
+3 QUIT DIV
+4 ;
PFTD(IEN) ;Primaries for this division
+1 NEW PFTD,PRI
+2 SET PFTD="N"
+3 SET PRI=0
FOR
SET PRI=$ORDER(^ONCO(165.5,"C",IEN,PRI))
if PRI'>0
QUIT
IF $PIECE($GET(^ONCO(165.5,PRI,"DIV")),U,1)=DUZ(2)
SET PFTD="Y"
+4 QUIT PFTD
+5 ;
PRICNT ;TOTAL PRIMARIES FOR PATIENT (160,17)
+1 SET PRI=0
SET PRICNT=0
FOR
SET PRI=$ORDER(^ONCO(165.5,"C",D0,PRI))
if PRI'>0
QUIT
IF $PIECE($GET(^ONCO(165.5,PRI,"DIV")),U,1)=DUZ(2)
Begin DoDot:1
+2 SET PRICNT=PRICNT+1
End DoDot:1
+3 SET X=PRICNT
+4 KILL PRI,PRICNT
+5 QUIT
+6 ;
DIDIV(IEN) ;Disease Index DIVISION screen
+1 ;Supported by IAs #417 and #2028
+2 NEW DIVMATCH
+3 SET DIVMATCH="N"
+4 SET VIPNT=$PIECE($GET(^AUPNVPOV(D0,0)),U,3)
if VIPNT=""
GOTO DIDIVEX
+5 SET HLPNT=$PIECE($GET(^AUPNVSIT(VIPNT,0)),U,22)
if HLPNT=""
GOTO DIDIVEX
+6 SET MCPNT=$PIECE($GET(^SC(HLPNT,0)),U,15)
if MCPNT=""
GOTO DIDIVEX
+7 SET INPNT=$PIECE($GET(^DG(40.8,MCPNT,0)),U,7)
+8 IF (INPNT=DUZ(2))!(AFLDIV[INPNT)
SET DIVMATCH="Y"
DIDIVEX KILL HLPNT,INPNT,MCPNT,VIPNT
+1 QUIT DIVMATCH
+2 ;
HIST(IEN,HSTFLD,HISTNAM,ICDFILE,ICDNUM) ;
+1 ;Histology ICD-O-2 (165.5,22) or Histology ICD-O-3 (165.5,22.3)
+2 NEW HISTICD,HNODE,ONCDTDX
+3 SET ONCDTDX=$PIECE($GET(^ONCO(165.5,IEN,0)),U,16)
+4 SET ICDNUM=3
IF ONCDTDX<3010000
SET ICDNUM=2
+5 SET HNODE=$SELECT(ICDNUM=3:2.2,1:2)
SET ICDFILE=$SELECT(ICDNUM=3:169.3,1:164.1)
+6 SET HSTFLD=$SELECT(ICDNUM=3:22.3,1:22)
+7 SET HISTICD=$PIECE($GET(^ONCO(165.5,IEN,HNODE)),U,3)
+8 SET HISTNAM=""
+9 IF HISTICD'=""
SET HISTNAM=$PIECE($GET(^ONCO(ICDFILE,HISTICD,0)),U,1)
+10 QUIT HISTICD
+11 ;
MORP(IEN) ;MorpH (73-91) ICD-O-1 extract
+1 NEW ONC731,ONC702,ONC703,ONCXX
+2 SET ONC731=$$GET1^DIQ(165.5,IEN,7031,"I")
+3 SET ONC702=$$GET1^DIQ(165.5,IEN,7002,"I")
+4 SET ONC703=$$GET1^DIQ(165.5,IEN,7003,"I")
+5 SET ONCXX=ONC731_ONC702_ONC703
+6 QUIT ONCXX
+7 ;
LYMPHOMA(IEN) ;Hodgkin and non-Hodgkin Lymphomas
+1 NEW LYMPHOMA
+2 SET LYMPHOMA=0
+3 SET ONCDTDX=$PIECE($GET(^ONCO(165.5,IEN,0)),U,16)
+4 SET HSTICD=$$HIST^ONCFUNC(IEN)
+5 SET HST123=$EXTRACT(HSTICD,1,3)
+6 IF ONCDTDX<3010000
IF (HST123>958)&(HST123<972)
SET LYMPHOMA=1
+7 IF ONCDTDX>3001231
IF (HST123>958)&(HST123<973)
SET LYMPHOMA=1
+8 IF ONCDTDX>3091231
IF (HSTICD=97353)!(HSTICD=97373)!(HSTICD=97383)
SET LYMPHOMA=1
+9 KILL HST123,HSTICD,ONCDTDX
+10 QUIT LYMPHOMA
+11 ;
LYMPH(IEN) ;Lymphomas
+1 NEW LYMPHOMA
+2 SET LYMPHOMA=0
+3 SET ONCDTDX=$PIECE($GET(^ONCO(165.5,IEN,0)),U,16)
+4 SET HSTICD=$$HIST^ONCFUNC(IEN)
+5 SET HST14=$EXTRACT(HSTICD,1,4)
+6 IF ONCDTDX<3100000
Begin DoDot:1
+7 IF ((HST14>9589)&(HST14<9597))!((HST14>9649)&(HST14<9720))!((HST14>9726)&(HST14<9730))
SET LYMPHOMA=1
End DoDot:1
+8 IF ONCDTDX>3091221
Begin DoDot:1
+9 IF ((HST14>9589)&(HST14<9727))!((HST14>9727)&(HST14<9733))!((HST14>9733)&(HST14<9741))!((HST14>9749)&(HST14<9763))!((HST14>9810)&(HST14<9832))!(HST14=9940)!(HST14=9980)!(HST14=9971)
SET LYMPHOMA=1
End DoDot:1
+10 KILL HST14,HSTICD,ONCDTDX
+11 QUIT LYMPHOMA
+12 ;
HEMATO(IEN) ;Hematopoietic, reticuloendothelial, immunoproliferative or
+1 ; myeloproliferative disease
+2 NEW HEMATO
+3 SET HEMATO=0
+4 SET ONCDTDX=$PIECE($GET(^ONCO(165.5,IEN,0)),U,16)
+5 SET HSTICD=$$HIST^ONCFUNC(IEN)
+6 SET HST14=$EXTRACT(HSTICD,1,4)
+7 IF ONCDTDX<3100000
Begin DoDot:1
+8 IF (HST14=9750)!((HST14>9759)&(HST14<9765))!((HST14>9799)&(HST14<9821))!(HST14=9826)!((HST14>9830)&(HST14<9921))!((HST14>9930)&(HST14<9965))!((HST14>9979)&(HST14<9990))
SET HEMATO=1
End DoDot:1
+9 IF ONCDTDX>3091221
Begin DoDot:1
+10 IF (HST14=9727)!(HST14=9733)!(HST14=9741)!(HST14=9742)!((HST14>9763)&(HST14<9810))!(HST14=9832)!((HST14>9839)&(HST14<9932))!(HST14=9945)!(HST14=9946)!((HST14>9949)&(HST14<9968))!((HST14>9974)&(HST14<9993))
SET HEMATO=1
End DoDot:1
+11 KILL HST14,HSTICD,ONCDTDX
+12 QUIT HEMATO
+13 ;
CC ;COMORBIDITY/COMPLICATION #1-10 (160,25-25.9) screen
+1 ;
+2 ;Use ICD API (#3990) instead of direct global read.
+3 NEW ONCICDY,ONCFLAG,ONC80I
+4 SET ONCFLAG=0
+5 SET ONC80I=$GET(^ICD9(+Y,0))
+6 SET ONCICDY=$$ICDDX^ICDEXC(ONC80I,,1)
if ONCICDY=-1
QUIT
+7 IF $EXTRACT($PIECE(ONCICDY,U,2),1)="V"
IF +($EXTRACT($PIECE(ONCICDY,U,2),2,9)>7.1)&+($EXTRACT($PIECE(ONCICDY,U,2),2,9)<7.4)
SET ONCFLAG=1
+8 IF $EXTRACT($PIECE(ONCICDY,U,2),1)="V"
IF +($EXTRACT($PIECE(ONCICDY,U,2),2,9)>9.91)&+($EXTRACT($PIECE(ONCICDY,U,2),2,9)<16)
SET ONCFLAG=1
+9 IF $EXTRACT($PIECE(ONCICDY,U,2),1)="V"
IF +($EXTRACT($PIECE(ONCICDY,U,2),2,9)>21.9)&+($EXTRACT($PIECE(ONCICDY,U,2),2,9)<23.2)
SET ONCFLAG=1
+10 IF $EXTRACT($PIECE(ONCICDY,U,2),1)="V"
IF +($EXTRACT($PIECE(ONCICDY,U,2),2,9)>25.3)&+($EXTRACT($PIECE(ONCICDY,U,2),2,9)<25.5)
SET ONCFLAG=1
+11 IF $EXTRACT($PIECE(ONCICDY,U,2),1)="V"
IF +($EXTRACT($PIECE(ONCICDY,U,2),2,9)>43.89)&+($EXTRACT($PIECE(ONCICDY,U,2),2,9)<46)
SET ONCFLAG=1
+12 IF $EXTRACT($PIECE(ONCICDY,U,2),1)="V"
IF +($EXTRACT($PIECE(ONCICDY,U,2),2,9)>50.4)&+($EXTRACT($PIECE(ONCICDY,U,2),2,9)<50.8)
SET ONCFLAG=1
+13 IF $EXTRACT($PIECE(ONCICDY,U,2),1)'="V"
IF $EXTRACT($PIECE(ONCICDY,U,2),1)="E"
IF ($EXTRACT($PIECE(ONCICDY,U,2),2,9)>869.9)&($EXTRACT($PIECE(ONCICDY,U,2),2,9)<880)
SET ONCFLAG=1
+14 IF $EXTRACT($PIECE(ONCICDY,U,2),1)'="V"
IF $EXTRACT($PIECE(ONCICDY,U,2),1)="E"
IF ($EXTRACT($PIECE(ONCICDY,U,2),2,9)>929.9)&($EXTRACT($PIECE(ONCICDY,U,2),2,9)<950)
SET ONCFLAG=1
+15 IF $EXTRACT($PIECE(ONCICDY,U,2),1)'="V"
IF $EXTRACT($PIECE(ONCICDY,U,2),1)'="E"
IF ($PIECE(ONCICDY,U,2)<140)!($PIECE(ONCICDY,U,2)>239.9)
SET ONCFLAG=1
+16 IF ($PIECE(ONCICDY,U,1)="-1")!($PIECE(ONCICDY,U,1)>499999)
SET ONCFLAG=0
+17 IF ONCFLAG=1
QUIT
+18 QUIT
SDIAG ;Secondary Diagnosis 1 - 10
+1 ;Use ICD API (#3990) instead of direct global read.
+2 NEW ONCICDY,ONCFLAG,ONC80I
+3 SET ONCFLAG=0
+4 SET ONC80I=$GET(^ICD9(Y,0))
+5 SET ONCICDY=$$ICDDX^ICDEXC(ONC80I,,30)
if ONCICDY=-1
QUIT
+6 IF ($PIECE(ONCICDY,U,1)>499999)
SET ONCFLAG=1
+7 IF ($PIECE(ONCICDY,U,1)="-1")
SET ONCFLAG=0
+8 IF ONCFLAG=1
QUIT
+9 QUIT
+10 ;
SDOT ;ICD CODE OUTPUT TRANSFORM
+1 NEW ONCICD,CODE,SPACE
+2 IF Y'=""
SET ONCICD=$$GET1^DIQ(80,Y,.01)
SET ONCICD=$$ICDDX^ICDEX(ONCICD)
if ($PIECE(ONCICD,U,1)=-1)
SET Y=-1
if (Y'=-1)
SET CODE=$PIECE(ONCICD,U,2)
SET SPACE=$SELECT($LENGTH(CODE)=4:" ",$LENGTH(CODE)=5:" ",1:" ")
SET (X,Y)=CODE_SPACE_$PIECE(ONCICD,U,4)
+3 QUIT
+4 ;
DSTS(IEN) ;DATE SYSTEMIC THERAPY STARTED
+1 NEW X
+2 SET X=$$GET1^DIQ(165.5,IEN,53,"I")
IF X'=""
SET DSTSDT(X)=""
+3 SET X=$$GET1^DIQ(165.5,IEN,54,"I")
IF X'=""
SET DSTSDT(X)=""
+4 SET X=$$GET1^DIQ(165.5,IEN,55,"I")
IF X'=""
SET DSTSDT(X)=""
+5 SET DSTS=$ORDER(DSTSDT(0))
+6 SET X=$$DATE^ONCACDU1(DSTS)
+7 KILL DSTS,DSTSDT
+8 QUIT X
+9 ;
DUPPRI ;Check for duplicate primaries belonging to another DIVISION
+1 KILL TMP
+2 SET XD1=0
+3 FOR
SET XD1=$ORDER(^ONCO(165.5,"C",XD0,XD1))
if XD1'>0
QUIT
Begin DoDot:1
+4 SET PS=$$GET1^DIQ(165.5,XD1,20,"I")
+5 SET SN=$$GET1^DIQ(165.5,XD1,.06,"I")
+6 SET DIV=$$GET1^DIQ(165.5,XD1,2000,"I")
+7 SET TMP(PS_U_SN,DIV)=XD1
+8 SET TMP(PS_U_SN)=$GET(TMP(PS_U_SN))+1
End DoDot:1
+9 SET PSSN=""
FOR
SET PSSN=$ORDER(TMP(PSSN))
if PSSN'>0
QUIT
IF TMP(PSSN)>1
Begin DoDot:1
+10 SET DIV=""
FOR
SET DIV=$ORDER(TMP(PSSN,DIV))
if DIV'>0
QUIT
IF DIV=DUZ(2)
Begin DoDot:2
+11 WRITE !
+12 WRITE !," NOTE: This patient has more than one primary with the same"
+13 WRITE !," SEQUENCE NUMBER and PRIMARY SITE. These primaries"
+14 WRITE !," belong to different divisions. You may wish to notify"
+15 WRITE !," the other division of any significant changes for this patient."
+16 WRITE !
+17 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))
SET J=J+1
DO ^ONCOCOML
+18 KILL DIR
SET DIR(0)="E"
DO ^DIR
End DoDot:2
QUIT
End DoDot:1
+19 KILL DIR,DIV,J,PS,PSSN,SN,TMP,XD0,XD1
+20 ;
CLEANUP ;Cleanup
+1 KILL AFLDIV,D0,Y
