MMRSIPC5 ;MIA/LMT - Auto-Extract MRSA IPEC Report ;08-20-09
;;1.0;MRSA PROGRAM TOOLS;;Aug 22, 2009;Build 35
;
;This routine will run the auto-extract for the MRSA IPEC Report.
;This routine uses functions contained in MMRSIPC, MMRSIPC2, MMRSIPC3, and MMRSIPC4.
TASK ;Entry for auto-extract to IPEC
;Extract prevalence and transmission data for all Acute Care and CLC units
Q:'$$PROD^XUPROD
N NOW,FIRST,STRTDT,ENDDT,MMRSDIV,TYPE,MMRSLOC,BYADM,PRTSUM,LOC,DATA,MMRSMSG
N MAILTO,MONTH,YEAR,DIV,DIVNUM,SUBJECT,LOCIEN,IPECUID
S NOW=$$NOW^XLFDT()
S FIRST=$E(NOW,1,5)_"01"
S ENDDT=$$FMADD^XLFDT(FIRST,-1,0,0,0)_".24"
S STRTDT=$E(ENDDT,1,5)_"01"
S MMRSDIV=0 F S MMRSDIV=$O(^MMRS(104,MMRSDIV)) Q:'MMRSDIV D
.F TYPE="AC","CLC" D
..N MMRSLOC,BYADM
..S LOC=0 F S LOC=$O(^MMRS(104.3,LOC)) Q:'LOC D
...I $P($G(^MMRS(104.3,LOC,0)),U,2)=MMRSDIV,$P($G(^MMRS(104.3,LOC,0)),U,3)=TYPE S MMRSLOC(LOC)=""
..I '$O(MMRSLOC(0)) Q
..F BYADM=0,1 D
...D CLEAN^MMRSIPC ;Kill Temp Global
...D GETPARAM^MMRSIPC ; 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^MMRSIPC ;Get patient days of care
...I BYADM D
....S LOC="" F S LOC=$O(^TMP($J,"MMRSIPC","DSUM",LOC)) Q:LOC="" D
.....S DATA=$G(^TMP($J,"MMRSIPC","DSUM",LOC))
.....S $P(MMRSMSG(MMRSDIV,TYPE_"U",LOC),"~",1,5)=$TR($P(DATA,U,5,9),U,"~")
....S DATA=$G(^TMP($J,"MMRSIPC","DSUM"))
....S MMRSMSG(MMRSDIV,TYPE_"S","FACILITY")=$TR($P(DATA,U,1,4),U,"~")
...I 'BYADM D
....S LOC="" F S LOC=$O(^TMP($J,"MMRSIPC","DSUM",LOC)) Q:LOC="" D
.....S DATA=$G(^TMP($J,"MMRSIPC","DSUM",LOC))
.....S $P(MMRSMSG(MMRSDIV,TYPE_"U",LOC),"~",6,10)=$TR($P(DATA,U,1,5),U,"~")
...D CLEAN^MMRSIPC ;Kill Temp Global
MAIL ;Mail prevalence and transmission measures to IPEC
S MAILTO="G.IPEC ACK MESSAGE@KANSAS-CITY.DOMAIN.EXT"
S MONTH=$E(STRTDT,4,5)
S YEAR=$E(STRTDT,1,3)+1700
S MMRSDIV=0 F S MMRSDIV=$O(MMRSMSG(MMRSDIV)) Q:'MMRSDIV D
.S DIV=$P($G(^MMRS(104,MMRSDIV,0)),U,1)
.S DIVNUM=$P($$SITE^VASITE(,DIV),U,3)
.S SUBJECT=$S($$PROD^XUPROD:"",1:"TEST")_"MRSA~"_DIVNUM_"~"_MONTH_"-"_YEAR
.I $D(MMRSMSG(MMRSDIV,"ACU")) D
..N TEXT,XMTEXT,XMDUZ,XMY,XMMG,XMSTRIP,XMROU,DIFROM,XMYBLOB,LINE,XMDUN,XMZ,XMSUB
..S XMSUB=SUBJECT_"~DU"
..S TEXT(1)="Type~VISN~Station~Unit~UnitID~Year~Month~PrevAdmissions~PrevScreensInd~PrevScreens~PrevScreensPos~PrevCulturesPos~TransBedDays~TransExits~TransSwabsInd~TransScreens~TransTrans"
..S LINE=2
..S LOC="" F S LOC=$O(MMRSMSG(MMRSDIV,"ACU",LOC)) Q:LOC="" D
...S LOCIEN=$O(^MMRS(104.3,"B",LOC,0))
...S IPECUID=$P($G(^MMRS(104.3,LOCIEN,0)),U,4)
...S TEXT(LINE)="DU~~"_DIVNUM_"~"_LOC_"~"_IPECUID_"~"_YEAR_"~"_+MONTH_"~"_$G(MMRSMSG(MMRSDIV,"ACU",LOC))
...S LINE=LINE+1
..S XMTEXT="TEXT("
..S XMY(MAILTO)=""
..D ^XMD
.I $D(MMRSMSG(MMRSDIV,"ACS","FACILITY")) D
..N TEXT,XMTEXT,XMDUZ,XMY,XMMG,XMSTRIP,XMROU,DIFROM,XMYBLOB,LINE,XMDUN,XMZ,XMSUB
..S XMSUB=SUBJECT_"~DS"
..S TEXT(1)="Type~VISN~Station~Year~Month~PrevAdmissions~PrevScreens~PrevScreensPos~PrevCulturesPos"
..S TEXT(2)="DS~~"_DIVNUM_"~"_YEAR_"~"_+MONTH_"~"_$G(MMRSMSG(MMRSDIV,"ACS","FACILITY"))
..S XMTEXT="TEXT("
..S XMY(MAILTO)=""
..D ^XMD
.I $D(MMRSMSG(MMRSDIV,"CLCU")) D
..N TEXT,XMTEXT,XMDUZ,XMY,XMMG,XMSTRIP,XMROU,DIFROM,XMYBLOB,LINE,XMDUN,XMZ,XMSUB
..S XMSUB=SUBJECT_"~CU"
..S TEXT(1)="Type~VISN~Station~Unit~UnitID~Year~Month~PrevAdmissions~PrevScreensInd~PrevScreens~PrevScreensPos~PrevCulturesPos~TransBedDays~TransExits~TransSwabsInd~TransScreens~TransTrans"
..S LINE=2
..S LOC="" F S LOC=$O(MMRSMSG(MMRSDIV,"CLCU",LOC)) Q:LOC="" D
...S LOCIEN=$O(^MMRS(104.3,"B",LOC,0))
...S IPECUID=$P($G(^MMRS(104.3,LOCIEN,0)),U,4)
...S TEXT(LINE)="CU~~"_DIVNUM_"~"_LOC_"~"_IPECUID_"~"_YEAR_"~"_+MONTH_"~"_$G(MMRSMSG(MMRSDIV,"CLCU",LOC))
...S LINE=LINE+1
..S XMTEXT="TEXT("
..S XMY(MAILTO)=""
..D ^XMD
.I $D(MMRSMSG(MMRSDIV,"CLCS","FACILITY")) D
..N TEXT,XMTEXT,XMDUZ,XMY,XMMG,XMSTRIP,XMROU,DIFROM,XMYBLOB,LINE,XMDUN,XMZ,XMSUB
..S XMSUB=SUBJECT_"~CS"
..S TEXT(1)="Type~VISN~Station~Year~Month~PrevAdmissions~PrevScreens~PrevScreensPos~PrevCulturesPos"
..S TEXT(2)="CS~~"_DIVNUM_"~"_YEAR_"~"_+MONTH_"~"_$G(MMRSMSG(MMRSDIV,"CLCS","FACILITY"))
..S XMTEXT="TEXT("
..S XMY(MAILTO)=""
..D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMMRSIPC5 4403 printed Apr 09, 2024@21:17:06 Page 2
MMRSIPC5 ;MIA/LMT - Auto-Extract MRSA IPEC Report ;08-20-09
+1 ;;1.0;MRSA PROGRAM TOOLS;;Aug 22, 2009;Build 35
+2 ;
+3 ;This routine will run the auto-extract for the MRSA IPEC Report.
+4 ;This routine uses functions contained in MMRSIPC, MMRSIPC2, MMRSIPC3, and MMRSIPC4.
TASK ;Entry for auto-extract to IPEC
+1 ;Extract prevalence and transmission data for all Acute Care and CLC units
+2 if '$$PROD^XUPROD
QUIT
+3 NEW NOW,FIRST,STRTDT,ENDDT,MMRSDIV,TYPE,MMRSLOC,BYADM,PRTSUM,LOC,DATA,MMRSMSG
+4 NEW MAILTO,MONTH,YEAR,DIV,DIVNUM,SUBJECT,LOCIEN,IPECUID
+5 SET NOW=$$NOW^XLFDT()
+6 SET FIRST=$EXTRACT(NOW,1,5)_"01"
+7 SET ENDDT=$$FMADD^XLFDT(FIRST,-1,0,0,0)_".24"
+8 SET STRTDT=$EXTRACT(ENDDT,1,5)_"01"
+9 SET MMRSDIV=0
FOR
SET MMRSDIV=$ORDER(^MMRS(104,MMRSDIV))
if 'MMRSDIV
QUIT
Begin DoDot:1
+10 FOR TYPE="AC","CLC"
Begin DoDot:2
+11 NEW MMRSLOC,BYADM
+12 SET LOC=0
FOR
SET LOC=$ORDER(^MMRS(104.3,LOC))
if 'LOC
QUIT
Begin DoDot:3
+13 IF $PIECE($GET(^MMRS(104.3,LOC,0)),U,2)=MMRSDIV
IF $PIECE($GET(^MMRS(104.3,LOC,0)),U,3)=TYPE
SET MMRSLOC(LOC)=""
End DoDot:3
+14 IF '$ORDER(MMRSLOC(0))
QUIT
+15 FOR BYADM=0,1
Begin DoDot:3
+16 ;Kill Temp Global
DO CLEAN^MMRSIPC
+17 ; Load parameters in temp global
DO GETPARAM^MMRSIPC
+18 ;Get movements and store in temp global
DO GETMOVE^MMRSIPC2
+19 ;Get swabbing rates and MRSA history and store in temp global
DO GETLABS^MMRSIPC3
+20 ;Get patient days of care
IF 'BYADM
DO PATDAYS^MMRSIPC
+21 IF BYADM
Begin DoDot:4
+22 SET LOC=""
FOR
SET LOC=$ORDER(^TMP($JOB,"MMRSIPC","DSUM",LOC))
if LOC=""
QUIT
Begin DoDot:5
+23 SET DATA=$GET(^TMP($JOB,"MMRSIPC","DSUM",LOC))
+24 SET $PIECE(MMRSMSG(MMRSDIV,TYPE_"U",LOC),"~",1,5)=$TRANSLATE($PIECE(DATA,U,5,9),U,"~")
End DoDot:5
+25 SET DATA=$GET(^TMP($JOB,"MMRSIPC","DSUM"))
+26 SET MMRSMSG(MMRSDIV,TYPE_"S","FACILITY")=$TRANSLATE($PIECE(DATA,U,1,4),U,"~")
End DoDot:4
+27 IF 'BYADM
Begin DoDot:4
+28 SET LOC=""
FOR
SET LOC=$ORDER(^TMP($JOB,"MMRSIPC","DSUM",LOC))
if LOC=""
QUIT
Begin DoDot:5
+29 SET DATA=$GET(^TMP($JOB,"MMRSIPC","DSUM",LOC))
+30 SET $PIECE(MMRSMSG(MMRSDIV,TYPE_"U",LOC),"~",6,10)=$TRANSLATE($PIECE(DATA,U,1,5),U,"~")
End DoDot:5
End DoDot:4
+31 ;Kill Temp Global
DO CLEAN^MMRSIPC
End DoDot:3
End DoDot:2
End DoDot:1
MAIL ;Mail prevalence and transmission measures to IPEC
+1 SET MAILTO="G.IPEC ACK MESSAGE@KANSAS-CITY.DOMAIN.EXT"
+2 SET MONTH=$EXTRACT(STRTDT,4,5)
+3 SET YEAR=$EXTRACT(STRTDT,1,3)+1700
+4 SET MMRSDIV=0
FOR
SET MMRSDIV=$ORDER(MMRSMSG(MMRSDIV))
if 'MMRSDIV
QUIT
Begin DoDot:1
+5 SET DIV=$PIECE($GET(^MMRS(104,MMRSDIV,0)),U,1)
+6 SET DIVNUM=$PIECE($$SITE^VASITE(,DIV),U,3)
+7 SET SUBJECT=$SELECT($$PROD^XUPROD:"",1:"TEST")_"MRSA~"_DIVNUM_"~"_MONTH_"-"_YEAR
+8 IF $DATA(MMRSMSG(MMRSDIV,"ACU"))
Begin DoDot:2
+9 NEW TEXT,XMTEXT,XMDUZ,XMY,XMMG,XMSTRIP,XMROU,DIFROM,XMYBLOB,LINE,XMDUN,XMZ,XMSUB
+10 SET XMSUB=SUBJECT_"~DU"
+11 SET TEXT(1)="Type~VISN~Station~Unit~UnitID~Year~Month~PrevAdmissions~PrevScreensInd~PrevScreens~PrevScreensPos~PrevCulturesPos~TransBedDays~TransExits~TransSwabsInd~TransScreens~TransTrans"
+12 SET LINE=2
+13 SET LOC=""
FOR
SET LOC=$ORDER(MMRSMSG(MMRSDIV,"ACU",LOC))
if LOC=""
QUIT
Begin DoDot:3
+14 SET LOCIEN=$ORDER(^MMRS(104.3,"B",LOC,0))
+15 SET IPECUID=$PIECE($GET(^MMRS(104.3,LOCIEN,0)),U,4)
+16 SET TEXT(LINE)="DU~~"_DIVNUM_"~"_LOC_"~"_IPECUID_"~"_YEAR_"~"_+MONTH_"~"_$GET(MMRSMSG(MMRSDIV,"ACU",LOC))
+17 SET LINE=LINE+1
End DoDot:3
+18 SET XMTEXT="TEXT("
+19 SET XMY(MAILTO)=""
+20 DO ^XMD
End DoDot:2
+21 IF $DATA(MMRSMSG(MMRSDIV,"ACS","FACILITY"))
Begin DoDot:2
+22 NEW TEXT,XMTEXT,XMDUZ,XMY,XMMG,XMSTRIP,XMROU,DIFROM,XMYBLOB,LINE,XMDUN,XMZ,XMSUB
+23 SET XMSUB=SUBJECT_"~DS"
+24 SET TEXT(1)="Type~VISN~Station~Year~Month~PrevAdmissions~PrevScreens~PrevScreensPos~PrevCulturesPos"
+25 SET TEXT(2)="DS~~"_DIVNUM_"~"_YEAR_"~"_+MONTH_"~"_$GET(MMRSMSG(MMRSDIV,"ACS","FACILITY"))
+26 SET XMTEXT="TEXT("
+27 SET XMY(MAILTO)=""
+28 DO ^XMD
End DoDot:2
+29 IF $DATA(MMRSMSG(MMRSDIV,"CLCU"))
Begin DoDot:2
+30 NEW TEXT,XMTEXT,XMDUZ,XMY,XMMG,XMSTRIP,XMROU,DIFROM,XMYBLOB,LINE,XMDUN,XMZ,XMSUB
+31 SET XMSUB=SUBJECT_"~CU"
+32 SET TEXT(1)="Type~VISN~Station~Unit~UnitID~Year~Month~PrevAdmissions~PrevScreensInd~PrevScreens~PrevScreensPos~PrevCulturesPos~TransBedDays~TransExits~TransSwabsInd~TransScreens~TransTrans"
+33 SET LINE=2
+34 SET LOC=""
FOR
SET LOC=$ORDER(MMRSMSG(MMRSDIV,"CLCU",LOC))
if LOC=""
QUIT
Begin DoDot:3
+35 SET LOCIEN=$ORDER(^MMRS(104.3,"B",LOC,0))
+36 SET IPECUID=$PIECE($GET(^MMRS(104.3,LOCIEN,0)),U,4)
+37 SET TEXT(LINE)="CU~~"_DIVNUM_"~"_LOC_"~"_IPECUID_"~"_YEAR_"~"_+MONTH_"~"_$GET(MMRSMSG(MMRSDIV,"CLCU",LOC))
+38 SET LINE=LINE+1
End DoDot:3
+39 SET XMTEXT="TEXT("
+40 SET XMY(MAILTO)=""
+41 DO ^XMD
End DoDot:2
+42 IF $DATA(MMRSMSG(MMRSDIV,"CLCS","FACILITY"))
Begin DoDot:2
+43 NEW TEXT,XMTEXT,XMDUZ,XMY,XMMG,XMSTRIP,XMROU,DIFROM,XMYBLOB,LINE,XMDUN,XMZ,XMSUB
+44 SET XMSUB=SUBJECT_"~CS"
+45 SET TEXT(1)="Type~VISN~Station~Year~Month~PrevAdmissions~PrevScreens~PrevScreensPos~PrevCulturesPos"
+46 SET TEXT(2)="CS~~"_DIVNUM_"~"_YEAR_"~"_+MONTH_"~"_$GET(MMRSMSG(MMRSDIV,"CLCS","FACILITY"))
+47 SET XMTEXT="TEXT("
+48 SET XMY(MAILTO)=""
+49 DO ^XMD
End DoDot:2
End DoDot:1
+50 QUIT
