- 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 Jan 18, 2025@03:24:04 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