ONCOCFL1 ;HINES OIFO/GWB - [CF Automatic Casefinding-Lab Search] ;10/21/11
;;2.2;ONCOLOGY;**1,10,15**;Jul 31, 2013;Build 5
;
;patch 10 - added new eligible cases
;
EN ;Start Date default
S SDDEF=$P(^ONCO(160.1,OSP,0),U,5)
I SDDEF="" S SDDEF=DT
S SDDEF=$E(SDDEF,4,5)_"-"_$E(SDDEF,6,7)_"-"_($E(SDDEF,1,3)+1700)
;
SD ;Start Date
W !
K DIR
S DIR(0)="D"
S DIR("A")=" Start Date"
S DIR("B")=SDDEF
D ^DIR
G EX:(Y="")!(Y[U)
I (Y>DT) W " Future dates not allowed" G SD
S (LRSDT,X)=Y D DD^%DT W " ",Y
;
ED ;End Date
K DIR
S DIR(0)="D"
S DIR("A")=" End Date"
D ^DIR
G EX:(Y="")!(Y[U)
I (Y<LRSDT) W " Invalid date sequence" G SD
I (Y>DT) W " Future dates not allowed" G ED
S $P(^ONCO(160.1,OSP,0),U,5)=Y
S (LRLDT,X)=Y D DD^%DT W " ",Y
S Y=LRSDT D D^ONCOLRU S LRSTR=Y
S Y=LRLDT D D^ONCOLRU S LRLST=Y
W !
K DIR
S DIR(0)="Y"
S DIR("A")=" Dates OK"
S DIR("B")="Y"
D ^DIR
G EX:(Y="")!(Y[U)
G EN:'Y
;Include Squamous and Basal cell neoplasms (Y/N?)
W !
S SBCIND="NO"
K DIR
S DIR(0)="Y"
S DIR("A")=" Include Squamous and Basal cell neoplasms"
S DIR("B")="Yes"
S DIR("?")=" "
S DIR("?",1)=" Answer 'YES' if you want to include squamous and basal cell neoplasms."
S DIR("?",2)=" Answer 'NO' if you want to exclude these neoplasms."
D ^DIR
G EX:(Y="")!(Y[U)
S:Y=1 SBCIND="YES"
K DIR
;patch 10 Add Urinary Tract Sites
S ONCO("SD")=LRSDT,ONCO("ED")=LRLDT
S LRSDT=LRSDT-.01,LRLDT=LRLDT+.99
F X=8,9 F Y=1,2,3,4,5,6,7,9 S Z=X_"***"_Y,LRM(Z)=5,LRN(Z)=Z
S LRM(67654)=5,LRN(67654)=67654
S LRM(67664)=5,LRN(67664)=67664
S LRM(67674)=5,LRN(67674)=67674
S LRM(67684)=5,LRN(67684)=67684
S LRM(69760)=5,LRN(69760)=69760
S LRM(74000)=5,LRN(74000)=74000
S LRM(74006)=5,LRN(74006)=74006
S LRM(74007)=5,LRN(74007)=74007
S LRM(74008)=5,LRN(74008)=74008
W !!?10,"This option will search for ICD-O morphology codes 800-998.",!
W !?10,"It will also search for High Grade Dysplasia of Stomach, Colon"
W !?10,"and Esophagus cases.",!
W !?10,"Exceptions to the above search criteria:",!
W !?10,"Behavior Code /0 (Benign) codes will be excluded."
W:SBCIND="NO" !?10,"Squamous cell neoplasms (805-808) of the skin will be excluded."
W:SBCIND="NO" !?10,"Basal cell neoplasms (809) will be excluded."
W !?10,"Benign tumors of the central nervous system will be included."
W !
S %ZIS="Q" D ^%ZIS I POP G EX
I '$D(IO("Q")) D SER^ONCOCFL1 G EX
S ZTRTN="SER^ONCOCFL1",ZTSAVE("LR*")="",ZTSAVE("ONCO*")="",ZTSAVE("SBCIND")=""
S ZTDESC="ONCOLOGY LAB SEARCH"
D ^%ZTLOAD
K ZTDESC,ZTRTN,ZTSAVE
G EX
;
SER ;Search LAB DATA (63) file
;Supported by IA #525
S AFFDIV=$G(DUZ(2)),ONCDIVSP=$O(^ONCO(160.1,"C",AFFDIV,""))
I ONCDIVSP="" W !!,"User does not have an associated DIVISION.",!! G EX
F Z=0:0 S Z=$O(^ONCO(160.1,ONCDIVSP,6,Z)) Q:Z'>0 S AFFDIV=AFFDIV_U_$G(^ONCO(160.1,ONCDIVSP,6,Z,0))
K ^TMP($J),^TMP("ONCO",$J)
D SNOMED
S ONSDT=LRSDT,ONLDT=LRLDT
S ^TMP("ONCO",$J,0)=0
F LRSS="SP","CY","EM","AU" S LRXR="A"_LRSS,LRSDT=ONSDT,LRLDT=ONLDT D LOOP
S LRDFN=0
F S LRDFN=$O(^TMP($J,LRDFN)) G RPT:LRDFN="" S LRSDT=0 F S LRSDT=$O(^TMP($J,LRDFN,LRSDT)) Q:LRSDT'>0 S LD=^(LRSDT),LRSS=$P(LD,U),LRI=$P(LD,U,6),XDT=$S(LRSS="AU":$P(^LR(LRDFN,LRSS),U),1:$P(^LR(LRDFN,LRSS,LRI,0),U,1)) S XDT=$P(XDT,".",1) D CK
;
CK ;Check ONCOLOGY PATIENT (160) file
D DIV Q:DVMTCH=0
S XD1=^LR(LRDFN,0) Q:$P(XD1,U,2)'=2 S X=$P(XD1,U,3) Q:'$D(^DPT(X))
S X=X_";DPT(",XD0=$O(^ONCO(160,"B",X,0)),ONCIEN=XD0
I XD0="" K DO S D="B",DIC="^ONCO(160,",DIC(0)="Z" D FILE^DICN K DO S ONCIEN=+Y D SET Q
I XD0'="" S ONCDIVS="",ONCS="" F S ONCS=$O(^ONCO(160,XD0,"SUS","C",ONCS)) Q:ONCS'>0 S ONCDIVS=ONCDIVS_U_ONCS
I ONCDIVS[DUZ(2) Q
G SET:'$D(^ONCO(165.5,"C",ONCIEN)) S XD2=0 F S XD2=$O(^ONCO(165.5,"C",ONCIEN,XD2)) Q:XD2="" I $$DIV^ONCFUNC(XD2)=DUZ(2) S XDX=$P($G(^ONCO(165.5,+XD2,0)),U,16) Q:XDT=XDX I $P($G(^ONCO(165.5,+XD2,1)),U,10)=XDT Q
Q:XD2'="" D SET Q
;
SET ;Create SUSPENSE (160.075) record
K DD,DO
S DA(1)=ONCIEN,DIC="^ONCO(160,"_DA(1)_",""SUS"","
S DIC(0)="L",DIC("P")=$P(^DD(160,75,0),U,2),X=XDT
D FILE^DICN K DO
S ^TMP("ONCO",$J,0)=^TMP("ONCO",$J,0)+1
K DIE S DA(1)=ONCIEN,DIE="^ONCO(160,"_DA(1)_",""SUS"","
S (ONCSUB,DA)=+Y,SR="L"_$E(LRSS),$P(^ONCO(160,ONCIEN,0),U,2)=LRDFN
S ONCMRPH=$E($P(LD,U,4),1,5) S:$E(ONCMRPH,5)=6 $E(ONCMRPH,5)=3 I '$D(^ONCO(164.1,ONCMRPH)) S ONCMRPH=""
S DR="1///^S X=DT;2///^S X=SR;3////^S X=DUZ(2);4////^S X=$P(LD,U,2);5////^S X=$P(LD,U,3);10////^S X=ONCMRPH;11///^S X=LRI;13////^S X=$P(LD,U,7)"
D ^DIE
Q
;
LOOP F S LRSDT=$O(^LR(LRXR,LRSDT)) Q:'LRSDT!(LRSDT>LRLDT) D LRDFN
Q
;
LRDFN S LRDFN=0 F S LRDFN=$O(^LR(LRXR,LRSDT,LRDFN)) Q:'LRDFN D @$S(LRSS'="AU":"LRI",1:"AU")
Q
;
LRI S LRI=0 F S LRI=$O(^LR(LRXR,LRSDT,LRDFN,LRI)) Q:'LRI D T
Q
;
T S T=0 F S T=$O(^LR(LRDFN,LRSS,LRI,2,T)) Q:'T S LRT=+^(T,0),TIS=$P($G(^LAB(61,LRT,0)),U,1),SNOMED=$P($G(^LAB(61,LRT,0)),U,2) D M
Q
;
M S M=0 F S M=$O(^LR(LRDFN,LRSS,LRI,2,T,2,M)) Q:'M S X=^(M,0),LRD=+X,LRM=$P(X,U,2) D MX I I Q
S DZX=0 F S DZX=$O(^LR(LRDFN,LRSS,LRI,2,T,1,DZX)) Q:'DZX D
.S DZPTR=$G(^LR(LRDFN,LRSS,LRI,2,T,1,DZX,0)) I DZPTR="" Q
.S DZCODE=$P($G(^LAB(61.4,+DZPTR,0)),U,2) I DZCODE="" Q
.I (DZCODE=4006)!((DZCODE>4078)&(DZCODE<4085)) D
..S DZMORP=$S(DZCODE=4006:99833,DZCODE=4079:99803,1:99823)
..S ^TMP($J,LRDFN,LRSDT)=LRSS_U_U_LRT_U_DZMORP_U_TIS_U_LRI_U_DZPTR
Q
;
MX Q:'$D(^LAB(61.1,LRD,0))
S W=^LAB(61.1,LRD,0),X=$P(W,U,2),Y=0 F Z=1:1 S Y=$O(LRN(Y)) Q:Y="" S Y(1)=LRM(Y),Y(2)=LRN(Y) D Y I I S ^TMP($J,LRDFN,LRSDT)=LRSS_U_LRD_U_LRT_U_X_U_TIS_U_LRI
Q
;
AU ;AUTOPSY
S LRI=9999999,T=0 F S T=$O(^LR(LRDFN,"AY",T)) Q:'T S LRT=+^(T,0),TIS=$P($G(^LAB(61,LRT,0)),U),SNOMED=$P($G(^LAB(61,LRT,0)),U,2) D AUM
Q
;
AUM S M=0 F S M=$O(^LR(LRDFN,"AY",T,2,M)) Q:'M S X=^(M,0),LRD=+X,LRM=$P(X,U,2) D MX
Q
;
Y ;Check for eligible cases
;Basal cell carcinomas
I SBCIND="NO",$E(X,1,3)=809 S I=0 Q
;Benign brain tumors
I SNOMED'="",($E(SNOMED,1,2)?1"X"1N)!($D(BBT(SNOMED))),$E(X,1)>7 S I=1 Q
;Squamous cell neoplasms of the skin
I SBCIND="NO",($E(X,1,3)=805)!($E(X,1,3)=806)!($E(X,1,3)=807)!($E(X,1,3)=808),($E(SNOMED,1,2)="01")!($E(SNOMED,1,2)="02") S I=0 Q
I $E(X,1,5)=Y(2) D Q
.S I=1
.I (X=74000)!(X=74006)!(X=74007)!(X=74008),($E(SNOMED,1,2)'=62)&($E(SNOMED,1,2)'=63)&($E(SNOMED,1,2)'=67) S I=0
S I=1 F I(1)=1:1:Y(1) S I(2)=$E(Y(2),I(1)) I I(2)'="*",I(2)'=$E(X,I(1)) S I=0 Q
Q
;
RPT ;Report
N ONCOST,ONCOEN
S ONCOST="L",ONCOEN="LS" G RPT^ONCOCFL
;
DIV ;Check division
;Supported by IA #5343
S DVMTCH=1,INST=""
I LRSS="AU" D
.S LBACC=$P($G(^LR(LRDFN,LRSS)),U,6)
.S LBYEAR=$P($G(^LR(LRDFN,LRSS)),U,1)
I LRSS'="AU" D
.S LBACC=$P($G(^LR(LRDFN,LRSS,LRI,0)),U,6)
.S LBYEAR=$P($G(^LR(LRDFN,LRSS,LRI,0)),U,1)
I (LBACC="")!(LBYEAR="") Q
I LBACC["LEGACY" S DVMTCH=0 Q
S LBAREA=$P(LBACC," ",1) I LBAREA="" Q
S LBNUM=$P(LBACC," ",3) I LBNUM="" Q
S ACCIEN=$O(^LRO(68,"B",LBAREA,"")) I ACCIEN="" Q
S LBYEAR=$E(LBYEAR,1,3)_"0000"
S INST=$G(^LRO(68,ACCIEN,1,LBYEAR,1,LBNUM,.4)) I INST="" Q
I AFFDIV'[INST S DVMTCH=0
Q
;
SNOMED ;Build SNOMED array for benign brain tumors
S BBT(45000)=""
S BBT(45010)=""
S BBT(45020)=""
S BBT(45030)=""
S BBT(45100)=""
S BBT(45110)=""
S BBT(45120)=""
S BBT(45300)=""
S BBT(45300)=""
S BBT(45301)=""
S BBT(45302)=""
S BBT(45303)=""
S BBT(45304)=""
S BBT(45305)=""
S BBT(45520)=""
S BBT(45521)=""
S BBT(45522)=""
S BBT(45523)=""
S BBT(45524)=""
S BBT(45525)=""
Q
;
EX ;KILL variables
D ^%ZISC
K %ZIS
K ACCIEN,AFFDIV,BBT,D,DA,DIC,DIE,DIR,DR,DVMTCH,DZCODE,DZMORP,DZPTR,DZX
K I,INST,LBACC,LBAREA,LBNUM,LBYEAR,LD,LRD,LRDFN,LRI,LRLDT,LRLST,LRM,LRN
K LRSDT,LRSS,LRSTR,LRT,LRXR,M,ONCDIVS,ONCDIVSP,ONCIEN,ONCMRPH,ONCO,ONCS
K ONCSUB,ONLDT,ONSDT,OSP,POP,SDDEF,SNOMED,SR,T,TIS,W,X,XD0,XD1,XD2,XDT
K XDX,Y,Z,SBCIND
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HONCOCFL1 7985 printed Apr 09, 2024@21:26:28 Page 2
ONCOCFL1 ;HINES OIFO/GWB - [CF Automatic Casefinding-Lab Search] ;10/21/11
+1 ;;2.2;ONCOLOGY;**1,10,15**;Jul 31, 2013;Build 5
+2 ;
+3 ;patch 10 - added new eligible cases
+4 ;
EN ;Start Date default
+1 SET SDDEF=$PIECE(^ONCO(160.1,OSP,0),U,5)
+2 IF SDDEF=""
SET SDDEF=DT
+3 SET SDDEF=$EXTRACT(SDDEF,4,5)_"-"_$EXTRACT(SDDEF,6,7)_"-"_($EXTRACT(SDDEF,1,3)+1700)
+4 ;
SD ;Start Date
+1 WRITE !
+2 KILL DIR
+3 SET DIR(0)="D"
+4 SET DIR("A")=" Start Date"
+5 SET DIR("B")=SDDEF
+6 DO ^DIR
+7 if (Y="")!(Y[U)
GOTO EX
+8 IF (Y>DT)
WRITE " Future dates not allowed"
GOTO SD
+9 SET (LRSDT,X)=Y
DO DD^%DT
WRITE " ",Y
+10 ;
ED ;End Date
+1 KILL DIR
+2 SET DIR(0)="D"
+3 SET DIR("A")=" End Date"
+4 DO ^DIR
+5 if (Y="")!(Y[U)
GOTO EX
+6 IF (Y<LRSDT)
WRITE " Invalid date sequence"
GOTO SD
+7 IF (Y>DT)
WRITE " Future dates not allowed"
GOTO ED
+8 SET $PIECE(^ONCO(160.1,OSP,0),U,5)=Y
+9 SET (LRLDT,X)=Y
DO DD^%DT
WRITE " ",Y
+10 SET Y=LRSDT
DO D^ONCOLRU
SET LRSTR=Y
+11 SET Y=LRLDT
DO D^ONCOLRU
SET LRLST=Y
+12 WRITE !
+13 KILL DIR
+14 SET DIR(0)="Y"
+15 SET DIR("A")=" Dates OK"
+16 SET DIR("B")="Y"
+17 DO ^DIR
+18 if (Y="")!(Y[U)
GOTO EX
+19 if 'Y
GOTO EN
+20 ;Include Squamous and Basal cell neoplasms (Y/N?)
+21 WRITE !
+22 SET SBCIND="NO"
+23 KILL DIR
+24 SET DIR(0)="Y"
+25 SET DIR("A")=" Include Squamous and Basal cell neoplasms"
+26 SET DIR("B")="Yes"
+27 SET DIR("?")=" "
+28 SET DIR("?",1)=" Answer 'YES' if you want to include squamous and basal cell neoplasms."
+29 SET DIR("?",2)=" Answer 'NO' if you want to exclude these neoplasms."
+30 DO ^DIR
+31 if (Y="")!(Y[U)
GOTO EX
+32 if Y=1
SET SBCIND="YES"
+33 KILL DIR
+34 ;patch 10 Add Urinary Tract Sites
+35 SET ONCO("SD")=LRSDT
SET ONCO("ED")=LRLDT
+36 SET LRSDT=LRSDT-.01
SET LRLDT=LRLDT+.99
+37 FOR X=8,9
FOR Y=1,2,3,4,5,6,7,9
SET Z=X_"***"_Y
SET LRM(Z)=5
SET LRN(Z)=Z
+38 SET LRM(67654)=5
SET LRN(67654)=67654
+39 SET LRM(67664)=5
SET LRN(67664)=67664
+40 SET LRM(67674)=5
SET LRN(67674)=67674
+41 SET LRM(67684)=5
SET LRN(67684)=67684
+42 SET LRM(69760)=5
SET LRN(69760)=69760
+43 SET LRM(74000)=5
SET LRN(74000)=74000
+44 SET LRM(74006)=5
SET LRN(74006)=74006
+45 SET LRM(74007)=5
SET LRN(74007)=74007
+46 SET LRM(74008)=5
SET LRN(74008)=74008
+47 WRITE !!?10,"This option will search for ICD-O morphology codes 800-998.",!
+48 WRITE !?10,"It will also search for High Grade Dysplasia of Stomach, Colon"
+49 WRITE !?10,"and Esophagus cases.",!
+50 WRITE !?10,"Exceptions to the above search criteria:",!
+51 WRITE !?10,"Behavior Code /0 (Benign) codes will be excluded."
+52 if SBCIND="NO"
WRITE !?10,"Squamous cell neoplasms (805-808) of the skin will be excluded."
+53 if SBCIND="NO"
WRITE !?10,"Basal cell neoplasms (809) will be excluded."
+54 WRITE !?10,"Benign tumors of the central nervous system will be included."
+55 WRITE !
+56 SET %ZIS="Q"
DO ^%ZIS
IF POP
GOTO EX
+57 IF '$DATA(IO("Q"))
DO SER^ONCOCFL1
GOTO EX
+58 SET ZTRTN="SER^ONCOCFL1"
SET ZTSAVE("LR*")=""
SET ZTSAVE("ONCO*")=""
SET ZTSAVE("SBCIND")=""
+59 SET ZTDESC="ONCOLOGY LAB SEARCH"
+60 DO ^%ZTLOAD
+61 KILL ZTDESC,ZTRTN,ZTSAVE
+62 GOTO EX
+63 ;
SER ;Search LAB DATA (63) file
+1 ;Supported by IA #525
+2 SET AFFDIV=$GET(DUZ(2))
SET ONCDIVSP=$ORDER(^ONCO(160.1,"C",AFFDIV,""))
+3 IF ONCDIVSP=""
WRITE !!,"User does not have an associated DIVISION.",!!
GOTO EX
+4 FOR Z=0:0
SET Z=$ORDER(^ONCO(160.1,ONCDIVSP,6,Z))
if Z'>0
QUIT
SET AFFDIV=AFFDIV_U_$GET(^ONCO(160.1,ONCDIVSP,6,Z,0))
+5 KILL ^TMP($JOB),^TMP("ONCO",$JOB)
+6 DO SNOMED
+7 SET ONSDT=LRSDT
SET ONLDT=LRLDT
+8 SET ^TMP("ONCO",$JOB,0)=0
+9 FOR LRSS="SP","CY","EM","AU"
SET LRXR="A"_LRSS
SET LRSDT=ONSDT
SET LRLDT=ONLDT
DO LOOP
+10 SET LRDFN=0
+11 FOR
SET LRDFN=$ORDER(^TMP($JOB,LRDFN))
if LRDFN=""
GOTO RPT
SET LRSDT=0
FOR
SET LRSDT=$ORDER(^TMP($JOB,LRDFN,LRSDT))
if LRSDT'>0
QUIT
SET LD=^(LRSDT)
SET LRSS=$PIECE(LD,U)
SET LRI=$PIECE(LD,U,6)
SET XDT=$SELECT(LRSS="AU":$PIECE(^LR(LRDFN,LRSS),U),1:$PIECE(^LR(LRDFN,LRSS,LRI,0),U,1))
SET XDT=$PIECE(XDT,".",1)
DO CK
+12 ;
CK ;Check ONCOLOGY PATIENT (160) file
+1 DO DIV
if DVMTCH=0
QUIT
+2 SET XD1=^LR(LRDFN,0)
if $PIECE(XD1,U,2)'=2
QUIT
SET X=$PIECE(XD1,U,3)
if '$DATA(^DPT(X))
QUIT
+3 SET X=X_";DPT("
SET XD0=$ORDER(^ONCO(160,"B",X,0))
SET ONCIEN=XD0
+4 IF XD0=""
KILL DO
SET D="B"
SET DIC="^ONCO(160,"
SET DIC(0)="Z"
DO FILE^DICN
KILL DO
SET ONCIEN=+Y
DO SET
QUIT
+5 IF XD0'=""
SET ONCDIVS=""
SET ONCS=""
FOR
SET ONCS=$ORDER(^ONCO(160,XD0,"SUS","C",ONCS))
if ONCS'>0
QUIT
SET ONCDIVS=ONCDIVS_U_ONCS
+6 IF ONCDIVS[DUZ(2)
QUIT
+7 if '$DATA(^ONCO(165.5,"C",ONCIEN))
GOTO SET
SET XD2=0
FOR
SET XD2=$ORDER(^ONCO(165.5,"C",ONCIEN,XD2))
if XD2=""
QUIT
IF $$DIV^ONCFUNC(XD2)=DUZ(2)
SET XDX=$PIECE($GET(^ONCO(165.5,+XD2,0)),U,16)
if XDT=XDX
QUIT
IF $PIECE($GET(^ONCO(165.5,+XD2,1)),U,10)=XDT
QUIT
+8 if XD2'=""
QUIT
DO SET
QUIT
+9 ;
SET ;Create SUSPENSE (160.075) record
+1 KILL DD,DO
+2 SET DA(1)=ONCIEN
SET DIC="^ONCO(160,"_DA(1)_",""SUS"","
+3 SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(160,75,0),U,2)
SET X=XDT
+4 DO FILE^DICN
KILL DO
+5 SET ^TMP("ONCO",$JOB,0)=^TMP("ONCO",$JOB,0)+1
+6 KILL DIE
SET DA(1)=ONCIEN
SET DIE="^ONCO(160,"_DA(1)_",""SUS"","
+7 SET (ONCSUB,DA)=+Y
SET SR="L"_$EXTRACT(LRSS)
SET $PIECE(^ONCO(160,ONCIEN,0),U,2)=LRDFN
+8 SET ONCMRPH=$EXTRACT($PIECE(LD,U,4),1,5)
if $EXTRACT(ONCMRPH,5)=6
SET $EXTRACT(ONCMRPH,5)=3
IF '$DATA(^ONCO(164.1,ONCMRPH))
SET ONCMRPH=""
+9 SET DR="1///^S X=DT;2///^S X=SR;3////^S X=DUZ(2);4////^S X=$P(LD,U,2);5////^S X=$P(LD,U,3);10////^S X=ONCMRPH;11///^S X=LRI;13////^S X=$P(LD,U,7)"
+10 DO ^DIE
+11 QUIT
+12 ;
LOOP FOR
SET LRSDT=$ORDER(^LR(LRXR,LRSDT))
if 'LRSDT!(LRSDT>LRLDT)
QUIT
DO LRDFN
+1 QUIT
+2 ;
LRDFN SET LRDFN=0
FOR
SET LRDFN=$ORDER(^LR(LRXR,LRSDT,LRDFN))
if 'LRDFN
QUIT
DO @$SELECT(LRSS'="AU":"LRI",1:"AU")
+1 QUIT
+2 ;
LRI SET LRI=0
FOR
SET LRI=$ORDER(^LR(LRXR,LRSDT,LRDFN,LRI))
if 'LRI
QUIT
DO T
+1 QUIT
+2 ;
T SET T=0
FOR
SET T=$ORDER(^LR(LRDFN,LRSS,LRI,2,T))
if 'T
QUIT
SET LRT=+^(T,0)
SET TIS=$PIECE($GET(^LAB(61,LRT,0)),U,1)
SET SNOMED=$PIECE($GET(^LAB(61,LRT,0)),U,2)
DO M
+1 QUIT
+2 ;
M SET M=0
FOR
SET M=$ORDER(^LR(LRDFN,LRSS,LRI,2,T,2,M))
if 'M
QUIT
SET X=^(M,0)
SET LRD=+X
SET LRM=$PIECE(X,U,2)
DO MX
IF I
QUIT
+1 SET DZX=0
FOR
SET DZX=$ORDER(^LR(LRDFN,LRSS,LRI,2,T,1,DZX))
if 'DZX
QUIT
Begin DoDot:1
+2 SET DZPTR=$GET(^LR(LRDFN,LRSS,LRI,2,T,1,DZX,0))
IF DZPTR=""
QUIT
+3 SET DZCODE=$PIECE($GET(^LAB(61.4,+DZPTR,0)),U,2)
IF DZCODE=""
QUIT
+4 IF (DZCODE=4006)!((DZCODE>4078)&(DZCODE<4085))
Begin DoDot:2
+5 SET DZMORP=$SELECT(DZCODE=4006:99833,DZCODE=4079:99803,1:99823)
+6 SET ^TMP($JOB,LRDFN,LRSDT)=LRSS_U_U_LRT_U_DZMORP_U_TIS_U_LRI_U_DZPTR
End DoDot:2
End DoDot:1
+7 QUIT
+8 ;
MX if '$DATA(^LAB(61.1,LRD,0))
QUIT
+1 SET W=^LAB(61.1,LRD,0)
SET X=$PIECE(W,U,2)
SET Y=0
FOR Z=1:1
SET Y=$ORDER(LRN(Y))
if Y=""
QUIT
SET Y(1)=LRM(Y)
SET Y(2)=LRN(Y)
DO Y
IF I
SET ^TMP($JOB,LRDFN,LRSDT)=LRSS_U_LRD_U_LRT_U_X_U_TIS_U_LRI
+2 QUIT
+3 ;
AU ;AUTOPSY
+1 SET LRI=9999999
SET T=0
FOR
SET T=$ORDER(^LR(LRDFN,"AY",T))
if 'T
QUIT
SET LRT=+^(T,0)
SET TIS=$PIECE($GET(^LAB(61,LRT,0)),U)
SET SNOMED=$PIECE($GET(^LAB(61,LRT,0)),U,2)
DO AUM
+2 QUIT
+3 ;
AUM SET M=0
FOR
SET M=$ORDER(^LR(LRDFN,"AY",T,2,M))
if 'M
QUIT
SET X=^(M,0)
SET LRD=+X
SET LRM=$PIECE(X,U,2)
DO MX
+1 QUIT
+2 ;
Y ;Check for eligible cases
+1 ;Basal cell carcinomas
+2 IF SBCIND="NO"
IF $EXTRACT(X,1,3)=809
SET I=0
QUIT
+3 ;Benign brain tumors
+4 IF SNOMED'=""
IF ($EXTRACT(SNOMED,1,2)?1"X"1N)!($DATA(BBT(SNOMED)))
IF $EXTRACT(X,1)>7
SET I=1
QUIT
+5 ;Squamous cell neoplasms of the skin
+6 IF SBCIND="NO"
IF ($EXTRACT(X,1,3)=805)!($EXTRACT(X,1,3)=806)!($EXTRACT(X,1,3)=807)!($EXTRACT(X,1,3)=808)
IF ($EXTRACT(SNOMED,1,2)="01")!($EXTRACT(SNOMED,1,2)="02")
SET I=0
QUIT
+7 IF $EXTRACT(X,1,5)=Y(2)
Begin DoDot:1
+8 SET I=1
+9 IF (X=74000)!(X=74006)!(X=74007)!(X=74008)
IF ($EXTRACT(SNOMED,1,2)'=62)&($EXTRACT(SNOMED,1,2)'=63)&($EXTRACT(SNOMED,1,2)'=67)
SET I=0
End DoDot:1
QUIT
+10 SET I=1
FOR I(1)=1:1:Y(1)
SET I(2)=$EXTRACT(Y(2),I(1))
IF I(2)'="*"
IF I(2)'=$EXTRACT(X,I(1))
SET I=0
QUIT
+11 QUIT
+12 ;
RPT ;Report
+1 NEW ONCOST,ONCOEN
+2 SET ONCOST="L"
SET ONCOEN="LS"
GOTO RPT^ONCOCFL
+3 ;
DIV ;Check division
+1 ;Supported by IA #5343
+2 SET DVMTCH=1
SET INST=""
+3 IF LRSS="AU"
Begin DoDot:1
+4 SET LBACC=$PIECE($GET(^LR(LRDFN,LRSS)),U,6)
+5 SET LBYEAR=$PIECE($GET(^LR(LRDFN,LRSS)),U,1)
End DoDot:1
+6 IF LRSS'="AU"
Begin DoDot:1
+7 SET LBACC=$PIECE($GET(^LR(LRDFN,LRSS,LRI,0)),U,6)
+8 SET LBYEAR=$PIECE($GET(^LR(LRDFN,LRSS,LRI,0)),U,1)
End DoDot:1
+9 IF (LBACC="")!(LBYEAR="")
QUIT
+10 IF LBACC["LEGACY"
SET DVMTCH=0
QUIT
+11 SET LBAREA=$PIECE(LBACC," ",1)
IF LBAREA=""
QUIT
+12 SET LBNUM=$PIECE(LBACC," ",3)
IF LBNUM=""
QUIT
+13 SET ACCIEN=$ORDER(^LRO(68,"B",LBAREA,""))
IF ACCIEN=""
QUIT
+14 SET LBYEAR=$EXTRACT(LBYEAR,1,3)_"0000"
+15 SET INST=$GET(^LRO(68,ACCIEN,1,LBYEAR,1,LBNUM,.4))
IF INST=""
QUIT
+16 IF AFFDIV'[INST
SET DVMTCH=0
+17 QUIT
+18 ;
SNOMED ;Build SNOMED array for benign brain tumors
+1 SET BBT(45000)=""
+2 SET BBT(45010)=""
+3 SET BBT(45020)=""
+4 SET BBT(45030)=""
+5 SET BBT(45100)=""
+6 SET BBT(45110)=""
+7 SET BBT(45120)=""
+8 SET BBT(45300)=""
+9 SET BBT(45300)=""
+10 SET BBT(45301)=""
+11 SET BBT(45302)=""
+12 SET BBT(45303)=""
+13 SET BBT(45304)=""
+14 SET BBT(45305)=""
+15 SET BBT(45520)=""
+16 SET BBT(45521)=""
+17 SET BBT(45522)=""
+18 SET BBT(45523)=""
+19 SET BBT(45524)=""
+20 SET BBT(45525)=""
+21 QUIT
+22 ;
EX ;KILL variables
+1 DO ^%ZISC
+2 KILL %ZIS
+3 KILL ACCIEN,AFFDIV,BBT,D,DA,DIC,DIE,DIR,DR,DVMTCH,DZCODE,DZMORP,DZPTR,DZX
+4 KILL I,INST,LBACC,LBAREA,LBNUM,LBYEAR,LD,LRD,LRDFN,LRI,LRLDT,LRLST,LRM,LRN
+5 KILL LRSDT,LRSS,LRSTR,LRT,LRXR,M,ONCDIVS,ONCDIVSP,ONCIEN,ONCMRPH,ONCO,ONCS
+6 KILL ONCSUB,ONLDT,ONSDT,OSP,POP,SDDEF,SNOMED,SR,T,TIS,W,X,XD0,XD1,XD2,XDT
+7 KILL XDX,Y,Z,SBCIND
+8 QUIT
