- 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 Feb 18, 2025@23:41:24 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)