MMRSCDI ;LEIDOS/TCK - Print CDI report ; 4/10/17 2:08pm
;;1.0;MRSA TOOLS REPORTS MENU;**4,5**;Mar 22, 2009;Build 146
;
MAIN ;
N EXTFLG,MMRSDIV,MMRSLOC
;check if parameters are setup.
D CLEAN
D CHECK^MMRSIPC Q:$D(EXTFLG)
S NUMDIV=1
D CHECK Q:$D(EXTFLG)
D PROMPT
I $D(EXTFLG) D CLEAN K MMRSSUM,DIVARY,DVSN,MDIV Q
Q:'CHK
K EXTFLG
Q:'CHK
D ASKDVC Q:$D(EXTFLG)
S MMRSNOW=$$NOW^XLFDT()
D CLEAN
D END^MMRSCDI1
D QUIT
Q
;
PROMPT ;Prompt for division
N STID,STNM,SIEN
S (STP,ALL)=0
I $G(MDROETIO)'>0 S MDROETIO=""
S MMRSMDRO="",MMRSMDRO=$O(^MMRS(104.2,"B","C. diff",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:DIV'>0 D Q:STP!('CHK)
..S WR=$$GET1^DIQ(104,+DIV,.01,"I")
..S IEN="",IEN=$O(^MMRS(104.1,"C",+DIV,MMRSMDRO,IEN))
..Q:$G(IEN)'>0
..S ORGP=$$GET1^DIQ(104.1,IEN,.01,"I")
..D CHKPAR(ORGP,+DIV,.CHK)
..I 'CHK S (MDROETIO,TSTSTP)=0 D ERROR Q
..S FID=$$GET1^DIQ(40.8,WR,1,"E"),STID=$$GET1^DIQ(40.8,WR,.01,"E")
..S MMRSLOC(FID)=STID,DIVARY(STID)=+DIV
..I $G(NUMDIV)'>0 S STP=1 Q
..;I $G(SPCM)'>0 S STP=1 Q
Q:STP
I 'Y D Q:'CHK
.N DLAYGO,DTOUT,DUOUT
.S CHK=1
.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
.S IEN="",IEN=$O(^MMRS(104.1,"C",+Y,MMRSMDRO,IEN))
.Q:$G(IEN)'>0
.S ORGP=$$GET1^DIQ(104.1,IEN,.01,"I")
.D CHKPAR(ORGP,+Y,.CHK)
.I 'CHK S (MDROETIO,TSTSTP)=0 D ERROR Q
.S STID=$$GET1^DIQ(104,+Y,.01,"E"),FID=$$GET1^DIQ(104,+Y,1,"E")
.S MMRSLOC(FID)=STID,DIVARY(STID)=+Y
.S CHK=1
.S Y=""
.S DIC("A")="Select another Division: " F D ^DIC Q:Y=-1 D Q:'CHK
..S IEN="",IEN=$O(^MMRS(104.1,"C",+Y,MMRSMDRO,IEN))
..Q:$G(IEN)'>0
..S ORGP=$$GET1^DIQ(104.1,IEN,.01,"I")
..D CHKPAR(ORGP,Y,.CHK)
..I 'CHK S (MDROETIO,TSTSTP)=0 D ERROR Q
..S STID=$$GET1^DIQ(104,+Y,.01,"E")
..S FID=$$GET1^DIQ(104,+Y,1,"E"),MMRSLOC(FID)=STID,DIVARY(STID)=+Y
..I $G(NUMDIV)'>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 ;
N DATE,%DT
S DATE=$$FMADD^XLFDT(DT,-364),%DT("B")=$$FMTE^XLFDT(DATE,"L")
W ! S %DT="AEPX",%DT("A")="Beginning POS CDI Lab ID Event (Collection) Date: " D ^%DT
I Y<0 S EXTFLG=1 Q
S STRTDT=Y
I STRTDT<DATE W !!,"The start date of the range cannot be greater than one year from today." G DATE
S DFLTDT=$$FMADD^XLFDT(STRTDT,-56)
DATE1 ;
S %DT("A")="Ending POS CDI Lab ID Event (Collection) Date: " K %DT("B") 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 end date of the range must be later than the starting date." G DATE1
Q
;
CHKPAR(ORG,Y,CHK) ;
;
N I,TST,ETI
S (TSTSTP,MDROETIO)=0
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 S TSTSTP=1 Q
S ETI=$$GET1^DIQ(104.109,LIEN,.01,"I")
I $G(ETI)>0 S MDROETIO=1 Q
S CHK=0
Q
;
CHECK ; Check if lab tests and etiologies are setup
N II,XX,TST,MRSASTAP,ORG,ETIONAME,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'["DIFF"
..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")
....;I $G(TST)'=""&(TST["DIFF") S TSTSTP=1
....I $G(TST)'="" S TSTSTP=1
....;Q:$G(TST)'["DIFF"
....;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'["CLOSTRIDIUM"
.....S ETIONAME=XX,ORG=II,MDROETIO=ORG
Q
;
ERROR ;
I 'TSTSTP&'MDROETIO D
.S EXTFLG=1
.W !!," >>>The report cannot be run because the Laboratory Test(s) or"
.W !," the Etiology is not configured in the MDRO TOOLS LAB "
.W !," SEARCH/EXTRACT file, (104.1). Use the MDRO Tools "
.W !," Lab Parameter Setup option to configure."
Q
;
MAIN2 ;
S MMRSNOW=$$NOW^XLFDT()
D GETPARAM ; Load parameters in temp global
D PRT
Q
CLEAN ;
K ^TMP($J,"MMRSCDI")
K ^TMP($J,"MMRS")
K ^TMP($J,"MMRSCD"),DIVARY,DVSN
Q
;
GETPARAM ; Loads lab search/extract parameters from file 104.1
N TSTNM,TST,TEST,IEN,TIEN,ITOP,TOP,ETOP,IBACT,BACT,EBACT
N ETIOL,ETIOLOGY,ANTI,ANTIM,INC,MRSASTAP,ETIONAME,MMRSI,MMRSET,ORG
N MDRO
Q:'$D(DIVARY)
S (TSTSTP,MMRSETIO,MMRSDIV)=0,DIVSN=""
S MMRSMDRO=$O(^MMRS(104.2,"B","C. diff",0))
F S DIVSN=$O(DIVARY(DIVSN)) Q:DIVSN="" D
.K ^TMP($J,"MMRSCD")
.S Y=DIVARY(DIVSN)
.S IEN="",IEN=$O(^MMRS(104.1,"C",Y,MMRSMDRO,IEN))
.Q:$G(IEN)'>0
.S (FND,TST,INC)=0
.;I $G(TSTSTP)'>0 S TSTSTP=1
.;I TSTSTP D
.S MDRO=MMRSMDRO
.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 TSTSTP=1
..S ^TMP($J,"MMRSCD","T",MDRO,TEST,0)=$P($G(^MMRS(104.1,IEN,3,TIEN,0)),U,2,3)
.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,"MMRSCD","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,MMRSMDRO,5,EBACT,0))
..I BACT'="" S ^TMP($J,"MMRSCD","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,"MMRSCD","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,"MMRSCD","ETIOL",MDRO,ETIOLOGY,ANTI)=$G(^MMRS(104.1,IEN,6,ETIOL,1,ANTI,0))
..I $G(ETIOLOGY)'="" D
...D FIND^DIC(61.2,,".01E;@","PM","CLOSTRIDIUM DIFFICILE",,"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'["CLOSTRIDIUM DIFFICILE" Q
..K ^TMP($J,"MMRSCD","ETIOL",MMRSMDRO,ORG)
..S ^TMP($J,"MMRSCD","ETIOL",MMRSMDRO,ORG)="",MDROETIO=1
.K MMRSET
.D SETDATA
Q
;
SETDATA ;
N LOCATION,LOCNAME,DFN,LOCTYPE,MMRSI,SDRESULT,Y,WLOC,WARD,WARDNAME,VAIP,WRDNME
S DFN=0 F S DFN=$O(^DPT(DFN)) Q:'DFN D
.Q:'$D(^PXRMINDX(63,"PI",DFN))
.Q:$G(DFN)'>0
.D SETDATA2(DFN)
Q
;
SETDATA2(DFN) ;
N INTT,IEN,INDATE,INIFN,MRSA,MRSACULT,LABORDER,TSTNM,LABTEST,ORDITM,ORDTEMP,PATNM,VADM,DCDATE
S LOC=""
S (CDIVT,PCD)=""
;Get MRSA history
D GETLAB^MMRSCDI1(DFN,.MRSA,MMRSMDRO,MMRSNOW,"CD")
Q:'$D(MRSA)
S I="" F S I=$O(MRSA(I)) Q:I="" D
.Q:I=""
.S CDIVT=I
.S MRSA=$P(MRSA(I),"^",1,2)
.S LOC=+$P(MRSA(I),"^",3)
.S DVSN=$$GET1^DIQ(44,+LOC,3.5,"E")
.Q:DVSN'=DIVSN
.Q:'$D(DIVARY(DVSN))
.S WARDNAME=$$GET1^DIQ(44,+LOC,.01,"E")
.;Get Order info
.S LABORDER="^^"
.Q:'CDIVT
.S MRSA=$P(MRSA(I),"^",2)
.S LRFILE=44
.S STPCD=$$GET1^DIQ(LRFILE,+LOC,8,"I")
.S TYPE=$$GET1^DIQ(LRFILE,+LOC,2,"E")
.S SERV=$$GET1^DIQ(LRFILE,+LOC,9,"E")
.D GTDATE(DFN,CDIVT,.INDATE,.DCDATE)
.I $G(TYPE)'="",TYPE'="WARD" S (INDATE,DCDATE)=""
.I $D(^TMP($J,"MMRSCD","T")) D
..S MDRO="" F S MDRO=$O(^TMP($J,"MMRSCD","T",MDRO)) Q:MDRO="" D
...Q:$G(MDRO)'>0
...S TST="" F S TST=$O(^TMP($J,"MMRSCD","T",MDRO,TST)) Q:TST="" D
....N TESTS D GORDITM(TST,.LABORDER,.TESTS) ;MIA/LMT - Added with patch MMRS*1*1
.S PCD="",PATNM=$$GET1^DIQ(2,DFN,.01,"E")
.Q:$D(^TMP($J,"MMRSCDI",DVSN,WARDNAME,PATNM,DFN,CDIVT))
.I $D(^TMP($J,"MMRSCDI",DVSN,WARDNAME,PATNM,DFN)) D
..S PCD=999999999999999
..S PCD=$O(^TMP($J,"MMRSCDI",DVSN,WARDNAME,PATNM,DFN,PCD),-1)
.S CD=CDIVT,CD=$O(MRSA(CD),-1)
.I $G(CD)>0,CD<CDIVT S PCD=CD
.Q:CDIVT<STRTDT
.S ^TMP($J,"MMRSCDI",DVSN,WARDNAME,PATNM,DFN,CDIVT)=$G(TYPE)_U_$G(SERV)_U_$G(STPCD)_U_$G(CDIVT)_U_$G(INDATE)_U_$G(DCDATE)_U_$G(MRSA)_U_$G(PCD),PCD=""
K MRSA
Q
;
GTDATE(DFN,CDIVT,IND,DCDT) ;
N DATE,IEN
S (IND,DCDT)="",FND=0
Q:$G(CDIVT)=""
Q:'$D(^DGPM("APTT1",DFN))
S DATE=9999999999,TT=1
F S DATE=$O(^DGPM("APTT"_TT,DFN,DATE),-1) Q:DATE="" D Q:FND
.Q:DATE=""
.I CDIVT<DATE Q
.S IEN="",IEN=$O(^DGPM("APTT"_TT,DFN,DATE,IEN))
.Q:$G(IEN)'>0
.I $G(IEN)>0 D
..S IND=$$GET1^DIQ(405,IEN,.01,"I")
..S WRD=$$GET1^DIQ(405,IEN,.06,"E")
..S LOCNME="",LOCNME=$$GET1^DIQ(44,LOC,.01,"E")
.I WRD=LOCNME S FND=1
.S NXDT=$O(^DGPM("APTT"_TT,DFN,DATE),-1)
.I $G(NXDT)'>0 K NXDT S FND=1
.I $G(NXDT)>0 S DATE=NXDT,NXDT=""
.Q:$G(DATE)'>0
.S IEN="",IEN=$O(^DGPM("APTT"_TT,DFN,DATE,IEN))
.S TIEN=$$GET1^DIQ(405,IEN,.17,"I")
.I $G(TIEN)'>0 Q
.S DCDT=$$GET1^DIQ(405,TIEN,.01,"I")
.I DCDT>CDIVT S FND=1,DCDT="" Q
.I DCDT'="" S FND=1 Q
Q
;
GORDITM(LABTEST,LABORDER,TESTS) ;MIA/LMT - Added with patch MMRS*1*1 - Include panels in search
N ORDITM,ORDTEMP,LABPANEL
I $D(TESTS(LABTEST)) Q ;prevent infinite recursion; if site has Panel A within Panel B, and Panel B within Panel A
S TESTS(LABTEST)=1 ;mark that we have searched this test (to prevent infinite recursion)
S ORDITM=0 F S ORDITM=$O(^ORD(101.43,"ID",LABTEST_";99LRT",ORDITM)) Q:'ORDITM D
.S ORDTEMP=$$GETORD(DFN,ORDITM,INDATE)
.I $P(LABORDER,U,1)'="YES"!(($P(LABORDER,U,3)'="YES")&($P(ORDTEMP,U,3)="YES")) S LABORDER=ORDTEMP
S LABPANEL=0 F S LABPANEL=$O(^LAB(60,"AB",LABTEST,LABPANEL)) Q:'LABPANEL D
.D GORDITM(LABPANEL,.LABORDER,.TESTS) ;Recursive call to check for tests within panels
Q
GETORD(DFN,ORDITM,INDATE) ;
N RESULT,START,STOP,DAS,STATUS,ORUPCHUK,LABREC
S RESULT="^^"
S START=$$FMADD^XLFDT(INDATE,-1)-.0000001
F S START=$O(^PXRMINDX(100,"PI",DFN,ORDITM,START)) Q:'START D
.S STOP="" F S STOP=$O(^PXRMINDX(100,"PI",DFN,ORDITM,START,STOP)) Q:STOP="" D
..S DAS="" F S DAS=$O(^PXRMINDX(100,"PI",DFN,ORDITM,START,STOP,DAS)) Q:DAS="" D
...D EN^ORX8(+DAS)
...S STATUS=$P(ORUPCHUK("ORSTS"),U,1)
...I STATUS'=2,STATUS'=5,STATUS'=6 Q
...S LABREC="NO"
...I STATUS=6!(STATUS=2) S LABREC="YES"
...I $P(RESULT,U,3)'="YES" S RESULT="YES^"_START_U_LABREC
Q RESULT
PRT ;
N LN,PG,LOCNAME,PATNM,DFN,NODE,LAST4,INTT,ADT,ORDDATE,VADM,QUIT,COUNT,DOB,PRVCDI
K ^TMP($J,"MMRSCDI","T")
K ^TMP($J,"MMRSCDI","ETIOL")
S $P(LN,"-",160)=""
S PG=1,QUIT=0
S DVS=""
F S DVS=$O(DIVARY(DVS)) Q:DVS="" D
.I '$D(^TMP($J,"MMRSCDI",DVS)) D Q
..S WARDNAME=""
..D PRTHDRS
..W !!!,"NO RECORDS FOUND FOR REPORTING PERIOD."
.S WARDNAME="" F S WARDNAME=$O(^TMP($J,"MMRSCDI",DVS,WARDNAME)) Q:WARDNAME="" D Q:QUIT
..I WARDNAME="" S QUIT=1 Q
..Q:'$D(^TMP($J,"MMRSCDI",DVS,WARDNAME))
..D PRTHDRS
..S PATNM="" F S PATNM=$O(^TMP($J,"MMRSCDI",DVS,WARDNAME,PATNM)) Q:PATNM="" D
...I PATNM?.N K ^TMP($J,"MMRSCDI",DVS,WARDNAME,PATNM) Q
...S DFN=0 F S DFN=$O(^TMP($J,"MMRSCDI",DVS,WARDNAME,PATNM,DFN)) Q:'DFN D Q:'DFN
....S CD=0 F S CD=$O(^TMP($J,"MMRSCDI",DVS,WARDNAME,PATNM,DFN,CD)) Q:'CD D
.....S NODE=$G(^TMP($J,"MMRSCDI",DVS,WARDNAME,PATNM,DFN,CD))
.....S TYPE=$P(NODE,"^")
.....S SERV=$P(NODE,"^",2)
.....S STPCD=$P(NODE,"^",3)
.....S CDIVT=$P(NODE,"^",4) I $G(CDIVT)>0 D
......S CDIVT=$$FMTE^XLFDT(CDIVT,2)
......I CDIVT["@" S CDIVT=$TR(CDIVT,"@"," ")
.....S INDATE=$P(NODE,"^",5) I $G(INDATE)>0 D
......S INDATE=$$FMTE^XLFDT(INDATE,2)
......I INDATE["@" S INDATE=$TR(INDATE,"@"," ")
.....S DCDT=$P(NODE,U,6) I $G(DCDT)>0 D
......S DCDT=$$FMTE^XLFDT(DCDT,2)
......I DCDT["@" S DCDT=$TR(DCDT,"@"," ")
.....S PRVCDI=$P(NODE,U,8) I $G(PRVCDI)>0 D
......S PRVCDI=$$FMTE^XLFDT(PRVCDI,2)
......I PRVCDI["@" S PRVCDI=$TR(PRVCDI,"@"," ")
.....D KVA^VADPT
.....D DEM^VADPT
.....S LAST4=$E($P(VADM(2),U),6,9)
.....D KVA^VADPT
.....S ORDDATE=$P(NODE,"^",5)
.....I ORDDATE S ORDDATE=$$FMTE^XLFDT(ORDDATE,"2M")
.....S DOB=$$GET1^DIQ(2,DFN,.03,"E")
.....W !,$E(PATNM,1,30),?25,LAST4,?30,DOB,?42,$G(CDIVT),?70,$G(INDATE),?90,$G(WARDNAME),?106,$G(DCDT),?130,$G(PRVCDI)
.....S COUNT=$G(COUNT)+1
.....S DL="^"
.....S ^TMP($J,"MMRS",COUNT)=PATNM_DL_LAST4_DL_DOB_DL_$G(CDIVT)_DL_$G(INDATE)_DL_$G(WARDNAME)_DL_$G(TYPE)_DL_$G(SERV)_DL_$G(STPCD)_DL_$G(DCDT)_DL_$G(PRVCDI)
....S PRVCDI=""
I '$D(ZTSK)&($G(ION)'["P-MESS") D
.D PRINTCDI
W !!,"END OF REPORT."
Q
;
PRINTCDI ;
W !!
I '$D(^TMP($J,"MMRS")) W !!!,"No CDI cases found during specified date range" Q
N DIR,DUOUT,DTOUT,DIRUT,Y
S PRINT=0
S DIR("A")="Print a delimited report to the screen? (Y/N): "
S DIR(0)="YA" D ^DIR
I $D(DIRUT)!($D(DUOUT)!$D(DTOUT)) S PRINT=0
I Y>0 S PRINT=1
S CDI=1
Q:'PRINT
W !!,"Delimited Report will now be printed to the screen..." H 3
D ^%ZIS
W @IOF
N C,I,DL
S (C,I)="",DL="^",CNT=0
F S C=$O(^TMP($J,"MMRS",C)) Q:C="" D
.S X1=$P(^TMP($J,"MMRS",C),DL)
.S X2=$P(^TMP($J,"MMRS",C),DL,2)
.S X3=$P(^TMP($J,"MMRS",C),DL,3)
.S X4=$P(^TMP($J,"MMRS",C),DL,4)
.S X5=$P(^TMP($J,"MMRS",C),DL,5)
.S X6=$P(^TMP($J,"MMRS",C),DL,6)
.S X7=$P(^TMP($J,"MMRS",C),DL,7)
.S X8=$P(^TMP($J,"MMRS",C),DL,8)
.S X9=$P(^TMP($J,"MMRS",C),DL,9)
.S X10=""
.S X11=$P(^TMP($J,"MMRS",C),DL,10)
.S X12=$P(^TMP($J,"MMRS",C),DL,11)
.W !,X1_DL_X2_DL_X3_DL_X4_DL_X5_DL_X6_DL_X7_DL_X8_DL_X9_DL_X10_DL_X11_DL_X12
Q
;
PRTHDRS ; Helper Function for PRT - Prints report headers
W @IOF
W ?13,"FACILITY CDI CASES REPORT"
W !,?13,"Division: ",DVS
W !,?13,"Geographical Location: ",WARDNAME
W !,?13,"Report period: ",$$FMTE^XLFDT(STRTDT)," to ",$$FMTE^XLFDT(ENDDT)
W !,?13,"Report printed on: ",$$FMTE^XLFDT(MMRSNOW),?75,"PAGE: ",PG
W !,"PATIENT",?25,"SSN",?30,"DOB",?42,"CDI Event D/T",?70,"ADM D/T",?90,"LOCATION",?105,"DC D/T",?130,"PREV CDI Event D/T"
W !,LN
S PG=PG+1
Q
ASKDVC ;Prompts user for device of output (allows queuing)
W !!
N MMRSVAR
W !!!,"This report is designed for a 132 column format (compressed).",!
S MMRSVAR("MMRSLOC")="",MMRS("MMRSLOC(")="",MMRSVAR("MMRSDIV")="",MMRSVAR("STRTDT")=""
S MMRSVAR("ENDDT")="",MMRSVAR("TSTSTP")="",MMRSVAR("MDROETIO")="",MMRSVAR("DFLTDT")="",MMRSVAR("DIVARY")="",MMRSVAR("DIVARY(")=""
D EN^XUTMDEVQ("MAIN2^MMRSCDI","Print CDI report (MMRSCDI)",.MMRSVAR,"QM",1)
W:$D(ZTSK) !,"Report Queued to Print ("_ZTSK_").",!
Q
;
QUIT ;
K ALL,DFLDT,DIV,DIVSN,DVS,FID,IXI,LIEN,LOCNME,MMRS
K MMRSETIO,NUMDIV,STP,TSTSTP,TT,WR,WRD,DFLTDT
K ENDDT,FND,CDI,LCPTR,LRFILE,MMRSMDRO,PCDIVT,PRINT,PCDIVT,SERV
K STPCD,STRTDT,TYPE,WPTR,WRDPTR,X2,X10,X12,X2,X3,X4,X5,X6,X7,X8,X9
K X1,X11,MRSA,^TMP($J),ORGP,MDROETIO,CNT,PCD,CD,ETIO,III,IX,I
K LOC,MMRSNOW,PTR,TSTSTP,ZTSK,DVSN,DIVARY
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMMRSCDI 15068 printed Oct 16, 2024@18:15:51 Page 2
MMRSCDI ;LEIDOS/TCK - Print CDI report ; 4/10/17 2:08pm
+1 ;;1.0;MRSA TOOLS REPORTS MENU;**4,5**;Mar 22, 2009;Build 146
+2 ;
MAIN ;
+1 NEW EXTFLG,MMRSDIV,MMRSLOC
+2 ;check if parameters are setup.
+3 DO CLEAN
+4 DO CHECK^MMRSIPC
if $DATA(EXTFLG)
QUIT
+5 SET NUMDIV=1
+6 DO CHECK
if $DATA(EXTFLG)
QUIT
+7 DO PROMPT
+8 IF $DATA(EXTFLG)
DO CLEAN
KILL MMRSSUM,DIVARY,DVSN,MDIV
QUIT
+9 if 'CHK
QUIT
+10 KILL EXTFLG
+11 if 'CHK
QUIT
+12 DO ASKDVC
if $DATA(EXTFLG)
QUIT
+13 SET MMRSNOW=$$NOW^XLFDT()
+14 DO CLEAN
+15 DO END^MMRSCDI1
+16 DO QUIT
+17 QUIT
+18 ;
PROMPT ;Prompt for division
+1 NEW STID,STNM,SIEN
+2 SET (STP,ALL)=0
+3 IF $GET(MDROETIO)'>0
SET MDROETIO=""
+4 SET MMRSMDRO=""
SET MMRSMDRO=$ORDER(^MMRS(104.2,"B","C. diff",0))
+5 WRITE !
+6 SET DIR(0)="YA"
SET DIR("A")="Do you want to select all divisions: "
SET DIR("B")="NO"
+7 DO ^DIR
KILL DIR
+8 IF $DATA(DIRUT)
SET EXTFLG=1
QUIT
+9 IF Y=1
SET ALL=1
Begin DoDot:1
+10 SET CHK=1
+11 SET DIV=0
FOR
SET DIV=$ORDER(^MMRS(104,DIV))
if DIV'>0
QUIT
Begin DoDot:2
+12 SET WR=$$GET1^DIQ(104,+DIV,.01,"I")
+13 SET IEN=""
SET IEN=$ORDER(^MMRS(104.1,"C",+DIV,MMRSMDRO,IEN))
+14 if $GET(IEN)'>0
QUIT
+15 SET ORGP=$$GET1^DIQ(104.1,IEN,.01,"I")
+16 DO CHKPAR(ORGP,+DIV,.CHK)
+17 IF 'CHK
SET (MDROETIO,TSTSTP)=0
DO ERROR
QUIT
+18 SET FID=$$GET1^DIQ(40.8,WR,1,"E")
SET STID=$$GET1^DIQ(40.8,WR,.01,"E")
+19 SET MMRSLOC(FID)=STID
SET DIVARY(STID)=+DIV
+20 IF $GET(NUMDIV)'>0
SET STP=1
QUIT
+21 ;I $G(SPCM)'>0 S STP=1 Q
End DoDot:2
if STP!('CHK)
QUIT
End DoDot:1
if 'CHK
QUIT
+22 if STP
QUIT
+23 IF 'Y
Begin DoDot:1
+24 NEW DLAYGO,DTOUT,DUOUT
+25 SET CHK=1
+26 WRITE !
+27 SET DIC("A")="Select Division: "
+28 SET DIC="^MMRS(104,"
SET DIC(0)="QEAM"
DO ^DIC
+29 IF (Y=-1)!($DATA(DTOUT))!($DATA(DUOUT))
SET EXTFLG=1
QUIT
+30 SET IEN=""
SET IEN=$ORDER(^MMRS(104.1,"C",+Y,MMRSMDRO,IEN))
+31 if $GET(IEN)'>0
QUIT
+32 SET ORGP=$$GET1^DIQ(104.1,IEN,.01,"I")
+33 DO CHKPAR(ORGP,+Y,.CHK)
+34 IF 'CHK
SET (MDROETIO,TSTSTP)=0
DO ERROR
QUIT
+35 SET STID=$$GET1^DIQ(104,+Y,.01,"E")
SET FID=$$GET1^DIQ(104,+Y,1,"E")
+36 SET MMRSLOC(FID)=STID
SET DIVARY(STID)=+Y
+37 SET CHK=1
+38 SET Y=""
+39 SET DIC("A")="Select another Division: "
FOR
DO ^DIC
if Y=-1
QUIT
Begin DoDot:2
+40 SET IEN=""
SET IEN=$ORDER(^MMRS(104.1,"C",+Y,MMRSMDRO,IEN))
+41 if $GET(IEN)'>0
QUIT
+42 SET ORGP=$$GET1^DIQ(104.1,IEN,.01,"I")
+43 DO CHKPAR(ORGP,Y,.CHK)
+44 IF 'CHK
SET (MDROETIO,TSTSTP)=0
DO ERROR
QUIT
+45 SET STID=$$GET1^DIQ(104,+Y,.01,"E")
+46 SET FID=$$GET1^DIQ(104,+Y,1,"E")
SET MMRSLOC(FID)=STID
SET DIVARY(STID)=+Y
+47 IF $GET(NUMDIV)'>0
SET STP=1
QUIT
End DoDot:2
if 'CHK
QUIT
+48 IF ($DATA(DTOUT))!($DATA(DUOUT))
SET EXTFLG=1
QUIT
End DoDot:1
if 'CHK
QUIT
+49 KILL DIC
+50 if $GET(NUMDIV)'>0
QUIT
+51 ;Q:$G(SPCM)'>0
+52 if $DATA(EXTFLG)
QUIT
+53 IF ($DATA(DTOUT))!($DATA(DUOUT))
SET EXTFLG=1
QUIT
DATE ;
+1 NEW DATE,%DT
+2 SET DATE=$$FMADD^XLFDT(DT,-364)
SET %DT("B")=$$FMTE^XLFDT(DATE,"L")
+3 WRITE !
SET %DT="AEPX"
SET %DT("A")="Beginning POS CDI Lab ID Event (Collection) Date: "
DO ^%DT
+4 IF Y<0
SET EXTFLG=1
QUIT
+5 SET STRTDT=Y
+6 IF STRTDT<DATE
WRITE !!,"The start date of the range cannot be greater than one year from today."
GOTO DATE
+7 SET DFLTDT=$$FMADD^XLFDT(STRTDT,-56)
DATE1 ;
+1 SET %DT("A")="Ending POS CDI Lab ID Event (Collection) Date: "
KILL %DT("B")
DO ^%DT
+2 IF Y<0
SET EXTFLG=1
QUIT
+3 SET ENDDT=Y
+4 IF '$PIECE(ENDDT,".",2)
SET ENDDT=Y+.24
+5 IF ENDDT<STRTDT
WRITE !!,"The end date of the range must be later than the starting date."
GOTO DATE1
+6 QUIT
+7 ;
CHKPAR(ORG,Y,CHK) ;
+1 ;
+2 NEW I,TST,ETI
+3 SET (TSTSTP,MDROETIO)=0
+4 IF '$DATA(^MMRS(104.1,"C",+Y,ORG))
SET CHK=0
QUIT
+5 SET I=""
SET I=$ORDER(^MMRS(104.1,"C",+Y,ORG,I))
+6 SET LIEN=1_","_I_","
+7 SET TST=$$GET1^DIQ(104.15,LIEN,.01,"I")
+8 IF $GET(TST)>0
SET TSTSTP=1
QUIT
+9 SET ETI=$$GET1^DIQ(104.109,LIEN,.01,"I")
+10 IF $GET(ETI)>0
SET MDROETIO=1
QUIT
+11 SET CHK=0
+12 QUIT
+13 ;
CHECK ; Check if lab tests and etiologies are setup
+1 NEW II,XX,TST,MRSASTAP,ORG,ETIONAME,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'["DIFF"
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 ;I $G(TST)'=""&(TST["DIFF") S TSTSTP=1
+19 IF $GET(TST)'=""
SET TSTSTP=1
+20 ;Q:$G(TST)'["DIFF"
+21 ;S TSTSTP=1
End DoDot:4
+22 IF $DATA(^MMRS(104.1,II,6))
Begin DoDot:4
+23 SET IXI=0
FOR
SET IXI=$ORDER(^MMRS(104.1,II,6,IXI))
if IXI'>0
QUIT
Begin DoDot:5
+24 if IXI=""
QUIT
+25 if 'IXI
QUIT
+26 SET III=IXI_","_II_","
+27 SET XX=$$GET1^DIQ(104.109,III,.01,"E")
+28 if XX'["CLOSTRIDIUM"
QUIT
+29 SET ETIONAME=XX
SET ORG=II
SET MDROETIO=ORG
End DoDot:5
if MDROETIO
QUIT
End DoDot:4
End DoDot:3
if TSTSTP
QUIT
End DoDot:2
if MDROETIO!(TSTSTP)
QUIT
End DoDot:1
+30 QUIT
+31 ;
ERROR ;
+1 IF 'TSTSTP&'MDROETIO
Begin DoDot:1
+2 SET EXTFLG=1
+3 WRITE !!," >>>The report cannot be run because the Laboratory Test(s) or"
+4 WRITE !," the Etiology is not configured in the MDRO TOOLS LAB "
+5 WRITE !," SEARCH/EXTRACT file, (104.1). Use the MDRO Tools "
+6 WRITE !," Lab Parameter Setup option to configure."
End DoDot:1
+7 QUIT
+8 ;
MAIN2 ;
+1 SET MMRSNOW=$$NOW^XLFDT()
+2 ; Load parameters in temp global
DO GETPARAM
+3 DO PRT
+4 QUIT
CLEAN ;
+1 KILL ^TMP($JOB,"MMRSCDI")
+2 KILL ^TMP($JOB,"MMRS")
+3 KILL ^TMP($JOB,"MMRSCD"),DIVARY,DVSN
+4 QUIT
+5 ;
GETPARAM ; Loads lab search/extract parameters from file 104.1
+1 NEW TSTNM,TST,TEST,IEN,TIEN,ITOP,TOP,ETOP,IBACT,BACT,EBACT
+2 NEW ETIOL,ETIOLOGY,ANTI,ANTIM,INC,MRSASTAP,ETIONAME,MMRSI,MMRSET,ORG
+3 NEW MDRO
+4 if '$DATA(DIVARY)
QUIT
+5 SET (TSTSTP,MMRSETIO,MMRSDIV)=0
SET DIVSN=""
+6 SET MMRSMDRO=$ORDER(^MMRS(104.2,"B","C. diff",0))
+7 FOR
SET DIVSN=$ORDER(DIVARY(DIVSN))
if DIVSN=""
QUIT
Begin DoDot:1
+8 KILL ^TMP($JOB,"MMRSCD")
+9 SET Y=DIVARY(DIVSN)
+10 SET IEN=""
SET IEN=$ORDER(^MMRS(104.1,"C",Y,MMRSMDRO,IEN))
+11 if $GET(IEN)'>0
QUIT
+12 SET (FND,TST,INC)=0
+13 ;I $G(TSTSTP)'>0 S TSTSTP=1
+14 ;I TSTSTP D
+15 SET MDRO=MMRSMDRO
+16 SET TIEN=0
FOR
SET TIEN=$ORDER(^MMRS(104.1,IEN,3,TIEN))
if 'TIEN
QUIT
Begin DoDot:2
+17 SET TEST=$PIECE($GET(^MMRS(104.1,IEN,3,TIEN,0)),U,1)
+18 if 'TEST
QUIT
+19 SET INC=INC+1
+20 SET TSTSTP=1
+21 SET ^TMP($JOB,"MMRSCD","T",MDRO,TEST,0)=$PIECE($GET(^MMRS(104.1,IEN,3,TIEN,0)),U,2,3)
End DoDot:2
+22 SET IBACT=0
FOR
SET IBACT=$ORDER(^MMRS(104.1,IEN,4,IBACT))
if 'IBACT
QUIT
Begin DoDot:2
+23 SET BACT=$GET(^MMRS(104.1,IEN,4,IBACT,0))
+24 IF BACT'=""
SET ^TMP($JOB,"MMRSCD","BACT",MDRO,"INC_REMARK",IBACT)=BACT
End DoDot:2
+25 SET EBACT=0
FOR
SET EBACT=$ORDER(^MMRS(104.1,IEN,5,EBACT))
if 'EBACT
QUIT
Begin DoDot:2
+26 SET BACT=$GET(^MMRS(104.1,MMRSMDRO,5,EBACT,0))
+27 IF BACT'=""
SET ^TMP($JOB,"MMRSCD","BACT",MDRO,"EXC_REMARK",EBACT)=BACT
End DoDot:2
+28 SET ETIOL=0
FOR
SET ETIOL=$ORDER(^MMRS(104.1,IEN,6,ETIOL))
if 'ETIOL
QUIT
Begin DoDot:2
+29 SET ETIOLOGY=$GET(^MMRS(104.1,IEN,6,ETIOL,0))
+30 if 'ETIOLOGY
QUIT
+31 SET ^TMP($JOB,"MMRSCD","ETIOL",MDRO,+ETIOLOGY)=""
+32 SET ANTI=0
FOR
SET ANTI=$ORDER(^MMRS(104.1,IEN,6,ETIOL,1,ANTI))
if 'ANTI
QUIT
Begin DoDot:3
+33 SET ANTIM=$PIECE($GET(^MMRS(104.1,IEN,6,ETIOL,1,ANTI,0)),U)
+34 IF ANTIM
SET ^TMP($JOB,"MMRSCD","ETIOL",MDRO,ETIOLOGY,ANTI)=$GET(^MMRS(104.1,IEN,6,ETIOL,1,ANTI,0))
End DoDot:3
+35 IF $GET(ETIOLOGY)'=""
Begin DoDot:3
+36 DO FIND^DIC(61.2,,".01E;@","PM","CLOSTRIDIUM DIFFICILE",,"B",,,"MMRSET")
End DoDot:3
End DoDot:2
+37 SET MMRSI=""
FOR
SET MMRSI=$ORDER(MMRSET("DILIST",MMRSI))
if MMRSI=""
QUIT
IF +MMRSI>0
Begin DoDot:2
+38 SET ETIONAME=$PIECE($GET(MMRSET("DILIST",MMRSI,0)),U,2)
+39 SET ORG=$PIECE($GET(MMRSET("DILIST",MMRSI,0)),U,1)
+40 IF ETIONAME'["CLOSTRIDIUM DIFFICILE"
QUIT
+41 KILL ^TMP($JOB,"MMRSCD","ETIOL",MMRSMDRO,ORG)
+42 SET ^TMP($JOB,"MMRSCD","ETIOL",MMRSMDRO,ORG)=""
SET MDROETIO=1
End DoDot:2
+43 KILL MMRSET
+44 DO SETDATA
End DoDot:1
+45 QUIT
+46 ;
SETDATA ;
+1 NEW LOCATION,LOCNAME,DFN,LOCTYPE,MMRSI,SDRESULT,Y,WLOC,WARD,WARDNAME,VAIP,WRDNME
+2 SET DFN=0
FOR
SET DFN=$ORDER(^DPT(DFN))
if 'DFN
QUIT
Begin DoDot:1
+3 if '$DATA(^PXRMINDX(63,"PI",DFN))
QUIT
+4 if $GET(DFN)'>0
QUIT
+5 DO SETDATA2(DFN)
End DoDot:1
+6 QUIT
+7 ;
SETDATA2(DFN) ;
+1 NEW INTT,IEN,INDATE,INIFN,MRSA,MRSACULT,LABORDER,TSTNM,LABTEST,ORDITM,ORDTEMP,PATNM,VADM,DCDATE
+2 SET LOC=""
+3 SET (CDIVT,PCD)=""
+4 ;Get MRSA history
+5 DO GETLAB^MMRSCDI1(DFN,.MRSA,MMRSMDRO,MMRSNOW,"CD")
+6 if '$DATA(MRSA)
QUIT
+7 SET I=""
FOR
SET I=$ORDER(MRSA(I))
if I=""
QUIT
Begin DoDot:1
+8 if I=""
QUIT
+9 SET CDIVT=I
+10 SET MRSA=$PIECE(MRSA(I),"^",1,2)
+11 SET LOC=+$PIECE(MRSA(I),"^",3)
+12 SET DVSN=$$GET1^DIQ(44,+LOC,3.5,"E")
+13 if DVSN'=DIVSN
QUIT
+14 if '$DATA(DIVARY(DVSN))
QUIT
+15 SET WARDNAME=$$GET1^DIQ(44,+LOC,.01,"E")
+16 ;Get Order info
+17 SET LABORDER="^^"
+18 if 'CDIVT
QUIT
+19 SET MRSA=$PIECE(MRSA(I),"^",2)
+20 SET LRFILE=44
+21 SET STPCD=$$GET1^DIQ(LRFILE,+LOC,8,"I")
+22 SET TYPE=$$GET1^DIQ(LRFILE,+LOC,2,"E")
+23 SET SERV=$$GET1^DIQ(LRFILE,+LOC,9,"E")
+24 DO GTDATE(DFN,CDIVT,.INDATE,.DCDATE)
+25 IF $GET(TYPE)'=""
IF TYPE'="WARD"
SET (INDATE,DCDATE)=""
+26 IF $DATA(^TMP($JOB,"MMRSCD","T"))
Begin DoDot:2
+27 SET MDRO=""
FOR
SET MDRO=$ORDER(^TMP($JOB,"MMRSCD","T",MDRO))
if MDRO=""
QUIT
Begin DoDot:3
+28 if $GET(MDRO)'>0
QUIT
+29 SET TST=""
FOR
SET TST=$ORDER(^TMP($JOB,"MMRSCD","T",MDRO,TST))
if TST=""
QUIT
Begin DoDot:4
+30 ;MIA/LMT - Added with patch MMRS*1*1
NEW TESTS
DO GORDITM(TST,.LABORDER,.TESTS)
End DoDot:4
End DoDot:3
End DoDot:2
+31 SET PCD=""
SET PATNM=$$GET1^DIQ(2,DFN,.01,"E")
+32 if $DATA(^TMP($JOB,"MMRSCDI",DVSN,WARDNAME,PATNM,DFN,CDIVT))
QUIT
+33 IF $DATA(^TMP($JOB,"MMRSCDI",DVSN,WARDNAME,PATNM,DFN))
Begin DoDot:2
+34 SET PCD=999999999999999
+35 SET PCD=$ORDER(^TMP($JOB,"MMRSCDI",DVSN,WARDNAME,PATNM,DFN,PCD),-1)
End DoDot:2
+36 SET CD=CDIVT
SET CD=$ORDER(MRSA(CD),-1)
+37 IF $GET(CD)>0
IF CD<CDIVT
SET PCD=CD
+38 if CDIVT<STRTDT
QUIT
+39 SET ^TMP($JOB,"MMRSCDI",DVSN,WARDNAME,PATNM,DFN,CDIVT)=$GET(TYPE)_U_$GET(SERV)_U_$GET(STPCD)_U_$GET(CDIVT)_U_$GET(INDATE)_U_$GET(DCDATE)_U_$GET(MRSA)_U_$GET(PCD)
SET PCD=""
End DoDot:1
+40 KILL MRSA
+41 QUIT
+42 ;
GTDATE(DFN,CDIVT,IND,DCDT) ;
+1 NEW DATE,IEN
+2 SET (IND,DCDT)=""
SET FND=0
+3 if $GET(CDIVT)=""
QUIT
+4 if '$DATA(^DGPM("APTT1",DFN))
QUIT
+5 SET DATE=9999999999
SET TT=1
+6 FOR
SET DATE=$ORDER(^DGPM("APTT"_TT,DFN,DATE),-1)
if DATE=""
QUIT
Begin DoDot:1
+7 if DATE=""
QUIT
+8 IF CDIVT<DATE
QUIT
+9 SET IEN=""
SET IEN=$ORDER(^DGPM("APTT"_TT,DFN,DATE,IEN))
+10 if $GET(IEN)'>0
QUIT
+11 IF $GET(IEN)>0
Begin DoDot:2
+12 SET IND=$$GET1^DIQ(405,IEN,.01,"I")
+13 SET WRD=$$GET1^DIQ(405,IEN,.06,"E")
+14 SET LOCNME=""
SET LOCNME=$$GET1^DIQ(44,LOC,.01,"E")
End DoDot:2
+15 IF WRD=LOCNME
SET FND=1
+16 SET NXDT=$ORDER(^DGPM("APTT"_TT,DFN,DATE),-1)
+17 IF $GET(NXDT)'>0
KILL NXDT
SET FND=1
+18 IF $GET(NXDT)>0
SET DATE=NXDT
SET NXDT=""
+19 if $GET(DATE)'>0
QUIT
+20 SET IEN=""
SET IEN=$ORDER(^DGPM("APTT"_TT,DFN,DATE,IEN))
+21 SET TIEN=$$GET1^DIQ(405,IEN,.17,"I")
+22 IF $GET(TIEN)'>0
QUIT
+23 SET DCDT=$$GET1^DIQ(405,TIEN,.01,"I")
+24 IF DCDT>CDIVT
SET FND=1
SET DCDT=""
QUIT
+25 IF DCDT'=""
SET FND=1
QUIT
End DoDot:1
if FND
QUIT
+26 QUIT
+27 ;
GORDITM(LABTEST,LABORDER,TESTS) ;MIA/LMT - Added with patch MMRS*1*1 - Include panels in search
+1 NEW ORDITM,ORDTEMP,LABPANEL
+2 ;prevent infinite recursion; if site has Panel A within Panel B, and Panel B within Panel A
IF $DATA(TESTS(LABTEST))
QUIT
+3 ;mark that we have searched this test (to prevent infinite recursion)
SET TESTS(LABTEST)=1
+4 SET ORDITM=0
FOR
SET ORDITM=$ORDER(^ORD(101.43,"ID",LABTEST_";99LRT",ORDITM))
if 'ORDITM
QUIT
Begin DoDot:1
+5 SET ORDTEMP=$$GETORD(DFN,ORDITM,INDATE)
+6 IF $PIECE(LABORDER,U,1)'="YES"!(($PIECE(LABORDER,U,3)'="YES")&($PIECE(ORDTEMP,U,3)="YES"))
SET LABORDER=ORDTEMP
End DoDot:1
+7 SET LABPANEL=0
FOR
SET LABPANEL=$ORDER(^LAB(60,"AB",LABTEST,LABPANEL))
if 'LABPANEL
QUIT
Begin DoDot:1
+8 ;Recursive call to check for tests within panels
DO GORDITM(LABPANEL,.LABORDER,.TESTS)
End DoDot:1
+9 QUIT
GETORD(DFN,ORDITM,INDATE) ;
+1 NEW RESULT,START,STOP,DAS,STATUS,ORUPCHUK,LABREC
+2 SET RESULT="^^"
+3 SET START=$$FMADD^XLFDT(INDATE,-1)-.0000001
+4 FOR
SET START=$ORDER(^PXRMINDX(100,"PI",DFN,ORDITM,START))
if 'START
QUIT
Begin DoDot:1
+5 SET STOP=""
FOR
SET STOP=$ORDER(^PXRMINDX(100,"PI",DFN,ORDITM,START,STOP))
if STOP=""
QUIT
Begin DoDot:2
+6 SET DAS=""
FOR
SET DAS=$ORDER(^PXRMINDX(100,"PI",DFN,ORDITM,START,STOP,DAS))
if DAS=""
QUIT
Begin DoDot:3
+7 DO EN^ORX8(+DAS)
+8 SET STATUS=$PIECE(ORUPCHUK("ORSTS"),U,1)
+9 IF STATUS'=2
IF STATUS'=5
IF STATUS'=6
QUIT
+10 SET LABREC="NO"
+11 IF STATUS=6!(STATUS=2)
SET LABREC="YES"
+12 IF $PIECE(RESULT,U,3)'="YES"
SET RESULT="YES^"_START_U_LABREC
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT RESULT
PRT ;
+1 NEW LN,PG,LOCNAME,PATNM,DFN,NODE,LAST4,INTT,ADT,ORDDATE,VADM,QUIT,COUNT,DOB,PRVCDI
+2 KILL ^TMP($JOB,"MMRSCDI","T")
+3 KILL ^TMP($JOB,"MMRSCDI","ETIOL")
+4 SET $PIECE(LN,"-",160)=""
+5 SET PG=1
SET QUIT=0
+6 SET DVS=""
+7 FOR
SET DVS=$ORDER(DIVARY(DVS))
if DVS=""
QUIT
Begin DoDot:1
+8 IF '$DATA(^TMP($JOB,"MMRSCDI",DVS))
Begin DoDot:2
+9 SET WARDNAME=""
+10 DO PRTHDRS
+11 WRITE !!!,"NO RECORDS FOUND FOR REPORTING PERIOD."
End DoDot:2
QUIT
+12 SET WARDNAME=""
FOR
SET WARDNAME=$ORDER(^TMP($JOB,"MMRSCDI",DVS,WARDNAME))
if WARDNAME=""
QUIT
Begin DoDot:2
+13 IF WARDNAME=""
SET QUIT=1
QUIT
+14 if '$DATA(^TMP($JOB,"MMRSCDI",DVS,WARDNAME))
QUIT
+15 DO PRTHDRS
+16 SET PATNM=""
FOR
SET PATNM=$ORDER(^TMP($JOB,"MMRSCDI",DVS,WARDNAME,PATNM))
if PATNM=""
QUIT
Begin DoDot:3
+17 IF PATNM?.N
KILL ^TMP($JOB,"MMRSCDI",DVS,WARDNAME,PATNM)
QUIT
+18 SET DFN=0
FOR
SET DFN=$ORDER(^TMP($JOB,"MMRSCDI",DVS,WARDNAME,PATNM,DFN))
if 'DFN
QUIT
Begin DoDot:4
+19 SET CD=0
FOR
SET CD=$ORDER(^TMP($JOB,"MMRSCDI",DVS,WARDNAME,PATNM,DFN,CD))
if 'CD
QUIT
Begin DoDot:5
+20 SET NODE=$GET(^TMP($JOB,"MMRSCDI",DVS,WARDNAME,PATNM,DFN,CD))
+21 SET TYPE=$PIECE(NODE,"^")
+22 SET SERV=$PIECE(NODE,"^",2)
+23 SET STPCD=$PIECE(NODE,"^",3)
+24 SET CDIVT=$PIECE(NODE,"^",4)
IF $GET(CDIVT)>0
Begin DoDot:6
+25 SET CDIVT=$$FMTE^XLFDT(CDIVT,2)
+26 IF CDIVT["@"
SET CDIVT=$TRANSLATE(CDIVT,"@"," ")
End DoDot:6
+27 SET INDATE=$PIECE(NODE,"^",5)
IF $GET(INDATE)>0
Begin DoDot:6
+28 SET INDATE=$$FMTE^XLFDT(INDATE,2)
+29 IF INDATE["@"
SET INDATE=$TRANSLATE(INDATE,"@"," ")
End DoDot:6
+30 SET DCDT=$PIECE(NODE,U,6)
IF $GET(DCDT)>0
Begin DoDot:6
+31 SET DCDT=$$FMTE^XLFDT(DCDT,2)
+32 IF DCDT["@"
SET DCDT=$TRANSLATE(DCDT,"@"," ")
End DoDot:6
+33 SET PRVCDI=$PIECE(NODE,U,8)
IF $GET(PRVCDI)>0
Begin DoDot:6
+34 SET PRVCDI=$$FMTE^XLFDT(PRVCDI,2)
+35 IF PRVCDI["@"
SET PRVCDI=$TRANSLATE(PRVCDI,"@"," ")
End DoDot:6
+36 DO KVA^VADPT
+37 DO DEM^VADPT
+38 SET LAST4=$EXTRACT($PIECE(VADM(2),U),6,9)
+39 DO KVA^VADPT
+40 SET ORDDATE=$PIECE(NODE,"^",5)
+41 IF ORDDATE
SET ORDDATE=$$FMTE^XLFDT(ORDDATE,"2M")
+42 SET DOB=$$GET1^DIQ(2,DFN,.03,"E")
+43 WRITE !,$EXTRACT(PATNM,1,30),?25,LAST4,?30,DOB,?42,$GET(CDIVT),?70,$GET(INDATE),?90,$GET(WARDNAME),?106,$GET(DCDT),?130,$GET(PRVCDI)
+44 SET COUNT=$GET(COUNT)+1
+45 SET DL="^"
+46 SET ^TMP($JOB,"MMRS",COUNT)=PATNM_DL_LAST4_DL_DOB_DL_$GET(CDIVT)_DL_$GET(INDATE)_DL_$GET(WARDNAME)_DL_$GET(TYPE)_DL_$GET(SERV)_DL_$GET(STPCD)_DL_$GET(DCDT)_DL_$GET(PRVCDI)
End DoDot:5
+47 SET PRVCDI=""
End DoDot:4
if 'DFN
QUIT
End DoDot:3
End DoDot:2
if QUIT
QUIT
End DoDot:1
+48 IF '$DATA(ZTSK)&($GET(ION)'["P-MESS")
Begin DoDot:1
+49 DO PRINTCDI
End DoDot:1
+50 WRITE !!,"END OF REPORT."
+51 QUIT
+52 ;
PRINTCDI ;
+1 WRITE !!
+2 IF '$DATA(^TMP($JOB,"MMRS"))
WRITE !!!,"No CDI cases found during specified date range"
QUIT
+3 NEW DIR,DUOUT,DTOUT,DIRUT,Y
+4 SET PRINT=0
+5 SET DIR("A")="Print a delimited report to the screen? (Y/N): "
+6 SET DIR(0)="YA"
DO ^DIR
+7 IF $DATA(DIRUT)!($DATA(DUOUT)!$DATA(DTOUT))
SET PRINT=0
+8 IF Y>0
SET PRINT=1
+9 SET CDI=1
+10 if 'PRINT
QUIT
+11 WRITE !!,"Delimited Report will now be printed to the screen..."
HANG 3
+12 DO ^%ZIS
+13 WRITE @IOF
+14 NEW C,I,DL
+15 SET (C,I)=""
SET DL="^"
SET CNT=0
+16 FOR
SET C=$ORDER(^TMP($JOB,"MMRS",C))
if C=""
QUIT
Begin DoDot:1
+17 SET X1=$PIECE(^TMP($JOB,"MMRS",C),DL)
+18 SET X2=$PIECE(^TMP($JOB,"MMRS",C),DL,2)
+19 SET X3=$PIECE(^TMP($JOB,"MMRS",C),DL,3)
+20 SET X4=$PIECE(^TMP($JOB,"MMRS",C),DL,4)
+21 SET X5=$PIECE(^TMP($JOB,"MMRS",C),DL,5)
+22 SET X6=$PIECE(^TMP($JOB,"MMRS",C),DL,6)
+23 SET X7=$PIECE(^TMP($JOB,"MMRS",C),DL,7)
+24 SET X8=$PIECE(^TMP($JOB,"MMRS",C),DL,8)
+25 SET X9=$PIECE(^TMP($JOB,"MMRS",C),DL,9)
+26 SET X10=""
+27 SET X11=$PIECE(^TMP($JOB,"MMRS",C),DL,10)
+28 SET X12=$PIECE(^TMP($JOB,"MMRS",C),DL,11)
+29 WRITE !,X1_DL_X2_DL_X3_DL_X4_DL_X5_DL_X6_DL_X7_DL_X8_DL_X9_DL_X10_DL_X11_DL_X12
End DoDot:1
+30 QUIT
+31 ;
PRTHDRS ; Helper Function for PRT - Prints report headers
+1 WRITE @IOF
+2 WRITE ?13,"FACILITY CDI CASES REPORT"
+3 WRITE !,?13,"Division: ",DVS
+4 WRITE !,?13,"Geographical Location: ",WARDNAME
+5 WRITE !,?13,"Report period: ",$$FMTE^XLFDT(STRTDT)," to ",$$FMTE^XLFDT(ENDDT)
+6 WRITE !,?13,"Report printed on: ",$$FMTE^XLFDT(MMRSNOW),?75,"PAGE: ",PG
+7 WRITE !,"PATIENT",?25,"SSN",?30,"DOB",?42,"CDI Event D/T",?70,"ADM D/T",?90,"LOCATION",?105,"DC D/T",?130,"PREV CDI Event D/T"
+8 WRITE !,LN
+9 SET PG=PG+1
+10 QUIT
ASKDVC ;Prompts user for device of output (allows queuing)
+1 WRITE !!
+2 NEW MMRSVAR
+3 WRITE !!!,"This report is designed for a 132 column format (compressed).",!
+4 SET MMRSVAR("MMRSLOC")=""
SET MMRS("MMRSLOC(")=""
SET MMRSVAR("MMRSDIV")=""
SET MMRSVAR("STRTDT")=""
+5 SET MMRSVAR("ENDDT")=""
SET MMRSVAR("TSTSTP")=""
SET MMRSVAR("MDROETIO")=""
SET MMRSVAR("DFLTDT")=""
SET MMRSVAR("DIVARY")=""
SET MMRSVAR("DIVARY(")=""
+6 DO EN^XUTMDEVQ("MAIN2^MMRSCDI","Print CDI report (MMRSCDI)",.MMRSVAR,"QM",1)
+7 if $DATA(ZTSK)
WRITE !,"Report Queued to Print ("_ZTSK_").",!
+8 QUIT
+9 ;
QUIT ;
+1 KILL ALL,DFLDT,DIV,DIVSN,DVS,FID,IXI,LIEN,LOCNME,MMRS
+2 KILL MMRSETIO,NUMDIV,STP,TSTSTP,TT,WR,WRD,DFLTDT
+3 KILL ENDDT,FND,CDI,LCPTR,LRFILE,MMRSMDRO,PCDIVT,PRINT,PCDIVT,SERV
+4 KILL STPCD,STRTDT,TYPE,WPTR,WRDPTR,X2,X10,X12,X2,X3,X4,X5,X6,X7,X8,X9
+5 KILL X1,X11,MRSA,^TMP($JOB),ORGP,MDROETIO,CNT,PCD,CD,ETIO,III,IX,I
+6 KILL LOC,MMRSNOW,PTR,TSTSTP,ZTSK,DVSN,DIVARY
+7 QUIT
+8 ;
