source: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMPROB.m@ 1800

PXRMPROB ; SLC/PKR - Code for Problem List. ;06/09/2006
 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
 ;
 ;===================================================
FPDAT(DFN,TAXARR,NGET,SDIR,BDT,EDT,STATUSA,FLIST) ;Find data for a
 ;patient. STATUSA is an array containing a list of status to search
 ;for. A status can be "A" for active or "I" for inactive. If STATUSA=""
 ;it will search for all with data.
 N BDTT,DAS,DATE,DEND,DS,DSAVE,DTT,EDATE,EDTT,ICDP,IND,JND,LGT,LLT
 N NFOUND,NPRIO,NSTAT,PRIO,PRIOA,STAT,STATUSAT,TDATE,TE,TIND,TLIST,TS
 I $G(^PXRMINDX(9000011,"DATE BUILT"))="" D  Q
 . D NOINDEX^PXRMERRH("TX",TAXARR("IEN"),9000011)
 I '$D(^PXRMINDX(9000011,"PSPI",DFN)) Q
 S NSTAT=STATUSA(0)
 I NSTAT=0 Q
 ;EDATE is the evaluation date.
 S EDATE=$$NOW^PXRMDATE
 S BDTT=BDT-.0000001
 S EDTT=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
 S DEND=$S(EDT[".":EDT,1:EDT+.240001)
 S DTT=EDATE+.240001
 ;Get the start and end of the taxonomy.
 S TS=$O(TAXARR(80,""))-1
 S TE=$O(TAXARR(80,""),-1)
 ;For chronic problems we use today's date so only search for chronic
 ;problems if today's datelies in the date range.
 I EDATE'<BDT,EDATE'>DEND S NPRIO=3,PRIOA(1)="C",PRIOA(2)="A",PRIOA(3)="U"
 E  S NPRIO=2,PRIOA(1)="A",PRIOA(2)="U"
 S NFOUND=0
 F IND=1:1:NSTAT D
 . S STAT=STATUSA(IND)
 . F JND=1:1:NPRIO D
 .. S PRIO=PRIOA(JND)
 .. I '$D(^PXRMINDX(9000011,"PSPI",DFN,STAT,PRIO)) Q
 .. I SDIR=-1,PRIO'="C" S DS=EDTT,LLT=BDT,LGT=EDT
 .. I SDIR=-1,PRIO="C" S DS=DTT,LLT=0,LGT=EDATE
 .. I SDIR=1,PRIO'="C" S DS=BDTT,LLT=0,LGT=EDT
 .. I SDIR=1,PRIO="C" S DS=0,LLT=0,LGT=EDATE
 .. S ICDP=TS
 .. F  S ICDP=$O(^PXRMINDX(9000011,"PSPI",DFN,STAT,PRIO,ICDP)) Q:(ICDP>TE)!(ICDP="")  D
 ... I '$D(TAXARR(80,ICDP)) Q
 ... S DATE=DS
 ... F  S DATE=+$O(^PXRMINDX(9000011,"PSPI",DFN,STAT,PRIO,ICDP,DATE),SDIR) Q:$S(DATE=0:1,DATE<LLT:1,DATE>LGT:1,1:0)  D
 .... S DAS=$O(^PXRMINDX(9000011,"PSPI",DFN,STAT,PRIO,ICDP,DATE,""))
 .... S DSAVE=$S(PRIO="C":EDATE,1:DATE)
 .... I DSAVE'<BDT,DSAVE'>DEND D
 ..... S NFOUND=NFOUND+1
 ..... S TLIST(DSAVE,NFOUND)=DAS_U_ICDP_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)_U_"ICD9"
 Q
 ;
 ;===================================================
GETDATA(DA,FIEVT) ;Return data for a specified Problem List entry.
 N GMPLCOND,GMPLDLM,GMPLICD,GMPLLEX,GMPLODAT,GMPLPNAM,GMPLPRIO,GMPLPRV
 N GMPLSTAT,GMPLTXT,GMPLXDAT
 ;DBIA #2644
 D CALL2^GMPLUTL3(DA)
 S FIEVT("PROVIDER NARRATIVE")=GMPLTXT
 S FIEVT("DATE ENTERED")=GMPLODAT
 S FIEVT("DATE LAST MODIFIED")=GMPLDLM
 S FIEVT("STATUS")=GMPLSTAT
 S FIEVT("PRIORITY")=GMPLPRIO
 Q
 ;
 ;===================================================
