- 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 23, 2025@18:29:37 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
