LREPI ;VA/DALOI/SED-EMERGING PATHOGENS SEARCH ; 17-Oct-2014 09:22 ; MKK
;;5.2;LAB SERVICE;**132,175,1018,260,281,1030,1034**;NOV 01, 1997;Build 88
;
; Reference to ^DGPT supported by IA #418
; Reference to ^ICD9 supported by IA #10082
; Reference to ^ORD(101 supported by IA #872
; Reference to PATS^PXRMXX supported by IA #3134
TEST S LRRPS=3000501,LRRPE=3000531,LRRTYPE=1
S LREPI(2)="",LREPI(17)="",LREPI(18)="",LREPI(19)=""
;S D0=0 F S D0=$O(^LAB(69.5,D0)) Q:+D0'>0 D
;.Q:$P(^LAB(69.5,D0,0),U,2)="1"
;.Q:$P(^LAB(69.5,D0,0),U,7)=""
;.Q:'$D(^ORD(101,$P(^LAB(69.5,D0,0),U,7),0))
;.S LREPI(D0)=""
S LRBEG=9999999-(LRRPE+.9),LREND=9999999-LRRPS+.999999
EN ;
;
INIT ;Set up search criteria
;Fix start and stop date problem CKA 6/2/2002
S LRBEG=(9999999-LRRPE)_".0000001",LREND=9999999-LRRPS+.999999
K ^TMP($J),^TMP("HLS",$J)
S D0=0 F S D0=$O(LREPI(D0)) Q:+D0'>0 D
.S ^TMP($J,$P(^LAB(69.5,D0,0),U,7))=""
.S:$P(^LAB(69.5,D0,0),U,8)=1 ^TMP($J,"LREPI",D0)=""
.S LRPROT=$P(^LAB(69.5,D0,0),U,7)
.Q:LRPROT=""
.S D1=0 F S D1=$O(^LAB(69.5,D0,1,D1)) Q:+D1'>0 D
..S TST=$P(^LAB(69.5,D0,1,D1,0),U)
..Q:'$D(^LAB(60,TST,0))
..Q:$P(^LAB(60,TST,0),U,4)=""
..I $P(^LAB(60,TST,0),U,4)="CH" D
...Q:$P(^LAB(60,TST,0),U,5)=""
...S ^TMP($J,"T",TST,D0)=""
...S ^TMP($J,"TPROT",TST,LRPROT)=""
...S LRIND=$P(^LAB(69.5,D0,1,D1,0),U,2,3)
...S ^TMP($J,$P(^LAB(60,TST,0),U,4),TST)=$P(^LAB(60,TST,0),U,5)_U_LRIND
..I $P(^LAB(60,TST,0),U,4)="CY" D
...S ^TMP($J,"T",TST,D0)=""
...S ^TMP($J,$P(^LAB(60,TST,0),U,4),TST)=""
.S D1=0 F S D1=$O(^LAB(69.5,D0,2,D1)) Q:+D1'>0 S ^TMP($J,"E",$P(^LAB(69.5,D0,2,D1,0),U),D0)=""
.S D1=0 F S D1=$O(^LAB(69.5,D0,9,D1)) Q:+D1'>0 S ^TMP($J,"SNO",$P(^LAB(69.5,D0,9,D1,0),U),D0)=""
.S D1=0 F S D1=$O(^LAB(69.5,D0,3,D1)) Q:+D1'>0 S ^TMP($J,"ICD",$P(^LAB(69.5,D0,3,D1,0),U),D0)=""
K D0,D1,TST,LRIND
I $D(^TMP($J,"LREPI")) D SEARCH^LREPI4
I $D(^TMP($J,"ICD")) D PTF^LREPI5
LAB63 ;Search file 63 for lab data
K LRIND
S LRDFN=0 F S LRDFN=$O(^LR(LRDFN)) Q:+LRDFN'>0 D
.Q:'$D(^LR(LRDFN,0))
.Q:$P(^LR(LRDFN,0),U,2)'=2
.S LRPAT=$P(^LR(LRDFN,0),U,3)
.I $D(^TMP($J,"CH")) D CH
.I $D(^TMP($J,"CY")) D CYTST^LREPICY
.I $D(^TMP($J,"E")) D MI
.;I '$D(^TMP($J,"ICD"))&($D(^TMP($J,"SNO"))) D CY^LREPICY
.I $D(^TMP($J,"SNO")) D CY^LREPICY
;Retrieve patient list from Clinical Reminders
S LRPROTX=$O(^ORD(101,"B","LREPI",""))
I LRPROTX]"" S LRSRXX="",LRSRGO=0 F S LRSRXX=$O(LREPI(LRSRXX)) Q:'LRSRXX I $G(^LAB(69.5,LRSRXX,0))["HEPATITIS" D Q
. D PATS^PXRMXX(LRRPS,LRRPE,"LREPISRCH")
. S EPISRCH=0 F S EPISRCH=$O(^TMP("LREPISRCH",$J,EPISRCH)) Q:'EPISRCH D
. . S LRENCDT=$P(^TMP("LREPISRCH",$J,EPISRCH),"^") Q:'LRENCDT
. . Q:$D(^TMP($J,LRPROTX,EPISRCH,LRENCDT)) ;Encounter date already exists, don't update
. . S ^TMP($J,LRPROTX,EPISRCH,LRENCDT)=$P(^TMP("LREPISRCH",$J,EPISRCH),"^",2)
I $G(LRREP) D ^LREPI2A
I '$G(LRREP) D ^LREPI2
EXIT ;EXIT
S D0=0
I $G(LRRTYPE)=0 F S D0=$O(LREPI(D0)) Q:+D0'>0 D
.S $P(^LAB(69.5,D0,0),U,4)=DT
K LREPI,DFN,CNT,DA,DIE,DR,DQ,HL,ENTRY,ENDT,ENC,FD,HLECH,HLFS,HLN,HLQ
K DDER,D0,HLRST,HLSAN,LRBEG,LRCNT,LRCS,LRDATE,LRDFN,LREFG,LRENCDT
K LREND,LRETND,LRHL7,LRINV,LRINVD,LRITN,LRND,LRNL,LRNLT,LRNTE,LROBR
K LRPAT,LRPFG,LRPID,LRPROT,LRPV1,LRRPE,LRRPS,LRRTYPE,LRTND,LRTNM,MSG
K MSGCNT,PTF,RR,SEG,SP,STDT,TST,UN,TSTNM,VAERR,X,XCNP,XMDUZ,XMZ,ZTSK
K AF,D,DI,LRENT,LRIND,LRPATH,OV,LRENDT,ADMDT,EPISITE,EPISRCH
K LR31799Z,LRANTI,LRCHK,LRIC,LRIEN,LRIPT,LRMG,LRMGN,LRNX,LRO,LROK
K LROVR,LRPCNT,LRPTOT,LRSI,LRSITE,LRCYSP,LRDIS,LRDISI,LRIC,LRICD
K LRICDI,LRIEN,LRIPT,LRMG,LRMGN,LRMOR,LRMORI,LRMSG,PXRMITEM
K LRSNM,LRSNO,LRSTOP,LRSUB,LRTOP,LRTOPP,LRWKI,LRPRO,LRPROI
K LRNDC,LRNTE1,LRFIND,LRDRUG,LRCODE,LRDRSEQ,HLHDR,HLMTIEN,HLMTIENS
K HLNEXT,HLNODE,HLQUIT,HLRESLT,HLRESLTA,LRANS,LRDRSQ1,LRPROTX,LRPTY
K LRPVVV,LRSRGO,LRSRXX,LRTOLD,LRTRM,LRPREV,LRPRECYC,X1,X2,X3
K LRANTIND,LRANTINV,LRREP,LRPV1NUM
Q
ENCT ;SET THE ENCOUNTER FOR PV1
S LRPROT=$P(^LAB(69.5,LRPATH,0),U,7)
S LRCHK=0 D ADDCHK^LREPI5 Q:LRCHK
S LRDATE=9999999-LRINV
K VAIN,DFN,VAINDT S DFN=LRPAT,VAINDT=LRDATE D INP^VADPT
S LRENCDT=$S(VAIN(7)'="":$P(VAIN(7),U),1:LRDATE)
I $P(^LAB(69.5,LRPATH,0),U,8)=1 D CHECK^LREPI4
S:'$D(^TMP($J,LRPROT,LRPAT,LRENCDT)) ^TMP($J,LRPROT,LRPAT,LRENCDT)=$S(VAIN(7)'="":"I",1:"O")_U_$G(VAIN(10))
S:$P(^TMP($J,LRPROT,LRPAT,LRENCDT),U)="O" ^(LRENCDT)="O"_U_$S($D(LRPATLOC):LRPATLOC,1:"")
S:'$D(^TMP($J,LRPROT,LRPAT,LRENCDT,LRPATH,LRINV,ND)) ^TMP($J,LRPROT,LRPAT,LRENCDT,LRPATH,LRINV,ND)=""
I $G(LRANTIND)="",$G(LRANTINV)="" Q
S:'$D(^TMP($J,LRPROT,LRPATH,LRENCDT,LRPAT,LRINV,ND,LRANTIND,LRANTINV)) ^TMP($J,LRPROT,LRPAT,LRENCDT,LRPATH,LRINV,ND,LRANTIND,LRANTINV)=""
Q
CH ;Check the 'CH' node
S LRINV=LRBEG
F S LRINV=$O(^LR(LRDFN,"CH",LRINV)) Q:+LRINV'>0!(LRINV>LREND) D
.Q:$P(^LR(LRDFN,"CH",LRINV,0),U,3)=""
.S LRCNT=1,LRTST=0 F S LRTST=$O(^TMP($J,"CH",LRTST)) Q:+LRTST'>0 D
..S LRND=$P($P(^TMP($J,"CH",LRTST),";",2),U,1) Q:+LRND'>0
..S LRPC=$P($P(^TMP($J,"CH",LRTST),";",3),U,1) Q:+LRPC'>0
..S LRRES=$P($G(^LR(LRDFN,"CH",LRINV,LRND)),U,LRPC) Q:LRRES=""
..S LRPATLOC=$P(^LR(LRDFN,"CH",LRINV,0),U,13)
..S ^TMP($J,"TST",LRTST)=+$G(^TMP($J,"TST",LRTST))+1
..S ^TMP($J,"TST",LRTST,LRDFN)=""
..S LRPATH=0 F S LRPATH=$O(^TMP($J,"T",LRTST,LRPATH)) Q:+LRPATH'>0 D CHKIND
K LRTST,LRND,LRPC,LRRES,LRNO
Q
CHKIND ;Check the results
I '$D(^LAB(69.5,LRPATH,1,"B",LRTST)) Q
S LRITST=0,ND="CH",LRNO=0
F S LRITST=$O(^LAB(69.5,LRPATH,1,"B",LRTST,LRITST)) Q:+LRITST'>0 D D:'LRNO ENCT
.S LRNO=0
.S LRIND=$P(^LAB(69.5,LRPATH,1,LRITST,0),U,2,3)
.Q:$P(LRIND,U,1)=""
.I $P(LRIND,U,1)=1 D Q
..Q:'LRRES#2
..S LRSPEC=$P($G(^LR(LRDFN,"CH",LRINV,0)),U,5) Q:LRSPEC=""
..Q:'$D(^LAB(60,LRTST,1,LRSPEC,0))
..S LRLOW=$P(^LAB(60,LRTST,1,LRSPEC,0),U,2),LRHIG=$P(^(0),U,3)
..Q:'LRLOW#2!('LRHIG#2)
..I LRRES<LRLOW!(LRRES>LRHIG) Q
..S LRNO=1
.I $P(LRIND,U,2)="" Q
.S LRRES=$$UP^XLFSTR(LRRES),LRIND=$$UP^XLFSTR(LRIND)
.I $P(LRIND,U,1)=2,(LRRES[$P(LRIND,U,2)) Q
.I $P(LRIND,U,1)=3,(LRRES>$P(LRIND,U,2)) Q
.I $P(LRIND,U,1)=4,(LRRES<$P(LRIND,U,2)) Q
.I $P(LRIND,U,1)=5,(LRRES=$P(LRIND,U,2)) Q
.S LRNO=1
K LRITST,LRLOW,LRHIG,LRSPEC
Q
MI ;Check the 'MI' node
S LRINV=LRBEG
F S LRINV=$O(^LR(LRDFN,"MI",LRINV)) Q:+LRINV'>0!(LRINV>LREND) D
.S LRCNT=1
.F LRMIND=3,6,9,12,17 S LRETND=0 F S LRETND=$O(^LR(LRDFN,"MI",LRINV,LRMIND,LRETND)) Q:+LRETND'>0 D
..I LRMIND=3,$P($G(^LR(LRDFN,"MI",LRINV,1)),U,2)'="F" Q
..I LRMIND'=3,$P($G(^LR(LRDFN,"MI",LRINV,(LRMIND-1))),U,2)'="F" Q
..S LRETI=$P($G(^LR(LRDFN,"MI",LRINV,LRMIND,LRETND,0)),U)
..Q:+LRETI'>0
..Q:'$D(^TMP($J,"E",LRETI))
..S ^TMP($J,"EPROT",LRETI)=""
..S ^TMP($J,"ETI",LRETI)=+$G(^TMP($J,"ETI",LRETI))+1
..S ^TMP($J,"ETI",LRETI,LRDFN)=""
..S LRPATH=0 F S LRPATH=$O(^TMP($J,"E",LRETI,LRPATH)) Q:+LRPATH'>0 D
...S ND="MI"
...D TOP Q:LRTOP
...I LRMIND=3 D ANTI Q
...D ENCT
K LRMIND,LRETI
Q
TOP ;CHECK TO SEE IF SCREEN ON SITE
S LRTOP=0
S LRSITE=$P($G(^LR(LRDFN,"MI",LRINV,0)),U,5) Q:+LRSITE'>0
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",LRSITE))) Q
I ($O(^LAB(69.5,LRPATH,6,0))'="")&('$D(^LAB(69.5,LRPATH,6,"B",LRSITE))) Q
S LRTOP=1
Q
ANTI ;LOOK FOR THE ANTIMICROBIAL SUS FOR ORGANISMS
I $O(^LAB(69.5,LRPATH,4,0))="" D ENCT Q
S LRANTI=0 F S LRANTI=$O(^LAB(69.5,LRPATH,4,LRANTI)) Q:+LRANTI'>0 D
.S LRANT=$G(^LAB(69.5,LRPATH,4,LRANTI,0),U),LRANTIND=$P(^(0),U,2),LRANTINV=$P(^(0),U,3) Q:+LRANT'>0
.S LRAND=$P($G(^LAB(62.06,LRANT,0)),U,2) Q:LRAND=""
.Q:'$D(^LR(LRDFN,"MI",LRINV,LRMIND,LRETND,LRAND))
.Q:$P(^LR(LRDFN,"MI",LRINV,LRMIND,LRETND,LRAND),U,2)=""
.Q:$$UP^XLFSTR($E($P($G(^LR(LRDFN,"MI",LRINV,LRMIND,LRETND,LRAND)),U,2),1,1))="S"
.D ENCT
.;CHECK MIC VALUES
.I LRANTIND=""!(LRANTINV="") Q
.S LRRES=$$UP^XLFSTR($E($P($G(^LR(LRDFN,"MI",LRINV,LRMIND,LRETND,LRAND)),U,2),1,1)),LRANTINV=$$UP^XLFSTR(LRANTINV),LRANTIND=$$UP^XLFSTR(LRANTIND)
.I LRANTIND=1,(LRRES[LRANTINV) D ENCT Q
.I LRANTIND=2,(LRRES>LRANTINV) D ENCT Q
.I LRANTIND=3,(LRRES<LRANTINV) D ENCT Q
.I LRANTIND=4,(LRRES=LRANTINV) D ENCT Q
Q
;
LREPI ;VA/DALOI/SED-EMERGING PATHOGENS SEARCH ; 17-Oct-2014 09:22 ; MKK
+1 ;;5.2;LAB SERVICE;**132,175,1018,260,281,1030,1034**;NOV 01, 1997;Build 88
+2 ;
+3 ; Reference to ^DGPT supported by IA #418
+4 ; Reference to ^ICD9 supported by IA #10082
+5 ; Reference to ^ORD(101 supported by IA #872
+6 ; Reference to PATS^PXRMXX supported by IA #3134
TEST SET LRRPS=3000501
SET LRRPE=3000531
SET LRRTYPE=1
+1 SET LREPI(2)=""
SET LREPI(17)=""
SET LREPI(18)=""
SET LREPI(19)=""
+2 ;S D0=0 F S D0=$O(^LAB(69.5,D0)) Q:+D0'>0 D
+3 ;.Q:$P(^LAB(69.5,D0,0),U,2)="1"
+4 ;.Q:$P(^LAB(69.5,D0,0),U,7)=""
+5 ;.Q:'$D(^ORD(101,$P(^LAB(69.5,D0,0),U,7),0))
+6 ;.S LREPI(D0)=""
+7 SET LRBEG=9999999-(LRRPE+.9)
SET LREND=9999999-LRRPS+.999999
EN ;
+1 ;
INIT ;Set up search criteria
+1 ;Fix start and stop date problem CKA 6/2/2002
+2 SET LRBEG=(9999999-LRRPE)_".0000001"
SET LREND=9999999-LRRPS+.999999
+3 KILL ^TMP($JOB),^TMP("HLS",$JOB)
+4 SET D0=0
FOR
SET D0=$ORDER(LREPI(D0))
IF +D0'>0
QUIT
Begin DoDot:1
+5 SET ^TMP($JOB,$PIECE(^LAB(69.5,D0,0),U,7))=""
+6 IF $PIECE(^LAB(69.5,D0,0),U,8)=1
SET ^TMP($JOB,"LREPI",D0)=""
+7 SET LRPROT=$PIECE(^LAB(69.5,D0,0),U,7)
+8 IF LRPROT=""
QUIT
+9 SET D1=0
FOR
SET D1=$ORDER(^LAB(69.5,D0,1,D1))
IF +D1'>0
QUIT
Begin DoDot:2
+10 SET TST=$PIECE(^LAB(69.5,D0,1,D1,0),U)
+11 IF '$DATA(^LAB(60,TST,0))
QUIT
+12 IF $PIECE(^LAB(60,TST,0),U,4)=""
QUIT
+13 IF $PIECE(^LAB(60,TST,0),U,4)="CH"
Begin DoDot:3
+14 IF $PIECE(^LAB(60,TST,0),U,5)=""
QUIT
+15 SET ^TMP($JOB,"T",TST,D0)=""
+16 SET ^TMP($JOB,"TPROT",TST,LRPROT)=""
+17 SET LRIND=$PIECE(^LAB(69.5,D0,1,D1,0),U,2,3)
+18 SET ^TMP($JOB,$PIECE(^LAB(60,TST,0),U,4),TST)=$PIECE(^LAB(60,TST,0),U,5)_U_LRIND
End DoDot:3
+19 IF $PIECE(^LAB(60,TST,0),U,4)="CY"
Begin DoDot:3
+20 SET ^TMP($JOB,"T",TST,D0)=""
+21 SET ^TMP($JOB,$PIECE(^LAB(60,TST,0),U,4),TST)=""
End DoDot:3
End DoDot:2
+22 SET D1=0
FOR
SET D1=$ORDER(^LAB(69.5,D0,2,D1))
IF +D1'>0
QUIT
SET ^TMP($JOB,"E",$PIECE(^LAB(69.5,D0,2,D1,0),U),D0)=""
+23 SET D1=0
FOR
SET D1=$ORDER(^LAB(69.5,D0,9,D1))
IF +D1'>0
QUIT
SET ^TMP($JOB,"SNO",$PIECE(^LAB(69.5,D0,9,D1,0),U),D0)=""
+24 SET D1=0
FOR
SET D1=$ORDER(^LAB(69.5,D0,3,D1))
IF +D1'>0
QUIT
SET ^TMP($JOB,"ICD",$PIECE(^LAB(69.5,D0,3,D1,0),U),D0)=""
End DoDot:1
+25 KILL D0,D1,TST,LRIND
+26 IF $DATA(^TMP($JOB,"LREPI"))
DO SEARCH^LREPI4
+27 IF $DATA(^TMP($JOB,"ICD"))
DO PTF^LREPI5
LAB63 ;Search file 63 for lab data
+1 KILL LRIND
+2 SET LRDFN=0
FOR
SET LRDFN=$ORDER(^LR(LRDFN))
IF +LRDFN'>0
QUIT
Begin DoDot:1
+3 IF '$DATA(^LR(LRDFN,0))
QUIT
+4 IF $PIECE(^LR(LRDFN,0),U,2)'=2
QUIT
+5 SET LRPAT=$PIECE(^LR(LRDFN,0),U,3)
+6 IF $DATA(^TMP($JOB,"CH"))
DO CH
+7 IF $DATA(^TMP($JOB,"CY"))
DO CYTST^LREPICY
+8 IF $DATA(^TMP($JOB,"E"))
DO MI
+9 ;I '$D(^TMP($J,"ICD"))&($D(^TMP($J,"SNO"))) D CY^LREPICY
+10 IF $DATA(^TMP($JOB,"SNO"))
DO CY^LREPICY
End DoDot:1
+11 ;Retrieve patient list from Clinical Reminders
+12 SET LRPROTX=$ORDER(^ORD(101,"B","LREPI",""))
+13 IF LRPROTX]""
SET LRSRXX=""
SET LRSRGO=0
FOR
SET LRSRXX=$ORDER(LREPI(LRSRXX))
IF 'LRSRXX
QUIT
IF $GET(^LAB(69.5,LRSRXX,0))["HEPATITIS"
Begin DoDot:1
+14 DO PATS^PXRMXX(LRRPS,LRRPE,"LREPISRCH")
+15 SET EPISRCH=0
FOR
SET EPISRCH=$ORDER(^TMP("LREPISRCH",$JOB,EPISRCH))
IF 'EPISRCH
QUIT
Begin DoDot:2
+16 SET LRENCDT=$PIECE(^TMP("LREPISRCH",$JOB,EPISRCH),"^")
IF 'LRENCDT
QUIT
+17 ;Encounter date already exists, don't update
IF $DATA(^TMP($JOB,LRPROTX,EPISRCH,LRENCDT))
QUIT
+18 SET ^TMP($JOB,LRPROTX,EPISRCH,LRENCDT)=$PIECE(^TMP("LREPISRCH",$JOB,EPISRCH),"^",2)
End DoDot:2
End DoDot:1
QUIT
+19 IF $GET(LRREP)
DO ^LREPI2A
+20 IF '$GET(LRREP)
DO ^LREPI2
EXIT ;EXIT
+1 SET D0=0
+2 IF $GET(LRRTYPE)=0
FOR
SET D0=$ORDER(LREPI(D0))
IF +D0'>0
QUIT
Begin DoDot:1
+3 SET $PIECE(^LAB(69.5,D0,0),U,4)=DT
End DoDot:1
+4 KILL LREPI,DFN,CNT,DA,DIE,DR,DQ,HL,ENTRY,ENDT,ENC,FD,HLECH,HLFS,HLN,HLQ
+5 KILL DDER,D0,HLRST,HLSAN,LRBEG,LRCNT,LRCS,LRDATE,LRDFN,LREFG,LRENCDT
+6 KILL LREND,LRETND,LRHL7,LRINV,LRINVD,LRITN,LRND,LRNL,LRNLT,LRNTE,LROBR
+7 KILL LRPAT,LRPFG,LRPID,LRPROT,LRPV1,LRRPE,LRRPS,LRRTYPE,LRTND,LRTNM,MSG
+8 KILL MSGCNT,PTF,RR,SEG,SP,STDT,TST,UN,TSTNM,VAERR,X,XCNP,XMDUZ,XMZ,ZTSK
+9 KILL AF,D,DI,LRENT,LRIND,LRPATH,OV,LRENDT,ADMDT,EPISITE,EPISRCH
+10 KILL LR31799Z,LRANTI,LRCHK,LRIC,LRIEN,LRIPT,LRMG,LRMGN,LRNX,LRO,LROK
+11 KILL LROVR,LRPCNT,LRPTOT,LRSI,LRSITE,LRCYSP,LRDIS,LRDISI,LRIC,LRICD
+12 KILL LRICDI,LRIEN,LRIPT,LRMG,LRMGN,LRMOR,LRMORI,LRMSG,PXRMITEM
+13 KILL LRSNM,LRSNO,LRSTOP,LRSUB,LRTOP,LRTOPP,LRWKI,LRPRO,LRPROI
+14 KILL LRNDC,LRNTE1,LRFIND,LRDRUG,LRCODE,LRDRSEQ,HLHDR,HLMTIEN,HLMTIENS
+15 KILL HLNEXT,HLNODE,HLQUIT,HLRESLT,HLRESLTA,LRANS,LRDRSQ1,LRPROTX,LRPTY
+16 KILL LRPVVV,LRSRGO,LRSRXX,LRTOLD,LRTRM,LRPREV,LRPRECYC,X1,X2,X3
+17 KILL LRANTIND,LRANTINV,LRREP,LRPV1NUM
+18 QUIT
ENCT ;SET THE ENCOUNTER FOR PV1
+1 SET LRPROT=$PIECE(^LAB(69.5,LRPATH,0),U,7)
+2 SET LRCHK=0
DO ADDCHK^LREPI5
IF LRCHK
QUIT
+3 SET LRDATE=9999999-LRINV
+4 KILL VAIN,DFN,VAINDT
SET DFN=LRPAT
SET VAINDT=LRDATE
DO INP^VADPT
+5 SET LRENCDT=$SELECT(VAIN(7)'="":$PIECE(VAIN(7),U),1:LRDATE)
+6 IF $PIECE(^LAB(69.5,LRPATH,0),U,8)=1
DO CHECK^LREPI4
+7 IF '$DATA(^TMP($JOB,LRPROT,LRPAT,LRENCDT))
SET ^TMP($JOB,LRPROT,LRPAT,LRENCDT)=$SELECT(VAIN(7)'="":"I",1:"O")_U_$GET(VAIN(10))
+8 IF $PIECE(^TMP($JOB,LRPROT,LRPAT,LRENCDT),U)="O"
SET ^(LRENCDT)="O"_U_$SELECT($DATA(LRPATLOC):LRPATLOC,1:"")
+9 IF '$DATA(^TMP($JOB,LRPROT,LRPAT,LRENCDT,LRPATH,LRINV,ND))
SET ^TMP($JOB,LRPROT,LRPAT,LRENCDT,LRPATH,LRINV,ND)=""
+10 IF $GET(LRANTIND)=""
IF $GET(LRANTINV)=""
QUIT
+11 IF '$DATA(^TMP($JOB,LRPROT,LRPATH,LRENCDT,LRPAT,LRINV,ND,LRANTIND,LRANTINV))
SET ^TMP($JOB,LRPROT,LRPAT,LRENCDT,LRPATH,LRINV,ND,LRANTIND,LRANTINV)=""
+12 QUIT
CH ;Check the 'CH' node
+1 SET LRINV=LRBEG
+2 FOR
SET LRINV=$ORDER(^LR(LRDFN,"CH",LRINV))
IF +LRINV'>0!(LRINV>LREND)
QUIT
Begin DoDot:1
+3 IF $PIECE(^LR(LRDFN,"CH",LRINV,0),U,3)=""
QUIT
+4 SET LRCNT=1
SET LRTST=0
FOR
SET LRTST=$ORDER(^TMP($JOB,"CH",LRTST))
IF +LRTST'>0
QUIT
Begin DoDot:2
+5 SET LRND=$PIECE($PIECE(^TMP($JOB,"CH",LRTST),";",2),U,1)
IF +LRND'>0
QUIT
+6 SET LRPC=$PIECE($PIECE(^TMP($JOB,"CH",LRTST),";",3),U,1)
IF +LRPC'>0
QUIT
+7 SET LRRES=$PIECE($GET(^LR(LRDFN,"CH",LRINV,LRND)),U,LRPC)
IF LRRES=""
QUIT
+8 SET LRPATLOC=$PIECE(^LR(LRDFN,"CH",LRINV,0),U,13)
+9 SET ^TMP($JOB,"TST",LRTST)=+$GET(^TMP($JOB,"TST",LRTST))+1
+10 SET ^TMP($JOB,"TST",LRTST,LRDFN)=""
+11 SET LRPATH=0
FOR
SET LRPATH=$ORDER(^TMP($JOB,"T",LRTST,LRPATH))
IF +LRPATH'>0
QUIT
DO CHKIND
End DoDot:2
End DoDot:1
+12 KILL LRTST,LRND,LRPC,LRRES,LRNO
+13 QUIT
CHKIND ;Check the results
+1 IF '$DATA(^LAB(69.5,LRPATH,1,"B",LRTST))
QUIT
+2 SET LRITST=0
SET ND="CH"
SET LRNO=0
+3 FOR
SET LRITST=$ORDER(^LAB(69.5,LRPATH,1,"B",LRTST,LRITST))
IF +LRITST'>0
QUIT
Begin DoDot:1
+4 SET LRNO=0
+5 SET LRIND=$PIECE(^LAB(69.5,LRPATH,1,LRITST,0),U,2,3)
+6 IF $PIECE(LRIND,U,1)=""
QUIT
+7 IF $PIECE(LRIND,U,1)=1
Begin DoDot:2
+8 IF 'LRRES#2
QUIT
+9 SET LRSPEC=$PIECE($GET(^LR(LRDFN,"CH",LRINV,0)),U,5)
IF LRSPEC=""
QUIT
+10 IF '$DATA(^LAB(60,LRTST,1,LRSPEC,0))
QUIT
+11 SET LRLOW=$PIECE(^LAB(60,LRTST,1,LRSPEC,0),U,2)
SET LRHIG=$PIECE(^(0),U,3)
+12 IF 'LRLOW#2!('LRHIG#2)
QUIT
+13 IF LRRES<LRLOW!(LRRES>LRHIG)
QUIT
+14 SET LRNO=1
End DoDot:2
QUIT
+15 IF $PIECE(LRIND,U,2)=""
QUIT
+16 SET LRRES=$$UP^XLFSTR(LRRES)
SET LRIND=$$UP^XLFSTR(LRIND)
+17 IF $PIECE(LRIND,U,1)=2
IF (LRRES[$PIECE(LRIND,U,2))
QUIT
+18 IF $PIECE(LRIND,U,1)=3
IF (LRRES>$PIECE(LRIND,U,2))
QUIT
+19 IF $PIECE(LRIND,U,1)=4
IF (LRRES<$PIECE(LRIND,U,2))
QUIT
+20 IF $PIECE(LRIND,U,1)=5
IF (LRRES=$PIECE(LRIND,U,2))
QUIT
+21 SET LRNO=1
End DoDot:1
IF 'LRNO
DO ENCT
+22 KILL LRITST,LRLOW,LRHIG,LRSPEC
+23 QUIT
MI ;Check the 'MI' node
+1 SET LRINV=LRBEG
+2 FOR
SET LRINV=$ORDER(^LR(LRDFN,"MI",LRINV))
IF +LRINV'>0!(LRINV>LREND)
QUIT
Begin DoDot:1
+3 SET LRCNT=1
+4 FOR LRMIND=3,6,9,12,17
SET LRETND=0
FOR
SET LRETND=$ORDER(^LR(LRDFN,"MI",LRINV,LRMIND,LRETND))
IF +LRETND'>0
QUIT
Begin DoDot:2
+5 IF LRMIND=3
IF $PIECE($GET(^LR(LRDFN,"MI",LRINV,1)),U,2)'="F"
QUIT
+6 IF LRMIND'=3
IF $PIECE($GET(^LR(LRDFN,"MI",LRINV,(LRMIND-1))),U,2)'="F"
QUIT
+7 SET LRETI=$PIECE($GET(^LR(LRDFN,"MI",LRINV,LRMIND,LRETND,0)),U)
+8 IF +LRETI'>0
QUIT
+9 IF '$DATA(^TMP($JOB,"E",LRETI))
QUIT
+10 SET ^TMP($JOB,"EPROT",LRETI)=""
+11 SET ^TMP($JOB,"ETI",LRETI)=+$GET(^TMP($JOB,"ETI",LRETI))+1
+12 SET ^TMP($JOB,"ETI",LRETI,LRDFN)=""
+13 SET LRPATH=0
FOR
SET LRPATH=$ORDER(^TMP($JOB,"E",LRETI,LRPATH))
IF +LRPATH'>0
QUIT
Begin DoDot:3
+14 SET ND="MI"
+15 DO TOP
IF LRTOP
QUIT
+16 IF LRMIND=3
DO ANTI
QUIT
+17 DO ENCT
End DoDot:3
End DoDot:2
End DoDot:1
+18 KILL LRMIND,LRETI
+19 QUIT
TOP ;CHECK TO SEE IF SCREEN ON SITE
+1 SET LRTOP=0
+2 SET LRSITE=$PIECE($GET(^LR(LRDFN,"MI",LRINV,0)),U,5)
IF +LRSITE'>0
QUIT
+3 IF ($ORDER(^LAB(69.5,LRPATH,5,0))="")&($ORDER(^LAB(69.5,LRPATH,6,0))="")
QUIT
+4 IF ($ORDER(^LAB(69.5,LRPATH,5,0))'="")&($ORDER(^LAB(69.5,LRPATH,6,0))'="")
QUIT
+5 IF ($ORDER(^LAB(69.5,LRPATH,5,0))'="")&($DATA(^LAB(69.5,LRPATH,5,"B",LRSITE)))
QUIT
+6 IF ($ORDER(^LAB(69.5,LRPATH,6,0))'="")&('$DATA(^LAB(69.5,LRPATH,6,"B",LRSITE)))
QUIT
+7 SET LRTOP=1
+8 QUIT
ANTI ;LOOK FOR THE ANTIMICROBIAL SUS FOR ORGANISMS
+1 IF $ORDER(^LAB(69.5,LRPATH,4,0))=""
DO ENCT
QUIT
+2 SET LRANTI=0
FOR
SET LRANTI=$ORDER(^LAB(69.5,LRPATH,4,LRANTI))
IF +LRANTI'>0
QUIT
Begin DoDot:1
+3 SET LRANT=$GET(^LAB(69.5,LRPATH,4,LRANTI,0),U)
SET LRANTIND=$PIECE(^(0),U,2)
SET LRANTINV=$PIECE(^(0),U,3)
IF +LRANT'>0
QUIT
+4 SET LRAND=$PIECE($GET(^LAB(62.06,LRANT,0)),U,2)
IF LRAND=""
QUIT
+5 IF '$DATA(^LR(LRDFN,"MI",LRINV,LRMIND,LRETND,LRAND))
QUIT
+6 IF $PIECE(^LR(LRDFN,"MI",LRINV,LRMIND,LRETND,LRAND),U,2)=""
QUIT
+7 IF $$UP^XLFSTR($EXTRACT($PIECE($GET(^LR(LRDFN,"MI",LRINV,LRMIND,LRETND,LRAND)),U,2),1,1))="S"
QUIT
+8 DO ENCT
+9 ;CHECK MIC VALUES
+10 IF LRANTIND=""!(LRANTINV="")
QUIT
+11 SET LRRES=$$UP^XLFSTR($EXTRACT($PIECE($GET(^LR(LRDFN,"MI",LRINV,LRMIND,LRETND,LRAND)),U,2),1,1))
SET LRANTINV=$$UP^XLFSTR(LRANTINV)
SET LRANTIND=$$UP^XLFSTR(LRANTIND)
+12 IF LRANTIND=1
IF (LRRES[LRANTINV)
DO ENCT
QUIT
+13 IF LRANTIND=2
IF (LRRES>LRANTINV)
DO ENCT
QUIT
+14 IF LRANTIND=3
IF (LRRES<LRANTINV)
DO ENCT
QUIT
+15 IF LRANTIND=4
IF (LRRES=LRANTINV)
DO ENCT
QUIT
End DoDot:1
+16 QUIT
+17 ;
