Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: MMRSORD

MMRSORD.m

Go to the documentation of this file. 
  1. MMRSORD ;MIA/LMT - Print ward census showing which patients need a nares swab ;02/15/17  08:34
  1.  ;;1.0;MRSA PROGRAM TOOLS;**1,5**;Mar 22, 2009;Build 146
  1.  ;
  1. MAIN ;
  1.  N EXTFLG,MMRSDIV,MMRSLOC
  1.  D CHECK^MMRSIPC
  1.  D CHECK2^MMRSIPC
  1.  I $D(EXTFLG) W ! H 2 Q
  1.  W !
  1.  S MMRSDIV=$$GETDIV^MMRSIPC Q:$D(EXTFLG)!(MMRSDIV="")
  1.  W !
  1.  D CHECK3^MMRSIPC
  1.  I $D(EXTFLG) W ! H 2 Q
  1.  D PROMPT^MMRSISL Q:$D(EXTFLG)
  1.  D ASKDVC Q:$D(EXTFLG)
  1.  Q
  1. MAIN2 ;
  1.  N MMRSNOW
  1.  D CLEAN
  1.  Q:'$D(MMRSDIV)!('$D(MMRSLOC))
  1.  S MMRSNOW=$$NOW^XLFDT()
  1.  D GETPARAM^MMRSIPC ; Load parameters in temp global
  1.  D SETDATA
  1.  D PRT
  1.  D CLEAN
  1.  Q
  1. CLEAN ;
  1.  K ^TMP($J,"MMRSIPC")
  1.  K ^TMP($J,"MMRSORD")
  1.  Q
  1. SETDATA ;
  1.  N LOCATION,LOCNAME,DFN,LOCTYPE,MMRSI,SDRESULT,Y,WLOC,WARD,WARDNAME,VAIP
  1.  I $G(MMRSLOC)="ALL" D  Q
  1.  .S LOCATION=0 F  S LOCATION=$O(^MMRS(104.3,LOCATION)) Q:'LOCATION  I $P($G(^MMRS(104.3,LOCATION,0)),U,2)=MMRSDIV D
  1.  ..S LOCNAME=$P($G(^MMRS(104.3,LOCATION,0)),U,1)
  1.  ..S WLOC=0 F  S WLOC=$O(^MMRS(104.3,LOCATION,1,WLOC)) Q:'WLOC  D
  1.  ...S WARD=$P($G(^MMRS(104.3,LOCATION,1,WLOC,0)),U,1)
  1.  ...Q:'WARD
  1.  ...;S WARDNAME=$P($G(^DIC(42,WARD,44)),U,1)
  1.  ...;S WARDNAME=$P($G(^SC(+WARDNAME,0)),U,1)
  1.  ...S WARDNAME=$P($G(^DIC(42,WARD,0)),U,1)
  1.  ...Q:WARDNAME=""
  1.  ...S DFN=0 F  S DFN=$O(^DPT("CN",WARDNAME,DFN)) Q:'DFN  D SETDATA2(DFN,LOCATION,LOCNAME)
  1.  S LOCATION=0 F  S LOCATION=$O(MMRSLOC(LOCATION)) Q:'LOCATION  D
  1.  .S LOCNAME=$P($G(^MMRS(104.3,LOCATION,0)),U,1)
  1.  .S WLOC=0 F  S WLOC=$O(^MMRS(104.3,LOCATION,1,WLOC)) Q:'WLOC  D
  1.  ..S WARD=$P($G(^MMRS(104.3,LOCATION,1,WLOC,0)),U,1)
  1.  ..Q:'WARD
  1.  ..;S WARDNAME=$P($G(^DIC(42,WARD,44)),U,1)
  1.  ..;S WARDNAME=$P($G(^SC(+WARDNAME,0)),U,1)
  1.  ..S WARDNAME=$P($G(^DIC(42,WARD,0)),U,1)
  1.  ..Q:WARDNAME=""
  1.  ..S DFN=0 F  S DFN=$O(^DPT("CN",WARDNAME,DFN)) Q:'DFN  D SETDATA2(DFN,LOCATION,LOCNAME)
  1.  Q
  1. SETDATA2(DFN,LOC,LOCNAME) ;
  1.  N INTT,IEN,INDATE,INIFN,MRSAMDRO,MRSA,MRSACULT,LABORDER,TSTNM,LABTEST,ORDITM,ORDTEMP,PATNM,VADM
  1.  N PREVIEN,PREVWARD
  1.  ;Get unit admission date and Transaction Type
  1.  D KVA^VADPT
  1.  S VAIP("D")=MMRSNOW
  1.  D IN5^VADPT
  1.  I 'VAIP(1) Q
  1.  S INTT=$$TRANTYPE^MMRSIPC2(+VAIP(4),+VAIP(2),VAIP(1),DFN)
  1.  S PREVWARD=$P(INTT,U,2)
  1.  S PREVIEN=$P(INTT,U,4)
  1.  S INTT=$P(INTT,U,1)
  1.  I PREVWARD="" S PREVWARD=+VAIP(15,4)
  1.  I PREVIEN="" S PREVIEN=VAIP(15)
  1.  F  Q:(INTT=1)!(INTT=2&$$CNGWARD^MMRSIPC2(LOC,+VAIP(5),PREVWARD))!(PREVIEN="")  D
  1.  .S IEN=+PREVIEN
  1.  .D KVA^VADPT
  1.  .S VAIP("E")=IEN
  1.  .D IN5^VADPT
  1.  .S INTT=$$TRANTYPE^MMRSIPC2(+VAIP(4),+VAIP(2),VAIP(1),DFN)
  1.  .S PREVWARD=$P(INTT,U,2)
  1.  .S PREVIEN=$P(INTT,U,4)
  1.  .S INTT=$P(INTT,U,1)
  1.  .I PREVWARD="" S PREVWARD=+VAIP(15,4)
  1.  .I PREVIEN="" S PREVIEN=VAIP(15)
  1.  I INTT<1!(INTT>2) Q
  1.  S INDATE=+VAIP(3)
  1.  S INIFN=+VAIP(1)
  1.  I '$G(INIFN) Q
  1.  ;Get MRSA history
  1.  S MRSAMDRO=1
  1.  S MRSA=$P($$GETLAB^MMRSIPC3(DFN,MRSAMDRO,$$FMADD^XLFDT(MMRSNOW,-365),MMRSNOW,"CD"),U,2)
  1.  ;Get Order info
  1.  S LABORDER="^^"
  1.  S TSTNM="MRSA SURVL NARES DN"
  1.  F  S TSTNM=$O(^LAB(60,"B",TSTNM)) Q:TSTNM=""!(TSTNM]"MRSA SURVL NARES DNA~zzz")  D
  1.  .I TSTNM'["MRSA SURVL NARES DNA" Q
  1.  .S LABTEST=0 F  S LABTEST=$O(^LAB(60,"B",TSTNM,LABTEST)) Q:'LABTEST  D
  1.  ..N TESTS D GORDITM(LABTEST,.LABORDER,.TESTS) ;MIA/LMT - Added with patch MMRS*1*1
  1.  S TSTNM="MRSA SURVL NARES AGA"
  1.  F  S TSTNM=$O(^LAB(60,"B",TSTNM)) Q:TSTNM=""!(TSTNM]"MRSA SURVL NARES AGAR~zzz")  D
  1.  .I TSTNM'["MRSA SURVL NARES AGAR" Q
  1.  .S LABTEST=0 F  S LABTEST=$O(^LAB(60,"B",TSTNM,LABTEST)) Q:'LABTEST  D
  1.  ..N TESTS D GORDITM(LABTEST,.LABORDER,.TESTS) ;MIA/LMT - Added with patch MMRS*1*1
  1.  D KVA^VADPT
  1.  D DEM^VADPT
  1.  S PATNM=VADM(1)
  1.  D KVA^VADPT
  1.  S ^TMP($J,"MMRSORD",LOCNAME,PATNM,DFN)=INDATE_U_INTT_U_MRSA_U_LABORDER
  1.  Q
  1. GORDITM(LABTEST,LABORDER,TESTS) ;MIA/LMT - Added with patch MMRS*1*1 - Include panels in search
  1.  N ORDITM,ORDTEMP,LABPANEL
  1.  I $D(TESTS(LABTEST)) Q  ;prevent infinite recursion; if site has Panel A within Panel B, and Panel B within Panel A
  1.  S TESTS(LABTEST)=1 ;mark that we have searched this test (to prevent infinite recursion)
  1.  S ORDITM=0 F  S ORDITM=$O(^ORD(101.43,"ID",LABTEST_";99LRT",ORDITM)) Q:'ORDITM  D
  1.  .S ORDTEMP=$$GETORD(DFN,ORDITM,INDATE)
  1.  .I $P(LABORDER,U,1)'="YES"!(($P(LABORDER,U,3)'="YES")&($P(ORDTEMP,U,3)="YES")) S LABORDER=ORDTEMP
  1.  S LABPANEL=0 F  S LABPANEL=$O(^LAB(60,"AB",LABTEST,LABPANEL)) Q:'LABPANEL  D
  1.  .D GORDITM(LABPANEL,.LABORDER,.TESTS) ;Recursive call to check for tests within panels
  1.  Q
  1. GETORD(DFN,ORDITM,INDATE) ;
  1.  N RESULT,START,STOP,DAS,STATUS,ORUPCHUK,LABREC
  1.  S RESULT="^^"
  1.  S START=$$FMADD^XLFDT(INDATE,-1)-.0000001
  1.  F  S START=$O(^PXRMINDX(100,"PI",DFN,ORDITM,START)) Q:'START  D
  1.  .S STOP="" F  S STOP=$O(^PXRMINDX(100,"PI",DFN,ORDITM,START,STOP)) Q:STOP=""  D
  1.  ..S DAS="" F  S DAS=$O(^PXRMINDX(100,"PI",DFN,ORDITM,START,STOP,DAS)) Q:DAS=""  D
  1.  ...D EN^ORX8(+DAS)
  1.  ...S STATUS=$P(ORUPCHUK("ORSTS"),U,1)
  1.  ...I STATUS'=2,STATUS'=5,STATUS'=6 Q
  1.  ...S LABREC="NO"
  1.  ...I STATUS=6!(STATUS=2) S LABREC="YES"
  1.  ...I $P(RESULT,U,3)'="YES" S RESULT="YES^"_START_U_LABREC
  1.  Q RESULT
  1. PRT ;
  1.  N LN,PG,LOCNAME,PATNM,DFN,NODE,LAST4,INTT,ADT,ORDDATE,VADM
  1.  ;^TMP($J,"MMRSORD",LOCNAME,PATNM,DFN)=INDATE_U_INTT_U_MRSA_U_LAB
  1.  S $P(LN,"-",101)=""
  1.  S PG=1
  1.  S LOCNAME="" F  S LOCNAME=$O(^TMP($J,"MMRSORD",LOCNAME)) Q:LOCNAME=""  D
  1.  .D PRTHDRS S PATNM="" F  S PATNM=$O(^TMP($J,"MMRSORD",LOCNAME,PATNM)) Q:PATNM=""  D
  1.  ..S DFN=0 F  S DFN=$O(^TMP($J,"MMRSORD",LOCNAME,PATNM,DFN)) Q:'DFN  D
  1.  ...S NODE=$G(^TMP($J,"MMRSORD",LOCNAME,PATNM,DFN))
  1.  ...D KVA^VADPT
  1.  ...D DEM^VADPT
  1.  ...S LAST4=$E($P(VADM(2),U),6,9)
  1.  ...D KVA^VADPT
  1.  ...S INTT=$P(NODE,U,2)
  1.  ...S ADT=$S(INTT=1:"A",INTT=2:"T",1:"")
  1.  ...S ORDDATE=$P(NODE,"^",5)
  1.  ...I ORDDATE S ORDDATE=$$FMTE^XLFDT(ORDDATE,"2M")
  1.  ...W !,$E(PATNM,1,23),?25,LAST4,?32,$$FMTE^XLFDT($P(NODE,"^",1),"2M"),?48,ADT,?53,$P($P(NODE,"^",3),";",1),?65,$P(NODE,"^",4)
  1.  ...W ?75,ORDDATE,?91,$P(NODE,"^",6)
  1.  ...I $Y+2>IOSL D PRTHDRS
  1.  Q
  1. PRTHDRS ; Helper Function for PRT - Prints report headers
  1.  W @IOF
  1.  W ?13,"NARES SWAB ORDER LIST"
  1.  W !,?13,"Geographical Location: ",LOCNAME
  1.  W !,?13,"Report printed on: ",$$FMTE^XLFDT(MMRSNOW),?75,"PAGE: ",PG
  1.  W !!,?32,"DATE",?53,"MRSA IN",?65,"NARES",?91,"LAB"
  1.  W !,"PATIENT",?25,"SSN",?32,"ENTERED WARD",?48,"ADT",?53,"PAST YEAR",?65,"ORDERED",?75,"ORDER DATE",?91,"RECEIVED"
  1.  W !,LN
  1.  S PG=PG+1
  1.  Q
  1. ASKDVC ;Prompts user for device of output (allows queuing)
  1.  N MMRSVAR,ZTSK
  1.  W !!!,"This report is designed for a 132 column format (compressed).",!
  1.  S MMRSVAR("MMRSLOC")="",MMRSVAR("MMRSLOC(")="",MMRSVAR("MMRSDIV")=""
  1.  D EN^XUTMDEVQ("MAIN2^MMRSORD","Print nares swab order list (MMRSORD)",.MMRSVAR,"QM",1)
  1.  W:$D(ZTSK) !,"Report Queued to Print ("_ZTSK_").",!
  1.  Q