source: FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMPROB.m@ 1801

Last change on this file since 1801 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 7.0 KB
Line 
1PXRMPROB ; SLC/PKR - Code for Problem List. ;06/09/2006
2 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
3 ;
4 ;===================================================
5FPDAT(DFN,TAXARR,NGET,SDIR,BDT,EDT,STATUSA,FLIST) ;Find data for a
6 ;patient. STATUSA is an array containing a list of status to search
7 ;for. A status can be "A" for active or "I" for inactive. If STATUSA=""
8 ;it will search for all with data.
9 N BDTT,DAS,DATE,DEND,DS,DSAVE,DTT,EDATE,EDTT,ICDP,IND,JND,LGT,LLT
10 N NFOUND,NPRIO,NSTAT,PRIO,PRIOA,STAT,STATUSAT,TDATE,TE,TIND,TLIST,TS
11 I $G(^PXRMINDX(9000011,"DATE BUILT"))="" D Q
12 . D NOINDEX^PXRMERRH("TX",TAXARR("IEN"),9000011)
13 I '$D(^PXRMINDX(9000011,"PSPI",DFN)) Q
14 S NSTAT=STATUSA(0)
15 I NSTAT=0 Q
16 ;EDATE is the evaluation date.
17 S EDATE=$$NOW^PXRMDATE
18 S BDTT=BDT-.0000001
19 S EDTT=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
20 S DEND=$S(EDT[".":EDT,1:EDT+.240001)
21 S DTT=EDATE+.240001
22 ;Get the start and end of the taxonomy.
23 S TS=$O(TAXARR(80,""))-1
24 S TE=$O(TAXARR(80,""),-1)
25 ;For chronic problems we use today's date so only search for chronic
26 ;problems if today's datelies in the date range.
27 I EDATE'<BDT,EDATE'>DEND S NPRIO=3,PRIOA(1)="C",PRIOA(2)="A",PRIOA(3)="U"
28 E S NPRIO=2,PRIOA(1)="A",PRIOA(2)="U"
29 S NFOUND=0
30 F IND=1:1:NSTAT D
31 . S STAT=STATUSA(IND)
32 . F JND=1:1:NPRIO D
33 .. S PRIO=PRIOA(JND)
34 .. I '$D(^PXRMINDX(9000011,"PSPI",DFN,STAT,PRIO)) Q
35 .. I SDIR=-1,PRIO'="C" S DS=EDTT,LLT=BDT,LGT=EDT
36 .. I SDIR=-1,PRIO="C" S DS=DTT,LLT=0,LGT=EDATE
37 .. I SDIR=1,PRIO'="C" S DS=BDTT,LLT=0,LGT=EDT
38 .. I SDIR=1,PRIO="C" S DS=0,LLT=0,LGT=EDATE
39 .. S ICDP=TS
40 .. F S ICDP=$O(^PXRMINDX(9000011,"PSPI",DFN,STAT,PRIO,ICDP)) Q:(ICDP>TE)!(ICDP="") D
41 ... I '$D(TAXARR(80,ICDP)) Q
42 ... S DATE=DS
43 ... 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
44 .... S DAS=$O(^PXRMINDX(9000011,"PSPI",DFN,STAT,PRIO,ICDP,DATE,""))
45 .... S DSAVE=$S(PRIO="C":EDATE,1:DATE)
46 .... I DSAVE'<BDT,DSAVE'>DEND D
47 ..... S NFOUND=NFOUND+1
48 ..... S TLIST(DSAVE,NFOUND)=DAS_U_ICDP_U_STAT_U_PRIO
49 ..... I NFOUND>NGET D
50 ...... S TDATE=$O(TLIST(""),-SDIR),TIND=$O(TLIST(TDATE,""))
51 ...... K TLIST(TDATE,TIND)
52 ;Return up to NGET of the most recent entries.
53 S NFOUND=0
54 S DATE=""
55 F S DATE=$O(TLIST(DATE),SDIR) Q:(DATE="")!(NFOUND=NGET) D
56 . S IND=0
57 . F S IND=$O(TLIST(DATE,IND)) Q:(IND="")!(NFOUND=NGET) D
58 .. S NFOUND=NFOUND+1
59 .. S FLIST(DATE,NFOUND,9000011)=TLIST(DATE,IND)_U_"ICD9"
60 Q
61 ;
62 ;===================================================
63GETDATA(DA,FIEVT) ;Return data for a specified Problem List entry.
64 N GMPLCOND,GMPLDLM,GMPLICD,GMPLLEX,GMPLODAT,GMPLPNAM,GMPLPRIO,GMPLPRV
65 N GMPLSTAT,GMPLTXT,GMPLXDAT
66 ;DBIA #2644
67 D CALL2^GMPLUTL3(DA)
68 S FIEVT("PROVIDER NARRATIVE")=GMPLTXT
69 S FIEVT("DATE ENTERED")=GMPLODAT
70 S FIEVT("DATE LAST MODIFIED")=GMPLDLM
71 S FIEVT("STATUS")=GMPLSTAT
72 S FIEVT("PRIORITY")=GMPLPRIO
73 Q
74 ;
75 ;===================================================
76GPLIST(TAXARR,NOCC,BDT,EDT,STATUSA,PLIST) ;Build patient list for
77 ;Problem List entries.
78 ;STATUSA is an array containing a list of status to search for. A
79 ;status can be "A" for active or "I" for inactive. If STATUSA=""
80 ;it will search for all with data.
81 N DAS,DATE,DEND,DFN,DSAVE,ICDP,IND,JND,NFOUND,NPRIO,NSTAT,PRIO,PRIOA
82 N STAT,TEMP,TLIST
83 I $G(^PXRMINDX(9000011,"DATE BUILT"))="" D Q
84 . D NOINDEX^PXRMERRH("TX",TAXARR("IEN"),9000011)
85 S TLIST="GPLIST_PXRMPROB"
86 S DEND=$S(EDT[".":EDT,1:EDT+.240001)
87 K ^TMP($J,TLIST)
88 S NSTAT=STATUSA(0)
89 I NSTAT=0 Q
90 ;EDATE is the evaluation date.
91 S EDATE=$$NOW^PXRMDATE
92 ;For chronic problems we use today's date so only search for chronic
93 ;problems if EDATE lies in the date range.
94 I EDATE'<BDT,EDATE'>DEND D
95 . S NPRIO=3
96 . S PRIOA(1)="C",PRIOA(2)="A",PRIOA(3)="U"
97 E D
98 . S NPRIO=2
99 . S PRIOA(1)="A",PRIOA(2)="U"
100 S NFOUND=0
101 S ICDP=""
102 F S ICDP=$O(TAXARR(80,ICDP)) Q:(ICDP="") D
103 .;Since chronic problems will have today's date find those first.
104 . I '$D(^PXRMINDX(9000011,"ISPP",ICDP)) Q
105 . F IND=1:1:NSTAT D
106 .. S STAT=STATUSA(IND)
107 .. I '$D(^PXRMINDX(9000011,"ISPP",ICDP,STAT)) Q
108 .. F JND=1:1:NPRIO D
109 ... S PRIO=PRIOA(JND)
110 ... I '$D(^PXRMINDX(9000011,"ISPP",ICDP,STAT,PRIO)) Q
111 ... S DFN=""
112 ... F S DFN=$O(^PXRMINDX(9000011,"ISPP",ICDP,STAT,PRIO,DFN)) Q:DFN="" D
113 .... S DATE=""
114 .... F S DATE=$O(^PXRMINDX(9000011,"ISPP",ICDP,STAT,PRIO,DFN,DATE)) Q:DATE="" D
115 ..... S DAS=$O(^PXRMINDX(9000011,"ISPP",ICDP,STAT,PRIO,DFN,DATE,""))
116 ..... S NFOUND=NFOUND+1
117 ..... S DSAVE=$S(PRIO="C":EDATE,1:DATE)
118 ..... I DSAVE'<BDT,DSAVE'>DEND S ^TMP($J,TLIST,DFN,DSAVE,DAS)=ICDP_U_"ICD9"_U_STAT_U_PRIO
119 ;Return up to NOCC of the most recent entries.
120 S DFN=0
121 F S DFN=$O(^TMP($J,TLIST,DFN)) Q:DFN="" D
122 . S NFOUND=0
123 . S DATE=""
124 . F S DATE=$O(^TMP($J,TLIST,DFN,DATE),-1) Q:(DATE="")!(NFOUND=NOCC) D
125 .. S DAS=""
126 .. F S DAS=$O(^TMP($J,TLIST,DFN,DATE,DAS)) Q:DAS="" D
127 ... S NFOUND=NFOUND+1
128 ... S TEMP=^TMP($J,TLIST,DFN,DATE,DAS)
129 ... S ^TMP($J,PLIST,1,DFN,NFOUND,9000011)=DAS_U_DATE_U_TEMP
130 K ^TMP($J,TLIST)
131 Q
132 ;
133 ;===================================================
134MHVOUT(INDENT,OCCLIST,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
135 N CODE,EM,D0,DIAG,EM,ICD9P,ICD9ZN,IND,JND,NAME,NIN,NOUT,PN,PRIORITY
136 N STATUS,TEMP,TEXTIN,TEXTOUT,VDATE
137 S NAME="Problem Diagnosis = "
138 S IND=0
139 F S IND=$O(OCCLIST(IND)) Q:IND="" D
140 . S VDATE=IFIEVAL(IND,"DATE")
141 . S TEMP=$$EDATE^PXRMDATE(VDATE)
142 . S ICD9P=IFIEVAL(IND,"CODEP")
143 . S ICD9ZN=$$ICDDX^ICDCODE(ICD9P,VDATE)
144 . S CODE=$P(ICD9ZN,U,2)
145 . S DIAG=$P(ICD9ZN,U,4)
146 . S TEMP=NAME_DIAG
147 . S TEMP=TEMP_" ("_$$EDATE^PXRMDATE(VDATE)_")"
148 . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
149 . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
150 S NLINES=NLINES+1,TEXT(NLINES)=""
151 Q
152 ;
153 ;===================================================
154OUTPUT(INDENT,OCCLIST,IFIEVAL,NLINES,TEXT) ;Produce the clinical
155 ;maintenance output. The Problem List information is: DATE, ICD9 IEN,
156 ;ICD9 CODE, PROVIDER NARRATIVE.
157 N CODE,EM,D0,DIAG,EM,ICD9P,ICD9ZN,IND,JND,NIN,NOUT,PN,PRIORITY
158 N STATUS,TEMP,TEXTIN,TEXTOUT,VDATE
159 S NLINES=NLINES+1
160 S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Problem Diagnosis:"
161 S IND=0
162 F S IND=$O(OCCLIST(IND)) Q:IND="" D
163 . S VDATE=IFIEVAL(IND,"DATE")
164 . S TEMP=$$EDATE^PXRMDATE(VDATE)
165 . S ICD9P=IFIEVAL(IND,"CODEP")
166 . S ICD9ZN=$$ICDDX^ICDCODE(ICD9P,VDATE)
167 . S CODE=$P(ICD9ZN,U,2)
168 . S DIAG=$P(ICD9ZN,U,4)
169 . S TEMP=TEMP_" "_CODE_" "_DIAG
170 . S PRIORITY=$G(IFIEVAL(IND,"PRIORITY"))
171 . S PRIORITY=$S(PRIORITY'="":$$EXTERNAL^DILFD(9000011,1.14,"",PRIORITY,.EM),1:"UNDEFINED")
172 . S TEMP=TEMP_" Priority: "_PRIORITY
173 .;If the Problem is inactive mark it as such.
174 . S STATUS=$G(IFIEVAL(IND,"STATUS"))
175 . S STATUS=$S(STATUS'="":$$EXTERNAL^DILFD(9000011,.12,"",STATUS,.EM),1:"UNDEFINED")
176 . S TEMP=TEMP_" Status: "_STATUS
177 . S TEXTIN(1)=TEMP_"\\",NIN=1
178 . S D0=^AUPNPROB(IFIEVAL(IND,"DAS"),0)
179 . S PN=$P(D0,U,5)
180 . I PN'="" S PN=$P($G(^AUTNPOV(PN,0)),U,1)
181 . I PN="" S PN="MISSING"
182 . I PN'=DIAG S TEXTIN(2)="Prov. Narr. - "_PN,NIN=2
183 . D FORMAT^PXRMTEXT(INDENT+2,PXRMRM,NIN,.TEXTIN,.NOUT,.TEXTOUT)
184 . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
185 S NLINES=NLINES+1,TEXT(NLINES)=""
186 Q
187 ;
Note: See TracBrowser for help on using the repository browser.