Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LREPICY

LREPICY.m

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