source: FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOCFL1.m@ 1569

Last change on this file since 1569 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 6.2 KB
Line 
1ONCOCFL1 ;Hines OIFO/GWB - LAB CASEFINDING ;8/11/93
2 ;;2.11;ONCOLOGY;**25,26,27,28,29,32,33,43,44,46**;Mar 07, 1995;Build 39
3 ;
4EN ;Start Date/End Date
5 S SDDEF=$P(^ONCO(160.1,OSP,0),U,5)
6 I SDDEF="" S SDDEF=DT
7 S SDDEF=$E(SDDEF,4,5)_"-"_$E(SDDEF,6,7)_"-"_($E(SDDEF,1,3)+1700)
8 ;
9SD ;Start Date
10 W !
11 K DIR
12 S DIR(0)="D"
13 S DIR("A")=" Start Date"
14 S DIR("B")=SDDEF
15 D ^DIR
16 G EX:(Y="")!(Y[U)
17 I (Y>DT) W *7," Future dates not allowed" G SD
18 S (LRSDT,X)=Y D DD^%DT W " ",Y
19 ;
20ED ;End Date
21 K DIR
22 S DIR(0)="D"
23 S DIR("A")=" End Date"
24 D ^DIR
25 G EX:(Y="")!(Y[U)
26 I (Y<LRSDT) W *7," Invalid date sequence" G SD
27 I (Y>DT) W *7," Future dates not allowed" G ED
28 S $P(^ONCO(160.1,OSP,0),U,5)=Y
29 S (LRLDT,X)=Y D DD^%DT W " ",Y
30 S Y=LRSDT D D^ONCOLRU S LRSTR=Y
31 S Y=LRLDT D D^ONCOLRU S LRLST=Y
32 W !
33 K DIR
34 S DIR(0)="Y"
35 S DIR("A")=" Dates OK"
36 S DIR("B")="Y"
37 D ^DIR
38 G EX:(Y="")!(Y[U)
39 G EN:'Y
40 S ONCO("SD")=LRSDT,ONCO("ED")=LRLDT
41 S LRSDT=LRSDT-.01,LRLDT=LRLDT+.99
42 F X=8,9 F Y=1,2,3,6,9 S Z=X_"***"_Y,LRM(Z)=5,LRN(Z)=Z
43 S LRM(69760)=5,LRN(69760)=69760
44 W !!?10,"This option will search for ICD-O morphology codes 800-998.",!
45 W !?10,"Exceptions to the above search criteria:",!
46 W !?10,"Behavior Code /0 (Benign) codes will be excluded."
47 W !?10,"Squamous cell neoplasms (805-808) of the skin will be excluded."
48 W !?10,"Basal cell neoplasms (809) will be excluded."
49 W !?10,"Benign tumors of the central nervous system will be included."
50 W !
51 K IO("Q") S %ZIS="Q" D ^%ZIS I POP G EX
52 I '$D(IO("Q")) D SER^ONCOCFL1 G EX
53 S ZTRTN="SER^ONCOCFL1",ZTSAVE("LR*")="",ZTSAVE("ONCO*")=""
54 S ZTDESC="ONCOLOGY LAB SEARCH"
55 D ^%ZTLOAD
56 G EX
57 ;
58SER ;Search LAB DATA (63) file
59 S AFFDIV=$G(DUZ(2)),ONCDIVSP=$O(^ONCO(160.1,"C",AFFDIV,""))
60 I ONCDIVSP="" W !!,"User does not have an associated DIVISION.",!! G EX
61 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))
62 K ^TMP($J),^TMP("ONCO",$J)
63 D SNOMED
64 S ONSDT=LRSDT,ONLDT=LRLDT
65 S ^TMP("ONCO",$J,0)=0
66 F LRSS="SP","CY","EM","AU" S LRXR="A"_LRSS,LRSDT=ONSDT,LRLDT=ONLDT D LOOP
67 S LRDFN=0
68 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
69 ;
70CK ;Check ONCOLOGY PATIENT (160) file
71 D DIV Q:DVMTCH=0
72 S XD1=^LR(LRDFN,0) Q:$P(XD1,U,2)'=2 S X=$P(XD1,U,3) Q:'$D(^DPT(X))
73 S X=X_";DPT(",XD0=$O(^ONCO(160,"B",X,0)),ONCIEN=XD0
74 I XD0="" S D="B",DIC="^ONCO(160,",DIC(0)="Z" D FILE^DICN S ONCIEN=+Y D SET Q
75 I XD0'="" S ONCDIVS="",ONCS="" F S ONCS=$O(^ONCO(160,XD0,"SUS","C",ONCS)) Q:ONCS'>0 S ONCDIVS=ONCDIVS_U_ONCS
76 I ONCDIVS[DUZ(2) Q
77 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
78 Q:XD2'="" D SET Q
79 ;
80SET ;Create SUSPENSE (160.075) record
81 K DD,DO
82 S DA(1)=ONCIEN,DIC="^ONCO(160,"_DA(1)_",""SUS"","
83 S DIC(0)="L",DIC("P")=$P(^DD(160,75,0),U,2),X=XDT
84 D FILE^DICN
85 S ^TMP("ONCO",$J,0)=^TMP("ONCO",$J,0)+1
86 K DIE S DA(1)=ONCIEN,DIE="^ONCO(160,"_DA(1)_",""SUS"","
87 S (ONCSUB,DA)=+Y,SR="L"_$E(LRSS),$P(^ONCO(160,ONCIEN,0),U,2)=LRDFN
88 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=""
89 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)"
90 D ^DIE
91 Q
92 ;
93LOOP F S LRSDT=$O(^LR(LRXR,LRSDT)) Q:'LRSDT!(LRSDT>LRLDT) D LRDFN
94 Q
95 ;
96LRDFN S LRDFN=0 F S LRDFN=$O(^LR(LRXR,LRSDT,LRDFN)) Q:'LRDFN D @$S(LRSS'="AU":"LRI",1:"AU")
97 Q
98 ;
99LRI S LRI=0 F S LRI=$O(^LR(LRXR,LRSDT,LRDFN,LRI)) Q:'LRI D T
100 Q
101 ;
102T 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
103 Q
104 ;
105M 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
106 S DZX=0 F S DZX=$O(^LR(LRDFN,LRSS,LRI,2,T,1,DZX)) Q:'DZX D
107 .S DZPTR=$G(^LR(LRDFN,LRSS,LRI,2,T,1,DZX,0)) I DZPTR="" Q
108 .S DZCODE=$P($G(^LAB(61.4,+DZPTR,0)),U,2) I DZCODE="" Q
109 .I (DZCODE=4006)!((DZCODE>4078)&(DZCODE<4085)) D
110 ..S DZMORP=$S(DZCODE=4006:99833,DZCODE=4079:99803,1:99823)
111 ..S ^TMP($J,LRDFN,LRSDT)=LRSS_U_U_LRT_U_DZMORP_U_TIS_U_LRI_U_DZPTR
112 Q
113 ;
114MX 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
115 Q
116 ;
117AU ;AUTOPSY
118 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
119 Q
120 ;
121AUM 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
122 Q
123 ;
124Y ;Check for eligible cases
125 ;Basal cell carcinomas
126 I (X=80901)!(X=80903)!(X=80913)!(X=80923)!(X=80933)!(X=80943)!(X=80953) S I=0 Q
127 ;Benign brain tumors
128 I SNOMED'="",($E(SNOMED,1,2)?1"X"1N)!($D(BBT(SNOMED))),$E(X,1)>7 S I=1 Q
129 ;Squamous cell neoplasms of the skin
130 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
131 I $E(X,1,5)=Y(2) S I=1 Q
132 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
133 Q
134 ;
135RPT ;Report
136 S ONCOST="L",ONCOEN="LS" G RPT^ONCOCFL
137 ;
138EX ;Exit
139 D ^%ZISC
140 Q
141 ;
142DIV ;Check division
143 S DVMTCH=1,INST=""
144 I LRSS="AU" D
145 .S LBACC=$P($G(^LR(LRDFN,LRSS)),U,6)
146 .S LBYEAR=$P($G(^LR(LRDFN,LRSS)),U,1)
147 I LRSS'="AU" D
148 .S LBACC=$P($G(^LR(LRDFN,LRSS,LRI,0)),U,6)
149 .S LBYEAR=$P($G(^LR(LRDFN,LRSS,LRI,0)),U,1)
150 I (LBACC="")!(LBYEAR="") Q
151 I LBACC["LEGACY" S DVMTCH=0 Q
152 S LBAREA=$P(LBACC," ",1) I LBAREA="" Q
153 S LBNUM=$P(LBACC," ",3) I LBNUM="" Q
154 S ACCIEN=$O(^LRO(68,"B",LBAREA,"")) I ACCIEN="" Q
155 S LBYEAR=$E(LBYEAR,1,3)_"0000"
156 S INST=$G(^LRO(68,ACCIEN,1,LBYEAR,1,LBNUM,.4)) I INST="" Q
157 I AFFDIV'[INST S DVMTCH=0
158 Q
159 ;
160SNOMED ;Build SNOMED array for benign brain tumors
161 S BBT(45000)=""
162 S BBT(45010)=""
163 S BBT(45020)=""
164 S BBT(45030)=""
165 S BBT(45100)=""
166 S BBT(45110)=""
167 S BBT(45120)=""
168 S BBT(45300)=""
169 S BBT(45300)=""
170 S BBT(45301)=""
171 S BBT(45302)=""
172 S BBT(45303)=""
173 S BBT(45304)=""
174 S BBT(45305)=""
175 S BBT(45520)=""
176 S BBT(45521)=""
177 S BBT(45522)=""
178 S BBT(45523)=""
179 S BBT(45524)=""
180 S BBT(45525)=""
181 Q
Note: See TracBrowser for help on using the repository browser.