MMRSCRE ;TCK - Print CRE Acute Care IPEC Report ; 3/22/17 3:02pm
;;1.0;MDRO PROGRAM TOOLS;**4,5**;June 01, 2016;Build 146
;
;This is the main routine to print the CRE Acute Care IPEC Report.
;This routine uses functions contained in MMRSCRE2, MMRSCRE3, and MMRSCRE4.
MAIN ;
N NUMDIV,MMRSDIV,MMRSLOC,EXTFLG,STRTDT,ENDDT,PRTSUM,BYADM
D CLEAN
D CHECK2
I $D(EXTFLG) W ! H 2 Q
W !
D CHECK3
I $D(EXTFLG) W ! H 2 Q
D PROMPT
I $D(EXTFLG) D CLEAN K MMRSSUM,DIVARY,DVSN,MDIV Q
D ASKDVC Q:$D(EXTFLG)
D CLEAN
D END
Q
;
CHKPAR(ORG,Y,CHK) ;
N I,TST,ETI
I '$D(^MMRS(104.1,"C",+Y,ORG)) S CHK=0 Q
S I="",I=$O(^MMRS(104.1,"C",+Y,ORG,I))
S LIEN=1_","_I_","
S TST=$$GET1^DIQ(104.15,LIEN,.01,"I")
I $G(TST)>0 Q
S ETI=$$GET1^DIQ(104.109,LIEN,.01,"I")
I $G(ETI)>0 Q
S CHK=0
Q
;
CHECK(L) ;Check if parameters are setup
N DVSN
S (SPCM,NUMDIV)=0
S MMRSDIV=0 F S MMRSDIV=$O(^MMRS(104,MMRSDIV)) Q:'MMRSDIV D Q:NUMDIV
.I $D(^MMRS(104,MMRSDIV,0)) S NUMDIV=NUMDIV+1 Q
I NUMDIV D
.Q:'$D(^MMRS(104,"B",L))
.S DVSN="",DVSN=$O(^MMRS(104,"B",L,DVSN))
.Q:$G(DVSN)'>0
.Q:'$D(^MMRS(104,DVSN,61))
.Q:'$P(^MMRS(104,DVSN,61,0),"^",3)
.S SPCM=1
I 'NUMDIV!('SPCM) D
.W !!," >>>Make sure a division and/or a Surveillance specimen has been "
.W !," setup using the option: 'CRE Tools Site Parameter Setup'"
.S EXTFLG=1
Q
CHECK2 ;Check if lab tests and etiologies are setup
N TST,MRSASTAP,MMRSET,MMRSI
S (MDROETIO,TSTSTP)=0
I $D(^MMRS(104.1)) D
.S II=0 F S II=$O(^MMRS(104.1,II)) Q:II'>0 D Q:MDROETIO!(TSTSTP)
..Q:'$D(^MMRS(104.1,II,0))
..S ORGP=$P(^MMRS(104.1,II,0),"^")
..Q:$G(ORGP)'>0
..S ETIO=$$GET1^DIQ(104.2,ORGP,.01,"E")
..S ETIO=$$UPPER^DGUTL(ETIO)
..Q:ETIO'["CRB"
..S IX=0
..F S IX=$O(^MMRS(104.1,II,3,IX)) Q:IX'>0 D Q:TSTSTP
...I $G(IX)>0 D
....Q:'$D(^MMRS(104.1,II,3,IX,0))
....S III=IX_","_II_","
....Q:III=""
....S TST=$$GET1^DIQ(104.15,III,.01,"E")
....S TSTSTP=1
..I $D(^MMRS(104.1,II,6)) D
...S IXI=0 F S IXI=$O(^MMRS(104.1,II,6,IXI)) Q:IXI'>0 D Q:MDROETIO
....Q:IXI=""
....Q:'IXI
....S III=IXI_","_II_","
....S XX=$$GET1^DIQ(104.109,III,.01,"E")
....Q:XX=""
....S ETIONAME=XX,ORG=II,MDROETIO=ORG
ERROR ;
I 'TSTSTP&'MDROETIO D
.S EXTFLG=1
.W !!," >>>The report cannot be run because the Etiology has not been "
.W !," configured in the MDRO TOOLS LAB SEARCH/EXTRACT file, "
.W !," (#104.1). Use the MDRO Tools Lab Parameter Setup "
.W !," option to configure."
Q
;
CHECK3 ;Check if Ward Mappings have been setup for this division
N NUMLOC,MMRSLOC,MMRSDIV
S NUMLOC=0
S MMRSDIV=0 F S MMRSDIV=$O(^MMRS(104.3,MMRSDIV)) Q:'MMRSDIV D
.I $G(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
D GETPARAM ; Load parameters in temp global
D CLEAN ;Kill Temp Global
Q
CLEAN ;
K DFN,INDT,LIENS,LIEN,IN,ADMTDT,COLDT,LRIDT
K ^TMP($J,"MMRSCRE"),TOTAL,DATA,DATA1,DIVARY,MDIV,DVSN
K ^TMP($J,"MMRSCREPD"),TMPDATA
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/Station: "
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.
S BYADM=1,PRMPTTXT="facility admission"
;
LOC ;Prompts user for division
N STID,STNM,SIEN
S (STP,ALL)=0
W !
S DIR(0)="YA",DIR("A")="Do you want to select all divisions: ",DIR("B")="NO"
D ^DIR K DIR
I $D(DIRUT) S EXTFLG=1 Q
I Y=1 S ALL=1 D Q:'CHK
.S CHK=1
.S DIV=0 F S DIV=$O(^MMRS(104,DIV)) Q:$G(DIV)'>0 D Q:STP!('CHK)
..D CHKPAR(ORGP,DIV,.CHK)
..I 'CHK S (MDROETIO,TSTSTP)=0 D ERROR Q
..S WR=$$GET1^DIQ(104,DIV,.01,"I")
..S FID=$$GET1^DIQ(40.8,WR,1,"E"),STID=$$GET1^DIQ(40.8,WR,.01,"E")
..S MMRSLOC(FID)=STID,DIVARY(STID)=+DIV
..D CHECK(WR)
..I $G(NUMDIV)'>0 S STP=1 Q
..I $G(SPCM)'>0 S STP=1 Q
Q:STP
;PROMPT FOR WARDS
I 'Y D Q:'CHK
.S CHK=1
.N DIC,DLAYGO,DTOUT,DUOUT
.W !
.S DIC("A")="Select Division: "
.S DIC="^MMRS(104,",DIC(0)="QEAM" D ^DIC
.I (Y=-1)!($D(DTOUT))!($D(DUOUT)) S EXTFLG=1 Q
.D CHKPAR(ORGP,Y,.CHK)
.I 'CHK S (MDROETIO,TSTSTP)=0 D ERROR Q
.S DPT=$P(Y,"^",2)
.S STID=$$GET1^DIQ(40.8,DPT,.01,"E"),FID=$$GET1^DIQ(40.8,DPT,1,"E")
.S MMRSLOC(FID)=STID,DIVARY(STID)=+Y
.S WR=+Y
.I $G(Y)>0 D CHECK(WR)
.Q:$G(NUMDIV)'>0
.Q:$G(SPCM)'>0
.S CHK=1
.S DIC("A")="Select another Division: " F D ^DIC Q:Y=-1 D Q:'CHK
..D CHKPAR(ORGP,Y,.CHK)
..I 'CHK S (MDROETIO,TSTSTP)=0 D ERROR Q
..S STID=$$GET1^DIQ(104,+Y,.01,"E"),WR=$$GET1^DIQ(104,+Y,.01,"I")
..S FID=$$GET1^DIQ(40.8,WR,1,"E"),MMRSLOC(FID)=STID,DIVARY(STID)=+Y
..I $G(Y)>0 D CHECK(WR)
..I $G(NUMDIV)'>0 S STP=1 Q
..I $G(SPCM)'>0 S STP=1 Q
.I ($D(DTOUT))!($D(DUOUT)) S EXTFLG=1 Q
K DIC
Q:$G(NUMDIV)'>0
Q:$G(SPCM)'>0
Q:$D(EXTFLG)
I ($D(DTOUT))!($D(DUOUT)) S EXTFLG=1 Q
;
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
;
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")=""
S MMRSVAR("DFLTDT")="",MMRSVAR("TSTSTP")="",MMRSVAR("MDROETIO")=""
S MMRSVAR("ORG")="",MMRSVAR("DIVARY")="",MMRSVAR("DIVARY(")=""
D EN^XUTMDEVQ("MAIN2^MMRSCRE","PRINT CRE Acute Care 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 TSTNM,TST,MDRO,TEST,IEN,TIEN,ITOP,TOP,ETOP,IBACT,BACT,EBACT
N ETIOL,ETIOLOGY,ANTI,ANTIM,INC,MRSASTAP,ETIONAME,MMRSI,MMRSET
N MDRO
S MMRSDIV=0,DIVSN="",LOC=""
S MMRSMDRO=$O(^MMRS(104.2,"B","CRB-R",0))
F S LOC=$O(DIVARY(LOC)) Q:LOC="" D
.K ^TMP($J,"MMRSCRE","T")
.K ^TMP($J,"MMRSCRE","ETIOL")
.S Y=DIVARY(LOC)
.S IEN="",IEN=$O(^MMRS(104.1,"C",+Y,MMRSMDRO,IEN))
.Q:$G(IEN)'>0
.;S MDROETIO=IEN
.S MDRO=MMRSMDRO
.S (FND,SUB,INC)=0
.I $G(TSTSTP)'>0 S TSTSTP=1
.I TSTSTP D
..S TIEN=0 F S TIEN=$O(^MMRS(104.1,IEN,3,TIEN)) Q:'TIEN D
...S LRIEN=TIEN_","_MDRO_","
...S TEST=$$GET1^DIQ(104.15,LRIEN,.01,"I")
...Q:'TEST
...S INC=INC+1
...S ^TMP($J,"MMRSCRE","T",MDRO,TEST_"_"_INC,0)=$P($G(^MMRS(104.1,MDRO,3,TIEN,0)),U,2,3)
.I MDROETIO D
..S IBACT=0 F S IBACT=$O(^MMRS(104.1,MDROETIO,4,IBACT)) Q:'IBACT D
...S BACT=$G(^MMRS(104.1,MDROETIO,4,IBACT,0))
...I BACT'="" S ^TMP($J,"MMRSCD","BACT",MDROETIO,"INC_REMARK",IBACT)=BACT
..S EBACT=0 F S EBACT=$O(^MMRS(104.1,MDROETIO,5,EBACT)) Q:'EBACT D
...S BACT=$G(^MMRS(104.1,MDROETIO,5,EBACT,0))
..S ETIOL=0 F S ETIOL=$O(^MMRS(104.1,MDROETIO,6,ETIOL)) Q:'ETIOL D
...S ETIOLOGY=$G(^MMRS(104.1,MDROETIO,6,ETIOL,0))
...Q:'ETIOLOGY
...S ^TMP($J,"MMRSCRE","ETIOL",MDROETIO,+ETIOLOGY)=""
.D GETMOVE^MMRSCRE2
.D GETLABS^MMRSCRE3
.D PRINT^MMRSCRE4
Q
;
PATDAYS ;Gets 'PATIENT DAYS OF CARE'.
N TTLRSLT,SDT,EDT,LOC,RSLT,WLOC,WARD,PATDAYS,RTOT
S (FND,TTLRSLT,RTOT,TOTAL("PAT"),RSLT)=0
S SDT=$P(STRTDT,".")
S EDT=$P(ENDDT,".")
Q:'$D(WRDLOC)
S WARD=0 F S WARD=$O(WRDLOC(WARD)) Q:$G(WARD)'>0 D
.S LOC=$$GET1^DIQ(42,WARD,.015,"E")
.Q:LOC'=LOCNAME
.S PATDAYS=$$GETPATDY(WARD,SDT,EDT)
.K WRDLOC(WARD)
.;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 $P(^TMP($J,"MMRSCREPD","DSUM",LOCNAME),U,1)=RSLT
S $P(^TMP($J,"MMRSCREPD","DSUM"),U,1)=TTLRSLT
S TOTAL("PAT")=TTLRSLT
Q
GETPATDY(WARD,SDT,EDT) ;Helper function for PATDAYS() - Gets Patient Days of care for specific ward
N CENSUS,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))
S CENSUS=$O(^DG(41.9,"B",WARD,0)) I 'CENSUS Q 0
S SDT=$$FMADD^XLFDT(SDT,-1,0,0,0)
S SCUMPD=$P($G(^DG(41.9,CENSUS,"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,CENSUS,"C",EDT,0)),U,3)
I $E(SDT,4,7)="0930" S SCUMPD=0 ; IF LAST DAY OF FY
I ECUMPD<SCUMPD Q 0
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)
;
END ;
K ALL,DIRUT,DIVSN,DPT,ETIO,FID,FND,II,III,IXI,LOCNME
K LRIEN,MDROETIO,OBOBS,ORGP,PRMPTTXT,SPCM,STP,SUB,TSTSTP
K WR,WRDLOC,XX,MMRSSUM,DIVARY,DVSN,MDIV
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMMRSCRE 9795 printed Apr 09, 2024@21:17:12 Page 2
MMRSCRE ;TCK - Print CRE Acute Care IPEC Report ; 3/22/17 3:02pm
+1 ;;1.0;MDRO PROGRAM TOOLS;**4,5**;June 01, 2016;Build 146
+2 ;
+3 ;This is the main routine to print the CRE Acute Care IPEC Report.
+4 ;This routine uses functions contained in MMRSCRE2, MMRSCRE3, and MMRSCRE4.
MAIN ;
+1 NEW NUMDIV,MMRSDIV,MMRSLOC,EXTFLG,STRTDT,ENDDT,PRTSUM,BYADM
+2 DO CLEAN
+3 DO CHECK2
+4 IF $DATA(EXTFLG)
WRITE !
HANG 2
QUIT
+5 WRITE !
+6 DO CHECK3
+7 IF $DATA(EXTFLG)
WRITE !
HANG 2
QUIT
+8 DO PROMPT
+9 IF $DATA(EXTFLG)
DO CLEAN
KILL MMRSSUM,DIVARY,DVSN,MDIV
QUIT
+10 DO ASKDVC
if $DATA(EXTFLG)
QUIT
+11 DO CLEAN
+12 DO END
+13 QUIT
+14 ;
CHKPAR(ORG,Y,CHK) ;
+1 NEW I,TST,ETI
+2 IF '$DATA(^MMRS(104.1,"C",+Y,ORG))
SET CHK=0
QUIT
+3 SET I=""
SET I=$ORDER(^MMRS(104.1,"C",+Y,ORG,I))
+4 SET LIEN=1_","_I_","
+5 SET TST=$$GET1^DIQ(104.15,LIEN,.01,"I")
+6 IF $GET(TST)>0
QUIT
+7 SET ETI=$$GET1^DIQ(104.109,LIEN,.01,"I")
+8 IF $GET(ETI)>0
QUIT
+9 SET CHK=0
+10 QUIT
+11 ;
CHECK(L) ;Check if parameters are setup
+1 NEW DVSN
+2 SET (SPCM,NUMDIV)=0
+3 SET MMRSDIV=0
FOR
SET MMRSDIV=$ORDER(^MMRS(104,MMRSDIV))
if 'MMRSDIV
QUIT
Begin DoDot:1
+4 IF $DATA(^MMRS(104,MMRSDIV,0))
SET NUMDIV=NUMDIV+1
QUIT
End DoDot:1
if NUMDIV
QUIT
+5 IF NUMDIV
Begin DoDot:1
+6 if '$DATA(^MMRS(104,"B",L))
QUIT
+7 SET DVSN=""
SET DVSN=$ORDER(^MMRS(104,"B",L,DVSN))
+8 if $GET(DVSN)'>0
QUIT
+9 if '$DATA(^MMRS(104,DVSN,61))
QUIT
+10 if '$PIECE(^MMRS(104,DVSN,61,0),"^",3)
QUIT
+11 SET SPCM=1
End DoDot:1
+12 IF 'NUMDIV!('SPCM)
Begin DoDot:1
+13 WRITE !!," >>>Make sure a division and/or a Surveillance specimen has been "
+14 WRITE !," setup using the option: 'CRE Tools Site Parameter Setup'"
+15 SET EXTFLG=1
End DoDot:1
+16 QUIT
CHECK2 ;Check if lab tests and etiologies are setup
+1 NEW TST,MRSASTAP,MMRSET,MMRSI
+2 SET (MDROETIO,TSTSTP)=0
+3 IF $DATA(^MMRS(104.1))
Begin DoDot:1
+4 SET II=0
FOR
SET II=$ORDER(^MMRS(104.1,II))
if II'>0
QUIT
Begin DoDot:2
+5 if '$DATA(^MMRS(104.1,II,0))
QUIT
+6 SET ORGP=$PIECE(^MMRS(104.1,II,0),"^")
+7 if $GET(ORGP)'>0
QUIT
+8 SET ETIO=$$GET1^DIQ(104.2,ORGP,.01,"E")
+9 SET ETIO=$$UPPER^DGUTL(ETIO)
+10 if ETIO'["CRB"
QUIT
+11 SET IX=0
+12 FOR
SET IX=$ORDER(^MMRS(104.1,II,3,IX))
if IX'>0
QUIT
Begin DoDot:3
+13 IF $GET(IX)>0
Begin DoDot:4
+14 if '$DATA(^MMRS(104.1,II,3,IX,0))
QUIT
+15 SET III=IX_","_II_","
+16 if III=""
QUIT
+17 SET TST=$$GET1^DIQ(104.15,III,.01,"E")
+18 SET TSTSTP=1
End DoDot:4
End DoDot:3
if TSTSTP
QUIT
+19 IF $DATA(^MMRS(104.1,II,6))
Begin DoDot:3
+20 SET IXI=0
FOR
SET IXI=$ORDER(^MMRS(104.1,II,6,IXI))
if IXI'>0
QUIT
Begin DoDot:4
+21 if IXI=""
QUIT
+22 if 'IXI
QUIT
+23 SET III=IXI_","_II_","
+24 SET XX=$$GET1^DIQ(104.109,III,.01,"E")
+25 if XX=""
QUIT
+26 SET ETIONAME=XX
SET ORG=II
SET MDROETIO=ORG
End DoDot:4
if MDROETIO
QUIT
End DoDot:3
End DoDot:2
if MDROETIO!(TSTSTP)
QUIT
End DoDot:1
ERROR ;
+1 IF 'TSTSTP&'MDROETIO
Begin DoDot:1
+2 SET EXTFLG=1
+3 WRITE !!," >>>The report cannot be run because the Etiology has not been "
+4 WRITE !," configured in the MDRO TOOLS LAB SEARCH/EXTRACT file, "
+5 WRITE !," (#104.1). Use the MDRO Tools Lab Parameter Setup "
+6 WRITE !," option to configure."
End DoDot:1
+7 QUIT
+8 ;
CHECK3 ;Check if Ward Mappings have been setup for this division
+1 NEW NUMLOC,MMRSLOC,MMRSDIV
+2 SET NUMLOC=0
+3 SET MMRSDIV=0
FOR
SET MMRSDIV=$ORDER(^MMRS(104.3,MMRSDIV))
if 'MMRSDIV
QUIT
Begin DoDot:1
+4 IF $GET(MMRSDIV)
SET NUMLOC=NUMLOC+1
End DoDot:1
+5 IF NUMLOC=0
WRITE !!," >>> Make sure the Ward Mappings for each Geographical Unit has been setup.",!!
SET EXTFLG=1
+6 QUIT
+7 ;
MAIN2 ; Entry for queuing
+1 ; Load parameters in temp global
DO GETPARAM
+2 ;Kill Temp Global
DO CLEAN
+3 QUIT
CLEAN ;
+1 KILL DFN,INDT,LIENS,LIEN,IN,ADMTDT,COLDT,LRIDT
+2 KILL ^TMP($JOB,"MMRSCRE"),TOTAL,DATA,DATA1,DIVARY,MDIV,DVSN
+3 KILL ^TMP($JOB,"MMRSCREPD"),TMPDATA
+4 QUIT
+5 ;
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/Station: "
+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
+14 ;
PROMPT ;Prompts user for start date, end date, locations, and if user wants to only print the Summary Report.
+1 SET BYADM=1
SET PRMPTTXT="facility admission"
+2 ;
LOC ;Prompts user for division
+1 NEW STID,STNM,SIEN
+2 SET (STP,ALL)=0
+3 WRITE !
+4 SET DIR(0)="YA"
SET DIR("A")="Do you want to select all divisions: "
SET DIR("B")="NO"
+5 DO ^DIR
KILL DIR
+6 IF $DATA(DIRUT)
SET EXTFLG=1
QUIT
+7 IF Y=1
SET ALL=1
Begin DoDot:1
+8 SET CHK=1
+9 SET DIV=0
FOR
SET DIV=$ORDER(^MMRS(104,DIV))
if $GET(DIV)'>0
QUIT
Begin DoDot:2
+10 DO CHKPAR(ORGP,DIV,.CHK)
+11 IF 'CHK
SET (MDROETIO,TSTSTP)=0
DO ERROR
QUIT
+12 SET WR=$$GET1^DIQ(104,DIV,.01,"I")
+13 SET FID=$$GET1^DIQ(40.8,WR,1,"E")
SET STID=$$GET1^DIQ(40.8,WR,.01,"E")
+14 SET MMRSLOC(FID)=STID
SET DIVARY(STID)=+DIV
+15 DO CHECK(WR)
+16 IF $GET(NUMDIV)'>0
SET STP=1
QUIT
+17 IF $GET(SPCM)'>0
SET STP=1
QUIT
End DoDot:2
if STP!('CHK)
QUIT
End DoDot:1
if 'CHK
QUIT
+18 if STP
QUIT
+19 ;PROMPT FOR WARDS
+20 IF 'Y
Begin DoDot:1
+21 SET CHK=1
+22 NEW DIC,DLAYGO,DTOUT,DUOUT
+23 WRITE !
+24 SET DIC("A")="Select Division: "
+25 SET DIC="^MMRS(104,"
SET DIC(0)="QEAM"
DO ^DIC
+26 IF (Y=-1)!($DATA(DTOUT))!($DATA(DUOUT))
SET EXTFLG=1
QUIT
+27 DO CHKPAR(ORGP,Y,.CHK)
+28 IF 'CHK
SET (MDROETIO,TSTSTP)=0
DO ERROR
QUIT
+29 SET DPT=$PIECE(Y,"^",2)
+30 SET STID=$$GET1^DIQ(40.8,DPT,.01,"E")
SET FID=$$GET1^DIQ(40.8,DPT,1,"E")
+31 SET MMRSLOC(FID)=STID
SET DIVARY(STID)=+Y
+32 SET WR=+Y
+33 IF $GET(Y)>0
DO CHECK(WR)
+34 if $GET(NUMDIV)'>0
QUIT
+35 if $GET(SPCM)'>0
QUIT
+36 SET CHK=1
+37 SET DIC("A")="Select another Division: "
FOR
DO ^DIC
if Y=-1
QUIT
Begin DoDot:2
+38 DO CHKPAR(ORGP,Y,.CHK)
+39 IF 'CHK
SET (MDROETIO,TSTSTP)=0
DO ERROR
QUIT
+40 SET STID=$$GET1^DIQ(104,+Y,.01,"E")
SET WR=$$GET1^DIQ(104,+Y,.01,"I")
+41 SET FID=$$GET1^DIQ(40.8,WR,1,"E")
SET MMRSLOC(FID)=STID
SET DIVARY(STID)=+Y
+42 IF $GET(Y)>0
DO CHECK(WR)
+43 IF $GET(NUMDIV)'>0
SET STP=1
QUIT
+44 IF $GET(SPCM)'>0
SET STP=1
QUIT
End DoDot:2
if 'CHK
QUIT
+45 IF ($DATA(DTOUT))!($DATA(DUOUT))
SET EXTFLG=1
QUIT
End DoDot:1
if 'CHK
QUIT
+46 KILL DIC
+47 if $GET(NUMDIV)'>0
QUIT
+48 if $GET(SPCM)'>0
QUIT
+49 if $DATA(EXTFLG)
QUIT
+50 IF ($DATA(DTOUT))!($DATA(DUOUT))
SET EXTFLG=1
QUIT
+51 ;
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
+11 ;
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 SET MMRSVAR("DFLTDT")=""
SET MMRSVAR("TSTSTP")=""
SET MMRSVAR("MDROETIO")=""
+6 SET MMRSVAR("ORG")=""
SET MMRSVAR("DIVARY")=""
SET MMRSVAR("DIVARY(")=""
+7 DO EN^XUTMDEVQ("MAIN2^MMRSCRE","PRINT CRE Acute Care IPEC REPORT",.MMRSVAR,"QM",1)
+8 if $DATA(ZTSK)
WRITE !,"Report Queued to Print ("_ZTSK_").",!
+9 QUIT
+10 ;
GETPARAM ;(MDRO) ; Loads lab search/extract parameters from file 104.1
+1 NEW TSTNM,TST,MDRO,TEST,IEN,TIEN,ITOP,TOP,ETOP,IBACT,BACT,EBACT
+2 NEW ETIOL,ETIOLOGY,ANTI,ANTIM,INC,MRSASTAP,ETIONAME,MMRSI,MMRSET
+3 NEW MDRO
+4 SET MMRSDIV=0
SET DIVSN=""
SET LOC=""
+5 SET MMRSMDRO=$ORDER(^MMRS(104.2,"B","CRB-R",0))
+6 FOR
SET LOC=$ORDER(DIVARY(LOC))
if LOC=""
QUIT
Begin DoDot:1
+7 KILL ^TMP($JOB,"MMRSCRE","T")
+8 KILL ^TMP($JOB,"MMRSCRE","ETIOL")
+9 SET Y=DIVARY(LOC)
+10 SET IEN=""
SET IEN=$ORDER(^MMRS(104.1,"C",+Y,MMRSMDRO,IEN))
+11 if $GET(IEN)'>0
QUIT
+12 ;S MDROETIO=IEN
+13 SET MDRO=MMRSMDRO
+14 SET (FND,SUB,INC)=0
+15 IF $GET(TSTSTP)'>0
SET TSTSTP=1
+16 IF TSTSTP
Begin DoDot:2
+17 SET TIEN=0
FOR
SET TIEN=$ORDER(^MMRS(104.1,IEN,3,TIEN))
if 'TIEN
QUIT
Begin DoDot:3
+18 SET LRIEN=TIEN_","_MDRO_","
+19 SET TEST=$$GET1^DIQ(104.15,LRIEN,.01,"I")
+20 if 'TEST
QUIT
+21 SET INC=INC+1
+22 SET ^TMP($JOB,"MMRSCRE","T",MDRO,TEST_"_"_INC,0)=$PIECE($GET(^MMRS(104.1,MDRO,3,TIEN,0)),U,2,3)
End DoDot:3
End DoDot:2
+23 IF MDROETIO
Begin DoDot:2
+24 SET IBACT=0
FOR
SET IBACT=$ORDER(^MMRS(104.1,MDROETIO,4,IBACT))
if 'IBACT
QUIT
Begin DoDot:3
+25 SET BACT=$GET(^MMRS(104.1,MDROETIO,4,IBACT,0))
+26 IF BACT'=""
SET ^TMP($JOB,"MMRSCD","BACT",MDROETIO,"INC_REMARK",IBACT)=BACT
End DoDot:3
+27 SET EBACT=0
FOR
SET EBACT=$ORDER(^MMRS(104.1,MDROETIO,5,EBACT))
if 'EBACT
QUIT
Begin DoDot:3
+28 SET BACT=$GET(^MMRS(104.1,MDROETIO,5,EBACT,0))
End DoDot:3
+29 SET ETIOL=0
FOR
SET ETIOL=$ORDER(^MMRS(104.1,MDROETIO,6,ETIOL))
if 'ETIOL
QUIT
Begin DoDot:3
+30 SET ETIOLOGY=$GET(^MMRS(104.1,MDROETIO,6,ETIOL,0))
+31 if 'ETIOLOGY
QUIT
+32 SET ^TMP($JOB,"MMRSCRE","ETIOL",MDROETIO,+ETIOLOGY)=""
End DoDot:3
End DoDot:2
+33 DO GETMOVE^MMRSCRE2
+34 DO GETLABS^MMRSCRE3
+35 DO PRINT^MMRSCRE4
End DoDot:1
+36 QUIT
+37 ;
PATDAYS ;Gets 'PATIENT DAYS OF CARE'.
+1 NEW TTLRSLT,SDT,EDT,LOC,RSLT,WLOC,WARD,PATDAYS,RTOT
+2 SET (FND,TTLRSLT,RTOT,TOTAL("PAT"),RSLT)=0
+3 SET SDT=$PIECE(STRTDT,".")
+4 SET EDT=$PIECE(ENDDT,".")
+5 if '$DATA(WRDLOC)
QUIT
+6 SET WARD=0
FOR
SET WARD=$ORDER(WRDLOC(WARD))
if $GET(WARD)'>0
QUIT
Begin DoDot:1
+7 SET LOC=$$GET1^DIQ(42,WARD,.015,"E")
+8 if LOC'=LOCNAME
QUIT
+9 SET PATDAYS=$$GETPATDY(WARD,SDT,EDT)
+10 KILL WRDLOC(WARD)
+11 ;bdoc are calculated by patients on ward @ midnight
+12 ;+ oneday admissions (patients admitted and discharged on same day).
+13 ;in order not to double-count oneday obs patient admitted to acute care
+14 ;on same day, adjus obs count.
+15 IF $GET(ODOBS(WARD))
SET PATDAYS=PATDAYS-ODOBS(WARD)
+16 SET RSLT=RSLT+PATDAYS
SET TTLRSLT=TTLRSLT+PATDAYS
+17 SET $PIECE(^TMP($JOB,"MMRSCREPD","DSUM",LOCNAME),U,1)=RSLT
End DoDot:1
+18 SET $PIECE(^TMP($JOB,"MMRSCREPD","DSUM"),U,1)=TTLRSLT
+19 SET TOTAL("PAT")=TTLRSLT
+20 QUIT
GETPATDY(WARD,SDT,EDT) ;Helper function for PATDAYS() - Gets Patient Days of care for specific ward
+1 NEW CENSUS,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 SET CENSUS=$ORDER(^DG(41.9,"B",WARD,0))
IF 'CENSUS
QUIT 0
+5 SET SDT=$$FMADD^XLFDT(SDT,-1,0,0,0)
+6 SET SCUMPD=$PIECE($GET(^DG(41.9,CENSUS,"C",SDT,0)),U,3)
+7 IF EDT=$$DT^XLFDT
SET EDT=$$FMADD^XLFDT(EDT,-1,0,0,0)
+8 SET ECUMPD=$PIECE($GET(^DG(41.9,CENSUS,"C",EDT,0)),U,3)
+9 ; IF LAST DAY OF FY
IF $EXTRACT(SDT,4,7)="0930"
SET SCUMPD=0
+10 IF ECUMPD<SCUMPD
QUIT 0
+11 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)
+3 ;
END ;
+1 KILL ALL,DIRUT,DIVSN,DPT,ETIO,FID,FND,II,III,IXI,LOCNME
+2 KILL LRIEN,MDROETIO,OBOBS,ORGP,PRMPTTXT,SPCM,STP,SUB,TSTSTP
+3 KILL WR,WRDLOC,XX,MMRSSUM,DIVARY,DVSN,MDIV
+4 QUIT
+5 ;
