ONCOCFL1.m

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 ---ONCOCFL1   7985     printed  Mar 13, 2025@21:29:17                                                                                                                                                                                                    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      ;