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