- LREPI ;DALOI/SED - EMERGING PATHOGENS SEARCH ;Aug 20, 2021@09:32
- ;;5.2;LAB SERVICE;**132,175,260,281,421,509,552**;Sep 27, 1994;Build 2
- ;
- ; Reference to ^DGPT supported by IA #418
- ; 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
- ;LR*5.2*552: Correction for date range to scan. Added +1 to LRRPE.
- S LRBEG=(9999999-(LRRPE+1))_".0000001",LREND=9999999-LRRPS+.999999
- ; Determine which Coding to system to activate:
- ; If report beginning date and ending date are prior to ICDx effective date
- ; report will print patients with ICD diagnosis codes
- ; and for summary report, count only ICD codes.
- ; If report beginning date and ending date are on or after ICDx effective date
- ; report will print patients with ICDx diagnosis codes
- ; and for summary report, count only ICDx codes.
- ; If report beginning date is prior to ICDx effective date and report ending date is on or after ICDx effective date
- ; report will print patients that have either ALL valid diagnosis codes
- ; and count both ALL valid diagnosis codes.
- ;
- N LRBEGSYS,LRENDSYS
- S LRBEGSYS=+$$ICDSYS^LREPICD(LRRPS,"D"),LRENDSYS=+$$ICDSYS^LREPICD(LRRPE,"D")
- K LREPISYS S:LRBEGSYS=0 LRBEGSYS=9 S:LRENDSYS=0 LRENDSYS=9 F LREPISYS=LRBEGSYS:1:LRENDSYS S LREPISYS(LREPISYS)=""
- ;
- 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 D
- ..S LREPISYS=$S(+$P(^LAB(69.5,D0,3,D1,0),U,2)=30:10,1:9)
- ..S:$D(LREPISYS(LREPISYS))&($P(^LAB(69.5,D0,3,D1,0),U)]"") ^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") ;LR509: no longer collect Clinical Reminder info for EPI
- . 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,LREPISYS
- 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
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLREPI 9423 printed Feb 18, 2025@23:40:01 Page 2
- LREPI ;DALOI/SED - EMERGING PATHOGENS SEARCH ;Aug 20, 2021@09:32
- +1 ;;5.2;LAB SERVICE;**132,175,260,281,421,509,552**;Sep 27, 1994;Build 2
- +2 ;
- +3 ; Reference to ^DGPT supported by IA #418
- +4 ; Reference to ^ORD(101 supported by IA #872
- +5 ; 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 ;LR*5.2*552: Correction for date range to scan. Added +1 to LRRPE.
- +3 SET LRBEG=(9999999-(LRRPE+1))_".0000001"
- SET LREND=9999999-LRRPS+.999999
- +4 ; Determine which Coding to system to activate:
- +5 ; If report beginning date and ending date are prior to ICDx effective date
- +6 ; report will print patients with ICD diagnosis codes
- +7 ; and for summary report, count only ICD codes.
- +8 ; If report beginning date and ending date are on or after ICDx effective date
- +9 ; report will print patients with ICDx diagnosis codes
- +10 ; and for summary report, count only ICDx codes.
- +11 ; If report beginning date is prior to ICDx effective date and report ending date is on or after ICDx effective date
- +12 ; report will print patients that have either ALL valid diagnosis codes
- +13 ; and count both ALL valid diagnosis codes.
- +14 ;
- +15 NEW LRBEGSYS,LRENDSYS
- +16 SET LRBEGSYS=+$$ICDSYS^LREPICD(LRRPS,"D")
- SET LRENDSYS=+$$ICDSYS^LREPICD(LRRPE,"D")
- +17 KILL LREPISYS
- if LRBEGSYS=0
- SET LRBEGSYS=9
- if LRENDSYS=0
- SET LRENDSYS=9
- FOR LREPISYS=LRBEGSYS:1:LRENDSYS
- SET LREPISYS(LREPISYS)=""
- +18 ;
- +19 KILL ^TMP($JOB),^TMP("HLS",$JOB)
- +20 SET D0=0
- FOR
- SET D0=$ORDER(LREPI(D0))
- if +D0'>0
- QUIT
- Begin DoDot:1
- +21 SET ^TMP($JOB,$PIECE(^LAB(69.5,D0,0),U,7))=""
- +22 if $PIECE(^LAB(69.5,D0,0),U,8)=1
- SET ^TMP($JOB,"LREPI",D0)=""
- +23 SET LRPROT=$PIECE(^LAB(69.5,D0,0),U,7)
- +24 if LRPROT=""
- QUIT
- +25 SET D1=0
- FOR
- SET D1=$ORDER(^LAB(69.5,D0,1,D1))
- if +D1'>0
- QUIT
- Begin DoDot:2
- +26 SET TST=$PIECE(^LAB(69.5,D0,1,D1,0),U)
- +27 if '$DATA(^LAB(60,TST,0))
- QUIT
- +28 if $PIECE(^LAB(60,TST,0),U,4)=""
- QUIT
- +29 IF $PIECE(^LAB(60,TST,0),U,4)="CH"
- Begin DoDot:3
- +30 if $PIECE(^LAB(60,TST,0),U,5)=""
- QUIT
- +31 SET ^TMP($JOB,"T",TST,D0)=""
- +32 SET ^TMP($JOB,"TPROT",TST,LRPROT)=""
- +33 SET LRIND=$PIECE(^LAB(69.5,D0,1,D1,0),U,2,3)
- +34 SET ^TMP($JOB,$PIECE(^LAB(60,TST,0),U,4),TST)=$PIECE(^LAB(60,TST,0),U,5)_U_LRIND
- End DoDot:3
- +35 IF $PIECE(^LAB(60,TST,0),U,4)="CY"
- Begin DoDot:3
- +36 SET ^TMP($JOB,"T",TST,D0)=""
- +37 SET ^TMP($JOB,$PIECE(^LAB(60,TST,0),U,4),TST)=""
- End DoDot:3
- End DoDot:2
- +38 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)=""
- +39 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)=""
- +40 SET D1=0
- FOR
- SET D1=$ORDER(^LAB(69.5,D0,3,D1))
- if +D1'>0
- QUIT
- Begin DoDot:2
- +41 SET LREPISYS=$SELECT(+$PIECE(^LAB(69.5,D0,3,D1,0),U,2)=30:10,1:9)
- +42 if $DATA(LREPISYS(LREPISYS))&($PIECE(^LAB(69.5,D0,3,D1,0),U)]"")
- SET ^TMP($JOB,"ICD",$PIECE(^LAB(69.5,D0,3,D1,0),U),D0)=""
- End DoDot:2
- End DoDot:1
- +43 KILL D0,D1,TST,LRIND
- +44 IF $DATA(^TMP($JOB,"LREPI"))
- DO SEARCH^LREPI4
- +45 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 ;D PATS^PXRMXX(LRRPS,LRRPE,"LREPISRCH") ;LR509: no longer collect Clinical Reminder info for EPI
- +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,LREPISYS
- +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 ;