source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LREPICY.m@ 724

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

initial load of WorldVistAEHR

File size: 3.0 KB
Line 
1LREPICY ;DALLAS/SED - EMERGING PATHOGENS SEARCH ; 5/1/98
2 ;;5.2;LAB SERVICE;**175**;Sep 27, 1994
3 ;
4CY ;Check the 'CY' node
5 S LRINV=LRBEG,ND="CY"
6 Q:'$D(LRDFN)
7 Q:'$D(^LR(LRDFN))
8 F S LRINV=$O(^LR(LRDFN,ND,LRINV)) Q:+LRINV'>0!(LRINV>LREND) D
9 .S LRCNT=1
10 .I $P($G(^LR(LRDFN,ND,LRINV,0)),U,3)="" Q
11 .I $D(^TMP($J,"ICD")) D
12 ..S LRICDI=0
13 ..F S LRICDI=$O(^LR(LRDFN,ND,LRINV,3,LRICDI)) Q:+LRICDI'>0 D
14 ...Q:'$D(^LR(LRDFN,ND,LRINV,3,LRICDI,0))
15 ...S LRICD=$P(^LR(LRDFN,ND,LRINV,3,LRICDI,0),U,1)
16 ...Q:'$D(^TMP($J,"ICD",+LRICD))
17 ...;TOT S ^TMP($J,"ICD9",LRICD)=+$G(^TMP($J,"ICD9",LRICD))+1
18 ...S LRPATH=0
19 ...F S LRPATH=$O(^TMP($J,"ICD",+LRICD,LRPATH)) Q:+LRPATH'>0 D ENCT^LREPI
20 .Q:'$D(^LR(LRDFN,ND,LRINV,2,0))
21 .I $D(^TMP($J,"SNO")) D
22 ..S LRTOP=0
23 ..F S LRTOP=$O(^LR(LRDFN,ND,LRINV,2,LRTOP)) Q:+LRTOP'>0 D
24 ...S LRTOPP=$P(^LR(LRDFN,ND,LRINV,2,LRTOP,0),U,1)
25 ...S LRDISI=0
26 ...F S LRDISI=$O(^LR(LRDFN,ND,LRINV,2,LRTOP,1,LRDISI)) Q:+LRDISI'>0 D
27 ....Q:'$D(^LR(LRDFN,ND,LRINV,2,LRTOP,1,LRDISI,0))
28 ....S LRDIS=$P(^LR(LRDFN,ND,LRINV,2,LRTOP,1,LRDISI,0),U,1)
29 ....S LRSNO=$P(^LAB(61.4,LRDIS,0),U,2)
30 ....S LRSNM=$P(^LAB(61.4,LRDIS,0),U,1)
31 ....D ENCT
32 ...S LRPROI=0
33 ...F S LRPROI=$O(^LR(LRDFN,ND,LRINV,2,LRTOP,4,LRPROI)) Q:+LRPROI'>0 D
34 ....Q:'$D(^LR(LRDFN,ND,LRINV,2,LRTOP,4,LRPROI,0))
35 ....S LRPRO=$P(^LR(LRDFN,ND,LRINV,2,LRTOP,4,LRPROI,0),U,1)
36 ....S LRSNO=$P(^LAB(61.5,LRPRO,0),U,2)
37 ....S LRSNM=$P(^LAB(61.5,LRPRO,0),U,1)
38 ....D ENCT
39 ...;LOOK INTO MORPHOLOGY SUB GROUP
40 ...S LRMORI=0
41 ...F S LRMORI=$O(^LR(LRDFN,ND,LRINV,2,LRTOP,2,LRMORI)) Q:+LRMORI'>0 D
42 ....Q:'$D(^LR(LRDFN,ND,LRINV,2,LRTOP,2,LRMORI,0))
43 ....S LRMOR=$P(^LR(LRDFN,ND,LRINV,2,LRTOP,2,LRMORI,0),U,1)
44 ....S LRSNO=$P(^LAB(61.1,LRMOR,0),U,2)
45 ....S LRSNM=$P(^LAB(61.1,LRMOR,0),U,1)
46 ....D ENCT
47 Q
48ENCT ;CHECK TO SEE IF SCREEN ON FOR TOPOGRAHY
49 S ^TMP($J,"STOT",LRSNO)=+$G(^TMP($J,"STOT",LRSNO))+1_U_LRSNM
50 S ^TMP($J,"STOT",LRSNO,LRDFN)=""
51 S LRPROT=$G(LRPROT,999999) S ^TMP($J,"SPROT",LRSNO,LRPROT)=""
52 S LRPATH=0
53 F S LRPATH=$O(^TMP($J,"SNO",LRSNO,LRPATH)) Q:+LRPATH'>0 D
54 .S LRSTOP=0 D
55 ..I ($O(^LAB(69.5,LRPATH,5,0))="")&($O(^LAB(69.5,LRPATH,6,0))="") Q
56 ..I ($O(^LAB(69.5,LRPATH,5,0))'="")&($O(^LAB(69.5,LRPATH,6,0))'="") Q
57 ..I ($O(^LAB(69.5,LRPATH,5,0))'="")&($D(^LAB(69.5,LRPATH,5,"B",LRTOPP))) Q
58 ..I ($O(^LAB(69.5,LRPATH,6,0))'="")&('$D(^LAB(69.5,LRPATH,6,"B",LRTOPP))) Q
59 ..S LRSTOP=1
60 .D:'LRSTOP ENCT^LREPI
61 Q
62CYTST ;Check the 'CY' node for test
63 S LRINV=LRBEG,ND="CY"
64 F S LRINV=$O(^LR(LRDFN,ND,LRINV)) Q:+LRINV'>0!(LRINV>LREND) D
65 .I $P($G(^LR(LRDFN,ND,LRINV,0)),U,3)="" Q
66 .Q:'$D(^LR(LRDFN,ND,LRINV,.1))
67 .S LRCNT=1,LRCYSP=0
68 .F S LRCYSP=$O(^LR(LRDFN,ND,LRINV,.1,LRCYSP)) Q:+LRCYSP'>0 D
69 ..Q:'$D(^LR(LRDFN,ND,LRINV,.1,LRCYSP,0))
70 ..Q:$P(^LR(LRDFN,ND,LRINV,.1,LRCYSP,0),U,1)=""
71 ..S LRTST=$P(^LR(LRDFN,ND,LRINV,.1,LRCYSP,0),U,2)
72 ..Q:+LRTST'>0
73 ..Q:'$D(^TMP($J,"T",LRTST))
74 ..S LRPATH=0
75 ..F S LRPATH=$O(^TMP($J,"T",LRTST,LRPATH)) Q:+LRPATH'>0 D
76 ...S ^TMP($J,"TST",LRTST)=+$G(^TMP($J,"TST",LRTST))+1
77 ...S ^TMP($J,"TST",LRTST,LRDFN)=""
78 ...D ENCT^LREPI
79 K LRTST,LRND
80 Q
81 ;
Note: See TracBrowser for help on using the repository browser.