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

PXRMPROB.m

Go to the documentation of this file.
  1. PXRMPROB ; SLC/PKR - Code for Problem List. ;10/11/2012
  1. ;;2.0;CLINICAL REMINDERS;**4,26**;Feb 04, 2005;Build 404
  1. ;
  1. ;===================================================
  1. FPDAT(DFN,TAXARR,NGET,SDIR,BDT,EDT,STATUSA,FLIST) ;Find data for a
  1. ;patient.
  1. N CODE,CODESYS,DAS,DATE,DEND,DS,DSAVE,EDATE,EDTT,IND,JND,NFOUND
  1. N PRIO,PRIOA,STAT,TDATE,TIND,TLIST
  1. I TAXARR("APDS",9000011,"NNODES")=0 Q
  1. I $G(^PXRMINDX(9000011,"DATE BUILT"))="" D Q
  1. . D NOINDEX^PXRMERRH("TX",TAXARR("IEN"),9000011)
  1. I STATUSA(0)=0 Q
  1. ;EDATE is the evaluation date.
  1. S EDATE=$$NOW^PXRMDATE
  1. S EDTT=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
  1. S DEND=$S(EDT[".":EDT,1:EDT+.24)
  1. S DS=$S(SDIR=+1:BDT-.000001,1:EDTT)
  1. D SPRIOA(BDT,DEND,EDATE,.TAXARR,.PRIOA)
  1. S CODESYS=""
  1. F S CODESYS=$O(TAXARR("AE",CODESYS)) Q:CODESYS="" D
  1. . I '$D(^PXRMINDX(9000011,CODESYS,"PSPI",DFN)) Q
  1. . S NFOUND=0
  1. . F IND=1:1:STATUSA(0) S STAT=STATUSA(IND) D
  1. .. I '$D(^PXRMINDX(9000011,CODESYS,"PSPI",DFN,STAT)) Q
  1. .. F JND=1:1:PRIOA(0) S PRIO=PRIOA(JND) D
  1. ... I '$D(^PXRMINDX(9000011,CODESYS,"PSPI",DFN,STAT,PRIO)) Q
  1. ... S CODE=""
  1. ... F S CODE=$O(TAXARR("AE",CODESYS,CODE)) Q:CODE="" D
  1. .... I '$D(^PXRMINDX(9000011,CODESYS,"PSPI",DFN,STAT,PRIO,CODE)) Q
  1. .... S DATE=DS
  1. .... F S DATE=+$O(^PXRMINDX(9000011,CODESYS,"PSPI",DFN,STAT,PRIO,CODE,DATE),SDIR) Q:$S(DATE=0:1,DATE<BDT:1,DATE>EDTT:1,1:0) D
  1. ..... S DSAVE=$S(PRIO="C":EDATE,1:DATE)
  1. ..... I (DSAVE<BDT)!(DSAVE>DEND) Q
  1. ..... S DAS=""
  1. ..... F S DAS=$O(^PXRMINDX(9000011,CODESYS,"PSPI",DFN,STAT,PRIO,CODE,DATE,DAS)) Q:DAS="" D
  1. ...... S NFOUND=NFOUND+1
  1. ...... S TLIST(DSAVE,NFOUND)=DAS_U_DSAVE_U_CODESYS_U_CODE_U_STAT_U_PRIO
  1. ...... I NFOUND>NGET D
  1. ....... S TDATE=$O(TLIST(""),-SDIR),TIND=$O(TLIST(TDATE,""))
  1. ....... K TLIST(TDATE,TIND)
  1. ;Return up to NGET of the most recent entries.
  1. S NFOUND=0
  1. S DATE=""
  1. F S DATE=$O(TLIST(DATE),SDIR) Q:(DATE="")!(NFOUND=NGET) D
  1. . S IND=0
  1. . F S IND=$O(TLIST(DATE,IND)) Q:(IND="")!(NFOUND=NGET) D
  1. .. S NFOUND=NFOUND+1
  1. .. S FLIST(DATE,NFOUND,9000011)=TLIST(DATE,IND)
  1. Q
  1. ;
  1. ;===================================================
  1. GETDATA(DAS,FIEVT) ;Return data for a specified Problem List entry.
  1. N DATA
  1. ;DBIA #5881
  1. D PROBDATA^GMPLPXRM(DAS,.DATA)
  1. M FIEVT=DATA
  1. Q
  1. ;
  1. ;===================================================
  1. GPLIST(TAXARR,NOCC,BDT,EDT,STATUSA,PLIST) ;Build patient list for
  1. ;Problem List entries.
  1. N CODE,CODESYS,DAS,DATE,DEND,DFN,DSAVE,EDATE,IND,JND,NFOUND,PRIO,PRIOA
  1. N STAT,TEMP,TLIST
  1. I $G(^PXRMINDX(9000011,"DATE BUILT"))="" D Q
  1. . D NOINDEX^PXRMERRH("TX",TAXARR("IEN"),9000011)
  1. S TLIST="GPLIST_PXRMPROB"
  1. S DEND=$S(EDT[".":EDT,1:EDT+.240001)
  1. K ^TMP($J,TLIST)
  1. I STATUSA(0)=0 Q
  1. ;EDATE is the evaluation date.
  1. S EDATE=$$NOW^PXRMDATE
  1. D SPRIOA(BDT,DEND,EDATE,.TAXARR,.PRIOA)
  1. S CODESYS="",NFOUND=0
  1. F S CODESYS=$O(TAXARR("AE",CODESYS)) Q:CODESYS="" D
  1. . I '$D(^PXRMINDX(9000011,CODESYS,"ISPP")) Q
  1. . S CODE=""
  1. . F S CODE=$O(TAXARR("AE",CODESYS,CODE)) Q:(CODE="") D
  1. .. I '$D(^PXRMINDX(9000011,CODESYS,"ISPP",CODE)) Q
  1. ..;Since chronic problems will have today's date find those first.
  1. .. F IND=1:1:STATUSA(0) D
  1. ... S STAT=STATUSA(IND)
  1. ... I '$D(^PXRMINDX(9000011,CODESYS,"ISPP",CODE,STAT)) Q
  1. ... F JND=1:1:PRIOA(0) D
  1. .... S PRIO=PRIOA(JND)
  1. .... I '$D(^PXRMINDX(9000011,CODESYS,"ISPP",CODE,STAT,PRIO)) Q
  1. .... S DFN=""
  1. .... F S DFN=$O(^PXRMINDX(9000011,CODESYS,"ISPP",CODE,STAT,PRIO,DFN)) Q:DFN="" D
  1. ..... S DATE=""
  1. ..... F S DATE=$O(^PXRMINDX(9000011,CODESYS,"ISPP",CODE,STAT,PRIO,DFN,DATE)) Q:DATE="" D
  1. ...... S DAS=""
  1. ...... F S DAS=$O(^PXRMINDX(9000011,CODESYS,"ISPP",CODE,STAT,PRIO,DFN,DATE,DAS)) Q:DAS="" D
  1. ....... S NFOUND=NFOUND+1
  1. ....... S DSAVE=$S(PRIO="C":EDATE,1:DATE)
  1. ....... I DSAVE'<BDT,DSAVE'>DEND S ^TMP($J,TLIST,DFN,DSAVE,DAS)=CODE_U_CODESYS_U_STAT_U_PRIO
  1. ;Return up to NOCC of the most recent entries.
  1. S DFN=0
  1. F S DFN=$O(^TMP($J,TLIST,DFN)) Q:DFN="" D
  1. . S NFOUND=0
  1. . S DATE=""
  1. . F S DATE=$O(^TMP($J,TLIST,DFN,DATE),-1) Q:(DATE="")!(NFOUND=NOCC) D
  1. .. S DAS=""
  1. .. F S DAS=$O(^TMP($J,TLIST,DFN,DATE,DAS)) Q:DAS="" D
  1. ... S NFOUND=NFOUND+1
  1. ... S TEMP=^TMP($J,TLIST,DFN,DATE,DAS)
  1. ... S ^TMP($J,PLIST,1,DFN,NFOUND,9000011)=DAS_U_DATE_U_TEMP
  1. K ^TMP($J,TLIST)
  1. Q
  1. ;
  1. ;===================================================
  1. MHVOUT(INDENT,OCCLIST,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
  1. N CDATA,CODE,CODESYS,IND,NAME,NOUT
  1. N RESULT,STATUS,TEMP,TEXTOUT,VDATE
  1. S NAME="Problem Diagnosis = "
  1. S IND=0
  1. F S IND=$O(OCCLIST(IND)) Q:IND="" D
  1. . S VDATE=IFIEVAL(IND,"DATE")
  1. . S CODE=IFIEVAL(IND,"CODE")
  1. . S CODESYS=IFIEVAL(IND,"CODESYS")
  1. . K CDATA
  1. .;DBIA #5679
  1. . S RESULT=$$CSDATA^LEXU(CODE,CODESYS,VDATE,.CDATA)
  1. . S TEMP=NAME_$P(CDATA("LEX",1),U,2)
  1. . S TEMP=TEMP_" ("_$$EDATE^PXRMDATE(VDATE)_")"
  1. . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
  1. . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
  1. S NLINES=NLINES+1,TEXT(NLINES)=""
  1. Q
  1. ;
  1. ;===================================================
  1. OUTPUT(INDENT,OCCLIST,IFIEVAL,NLINES,TEXT) ;Produce the clinical
  1. ;maintenance output.
  1. N CDATA,CODE,CODEDATE,CODESYS,CODESYSN,EM,IND,JND,NIN,NOUT,PN,PRIORITY
  1. N RESULT,STATUS,TEXTIN,TEXTOUT,VDATE
  1. S NLINES=NLINES+1
  1. S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Problem Diagnosis:"
  1. S IND=0
  1. F S IND=$O(OCCLIST(IND)) Q:IND="" D
  1. . S VDATE=IFIEVAL(IND,"DATE")
  1. . S CODE=IFIEVAL(IND,"CODE")
  1. . S CODESYS=IFIEVAL(IND,"CODESYS")
  1. . S CODEDATE=$G(IFIEVAL(IND,"MT CODE DATE"))
  1. . I CODEDATE="" S CODEDATE=$G(IFIEVAL(IND,"DATE OF INTEREST"))
  1. . I CODEDATE="" S CODEDATE=$G(IFIEVAL(IND,"DATE ENTERED"))
  1. .;DBIA #5679
  1. . I '$D(CODESYSN(CODESYS)) S CODESYSN(CODESYS)=$P($$CSYS^LEXU(CODESYS),U,4)
  1. . K CDATA
  1. . S RESULT=$$CSDATA^LEXU(CODE,CODESYS,CODEDATE,.CDATA)
  1. . S PRIORITY=$G(IFIEVAL(IND,"PRIORITY"))
  1. . S PRIORITY=$S(PRIORITY'="":$$EXTERNAL^DILFD(9000011,1.14,"",PRIORITY,.EM),1:"UNDEFINED")
  1. . S STATUS=$G(IFIEVAL(IND,"STATUS"))
  1. . S STATUS=$S(STATUS'="":$$EXTERNAL^DILFD(9000011,.12,"",STATUS,.EM),1:"UNDEFINED")
  1. . S PN=$G(IFIEVAL(IND,"PROVIDER NARRATIVE"))
  1. . S PN=$S(PN="":"MISSING",1:$P($G(^AUTNPOV(PN,0)),U,1))
  1. . S TEXTIN(1)=$$EDATE^PXRMDATE(VDATE)_" "_CODE_" ("_CODESYSN(CODESYS)_")"
  1. . S TEXTIN(2)=$P(CDATA("LEX",1),U,2)_"\\"
  1. . S TEXTIN(3)=" Date Entered: "_$$EDATE^PXRMDATE(IFIEVAL(IND,"DATE ENTERED"))_"; Date Last Modified: "_$$EDATE^PXRMDATE(IFIEVAL(IND,"DATE LAST MODIFIED"))_"\\"
  1. . S TEXTIN(4)=" Status: "_STATUS_"; Priority: "_PRIORITY_"\\"
  1. . S TEXTIN(5)=" Prov. Narr. - "_PN
  1. . D FORMAT^PXRMTEXT(INDENT+2,PXRMRM,5,.TEXTIN,.NOUT,.TEXTOUT)
  1. . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
  1. S NLINES=NLINES+1,TEXT(NLINES)=""
  1. Q
  1. ;
  1. ;===================================================
  1. SPRIOA(BDT,DEND,EDATE,TAXARR,PRIOA) ;Set the priority array.
  1. N NPRIO,PRIOL
  1. S PRIOL=$P(TAXARR(15),U,1)
  1. I PRIOL="" S PRIOA(0)=3,PRIOA(1)="A",PRIOA(2)="U",PRIOA(3)="C" Q
  1. S NPRIO=0
  1. I PRIOL["A" S NPRIO=NPRIO+1,PRIOA(NPRIO)="A"
  1. I PRIOL["U" S NPRIO=NPRIO+1,PRIOA(NPRIO)="U"
  1. ;For chronic problems the evaluation date becomes the finding date
  1. ;so only search for chronic problems if the evaluation date lies in
  1. ;the date range.
  1. I PRIOL["C",EDATE'<BDT,EDATE'>DEND S NPRIO=NPRIO+1,PRIOA(NPRIO)="C"
  1. S PRIOA(0)=NPRIO
  1. Q
  1. ;