- 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 Feb 18, 2025@23:40:11 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 ;
