source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LREPICY.m@ 1751

LREPICY ;DALLAS/SED - EMERGING PATHOGENS SEARCH ; 5/1/98
 ;;5.2;LAB SERVICE;**175**;Sep 27, 1994
 ;
CY ;Check the 'CY' node
 S LRINV=LRBEG,ND="CY"
 Q:'$D(LRDFN)
 Q:'$D(^LR(LRDFN))
 F  S LRINV=$O(^LR(LRDFN,ND,LRINV)) Q:+LRINV'>0!(LRINV>LREND)  D
 .S LRCNT=1
 .I $P($G(^LR(LRDFN,ND,LRINV,0)),U,3)="" Q
 .I $D(^TMP($J,"ICD")) D
 ..S LRICDI=0
 ..F  S LRICDI=$O(^LR(LRDFN,ND,LRINV,3,LRICDI)) Q:+LRICDI'>0  D
 ...Q:'$D(^LR(LRDFN,ND,LRINV,3,LRICDI,0))
 ...S LRICD=$P(^LR(LRDFN,ND,LRINV,3,LRICDI,0),U,1)
 ...Q:'$D(^TMP($J,"ICD",+LRICD))
 ...;TOT S ^TMP($J,"ICD9",LRICD)=+$G(^TMP($J,"ICD9",LRICD))+1
 ...S LRPATH=0
 ...F  S LRPATH=$O(^TMP($J,"ICD",+LRICD,LRPATH)) Q:+LRPATH'>0  D ENCT^LREPI
 .Q:'$D(^LR(LRDFN,ND,LRINV,2,0))
 .I $D(^TMP($J,"SNO")) D
 ..S LRTOP=0
 ..F  S LRTOP=$O(^LR(LRDFN,ND,LRINV,2,LRTOP)) Q:+LRTOP'>0  D
 ...S LRTOPP=$P(^LR(LRDFN,ND,LRINV,2,LRTOP,0),U,1)
 ...S LRDISI=0
 ...F  S LRDISI=$O(^LR(LRDFN,ND,LRINV,2,LRTOP,1,LRDISI)) Q:+LRDISI'>0  D
 ....Q:'$D(^LR(LRDFN,ND,LRINV,2,LRTOP,1,LRDISI,0))
 ....S LRDIS=$P(^LR(LRDFN,ND,LRINV,2,LRTOP,1,LRDISI,0),U,1)
 ....S LRSNO=$P(^LAB(61.4,LRDIS,0),U,2)
 ....S LRSNM=$P(^LAB(61.4,LRDIS,0),U,1)
 ....D ENCT
 ...S LRPROI=0
 ...F  S LRPROI=$O(^LR(LRDFN,ND,LRINV,2,LRTOP,4,LRPROI)) Q:+LRPROI'>0  D
 ....Q:'$D(^LR(LRDFN,ND,LRINV,2,LRTOP,4,LRPROI,0))
 ....S LRPRO=$P(^LR(LRDFN,ND,LRINV,2,LRTOP,4,LRPROI,0),U,1)
 ....S LRSNO=$P(^LAB(61.5,LRPRO,0),U,2)
 ....S LRSNM=$P(^LAB(61.5,LRPRO,0),U,1)
 ....D ENCT
 ...;LOOK INTO MORPHOLOGY SUB GROUP
 ...S LRMORI=0
 ...F  S LRMORI=$O(^LR(LRDFN,ND,LRINV,2,LRTOP,2,LRMORI)) Q:+LRMORI'>0  D
 ....Q:'$D(^LR(LRDFN,ND,LRINV,2,LRTOP,2,LRMORI,0))
 ....S LRMOR=$P(^LR(LRDFN,ND,LRINV,2,LRTOP,2,LRMORI,0),U,1)
 ....S LRSNO=$P(^LAB(61.1,LRMOR,0),U,2)
 ....S LRSNM=$P(^LAB(61.1,LRMOR,0),U,1)
 ....D ENCT
 Q
ENCT ;CHECK TO SEE IF SCREEN ON FOR TOPOGRAHY
 S ^TMP($J,"STOT",LRSNO)=+$G(^TMP($J,"STOT",LRSNO))+1_U_LRSNM
 S ^TMP($J,"STOT",LRSNO,LRDFN)=""
 S LRPROT=$G(LRPROT,999999) S ^TMP($J,"SPROT",LRSNO,LRPROT)=""
 S LRPATH=0
 F  S LRPATH=$O(^TMP($J,"SNO",LRSNO,LRPATH)) Q:+LRPATH'>0  D
 .S LRSTOP=0 D
 ..I ($O(^LAB(69.5,LRPATH,5,0))="")&($O(^LAB(69.5,LRPATH,6,0))="") Q
 ..I ($O(^LAB(69.5,LRPATH,5,0))'="")&($O(^LAB(69.5,LRPATH,6,0))'="") Q
 ..I ($O(^LAB(69.5,LRPATH,5,0))'="")&($D(^LAB(69.5,LRPATH,5,"B",LRTOPP))) Q
 ..I ($O(^LAB(69.5,LRPATH,6,0))'="")&('$D(^LAB(69.5,LRPATH,6,"B",LRTOPP))) Q
 ..S LRSTOP=1
 .D:'LRSTOP ENCT^LREPI
 Q
CYTST ;Check the 'CY' node for test
 S LRINV=LRBEG,ND="CY"
 F  S LRINV=$O(^LR(LRDFN,ND,LRINV)) Q:+LRINV'>0!(LRINV>LREND)  D
 .I $P($G(^LR(LRDFN,ND,LRINV,0)),U,3)="" Q
 .Q:'$D(^LR(LRDFN,ND,LRINV,.1))
 .S LRCNT=1,LRCYSP=0
 .F  S LRCYSP=$O(^LR(LRDFN,ND,LRINV,.1,LRCYSP)) Q:+LRCYSP'>0  D
 ..Q:'$D(^LR(LRDFN,ND,LRINV,.1,LRCYSP,0))
 ..Q:$P(^LR(LRDFN,ND,LRINV,.1,LRCYSP,0),U,1)=""
 ..S LRTST=$P(^LR(LRDFN,ND,LRINV,.1,LRCYSP,0),U,2)
 ..Q:+LRTST'>0
 ..Q:'$D(^TMP($J,"T",LRTST))
 ..S LRPATH=0
 ..F  S LRPATH=$O(^TMP($J,"T",LRTST,LRPATH)) Q:+LRPATH'>0  D
 ...S ^TMP($J,"TST",LRTST)=+$G(^TMP($J,"TST",LRTST))+1
 ...S ^TMP($J,"TST",LRTST,LRDFN)=""
 ...D ENCT^LREPI
 K LRTST,LRND
 Q
 ;