Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ONCACDU1

ONCACDU1.m

Go to the documentation of this file.
ONCACDU1 ;Hines OIFO/GWB - NAACCR extract utilities #1 ;05/08/12
 ;;2.2;ONCOLOGY;**1,4,7,5,10,12**;Jul 31, 2013;Build 8
 ;
BDATE(ACD160) ;Date of Birth [240] 196-203
 N D0,X,Y
 S D0=ACD160
 D DOB1^ONCOES
 S X=$G(X)
 Q X
 ;
BEHAV(IEN) ;Behavior Code (called by extract RULES)
 N BEHAV
 S BEHAV=$E($$HIST^ONCFUNC(IEN),5)
 Q BEHAV
 ;
LYMPH(IEN) ;Lymph-Vascular Invasion (1297-1297)
 N MPH,LV,ONCDANS,DATEDX
 S DATEDX=$$GET1^DIQ(165.5,IEN,3,"I"),ONCDANS=""
 I DATEDX<3100000 K DATEDX Q ONCDANS
 S MPH=$$GET1^DIQ(165.5,IEN,22.3,"I")
 S MPH=$E(MPH,1,4),LV=$$GET1^DIQ(165.5,IEN,149,"I")
 S ONCDANS=LV
 I DATEDX<3180000 S ONCDANS=$S((MPH>9589)&(MPH<9993):8,LV[0:0,LV[1:1,LV[8:8,1:9)
 K LV,MPH
 Q ONCDANS
 ;
ICD9(ACD160,ONIEN) ;COMOR/COMP 1-10 for ICD9 and Secondary Diagnosis for ICD10
 N ONCDANS
 S ONCDANS=$$GET1^DIQ(160,ACD160,ONIEN,"I")
 S:ONCDANS'="" ONCDANS=$$GET1^DIQ(80,ONCDANS,.01,"I")
 ;ICD10 invalid code
 I ($E(ONCDANS,1,7)="Invalid")!($E(ONCDANS,1,3)="-1") S ONCDANS="" Q ONCDANS
 I $G(EXTRACT)'=3 S ONCPHI=1
 I (($E(ONCDANS,1,4)="T40.")!($E(ONCDANS,1,4)="T43.")),(ONCPHI=1) S ONCDANS="" Q ONCDANS
 ;
 I $G(ONCPHI)=0 S ONCDANS=$P(ONCDANS,".",1)_$P(ONCDANS,".",2) Q ONCDANS
 ;
 N ONCMO1,ONCMO2,ONCI1,ONCJ1
 K ^TMP($J,"ONCOMO")
 F ONCI1=1:1 S ONCMO1=$P($T(COMO+ONCI1),";",3) Q:ONCMO1=""  F ONCJ1=1:1 S ONCMO2=$P(ONCMO1,"^",ONCJ1) Q:ONCMO2=""  D
 .S ^TMP($J,"ONCOMO",ONCMO2)=""
 I $G(ONCPHI),(ONCDANS'=""),($D(^TMP($J,"ONCOMO",ONCDANS))) S ONCDANS=""
 K ^TMP($J,"ONCOMO")
 S ONCDANS=$P(ONCDANS,".",1)_$P(ONCDANS,".",2)
 Q ONCDANS
 ;
COMO ;ICD10 PHI Code.
 ;;F10.10^F10.20^F10.21^F10.27^F10.929^F10.950^F10.951^F10.96^F10.99^F10.231^F10.239^F10.159^F10.180^F10.181^F10.182
 ;;F10.282^F10.982^F10.188^F10.259^F10.280^F10.281^F10.288^F10.229^F11.10^F11.20^F11.21^F12.10^F12.20^F12.21^F12.90
 ;;F13.10^F13.20^F13.21^F14.10^F14.20^F14.21^F15.10^F15.20^F15.21^F16.10^F16.20^F16.21^F18.10^F19.10^F19.20^F19.21
 ;;291.81^291.82^291.89^142.6^B20^B20.^B97.35^G62.1^K70.0^K74.0^K74.60^K74.69^K74.1^K76.9^K29.20^K29.21^K70.10^K70.30^K70.9
 ;;P04.3^R78.0^R97.0^R97.1^R97.8^R75^D57.1^D57.00^D57.01^D57.02^D57.80^D57.819^D57.40^D57.419^Z63.72^Z13.89^Z21^Z71.7
 ;;T50.991A^T51.91^T51.1X1A^T51.1X2A^T51.1X3A^T51.1X4A^T51.2X1A^T51.2X2A^T51.2X3A^T51.2X4A^T51.9X1A^T51.9X2A^T51.9X3A
 ;;T51.9X4A^T51.0X1A^T51.0X2A^T51.0X3A^T51.0X4A^T51.6X1A^T51.8X1A^T51.8X2A^T51.8X3A^T51.8X4A^142.6
 ;;B20^B20.^B97.35^E24.2^E24.4^G31.2^G62.0^G62.2^G72.1^G72.2^I42.6^J68.0^K28.2^K29.21^K70^K70.9^K86.0
 ;;O35.4^O35.5XX9^O98.7^O98.73^O99.31^O99.335^P04.12^P04.49^R78^R78.6^T36^T50.996S^Z20.6^Z21.
 ;;G62.1^K28.3^K28.9^K29.00^K29.01^K29.20^K29.21^K70.0^K70.10^K70.11^K70.2^K70.30^K70.31^K70.40^K70.41
 ;;O35.4XX0^O35.4XX1^O35.4XX2^O35.4XX3^O35.4XX4^O35.4XX5^O35.4XX9^O35.5XX0^O35.5XX1^O35.5XX2^O35.5XX3
 ;;O35.5XX4^O35.5XX5^O35.5XX9^O98.711^O98.712^O98.713^O98.719^O98.72^R78.1^R78.2^R78.3^78.4^78.5
 ;;O99.310^O99.311^O99.312^O99313^O99.314^O99.315^O99.320^O99.322^O99.323^O99.324^O99.325
 ;;O99.330^O99.331^O99.332^O99.333^O99.334^P04.12^P04.13^P04.14^P04.15^P04.16^P04.17^P04.18^P04.19
 ;;P04.1A^P04.2^P04.3^P04.40^P04.41^P04.42^R75.
 Q
 ;
DATE(ACDANS) ;Convert date to NAACCR format CCYYMMDD
 N DATE,X
 S DATE=""
 S X=ACDANS
 D DATEOT^ONCOES
 I X'="" D
 .I X="00/00/0000" S DATE="" Q
 .I X="88/88/8888" S DATE="" Q
 .I X="99/99/9999" S DATE="" Q
 .S DATE=$E(X,7,10)_$E(X,1,2)_$E(X,4,5)
 .S DATE=$S($E(DATE,5,8)=9999:$E(DATE,1,4),$E(DATE,7,8)=99:$E(DATE,1,6),1:DATE)
 Q DATE
 ;
DTFLAG(ACDANS,ITEM) ;Compute Date Flag
 N FLAG,N,REC,ONCSCMA
 S FLAG=""
 S N=ITEM
 D CHKFLGS  ;first check the Date Flag fields, make sure nothing entered
 I ONCDTFLG'="" S FLAG=ONCDTFLG G FLAG
 ;patch *2.2*4
 I (N=1861),(ACDANS'=""),(ACDANS'="9999999"),(ACDANS'="0000000"),(ACDANS'="8888888") G FLAG
 I N=1861 I ($$GET1^DIQ(165.5,IEN,71,"I")=4)!($$GET1^DIQ(165.5,IEN,71,"I")=5) S FLAG=11 G FLAG
 I ACDANS="" D
 .S FLAG=$S(N=1751:12,N=1861:10,1:"")
 .I N=683,$P($G(^ONCO(165.5,IEN,0)),"^",16)>3171231 S FLAG=11
 .S ONCSCMA=$P($G(^ONCO(165.5,IEN,"SSD1")),"^",1)
 .I ($G(ONCSCMA)'="00480")&('$$MELANOMA^ONCOU55(IEN)) Q
 .I N=833,$P($G(^ONCO(165.5,IEN,0)),"^",16)>3171231 S FLAG=11 Q
 .Q  ;only set 833 above if Schema 00480 or Melanoma above
 I ACDANS'="",((N=833)!(N=683)) S FLAG="" G FLAG
 I ACDANS="9999999" D
 .S FLAG=$S((N=391)!(N=439)!(N=581)!(N=1751):12,(N=448)!(N=591)!(N=601)!(N=1201)!(N=1211)!(N=1221)!(N=1231)!(N=1241)!(N=1251)!(N=1271)!(N=1281)!(N=1661)!(N=1681)!(N=1701)!(N=1861)!(N=3171)!(N=3181)!(N=3221)!(N=3231):10,1:"") Q
 I ACDANS="8888888" D
 .S FLAG=$S((N=448)!(N=439):11,N=391:12,(N=1211)!(N=1221)!(N=1231)!(N=1241)!(N=3221)!(N=3231):15,1:"") Q
 I ACDANS="0000000" D
 .S FLAG=$S((N=591)!(N=601)!(N=1201)!(N=1211)!(N=1221)!(N=1231)!(N=1241)!(N=1251)!(N=1271)!(N=1281)!(N=1661)!(N=1681)!(N=1701)!(N=1861)!(N=3171)!(N=3181)!(N=3221)!(N=3231):11,N=391:12,(N=448)!(N=439):15,1:"") Q
FLAG K ONCDTFLG,ZZFLDNUM
 Q FLAG
 ;
CHKFLGS ;CHECK THE DATE FLAG FIELDS IF USER NEEDED TO OVERRIDE VALUE
 ; if the DATE FLAG field is not NULL use that value to override the
 ; calculated value from DTFLAG entry point above
 S ONCDTFLG=""
 S ZZFLDNUM=$S(N=391:999.1,N=448:999.2,N=439:999.3,N=581:999.4,N=591:999.5,N=601:999.6,N=1271:999.7,N=1201:999.8,1:"")
 I ZZFLDNUM="" S ZZFLDNUM=$S(N=3171:999.9,N=3181:999.11,N=1211:999.12,N=3221:999.13,N=3231:999.14,N=1221:999.15,N=1231:999.16,N=1241:999.17,1:"")
 I ZZFLDNUM="" S ZZFLDNUM=$S(N=1251:999.18,N=1281:999.19,N=1861:999.21,N=1751:999.22,N=1661:999.23,N=1681:999.24,N=1701:999.25,N=833:7018,N=683:7014,1:"")
 I ZZFLDNUM="" Q
 S ONCDTFLG=$$GET1^DIQ(165.5,IEN,ZZFLDNUM,"I")
 Q
 ;
ADDDXST(IEN) ;Addr at DX--State [80] 145-146
 S ITEM=80 D CHKADDS I ONCADDF'="" Q ONCADDF  ;check overrides
 S XX=$S($$GET1^DIQ(165.5,IEN,16,"I")'="":$$GET1^DIQ(5,$$GET1^DIQ(165.5,IEN,16,"I"),1,"I"),1:"")
 S XX=$S(XX="CANAD":"CD",XX="EU":"YY",XX="FG":"YY",XX="MX":"XX",XX="NF":"NL",XX="PH":"XX",XX="UN":"ZZ",1:XX)
 Q XX
 ;
CHKADDS ;CHECK THE ADDRESS--STATE & COUNTRY FIELDS IF USER NEEDED TO OVERRIDE
 ; if the ADDRESS--STATE/COUNTRY field is not NULL use that value to
 ; overwrite the calculated value from the ADDDXST entry point and the
 ; CSTST,ADDCTRY entry points in ONCACDU2
 S ONCADDF="",N=ITEM
 S ZZFLDNUM=$S(N=80:999.26,N=102:999.27,N=1820:999.28,N=1832:999.29,1:"")
 I ZZFLDNUM="" Q
 S ONCADDF=$$GET1^DIQ(165.5,IEN,ZZFLDNUM,"I")
 K N,ZZFLDNUM Q
 ;
CNTY(IEN) ;COUNTY AT DX [90] 156-158
 N FIPSCODE
 S FIPSCODE=$$GET1^DIQ(165.5,IEN,10,"I")
 I (FIPSCODE=998)!(FIPSCODE=999) G QCNTY
 S FIPSCODE=$E($$GET1^DIQ(165.5,IEN,10,"I"),3,5)
QCNTY Q FIPSCODE
 ;
AGEDX(IEN) ;Age at Diagnosis [230] 119-121
 N ACDAGE,D0,X
 S D0=IEN
 D AGE^ONCOCOM S ACDAGE=$S(X=""!(X<0)!(X>999):"",1:X)
 Q ACDAGE
 ;
OCCUP(ACD160) ;Text--Usual Occupation [310] 143-182
 N X,OCCUP
 S X="UNKNOWN"
 S OCCUP=$O(^ONCO(160,ACD160,7,0))
 I OCCUP'<1 D
 .N OCC
 .S OCC=$P($G(^ONCO(160,ACD160,7,OCCUP,0)),U,1)
 .Q:OCC=""
 .S X=OCC
 Q X
 ;
IND(ACD160) ;Text--Usual Industry [320] 183-222
 N X,OCCUP
 S X="UNKNOWN"
 S OCCUP=$O(^ONCO(160,ACD160,7,0))
 I OCCUP'<1 D
 .N IND
 .S IND=$P($G(^ONCO(160,ACD160,7,OCCUP,0)),U,4)
 .Q:IND=""
 .S X=IND
 Q X
 ;
TOB(IEN) ;Tobacco History [340] 224-224 VACCR extract only
 N X,AASTOB
 S X=$P($G(^ONCO(160,ACD160,8)),U,2)
 S AASTOB=$S(X="Y":"Y",X="N":0,X="U":9,1:X)
 I AASTOB="Y" D
 .N X S X=""
 .S X=$O(^ONCO(160,ACD160,5,X),-1)
 .I X'<1 I $G(^ONCO(160,ACD160,5,X,0))'="" D
 ..N Y S Y=^ONCO(160,ACD160,5,X,0)
 ..I $P(Y,U,3)'="" S AASTOB=5 Q  ;Previous use
 ..S AASTOB=$S($P(Y,U)=1:1,$P(Y,U)=2:2,$P(Y,U)=3:2,$P(Y,U)=4:3,$P(Y,U)=5:3,$P(Y,U)=7:4,1:9)
 .I AASTOB="Y" S AASTOB=9
 Q AASTOB
 ;
ALC(IEN) ;Alcohol History [350] 225-225 VACCR extract only
 N X,AASALCO
 S X=$P($G(^ONCO(160,ACD160,8)),U,3)
 S AASALCO=$S(X="Y":"Y",X="N":0,X="U":9,1:X)
 I AASALCO="Y" D
 .N X S X=""
 .S X=$O(^ONCO(160,ACD160,6,X),-1)
 .I X'<1 I $G(^ONCO(160,ACD160,6,X,0))'="" D
 ..N Y S Y=^ONCO(160,ACD160,6,X,0)
 ..I $P(Y,U,4)'="" S AASALCO=2 Q  ;Past history of alcohol use
 ..S AASALCO=1
 .I AASALCO="Y" S AASALCO=9
 Q AASALCO
 ;
SG(IEN,TYPE) ;TNM Stage Groups
 ;TNM Path Stage Group  [910]  569-570
 ;TNM Clin Stage Group  [970]  579-580
 N GS
 S GS=""
 I TYPE="" Q GS
 I TYPE="P" S GS=$$GET1^DIQ(165.5,IEN,88,"I")
 I TYPE="C" S GS=$$GET1^DIQ(165.5,IEN,38,"I")
 Q GS
 ;
CC ;Comorbid/Complication 1-10
 ;No longer needed.  Used by NAACCR v11.3.
 ;[3110] 675-679
 ;[3120] 680-684
 ;[3130] 685-689
 ;[3140] 690-694
 ;[3150] 695-699
 ;[3160] 700-704
 ;[3161] 717-721
 ;[3162] 722-726
 ;[3163] 727-731
 ;[3164] 732-736
 ;S CCEX(1)="00000"
 ;F CCSUB=1:1:10 S CC(CCSUB)=""
 ;S CCSUB=0
 ;F FLD=25:.1:25.9 S CC=$$GET1^DIQ(160,ACD160,FLD,"I") S:CC'="" CC=$$GET1^DIQ(80,CC,.01,"I") S CCSUB=CCSUB+1,CC(CCSUB)=$P(CC," ",1)
 ;F CCEXSUB=1:1:10 S CCEX(CCEXSUB)=""
 ;I CC(1)="" Q
 ;I EXT="VACCR" F CCSUB=1:1:10 S CCEX(CCSUB)=$P(CC(CCSUB),".",1)_$P(CC(CCSUB),".",2) G CCEX
 ;S CCEXSUB=0
 ;S CCSUB=0 F  S CCSUB=$O(CC(CCSUB)) Q:CCSUB'>0  D
 ;.I ($E(CC(CCSUB),1)="E")!($E(CC(CCSUB),1)="V")!((+CC(CCSUB)>99.9)&(+CC(CCSUB)<290))!(+CC(CCSUB)>319) S CCEXSUB=CCEXSUB+1,CCEX(CCEXSUB)=$P(CC(CCSUB),".",1)_$P(CC(CCSUB),".",2)
CCEX ;K CC,CCEXSUB,CCSUB,FLD
 Q
 ;
RXCOD(IEN) ;RX Coding System--Current [1460] 888-889
 N OUT
 S OUT="06"
 Q OUT
 ;
FHCT ;Family History of Cancer Text 1456-1505 VACCR extract only
 K ONC S IEN160=ACD160_"," D GETS^DIQ(160,IEN160,"44*","","ONC")
 S (ACDANS,FHCTIEN)=""
 F  S FHCTIEN=$O(ONC(160.044,FHCTIEN)) Q:FHCTIEN'>0  D
 .S FHCT=ONC(160.044,FHCTIEN,.01)_"("_ONC(160.044,FHCTIEN,1)_")"
 .Q:($L(ACDANS)+$L(FHCT))>50
 .S ACDANS=ACDANS_FHCT_"/"
 S ACDANS=$E(ACDANS,1,$L(ACDANS)-1)
 K ONC,IEN160,FHCTIEN,FHCT
 Q
 ;
PHCT ;Patient History of Cancer Text 1785-1804 VACCR extract only
 S ACDANS=""
 F I=148.1,148.2,148.3,148.4 S PHCTPT=$$GET1^DIQ(165.5,IEN,I,"I") D
 .Q:PHCTPT=""
 .S PHCT=$$GET1^DIQ(164.2,PHCTPT,.01,"I")
 .Q:PHCT="NOT APPLICABLE"
 .Q:($L(ACDANS)+$L(PHCT))>20
 .S ACDANS=ACDANS_PHCT_"/"
 S ACDANS=$E(ACDANS,1,$L(ACDANS)-1)
 K I,PHCTPT,PHCT
 Q
 ;
NL ;Name--Last [2230] 1947-1971
 S ACDANS=$$STRIP^XLFSTR(ACDANS," !""""#$%&'()*+,./:;<=>?[>]^_\{|}~`")
 Q