MMRSIPC ;MIA/LMT - Print MRSA IPEC Report ;Oct 18, 2018@15:12
;;1.0;MRSA PROGRAM TOOLS;**3,5,7,10**;Mar 22, 2009;Build 2
;
; Reference to ^DG(41.9 in ICR #5433
;
;This is the main routine to print the MRSA IPEC Report.
;This routine uses functions contained in MMRSIPC2, MMRSIPC3, and MMRSIPC4.
MAIN ;
N NUMDIV,MMRSDIV,MMRSLOC,EXTFLG,STRTDT,ENDDT,PRTSUM,BYADM
D CHECK
D CHECK2
I $D(EXTFLG) W ! H 2 Q
W !
S MMRSDIV=$$GETDIV Q:$D(EXTFLG)!(MMRSDIV="")
D CHECK3
I $D(EXTFLG) W ! H 2 Q
D PROMPT Q:$D(EXTFLG)
D ASKDVC Q:$D(EXTFLG)
K MMRSSUM
Q
CHECK ;Check if parameters are setup
N NUMDIV,MMRSDIV
S NUMDIV=0
S MMRSDIV=0 F S MMRSDIV=$O(^MMRS(104,MMRSDIV)) Q:'MMRSDIV I $D(^MMRS(104,MMRSDIV,0)) S NUMDIV=NUMDIV+1
I NUMDIV=0 D
.W !!," >>> Make sure a division has been setup using option:"
.W !," 'MRSA Tools Parameter Setup (Main)'"
.S EXTFLG=1
Q
CHECK2 ;Check if lab tests and etiologies are setup
N TSTSTP,MRSAETIO,MRSASTAP,ORG,ETIONAME,MMRSET,MMRSI
S TSTSTP=0
I $D(^LAB(60,"B","MRSA SURVL NARES DNA"))!($D(^LAB(60,"B","MRSA SURVL NARES AGAR"))) S TSTSTP=1
I $O(^LAB(60,"B","MRSA SURVL NARES DNA"))["MRSA SURVL NARES DNA" S TSTSTP=1
I $O(^LAB(60,"B","MRSA SURVL NARES AGAR"))["MRSA SURVL NARES AGAR" S TSTSTP=1
I 'TSTSTP D
.S EXTFLG=1
.W !!," >>> Make sure the MRSA CH-subscripted tests have been setup according"
.W !," to the National Guidelines. Laboratory needs to setup at least"
.W !," one of these lab tests in the system before generating reports:"
.W !," 1. 'MRSA SURVL NARES DNA'"
.W !," 2. 'MRSA SURVL NARES AGAR'"
S MRSAETIO=0
;S MRSASTAP="STAPHYLOCOCCUS AUREUS METH" F S MRSASTAP=$O(^LAB(61.2,"B",MRSASTAP)) Q:MRSASTAP=""!(MRSASTAP]"STAPHYLOCOCCUS AUREUSZ") D
;.S ORG=0 F S ORG=$O(^LAB(61.2,"B",MRSASTAP,ORG)) Q:'ORG D
;..S ETIONAME=$P($G(^LAB(61.2,ORG,0)),U,1)
;..I ETIONAME["STAPHYLOCOCCUS AUREUS METHICILLIN RESISTANT (MRSA)" S MRSAETIO=ORG
D FIND^DIC(61.2,,".01E;@","PM","STAPHYLOCOCCUS AUREUS METHICILLIN RESISTANT",,"B",,,"MMRSET")
S MMRSI="" F S MMRSI=$O(MMRSET("DILIST",MMRSI)) Q:MMRSI="" I +MMRSI>0 D
.S ETIONAME=$P($G(MMRSET("DILIST",MMRSI,0)),U,2)
.S ORG=$P($G(MMRSET("DILIST",MMRSI,0)),U,1)
.I ETIONAME["STAPHYLOCOCCUS AUREUS METHICILLIN RESISTANT" S MRSAETIO=ORG
I 'MRSAETIO D
.S EXTFLG=1
.W !!," >>> Make sure the Etiology has been setup according "
.W !," to the National Guidelines. The following etiology "
.W !," must be added to the Etiology Field file (#61.2):"
.W !," 'STAPHYLOCOCCUS AUREUS METHICILLIN RESISTANT (MRSA)' "
Q
CHECK3 ;Check if Ward Mappings have been setup for this division
N NUMLOC,MMRSLOC
S NUMLOC=0
S MMRSLOC=0 F S MMRSLOC=$O(^MMRS(104.3,MMRSLOC)) Q:'MMRSLOC I $P($G(^MMRS(104.3,MMRSLOC,0)),U,2)=MMRSDIV S NUMLOC=NUMLOC+1
I NUMLOC=0 W !!," >>> Make sure the Ward Mappings for each Geographical Unit has been setup.",!! S EXTFLG=1
Q
MAIN2 ; Entry for queuing
N ODOBS
D CLEAN ;Kill Temp Global
D GETPARAM ; Load parameters in temp global
D GETMOVE^MMRSIPC2 ;Get movements and store in temp global
D GETLABS^MMRSIPC3 ;Get swabbing rates and MRSA history and store in temp global
I 'BYADM D PATDAYS ;Get patient days of care
D PRINT^MMRSIPC4 ;Print report
D CLEAN ;Kill Temp Global
Q
CLEAN ;
K ^TMP($J,"MMRSIPC")
Q
GETDIV() ;Prompt user to select Division
N MMRSDIV,COUNT,DIV,DIC,Y,DLAYGO,X,DTOUT,DUOUT
S MMRSDIV=""
S COUNT=0,DIV=0 F S DIV=$O(^MMRS(104,DIV)) Q:'DIV S COUNT=COUNT+1
I COUNT=1 S MMRSDIV=$O(^MMRS(104,0)) Q MMRSDIV
S DIC="^DG(40.8,"
S DIC(0)="AEMQ"
S DIC("A")="Select the Division: "
S DIC("S")="I $D(^MMRS(104,""B"",Y))"
D ^DIC K DIC
I $D(DTOUT)!($D(DUOUT))!(Y=-1) S EXTFLG=1 Q ""
S MMRSDIV=+Y
S MMRSDIV=$O(^MMRS(104,"B",MMRSDIV,0))
Q MMRSDIV
PROMPT ;Prompts user for start date, end date, locations, and if user wants to only print the Summary Report.
;Prompt if should run report by Admission or Discharge
N DIR,DIRUT,PRMPTTXT,Y
S DIR(0)="S^A:Admission Report;D:Discharge/Transmission Report"
S DIR("A")="Run (A)dmission Or (D)ischarge/Transmission Report"
D ^DIR K DIR
I $D(DIRUT) S EXTFLG=1 Q
I Y="A" S BYADM=1,PRMPTTXT="ward admission"
I Y="D" S BYADM=0,PRMPTTXT="ward discharge"
DATE ;Prompts user for date range
N %DT,X
K Y
W ! S %DT="AEPX",%DT("A")="Begin with "_PRMPTTXT_" date: " D ^%DT
I Y<0 S EXTFLG=1 Q
S STRTDT=Y
S %DT("A")="End with "_PRMPTTXT_" date: " D ^%DT
I Y<0 S EXTFLG=1 Q
S ENDDT=Y
I '$P(ENDDT,".",2) S ENDDT=Y+.24
I ENDDT<STRTDT W !!,"The ending date of the range must be later than the starting date." G DATE
LOC ;Prompts user for locations
W !
S DIR(0)="YA",DIR("A")="Do you want to select all locations? ",DIR("B")="NO"
D ^DIR K DIR
I $D(DIRUT) S EXTFLG=1 Q
I Y=1 D G SUMRPT
.S Y=0 F S Y=$O(^MMRS(104.3,Y)) Q:'Y I $P($G(^MMRS(104.3,Y,0)),U,2)=MMRSDIV S MMRSLOC(Y)=""
;PROMPT FOR WARDS
N DIC,DLAYGO,DTOUT,DUOUT
W !
S DIC("A")="Select Geographical Location: "
S DIC("S")="I $P($G(^MMRS(104.3,Y,0)),U,2)="_MMRSDIV
S DIC="^MMRS(104.3,",DIC(0)="QEAM" D ^DIC
I (Y=-1)!($D(DTOUT))!($D(DUOUT)) S EXTFLG=1 Q
S MMRSLOC(+Y)=""
S DIC("A")="Select another Geographical Location: " F D ^DIC Q:Y=-1 S MMRSLOC(+Y)=""
K DIC
I ($D(DTOUT))!($D(DUOUT)) S EXTFLG=1 Q
SUMRPT ;Prompt user if should only run the summary report.
I $G(MMRSSUM) S PRTSUM=1 Q ; IF OPTION IS ONLY FOR SUMMARY REPORT...
W !
S DIR(0)="Y"
S DIR("A")="Do you want to only print the summary report"
S DIR("B")="NO"
D ^DIR K DIR
I $D(DIRUT) S EXTFLG=1 Q
S PRTSUM=Y
Q
ASKDVC ;Prompts user for device of output (allows queuing)
N MMRSVAR,ZTSK
W !! W:'PRTSUM !,"This report is designed for a 176 column format (landscape).",!
S MMRSVAR("STRTDT")="",MMRSVAR("ENDDT")="",MMRSVAR("MMRSLOC(")=""
S MMRSVAR("PRTSUM")="",MMRSVAR("BYADM")="",MMRSVAR("MMRSDIV")=""
D EN^XUTMDEVQ("MAIN2^MMRSIPC","PRINT MRSA IPEC REPORT",.MMRSVAR,"QM",1)
W:$D(ZTSK) !,"Report Queued to Print ("_ZTSK_").",!
Q
GETPARAM ;(MDRO) ; Loads lab search/extract parameters from file 104.1
N MRSAMDRO,TSTNM,TST,MDRO,TEST,IEN,TIEN,ITOP,TOP,ETOP,IBACT,BACT,EBACT
N ETIOL,ETIOLOGY,ANTI,ANTIM,INC,MRSASTAP,ETIONAME,MMRSI,MMRSET,ORG
S MRSAMDRO=$O(^MMRS(104.2,"B","MRSA",0))
S INC=0
S TSTNM="MRSA SURVL NARES DN"
F S TSTNM=$O(^LAB(60,"B",TSTNM)) Q:TSTNM=""!(TSTNM]"MRSA SURVL NARES DNA~zzz") D
.I TSTNM'["MRSA SURVL NARES DNA" Q
.S TST=0 F S TST=$O(^LAB(60,"B",TSTNM,TST)) Q:'TST D
..S INC=INC+1
..S ^TMP($J,"MMRSIPC","T","MRSA_SCREEN",TST_"_"_INC,0)="2^POS"
..S ^TMP($J,"MMRSIPC","T",MRSAMDRO,TST_"_"_INC,0)="2^POS"
..S INC=INC+1
..S ^TMP($J,"MMRSIPC","T","MRSA_SCREEN",TST_"_"_INC,0)="5^DETECTED"
..S ^TMP($J,"MMRSIPC","T",MRSAMDRO,TST_"_"_INC,0)="5^DETECTED"
S TSTNM="MRSA SURVL NARES AGA"
F S TSTNM=$O(^LAB(60,"B",TSTNM)) Q:TSTNM=""!(TSTNM]"MRSA SURVL NARES AGAR~zzz") D
.I TSTNM'["MRSA SURVL NARES AGAR" Q
.S TST=0 F S TST=$O(^LAB(60,"B",TSTNM,TST)) Q:'TST D
..S INC=INC+1
..S ^TMP($J,"MMRSIPC","T","MRSA_SCREEN",TST_"_"_INC,0)="2^POS"
..S ^TMP($J,"MMRSIPC","T",MRSAMDRO,TST_"_"_INC,0)="2^POS"
S TSTNM="MRSA SURVL OTHER DN"
F S TSTNM=$O(^LAB(60,"B",TSTNM)) Q:TSTNM=""!(TSTNM]"MRSA SURVL OTHER DNA~zzz") D
.I TSTNM'["MRSA SURVL OTHER DNA" Q
.S TST=0 F S TST=$O(^LAB(60,"B",TSTNM,TST)) Q:'TST D
..S INC=INC+1
..S ^TMP($J,"MMRSIPC","T","MRSA_SURV",TST_"_"_INC,0)="2^POS"
..S ^TMP($J,"MMRSIPC","T",MRSAMDRO,TST_"_"_INC,0)="2^POS"
..S INC=INC+1
..S ^TMP($J,"MMRSIPC","T","MRSA_SURV",TST_"_"_INC,0)="5^DETECTED"
..S ^TMP($J,"MMRSIPC","T",MRSAMDRO,TST_"_"_INC,0)="5^DETECTED"
S TSTNM="MRSA SURVL OTHER AGA"
F S TSTNM=$O(^LAB(60,"B",TSTNM)) Q:TSTNM=""!(TSTNM]"MRSA SURVL OTHER AGAR~zzz") D
.I TSTNM'["MRSA SURVL OTHER AGAR" Q
.S TST=0 F S TST=$O(^LAB(60,"B",TSTNM,TST)) Q:'TST D
..S INC=INC+1
..S ^TMP($J,"MMRSIPC","T","MRSA_SURV",TST_"_"_INC,0)="2^POS"
..S ^TMP($J,"MMRSIPC","T",MRSAMDRO,TST_"_"_INC,0)="2^POS"
S IEN="" F S IEN=$O(^MMRS(104.1,"D",MMRSDIV,IEN)) Q:'IEN D
.S MDRO=$P($G(^MMRS(104.1,IEN,0)),U,1)
.Q:'MDRO
.S TIEN=0 F S TIEN=$O(^MMRS(104.1,IEN,3,TIEN)) Q:'TIEN D
..S TEST=$P($G(^MMRS(104.1,IEN,3,TIEN,0)),U,1)
..Q:'TEST
..S INC=INC+1
..S ^TMP($J,"MMRSIPC","T",MDRO,TEST_"_"_INC,0)=$P($G(^MMRS(104.1,IEN,3,TIEN,0)),U,2,3)
.;S ITOP=0 F S ITOP=$O(^MMRS(104.1,IEN,1,ITOP)) Q:'ITOP D
.;.S TOP=$G(^MMRS(104.1,IEN,1,ITOP,0))
.;.I TOP S ^TMP($J,"MMRSIPC","TOP",MDRO,"INC_TOP",TOP)=""
.;S ETOP=0 F S ETOP=$O(^MMRS(104.1,IEN,2,ETOP)) Q:'ETOP D
.;.S TOP=$G(^MMRS(104.1,IEN,2,ETOP,0))
.;.I TOP S ^TMP($J,"MMRSIPC","TOP",MDRO,"EXC_TOP",TOP)=""
.S IBACT=0 F S IBACT=$O(^MMRS(104.1,IEN,4,IBACT)) Q:'IBACT D
..S BACT=$G(^MMRS(104.1,IEN,4,IBACT,0))
..I BACT'="" S ^TMP($J,"MMRSIPC","BACT",MDRO,"INC_REMARK",IBACT)=BACT
.S EBACT=0 F S EBACT=$O(^MMRS(104.1,IEN,5,EBACT)) Q:'EBACT D
..S BACT=$G(^MMRS(104.1,IEN,5,EBACT,0))
..I BACT'="" S ^TMP($J,"MMRSIPC","BACT",MDRO,"EXC_REMARK",EBACT)=BACT
.S ETIOL=0 F S ETIOL=$O(^MMRS(104.1,IEN,6,ETIOL)) Q:'ETIOL D
..S ETIOLOGY=$G(^MMRS(104.1,IEN,6,ETIOL,0))
..Q:'ETIOLOGY
..S ^TMP($J,"MMRSIPC","ETIOL",MDRO,+ETIOLOGY)=""
..S ANTI=0 F S ANTI=$O(^MMRS(104.1,IEN,6,ETIOL,1,ANTI)) Q:'ANTI D
...S ANTIM=$P($G(^MMRS(104.1,IEN,6,ETIOL,1,ANTI,0)),U)
...I ANTIM S ^TMP($J,"MMRSIPC","ETIOL",MDRO,ETIOLOGY,ANTI)=$G(^MMRS(104.1,IEN,6,ETIOL,1,ANTI,0))
D FIND^DIC(61.2,,".01E;@","PM","STAPHYLOCOCCUS AUREUS METHICILLIN RESISTANT",,"B",,,"MMRSET")
S MMRSI="" F S MMRSI=$O(MMRSET("DILIST",MMRSI)) Q:MMRSI="" I +MMRSI>0 D
.S ETIONAME=$P($G(MMRSET("DILIST",MMRSI,0)),U,2)
.S ORG=$P($G(MMRSET("DILIST",MMRSI,0)),U,1)
.I ETIONAME'["STAPHYLOCOCCUS AUREUS METHICILLIN RESISTANT" Q
.K ^TMP($J,"MMRSIPC","ETIOL",MRSAMDRO,ORG)
.S ^TMP($J,"MMRSIPC","ETIOL","MRSA_CULTURE",ORG)=""
.S ^TMP($J,"MMRSIPC","ETIOL",MRSAMDRO,ORG)=""
Q
PATDAYS ;Gets 'PATIENT DAYS OF CARE'.
N TTLRSLT,SDT,EDT,LOC,RSLT,WLOC,WARD,PATDAYS,LOCNAME
S TTLRSLT=0
S SDT=$P(STRTDT,".")
S EDT=$P(ENDDT,".")
S LOC=0 F S LOC=$O(MMRSLOC(LOC)) Q:'LOC D
.S RSLT=0
.S WLOC=0 F S WLOC=$O(^MMRS(104.3,LOC,1,WLOC)) Q:'WLOC D
..S WARD=$P($G(^MMRS(104.3,LOC,1,WLOC,0)),U,1) I 'WARD Q
..S PATDAYS=$$GETPATDY(WARD,SDT,EDT)
..;bdoc are calculated by patients on ward @ midnight
..;+ oneday admissions (patients admitted and discharged on same day).
..;in order not to double-count oneday obs patient admitted to acute care
..;on same day, adjus obs count.
..I $G(ODOBS(WARD)) S PATDAYS=PATDAYS-ODOBS(WARD)
..S RSLT=RSLT+PATDAYS,TTLRSLT=TTLRSLT+PATDAYS
..S LOCNAME=$P($G(^MMRS(104.3,LOC,0)),U)
..S $P(^TMP($J,"MMRSIPC","DSUM",LOCNAME),U,1)=RSLT
S $P(^TMP($J,"MMRSIPC","DSUM"),U,1)=TTLRSLT
Q
GETPATDY(WARD,SDT,EDT) ;Helper function for PATDAYS() - Gets Patient Days of care for specific ward
N SCUMPD,ECUMPD
I SDT>EDT Q 0
I SDT<($$FY(EDT)_"1001") Q ($$GETPATDY(WARD,SDT,($$FY(EDT)_"0930"))+$$GETPATDY(WARD,($$FY(EDT)_"1001"),EDT))
;MMRS*1.0*10: Comment out line below since the "B" index
; is DINUM'd and since some sites are missing
; random "B" index entries for an unknown reason.
;S CENSUS=$O(^DG(41.9,"B",WARD,0)) I 'CENSUS Q 0
S SDT=$$FMADD^XLFDT(SDT,-1,0,0,0)
;MMRS*1.0*10: Replace CENSUS with WARD for SCUMPD and ECUMPD.
S SCUMPD=$P($G(^DG(41.9,WARD,"C",SDT,0)),U,3)
I EDT=$$DT^XLFDT S EDT=$$FMADD^XLFDT(EDT,-1,0,0,0)
S ECUMPD=$P($G(^DG(41.9,WARD,"C",EDT,0)),U,3)
I $E(SDT,4,7)="0930" S SCUMPD=0 ; IF LAST DAY OF FY
Q ECUMPD-SCUMPD
FY(DATE) ;Helper function for GETPATDY - Gets fiscal year for the specified date
I $E(DATE,4,7)>("1000"),$E(DATE,4,7)<("1232") Q $E(DATE,1,3)
Q ($E(DATE,1,3)-1)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMMRSIPC 11799 printed Oct 16, 2024@18:15:57 Page 2
MMRSIPC ;MIA/LMT - Print MRSA IPEC Report ;Oct 18, 2018@15:12
+1 ;;1.0;MRSA PROGRAM TOOLS;**3,5,7,10**;Mar 22, 2009;Build 2
+2 ;
+3 ; Reference to ^DG(41.9 in ICR #5433
+4 ;
+5 ;This is the main routine to print the MRSA IPEC Report.
+6 ;This routine uses functions contained in MMRSIPC2, MMRSIPC3, and MMRSIPC4.
MAIN ;
+1 NEW NUMDIV,MMRSDIV,MMRSLOC,EXTFLG,STRTDT,ENDDT,PRTSUM,BYADM
+2 DO CHECK
+3 DO CHECK2
+4 IF $DATA(EXTFLG)
WRITE !
HANG 2
QUIT
+5 WRITE !
+6 SET MMRSDIV=$$GETDIV
if $DATA(EXTFLG)!(MMRSDIV="")
QUIT
+7 DO CHECK3
+8 IF $DATA(EXTFLG)
WRITE !
HANG 2
QUIT
+9 DO PROMPT
if $DATA(EXTFLG)
QUIT
+10 DO ASKDVC
if $DATA(EXTFLG)
QUIT
+11 KILL MMRSSUM
+12 QUIT
CHECK ;Check if parameters are setup
+1 NEW NUMDIV,MMRSDIV
+2 SET NUMDIV=0
+3 SET MMRSDIV=0
FOR
SET MMRSDIV=$ORDER(^MMRS(104,MMRSDIV))
if 'MMRSDIV
QUIT
IF $DATA(^MMRS(104,MMRSDIV,0))
SET NUMDIV=NUMDIV+1
+4 IF NUMDIV=0
Begin DoDot:1
+5 WRITE !!," >>> Make sure a division has been setup using option:"
+6 WRITE !," 'MRSA Tools Parameter Setup (Main)'"
+7 SET EXTFLG=1
End DoDot:1
+8 QUIT
CHECK2 ;Check if lab tests and etiologies are setup
+1 NEW TSTSTP,MRSAETIO,MRSASTAP,ORG,ETIONAME,MMRSET,MMRSI
+2 SET TSTSTP=0
+3 IF $DATA(^LAB(60,"B","MRSA SURVL NARES DNA"))!($DATA(^LAB(60,"B","MRSA SURVL NARES AGAR")))
SET TSTSTP=1
+4 IF $ORDER(^LAB(60,"B","MRSA SURVL NARES DNA"))["MRSA SURVL NARES DNA"
SET TSTSTP=1
+5 IF $ORDER(^LAB(60,"B","MRSA SURVL NARES AGAR"))["MRSA SURVL NARES AGAR"
SET TSTSTP=1
+6 IF 'TSTSTP
Begin DoDot:1
+7 SET EXTFLG=1
+8 WRITE !!," >>> Make sure the MRSA CH-subscripted tests have been setup according"
+9 WRITE !," to the National Guidelines. Laboratory needs to setup at least"
+10 WRITE !," one of these lab tests in the system before generating reports:"
+11 WRITE !," 1. 'MRSA SURVL NARES DNA'"
+12 WRITE !," 2. 'MRSA SURVL NARES AGAR'"
End DoDot:1
+13 SET MRSAETIO=0
+14 ;S MRSASTAP="STAPHYLOCOCCUS AUREUS METH" F S MRSASTAP=$O(^LAB(61.2,"B",MRSASTAP)) Q:MRSASTAP=""!(MRSASTAP]"STAPHYLOCOCCUS AUREUSZ") D
+15 ;.S ORG=0 F S ORG=$O(^LAB(61.2,"B",MRSASTAP,ORG)) Q:'ORG D
+16 ;..S ETIONAME=$P($G(^LAB(61.2,ORG,0)),U,1)
+17 ;..I ETIONAME["STAPHYLOCOCCUS AUREUS METHICILLIN RESISTANT (MRSA)" S MRSAETIO=ORG
+18 DO FIND^DIC(61.2,,".01E;@","PM","STAPHYLOCOCCUS AUREUS METHICILLIN RESISTANT",,"B",,,"MMRSET")
+19 SET MMRSI=""
FOR
SET MMRSI=$ORDER(MMRSET("DILIST",MMRSI))
if MMRSI=""
QUIT
IF +MMRSI>0
Begin DoDot:1
+20 SET ETIONAME=$PIECE($GET(MMRSET("DILIST",MMRSI,0)),U,2)
+21 SET ORG=$PIECE($GET(MMRSET("DILIST",MMRSI,0)),U,1)
+22 IF ETIONAME["STAPHYLOCOCCUS AUREUS METHICILLIN RESISTANT"
SET MRSAETIO=ORG
End DoDot:1
+23 IF 'MRSAETIO
Begin DoDot:1
+24 SET EXTFLG=1
+25 WRITE !!," >>> Make sure the Etiology has been setup according "
+26 WRITE !," to the National Guidelines. The following etiology "
+27 WRITE !," must be added to the Etiology Field file (#61.2):"
+28 WRITE !," 'STAPHYLOCOCCUS AUREUS METHICILLIN RESISTANT (MRSA)' "
End DoDot:1
+29 QUIT
CHECK3 ;Check if Ward Mappings have been setup for this division
+1 NEW NUMLOC,MMRSLOC
+2 SET NUMLOC=0
+3 SET MMRSLOC=0
FOR
SET MMRSLOC=$ORDER(^MMRS(104.3,MMRSLOC))
if 'MMRSLOC
QUIT
IF $PIECE($GET(^MMRS(104.3,MMRSLOC,0)),U,2)=MMRSDIV
SET NUMLOC=NUMLOC+1
+4 IF NUMLOC=0
WRITE !!," >>> Make sure the Ward Mappings for each Geographical Unit has been setup.",!!
SET EXTFLG=1
+5 QUIT
MAIN2 ; Entry for queuing
+1 NEW ODOBS
+2 ;Kill Temp Global
DO CLEAN
+3 ; Load parameters in temp global
DO GETPARAM
+4 ;Get movements and store in temp global
DO GETMOVE^MMRSIPC2
+5 ;Get swabbing rates and MRSA history and store in temp global
DO GETLABS^MMRSIPC3
+6 ;Get patient days of care
IF 'BYADM
DO PATDAYS
+7 ;Print report
DO PRINT^MMRSIPC4
+8 ;Kill Temp Global
DO CLEAN
+9 QUIT
CLEAN ;
+1 KILL ^TMP($JOB,"MMRSIPC")
+2 QUIT
GETDIV() ;Prompt user to select Division
+1 NEW MMRSDIV,COUNT,DIV,DIC,Y,DLAYGO,X,DTOUT,DUOUT
+2 SET MMRSDIV=""
+3 SET COUNT=0
SET DIV=0
FOR
SET DIV=$ORDER(^MMRS(104,DIV))
if 'DIV
QUIT
SET COUNT=COUNT+1
+4 IF COUNT=1
SET MMRSDIV=$ORDER(^MMRS(104,0))
QUIT MMRSDIV
+5 SET DIC="^DG(40.8,"
+6 SET DIC(0)="AEMQ"
+7 SET DIC("A")="Select the Division: "
+8 SET DIC("S")="I $D(^MMRS(104,""B"",Y))"
+9 DO ^DIC
KILL DIC
+10 IF $DATA(DTOUT)!($DATA(DUOUT))!(Y=-1)
SET EXTFLG=1
QUIT ""
+11 SET MMRSDIV=+Y
+12 SET MMRSDIV=$ORDER(^MMRS(104,"B",MMRSDIV,0))
+13 QUIT MMRSDIV
PROMPT ;Prompts user for start date, end date, locations, and if user wants to only print the Summary Report.
+1 ;Prompt if should run report by Admission or Discharge
+2 NEW DIR,DIRUT,PRMPTTXT,Y
+3 SET DIR(0)="S^A:Admission Report;D:Discharge/Transmission Report"
+4 SET DIR("A")="Run (A)dmission Or (D)ischarge/Transmission Report"
+5 DO ^DIR
KILL DIR
+6 IF $DATA(DIRUT)
SET EXTFLG=1
QUIT
+7 IF Y="A"
SET BYADM=1
SET PRMPTTXT="ward admission"
+8 IF Y="D"
SET BYADM=0
SET PRMPTTXT="ward discharge"
DATE ;Prompts user for date range
+1 NEW %DT,X
+2 KILL Y
+3 WRITE !
SET %DT="AEPX"
SET %DT("A")="Begin with "_PRMPTTXT_" date: "
DO ^%DT
+4 IF Y<0
SET EXTFLG=1
QUIT
+5 SET STRTDT=Y
+6 SET %DT("A")="End with "_PRMPTTXT_" date: "
DO ^%DT
+7 IF Y<0
SET EXTFLG=1
QUIT
+8 SET ENDDT=Y
+9 IF '$PIECE(ENDDT,".",2)
SET ENDDT=Y+.24
+10 IF ENDDT<STRTDT
WRITE !!,"The ending date of the range must be later than the starting date."
GOTO DATE
LOC ;Prompts user for locations
+1 WRITE !
+2 SET DIR(0)="YA"
SET DIR("A")="Do you want to select all locations? "
SET DIR("B")="NO"
+3 DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
SET EXTFLG=1
QUIT
+5 IF Y=1
Begin DoDot:1
+6 SET Y=0
FOR
SET Y=$ORDER(^MMRS(104.3,Y))
if 'Y
QUIT
IF $PIECE($GET(^MMRS(104.3,Y,0)),U,2)=MMRSDIV
SET MMRSLOC(Y)=""
End DoDot:1
GOTO SUMRPT
+7 ;PROMPT FOR WARDS
+8 NEW DIC,DLAYGO,DTOUT,DUOUT
+9 WRITE !
+10 SET DIC("A")="Select Geographical Location: "
+11 SET DIC("S")="I $P($G(^MMRS(104.3,Y,0)),U,2)="_MMRSDIV
+12 SET DIC="^MMRS(104.3,"
SET DIC(0)="QEAM"
DO ^DIC
+13 IF (Y=-1)!($DATA(DTOUT))!($DATA(DUOUT))
SET EXTFLG=1
QUIT
+14 SET MMRSLOC(+Y)=""
+15 SET DIC("A")="Select another Geographical Location: "
FOR
DO ^DIC
if Y=-1
QUIT
SET MMRSLOC(+Y)=""
+16 KILL DIC
+17 IF ($DATA(DTOUT))!($DATA(DUOUT))
SET EXTFLG=1
QUIT
SUMRPT ;Prompt user if should only run the summary report.
+1 ; IF OPTION IS ONLY FOR SUMMARY REPORT...
IF $GET(MMRSSUM)
SET PRTSUM=1
QUIT
+2 WRITE !
+3 SET DIR(0)="Y"
+4 SET DIR("A")="Do you want to only print the summary report"
+5 SET DIR("B")="NO"
+6 DO ^DIR
KILL DIR
+7 IF $DATA(DIRUT)
SET EXTFLG=1
QUIT
+8 SET PRTSUM=Y
+9 QUIT
ASKDVC ;Prompts user for device of output (allows queuing)
+1 NEW MMRSVAR,ZTSK
+2 WRITE !!
if 'PRTSUM
WRITE !,"This report is designed for a 176 column format (landscape).",!
+3 SET MMRSVAR("STRTDT")=""
SET MMRSVAR("ENDDT")=""
SET MMRSVAR("MMRSLOC(")=""
+4 SET MMRSVAR("PRTSUM")=""
SET MMRSVAR("BYADM")=""
SET MMRSVAR("MMRSDIV")=""
+5 DO EN^XUTMDEVQ("MAIN2^MMRSIPC","PRINT MRSA IPEC REPORT",.MMRSVAR,"QM",1)
+6 if $DATA(ZTSK)
WRITE !,"Report Queued to Print ("_ZTSK_").",!
+7 QUIT
GETPARAM ;(MDRO) ; Loads lab search/extract parameters from file 104.1
+1 NEW MRSAMDRO,TSTNM,TST,MDRO,TEST,IEN,TIEN,ITOP,TOP,ETOP,IBACT,BACT,EBACT
+2 NEW ETIOL,ETIOLOGY,ANTI,ANTIM,INC,MRSASTAP,ETIONAME,MMRSI,MMRSET,ORG
+3 SET MRSAMDRO=$ORDER(^MMRS(104.2,"B","MRSA",0))
+4 SET INC=0
+5 SET TSTNM="MRSA SURVL NARES DN"
+6 FOR
SET TSTNM=$ORDER(^LAB(60,"B",TSTNM))
if TSTNM=""!(TSTNM]"MRSA SURVL NARES DNA~zzz")
QUIT
Begin DoDot:1
+7 IF TSTNM'["MRSA SURVL NARES DNA"
QUIT
+8 SET TST=0
FOR
SET TST=$ORDER(^LAB(60,"B",TSTNM,TST))
if 'TST
QUIT
Begin DoDot:2
+9 SET INC=INC+1
+10 SET ^TMP($JOB,"MMRSIPC","T","MRSA_SCREEN",TST_"_"_INC,0)="2^POS"
+11 SET ^TMP($JOB,"MMRSIPC","T",MRSAMDRO,TST_"_"_INC,0)="2^POS"
+12 SET INC=INC+1
+13 SET ^TMP($JOB,"MMRSIPC","T","MRSA_SCREEN",TST_"_"_INC,0)="5^DETECTED"
+14 SET ^TMP($JOB,"MMRSIPC","T",MRSAMDRO,TST_"_"_INC,0)="5^DETECTED"
End DoDot:2
End DoDot:1
+15 SET TSTNM="MRSA SURVL NARES AGA"
+16 FOR
SET TSTNM=$ORDER(^LAB(60,"B",TSTNM))
if TSTNM=""!(TSTNM]"MRSA SURVL NARES AGAR~zzz")
QUIT
Begin DoDot:1
+17 IF TSTNM'["MRSA SURVL NARES AGAR"
QUIT
+18 SET TST=0
FOR
SET TST=$ORDER(^LAB(60,"B",TSTNM,TST))
if 'TST
QUIT
Begin DoDot:2
+19 SET INC=INC+1
+20 SET ^TMP($JOB,"MMRSIPC","T","MRSA_SCREEN",TST_"_"_INC,0)="2^POS"
+21 SET ^TMP($JOB,"MMRSIPC","T",MRSAMDRO,TST_"_"_INC,0)="2^POS"
End DoDot:2
End DoDot:1
+22 SET TSTNM="MRSA SURVL OTHER DN"
+23 FOR
SET TSTNM=$ORDER(^LAB(60,"B",TSTNM))
if TSTNM=""!(TSTNM]"MRSA SURVL OTHER DNA~zzz")
QUIT
Begin DoDot:1
+24 IF TSTNM'["MRSA SURVL OTHER DNA"
QUIT
+25 SET TST=0
FOR
SET TST=$ORDER(^LAB(60,"B",TSTNM,TST))
if 'TST
QUIT
Begin DoDot:2
+26 SET INC=INC+1
+27 SET ^TMP($JOB,"MMRSIPC","T","MRSA_SURV",TST_"_"_INC,0)="2^POS"
+28 SET ^TMP($JOB,"MMRSIPC","T",MRSAMDRO,TST_"_"_INC,0)="2^POS"
+29 SET INC=INC+1
+30 SET ^TMP($JOB,"MMRSIPC","T","MRSA_SURV",TST_"_"_INC,0)="5^DETECTED"
+31 SET ^TMP($JOB,"MMRSIPC","T",MRSAMDRO,TST_"_"_INC,0)="5^DETECTED"
End DoDot:2
End DoDot:1
+32 SET TSTNM="MRSA SURVL OTHER AGA"
+33 FOR
SET TSTNM=$ORDER(^LAB(60,"B",TSTNM))
if TSTNM=""!(TSTNM]"MRSA SURVL OTHER AGAR~zzz")
QUIT
Begin DoDot:1
+34 IF TSTNM'["MRSA SURVL OTHER AGAR"
QUIT
+35 SET TST=0
FOR
SET TST=$ORDER(^LAB(60,"B",TSTNM,TST))
if 'TST
QUIT
Begin DoDot:2
+36 SET INC=INC+1
+37 SET ^TMP($JOB,"MMRSIPC","T","MRSA_SURV",TST_"_"_INC,0)="2^POS"
+38 SET ^TMP($JOB,"MMRSIPC","T",MRSAMDRO,TST_"_"_INC,0)="2^POS"
End DoDot:2
End DoDot:1
+39 SET IEN=""
FOR
SET IEN=$ORDER(^MMRS(104.1,"D",MMRSDIV,IEN))
if 'IEN
QUIT
Begin DoDot:1
+40 SET MDRO=$PIECE($GET(^MMRS(104.1,IEN,0)),U,1)
+41 if 'MDRO
QUIT
+42 SET TIEN=0
FOR
SET TIEN=$ORDER(^MMRS(104.1,IEN,3,TIEN))
if 'TIEN
QUIT
Begin DoDot:2
+43 SET TEST=$PIECE($GET(^MMRS(104.1,IEN,3,TIEN,0)),U,1)
+44 if 'TEST
QUIT
+45 SET INC=INC+1
+46 SET ^TMP($JOB,"MMRSIPC","T",MDRO,TEST_"_"_INC,0)=$PIECE($GET(^MMRS(104.1,IEN,3,TIEN,0)),U,2,3)
End DoDot:2
+47 ;S ITOP=0 F S ITOP=$O(^MMRS(104.1,IEN,1,ITOP)) Q:'ITOP D
+48 ;.S TOP=$G(^MMRS(104.1,IEN,1,ITOP,0))
+49 ;.I TOP S ^TMP($J,"MMRSIPC","TOP",MDRO,"INC_TOP",TOP)=""
+50 ;S ETOP=0 F S ETOP=$O(^MMRS(104.1,IEN,2,ETOP)) Q:'ETOP D
+51 ;.S TOP=$G(^MMRS(104.1,IEN,2,ETOP,0))
+52 ;.I TOP S ^TMP($J,"MMRSIPC","TOP",MDRO,"EXC_TOP",TOP)=""
+53 SET IBACT=0
FOR
SET IBACT=$ORDER(^MMRS(104.1,IEN,4,IBACT))
if 'IBACT
QUIT
Begin DoDot:2
+54 SET BACT=$GET(^MMRS(104.1,IEN,4,IBACT,0))
+55 IF BACT'=""
SET ^TMP($JOB,"MMRSIPC","BACT",MDRO,"INC_REMARK",IBACT)=BACT
End DoDot:2
+56 SET EBACT=0
FOR
SET EBACT=$ORDER(^MMRS(104.1,IEN,5,EBACT))
if 'EBACT
QUIT
Begin DoDot:2
+57 SET BACT=$GET(^MMRS(104.1,IEN,5,EBACT,0))
+58 IF BACT'=""
SET ^TMP($JOB,"MMRSIPC","BACT",MDRO,"EXC_REMARK",EBACT)=BACT
End DoDot:2
+59 SET ETIOL=0
FOR
SET ETIOL=$ORDER(^MMRS(104.1,IEN,6,ETIOL))
if 'ETIOL
QUIT
Begin DoDot:2
+60 SET ETIOLOGY=$GET(^MMRS(104.1,IEN,6,ETIOL,0))
+61 if 'ETIOLOGY
QUIT
+62 SET ^TMP($JOB,"MMRSIPC","ETIOL",MDRO,+ETIOLOGY)=""
+63 SET ANTI=0
FOR
SET ANTI=$ORDER(^MMRS(104.1,IEN,6,ETIOL,1,ANTI))
if 'ANTI
QUIT
Begin DoDot:3
+64 SET ANTIM=$PIECE($GET(^MMRS(104.1,IEN,6,ETIOL,1,ANTI,0)),U)
+65 IF ANTIM
SET ^TMP($JOB,"MMRSIPC","ETIOL",MDRO,ETIOLOGY,ANTI)=$GET(^MMRS(104.1,IEN,6,ETIOL,1,ANTI,0))
End DoDot:3
End DoDot:2
End DoDot:1
+66 DO FIND^DIC(61.2,,".01E;@","PM","STAPHYLOCOCCUS AUREUS METHICILLIN RESISTANT",,"B",,,"MMRSET")
+67 SET MMRSI=""
FOR
SET MMRSI=$ORDER(MMRSET("DILIST",MMRSI))
if MMRSI=""
QUIT
IF +MMRSI>0
Begin DoDot:1
+68 SET ETIONAME=$PIECE($GET(MMRSET("DILIST",MMRSI,0)),U,2)
+69 SET ORG=$PIECE($GET(MMRSET("DILIST",MMRSI,0)),U,1)
+70 IF ETIONAME'["STAPHYLOCOCCUS AUREUS METHICILLIN RESISTANT"
QUIT
+71 KILL ^TMP($JOB,"MMRSIPC","ETIOL",MRSAMDRO,ORG)
+72 SET ^TMP($JOB,"MMRSIPC","ETIOL","MRSA_CULTURE",ORG)=""
+73 SET ^TMP($JOB,"MMRSIPC","ETIOL",MRSAMDRO,ORG)=""
End DoDot:1
+74 QUIT
PATDAYS ;Gets 'PATIENT DAYS OF CARE'.
+1 NEW TTLRSLT,SDT,EDT,LOC,RSLT,WLOC,WARD,PATDAYS,LOCNAME
+2 SET TTLRSLT=0
+3 SET SDT=$PIECE(STRTDT,".")
+4 SET EDT=$PIECE(ENDDT,".")
+5 SET LOC=0
FOR
SET LOC=$ORDER(MMRSLOC(LOC))
if 'LOC
QUIT
Begin DoDot:1
+6 SET RSLT=0
+7 SET WLOC=0
FOR
SET WLOC=$ORDER(^MMRS(104.3,LOC,1,WLOC))
if 'WLOC
QUIT
Begin DoDot:2
+8 SET WARD=$PIECE($GET(^MMRS(104.3,LOC,1,WLOC,0)),U,1)
IF 'WARD
QUIT
+9 SET PATDAYS=$$GETPATDY(WARD,SDT,EDT)
+10 ;bdoc are calculated by patients on ward @ midnight
+11 ;+ oneday admissions (patients admitted and discharged on same day).
+12 ;in order not to double-count oneday obs patient admitted to acute care
+13 ;on same day, adjus obs count.
+14 IF $GET(ODOBS(WARD))
SET PATDAYS=PATDAYS-ODOBS(WARD)
+15 SET RSLT=RSLT+PATDAYS
SET TTLRSLT=TTLRSLT+PATDAYS
+16 SET LOCNAME=$PIECE($GET(^MMRS(104.3,LOC,0)),U)
+17 SET $PIECE(^TMP($JOB,"MMRSIPC","DSUM",LOCNAME),U,1)=RSLT
End DoDot:2
End DoDot:1
+18 SET $PIECE(^TMP($JOB,"MMRSIPC","DSUM"),U,1)=TTLRSLT
+19 QUIT
GETPATDY(WARD,SDT,EDT) ;Helper function for PATDAYS() - Gets Patient Days of care for specific ward
+1 NEW SCUMPD,ECUMPD
+2 IF SDT>EDT
QUIT 0
+3 IF SDT<($$FY(EDT)_"1001")
QUIT ($$GETPATDY(WARD,SDT,($$FY(EDT)_"0930"))+$$GETPATDY(WARD,($$FY(EDT)_"1001"),EDT))
+4 ;MMRS*1.0*10: Comment out line below since the "B" index
+5 ; is DINUM'd and since some sites are missing
+6 ; random "B" index entries for an unknown reason.
+7 ;S CENSUS=$O(^DG(41.9,"B",WARD,0)) I 'CENSUS Q 0
+8 SET SDT=$$FMADD^XLFDT(SDT,-1,0,0,0)
+9 ;MMRS*1.0*10: Replace CENSUS with WARD for SCUMPD and ECUMPD.
+10 SET SCUMPD=$PIECE($GET(^DG(41.9,WARD,"C",SDT,0)),U,3)
+11 IF EDT=$$DT^XLFDT
SET EDT=$$FMADD^XLFDT(EDT,-1,0,0,0)
+12 SET ECUMPD=$PIECE($GET(^DG(41.9,WARD,"C",EDT,0)),U,3)
+13 ; IF LAST DAY OF FY
IF $EXTRACT(SDT,4,7)="0930"
SET SCUMPD=0
+14 QUIT ECUMPD-SCUMPD
FY(DATE) ;Helper function for GETPATDY - Gets fiscal year for the specified date
+1 IF $EXTRACT(DATE,4,7)>("1000")
IF $EXTRACT(DATE,4,7)<("1232")
QUIT $EXTRACT(DATE,1,3)
+2 QUIT ($EXTRACT(DATE,1,3)-1)
