source: FOIAVistA/trunk/r/ONCOLOGY-ONC/ONCOCFL1.m@ 1336

ONCOCFL1 ;Hines OIFO/GWB - LAB CASEFINDING  ;8/11/93
 ;;2.11;ONCOLOGY;**25,26,27,28,29,32,33,43,44,46**;Mar 07, 1995;Build 39
 ;
EN ;Start Date/End Date
 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 *7,"  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 *7,"  Invalid date sequence" G SD
 I (Y>DT) W *7,"  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
 S ONCO("SD")=LRSDT,ONCO("ED")=LRLDT
 S LRSDT=LRSDT-.01,LRLDT=LRLDT+.99
 F X=8,9 F Y=1,2,3,6,9 S Z=X_"***"_Y,LRM(Z)=5,LRN(Z)=Z
 S LRM(69760)=5,LRN(69760)=69760
 W !!?10,"This option will search for ICD-O morphology codes 800-998.",!
 W !?10,"Exceptions to the above search criteria:",!
 W !?10,"Behavior Code /0 (Benign) codes will be excluded."
 W !?10,"Squamous cell neoplasms (805-808) of the skin will be excluded."
 W !?10,"Basal cell neoplasms (809) will be excluded."
 W !?10,"Benign tumors of the central nervous system will be included."
 W !
 K IO("Q") 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*")=""
 S ZTDESC="ONCOLOGY LAB SEARCH"
 D ^%ZTLOAD
 G EX
 ;
SER ;Search LAB DATA (63) file
 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,10)),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="" S D="B",DIC="^ONCO(160,",DIC(0)="Z" D FILE^DICN 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
 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=^(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 (X=80901)!(X=80903)!(X=80913)!(X=80923)!(X=80933)!(X=80943)!(X=80953) 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 ($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) S I=1 Q
 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
 S ONCOST="L",ONCOEN="LS" G RPT^ONCOCFL
 ;
EX ;Exit
 D ^%ZISC
 Q
 ;
DIV ;Check division
 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