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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLREPICY 3156 printed Sep 23, 2025@19:49:58 Page 2
LREPICY ;DALLAS/SED - EMERGING PATHOGENS SEARCH ; 5/1/98
+1 ;;5.2;LAB SERVICE;**175**;Sep 27, 1994
+2 ;
CY ;Check the 'CY' node
+1 SET LRINV=LRBEG
SET ND="CY"
+2 if '$DATA(LRDFN)
QUIT
+3 if '$DATA(^LR(LRDFN))
QUIT
+4 FOR
SET LRINV=$ORDER(^LR(LRDFN,ND,LRINV))
if +LRINV'>0!(LRINV>LREND)
QUIT
Begin DoDot:1
+5 SET LRCNT=1
+6 IF $PIECE($GET(^LR(LRDFN,ND,LRINV,0)),U,3)=""
QUIT
+7 IF $DATA(^TMP($JOB,"ICD"))
Begin DoDot:2
+8 SET LRICDI=0
+9 FOR
SET LRICDI=$ORDER(^LR(LRDFN,ND,LRINV,3,LRICDI))
if +LRICDI'>0
QUIT
Begin DoDot:3
+10 if '$DATA(^LR(LRDFN,ND,LRINV,3,LRICDI,0))
QUIT
+11 SET LRICD=$PIECE(^LR(LRDFN,ND,LRINV,3,LRICDI,0),U,1)
+12 if '$DATA(^TMP($JOB,"ICD",+LRICD))
QUIT
+13 ;TOT S ^TMP($J,"ICD9",LRICD)=+$G(^TMP($J,"ICD9",LRICD))+1
+14 SET LRPATH=0
+15 FOR
SET LRPATH=$ORDER(^TMP($JOB,"ICD",+LRICD,LRPATH))
if +LRPATH'>0
QUIT
DO ENCT^LREPI
End DoDot:3
End DoDot:2
+16 if '$DATA(^LR(LRDFN,ND,LRINV,2,0))
QUIT
+17 IF $DATA(^TMP($JOB,"SNO"))
Begin DoDot:2
+18 SET LRTOP=0
+19 FOR
SET LRTOP=$ORDER(^LR(LRDFN,ND,LRINV,2,LRTOP))
if +LRTOP'>0
QUIT
Begin DoDot:3
+20 SET LRTOPP=$PIECE(^LR(LRDFN,ND,LRINV,2,LRTOP,0),U,1)
+21 SET LRDISI=0
+22 FOR
SET LRDISI=$ORDER(^LR(LRDFN,ND,LRINV,2,LRTOP,1,LRDISI))
if +LRDISI'>0
QUIT
Begin DoDot:4
+23 if '$DATA(^LR(LRDFN,ND,LRINV,2,LRTOP,1,LRDISI,0))
QUIT
+24 SET LRDIS=$PIECE(^LR(LRDFN,ND,LRINV,2,LRTOP,1,LRDISI,0),U,1)
+25 SET LRSNO=$PIECE(^LAB(61.4,LRDIS,0),U,2)
+26 SET LRSNM=$PIECE(^LAB(61.4,LRDIS,0),U,1)
+27 DO ENCT
End DoDot:4
+28 SET LRPROI=0
+29 FOR
SET LRPROI=$ORDER(^LR(LRDFN,ND,LRINV,2,LRTOP,4,LRPROI))
if +LRPROI'>0
QUIT
Begin DoDot:4
+30 if '$DATA(^LR(LRDFN,ND,LRINV,2,LRTOP,4,LRPROI,0))
QUIT
+31 SET LRPRO=$PIECE(^LR(LRDFN,ND,LRINV,2,LRTOP,4,LRPROI,0),U,1)
+32 SET LRSNO=$PIECE(^LAB(61.5,LRPRO,0),U,2)
+33 SET LRSNM=$PIECE(^LAB(61.5,LRPRO,0),U,1)
+34 DO ENCT
End DoDot:4
+35 ;LOOK INTO MORPHOLOGY SUB GROUP
+36 SET LRMORI=0
+37 FOR
SET LRMORI=$ORDER(^LR(LRDFN,ND,LRINV,2,LRTOP,2,LRMORI))
if +LRMORI'>0
QUIT
Begin DoDot:4
+38 if '$DATA(^LR(LRDFN,ND,LRINV,2,LRTOP,2,LRMORI,0))
QUIT
+39 SET LRMOR=$PIECE(^LR(LRDFN,ND,LRINV,2,LRTOP,2,LRMORI,0),U,1)
+40 SET LRSNO=$PIECE(^LAB(61.1,LRMOR,0),U,2)
+41 SET LRSNM=$PIECE(^LAB(61.1,LRMOR,0),U,1)
+42 DO ENCT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+43 QUIT
ENCT ;CHECK TO SEE IF SCREEN ON FOR TOPOGRAHY
+1 SET ^TMP($JOB,"STOT",LRSNO)=+$GET(^TMP($JOB,"STOT",LRSNO))+1_U_LRSNM
+2 SET ^TMP($JOB,"STOT",LRSNO,LRDFN)=""
+3 SET LRPROT=$GET(LRPROT,999999)
SET ^TMP($JOB,"SPROT",LRSNO,LRPROT)=""
+4 SET LRPATH=0
+5 FOR
SET LRPATH=$ORDER(^TMP($JOB,"SNO",LRSNO,LRPATH))
if +LRPATH'>0
QUIT
Begin DoDot:1
+6 SET LRSTOP=0
Begin DoDot:2
+7 IF ($ORDER(^LAB(69.5,LRPATH,5,0))="")&($ORDER(^LAB(69.5,LRPATH,6,0))="")
QUIT
+8 IF ($ORDER(^LAB(69.5,LRPATH,5,0))'="")&($ORDER(^LAB(69.5,LRPATH,6,0))'="")
QUIT
+9 IF ($ORDER(^LAB(69.5,LRPATH,5,0))'="")&($DATA(^LAB(69.5,LRPATH,5,"B",LRTOPP)))
QUIT
+10 IF ($ORDER(^LAB(69.5,LRPATH,6,0))'="")&('$DATA(^LAB(69.5,LRPATH,6,"B",LRTOPP)))
QUIT
+11 SET LRSTOP=1
End DoDot:2
+12 if 'LRSTOP
DO ENCT^LREPI
End DoDot:1
+13 QUIT
CYTST ;Check the 'CY' node for test
+1 SET LRINV=LRBEG
SET ND="CY"
+2 FOR
SET LRINV=$ORDER(^LR(LRDFN,ND,LRINV))
if +LRINV'>0!(LRINV>LREND)
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^LR(LRDFN,ND,LRINV,0)),U,3)=""
QUIT
+4 if '$DATA(^LR(LRDFN,ND,LRINV,.1))
QUIT
+5 SET LRCNT=1
SET LRCYSP=0
+6 FOR
SET LRCYSP=$ORDER(^LR(LRDFN,ND,LRINV,.1,LRCYSP))
if +LRCYSP'>0
QUIT
Begin DoDot:2
+7 if '$DATA(^LR(LRDFN,ND,LRINV,.1,LRCYSP,0))
QUIT
+8 if $PIECE(^LR(LRDFN,ND,LRINV,.1,LRCYSP,0),U,1)=""
QUIT
+9 SET LRTST=$PIECE(^LR(LRDFN,ND,LRINV,.1,LRCYSP,0),U,2)
+10 if +LRTST'>0
QUIT
+11 if '$DATA(^TMP($JOB,"T",LRTST))
QUIT
+12 SET LRPATH=0
+13 FOR
SET LRPATH=$ORDER(^TMP($JOB,"T",LRTST,LRPATH))
if +LRPATH'>0
QUIT
Begin DoDot:3
+14 SET ^TMP($JOB,"TST",LRTST)=+$GET(^TMP($JOB,"TST",LRTST))+1
+15 SET ^TMP($JOB,"TST",LRTST,LRDFN)=""
+16 DO ENCT^LREPI
End DoDot:3
End DoDot:2
End DoDot:1
+17 KILL LRTST,LRND
+18 QUIT
+19 ;