GPLIST(TAXARR,NOCC,BDT,EDT,STATUSA,PLIST) ;Build patient list for
 ;Problem List entries.
 ;STATUSA is an array containing a list of status to search for. A
 ;status can be "A" for active or "I" for inactive. If STATUSA=""
 ;it will search for all with data.
 N DAS,DATE,DEND,DFN,DSAVE,ICDP,IND,JND,NFOUND,NPRIO,NSTAT,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)
 S NSTAT=STATUSA(0)
 I NSTAT=0 Q
 ;EDATE is the evaluation date.
 S EDATE=$$NOW^PXRMDATE
 ;For chronic problems we use today's date so only search for chronic
 ;problems if EDATE lies in the date range.
 I EDATE'<BDT,EDATE'>DEND D
 . S NPRIO=3
 . S PRIOA(1)="C",PRIOA(2)="A",PRIOA(3)="U"
 E  D
 . S NPRIO=2
 . S PRIOA(1)="A",PRIOA(2)="U"
 S NFOUND=0
 S ICDP=""
 F  S ICDP=$O(TAXARR(80,ICDP)) Q:(ICDP="")  D
 .;Since chronic problems will have today's date find those first.
 . I '$D(^PXRMINDX(9000011,"ISPP",ICDP)) Q
 . F IND=1:1:NSTAT D
 .. S STAT=STATUSA(IND)
 .. I '$D(^PXRMINDX(9000011,"ISPP",ICDP,STAT)) Q
 .. F JND=1:1:NPRIO D
 ... S PRIO=PRIOA(JND)
 ... I '$D(^PXRMINDX(9000011,"ISPP",ICDP,STAT,PRIO)) Q
 ... S DFN=""
 ... F  S DFN=$O(^PXRMINDX(9000011,"ISPP",ICDP,STAT,PRIO,DFN)) Q:DFN=""  D
 .... S DATE=""
 .... F  S DATE=$O(^PXRMINDX(9000011,"ISPP",ICDP,STAT,PRIO,DFN,DATE)) Q:DATE=""  D
 ..... S DAS=$O(^PXRMINDX(9000011,"ISPP",ICDP,STAT,PRIO,DFN,DATE,""))
 ..... S NFOUND=NFOUND+1
 ..... S DSAVE=$S(PRIO="C":EDATE,1:DATE)
 ..... I DSAVE'<BDT,DSAVE'>DEND S ^TMP($J,TLIST,DFN,DSAVE,DAS)=ICDP_U_"ICD9"_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 CODE,EM,D0,DIAG,EM,ICD9P,ICD9ZN,IND,JND,NAME,NIN,NOUT,PN,PRIORITY
 N STATUS,TEMP,TEXTIN,TEXTOUT,VDATE
 S NAME="Problem Diagnosis = "
 S IND=0
 F  S IND=$O(OCCLIST(IND)) Q:IND=""  D
 . S VDATE=IFIEVAL(IND,"DATE")
 . S TEMP=$$EDATE^PXRMDATE(VDATE)
 . S ICD9P=IFIEVAL(IND,"CODEP")
 . S ICD9ZN=$$ICDDX^ICDCODE(ICD9P,VDATE)
 . S CODE=$P(ICD9ZN,U,2)
 . S DIAG=$P(ICD9ZN,U,4)
 . S TEMP=NAME_DIAG
 . 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. The Problem List information is:  DATE, ICD9 IEN, 
 ;ICD9 CODE, PROVIDER NARRATIVE.
 N CODE,EM,D0,DIAG,EM,ICD9P,ICD9ZN,IND,JND,NIN,NOUT,PN,PRIORITY
 N STATUS,TEMP,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 TEMP=$$EDATE^PXRMDATE(VDATE)
 . S ICD9P=IFIEVAL(IND,"CODEP")
 . S ICD9ZN=$$ICDDX^ICDCODE(ICD9P,VDATE)
 . S CODE=$P(ICD9ZN,U,2)
 . S DIAG=$P(ICD9ZN,U,4)
 . S TEMP=TEMP_" "_CODE_" "_DIAG
 . S PRIORITY=$G(IFIEVAL(IND,"PRIORITY"))
 . S PRIORITY=$S(PRIORITY'="":$$EXTERNAL^DILFD(9000011,1.14,"",PRIORITY,.EM),1:"UNDEFINED")
 . S TEMP=TEMP_" Priority: "_PRIORITY
 .;If the Problem is inactive mark it as such.
 . S STATUS=$G(IFIEVAL(IND,"STATUS"))
 . S STATUS=$S(STATUS'="":$$EXTERNAL^DILFD(9000011,.12,"",STATUS,.EM),1:"UNDEFINED")
 . S TEMP=TEMP_" Status: "_STATUS
 . S TEXTIN(1)=TEMP_"\\",NIN=1
 . S D0=^AUPNPROB(IFIEVAL(IND,"DAS"),0)
 . S PN=$P(D0,U,5)
 . I PN'="" S PN=$P($G(^AUTNPOV(PN,0)),U,1)
 . I PN="" S PN="MISSING"
 . I PN'=DIAG S TEXTIN(2)="Prov. Narr. - "_PN,NIN=2
 . D FORMAT^PXRMTEXT(INDENT+2,PXRMRM,NIN,.TEXTIN,.NOUT,.TEXTOUT)
 . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
 S NLINES=NLINES+1,TEXT(NLINES)=""
 Q
 ;