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