source: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDRGR.m@ 619

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

initial load of WorldVistAEHR
File size: 6.8 KB
Line 
1PXRMDRGR ; SLC/PKR - Handle groups of drug findings. ;06/20/2007
2 ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
3 ;Groups are drug classes or VA Generic.
4 ;==================================================
5EVALFI(DFN,DEFARR,ENODE,XREF,FIEVAL) ;Evaluate drug group findings.
6 N DRGRIEN,FIEVT,FINDPA,FINDING,NOINDEX
7 S NOINDEX=0
8 I $G(^PXRMINDX(52,"DATE BUILT"))="" D
9 . D NOINDEX^PXRMERRH("D",PXRMITEM,52)
10 . S NOINDEX=1
11 I $G(^PXRMINDX(55,"DATE BUILT"))="" D
12 . D NOINDEX^PXRMERRH("D",PXRMITEM,55)
13 . S NOINDEX=1
14 S DRGRIEN=""
15 F S DRGRIEN=$O(DEFARR("E",ENODE,DRGRIEN)) Q:+DRGRIEN=0 D
16 . S FINDING=""
17 . F S FINDING=$O(DEFARR("E",ENODE,DRGRIEN,FINDING)) Q:+FINDING=0 D
18 .. I NOINDEX S FIEVAL(FINDING)=0 Q
19 .. K FIEVT,FINDPA
20 .. M FINDPA=DEFARR(20,FINDING)
21 .. D FIEVAL(DFN,DRGRIEN,.FINDPA,.DEFARR,FINDING,XREF,.FIEVT)
22 .. M FIEVAL(FINDING)=FIEVT
23 .. S FIEVAL(FINDING,"FINDING")=$P(FINDPA(0),U,1)
24 Q
25 ;
26 ;==================================================
27EVALPL(FINDPA,ENODE,XREF,TERMARR,PLIST) ;Evaluate drug group
28 ;terms for building patient lists.
29 N DRGRIEN,NOINDEX,PFINDPA
30 N TEMP,TFINDPA,TFINDING
31 S NOINDEX=0
32 I $G(^PXRMINDX(52,"DATE BUILT"))="" D
33 . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),52)
34 . S NOINDEX=1
35 I $G(^PXRMINDX(55,"DATE BUILT"))="" D
36 . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),55)
37 . S NOINDEX=1
38 I NOINDEX Q
39 S DRGRIEN=""
40 F S DRGRIEN=$O(TERMARR("E",ENODE,DRGRIEN)) Q:+DRGRIEN=0 D
41 . S TFINDING=""
42 . F S TFINDING=$O(TERMARR("E",ENODE,DRGRIEN,TFINDING)) Q:+TFINDING=0 D
43 .. K PFINDPA,TFINDPA
44 .. M TFINDPA=TERMARR(20,TFINDING)
45 ..;Set the finding parameters.
46 .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
47 .. D GPLIST(DRGRIEN,.PFINDPA,XREF,.PLIST)
48 Q
49 ;
50 ;==================================================
51EVALTERM(DFN,FINDPA,ENODE,XREF,TERMARR,TFIEVAL) ;Evaluate drug
52 ;group terms.
53 N DRGRIEN,FIEVT,NOINDEX,PFINDPA
54 N TEMP,TFINDPA,TFINDING
55 S NOINDEX=0
56 I $G(^PXRMINDX(52,"DATE BUILT"))="" D
57 . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),52)
58 . S NOINDEX=1
59 I $G(^PXRMINDX(55,"DATE BUILT"))="" D
60 . D NOINDEX^PXRMERRH("TR",TERMARR("IEN"),55)
61 . S NOINDEX=1
62 S DRGRIEN=""
63 F S DRGRIEN=$O(TERMARR("E",ENODE,DRGRIEN)) Q:+DRGRIEN=0 D
64 . S TFINDING=""
65 . F S TFINDING=$O(TERMARR("E",ENODE,DRGRIEN,TFINDING)) Q:+TFINDING=0 D
66 .. I NOINDEX S TFIEVAL(TFINDING)=0 Q
67 .. K FIEVT,PFINDPA,TFINDPA
68 .. M TFINDPA=TERMARR(20,TFINDING)
69 ..;Set the finding parameters.
70 .. D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
71 .. D FIEVAL(DFN,DRGRIEN,.PFINDPA,.TERMARR,TFINDING,XREF,.FIEVT)
72 .. M TFIEVAL(TFINDING)=FIEVT
73 .. S TFIEVAL(TFINDING,"FINDING")=$P(TFINDPA(0),U,1)
74 Q
75 ;
76 ;==================================================
77FIEVAL(DFN,DRGRIEN,FINDPA,DEFARR,FINDING,XREF,FIEVAL) ;
78 N DATE,DATEORDR,DRBEG,DREND,DRUG,DRUGIEN,IND,FIEVT,FIEVTL
79 N NOCC,NFOUND,POI,POIBEG,POIEND,POIIEN,RXTYL
80 N SDIR,TDATE,TIND
81 S NOCC=$P(FINDPA(0),U,14)
82 I NOCC="" S NOCC=1
83 S SDIR=$S(NOCC<0:+1,1:-1)
84 S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
85 ;Determine where we search.
86 D SRXTYL^PXRMRXTY(FINDPA(0),.RXTYL)
87 D GETPDR(DFN,.RXTYL,.DRBEG,.DREND,.POIBEG,.POIEND)
88 I DREND=0,POIEND=0 S FIEVAL=0 Q
89 S (DRUGIEN,NFOUND)=0
90 F S DRUGIEN=+$O(^PSDRUG(XREF,DRGRIEN,DRUGIEN)) Q:DRUGIEN=0 D
91 . I DRUGIEN'<DRBEG,DRUGIEN'>DREND S DRUG=DRUGIEN
92 . E S DRUG=0
93 .;DBIA #221
94 . S POIIEN=$P($G(^PSDRUG(DRUGIEN,2)),U,1)
95 . I POIIEN'<POIBEG,POIIEN'>POIEND S POI=POIIEN
96 . E S POI=0
97 . K FIEVT
98 . D DEVAL^PXRMDRUG(DFN,.FINDPA,.DEFARR,FINDING,.RXTYL,DRUG,POI,.FIEVT)
99 . I FIEVT D
100 .. S IND=0
101 .. F S IND=+$O(FIEVT(IND)) Q:IND=0 D
102 ...;Make sure this is not already on the list
103 ... I $$ONLIST(.FIEVTL,IND,.FIEVT) Q
104 ... S NFOUND=NFOUND+1,FIEVTL(NFOUND,"DISPENSE DRUG")=DRUGIEN
105 ... M FIEVTL(NFOUND)=FIEVT(IND)
106 ... S DATEORDR(FIEVT(IND,"DATE"),NFOUND)=FIEVT(IND,"FINDING")
107 ...;Don't keep more than NOCC occurrences on the list.
108 ... I NFOUND>NOCC D
109 .... S TDATE=$O(DATEORDR(""),-SDIR),TIND=$O(DATEORDR(TDATE,""))
110 .... K FIEVTL(TIND),DATEORDR(TDATE,TIND)
111 I NFOUND=0 S FIEVAL=0 Q
112 ;Order by date.
113 S DATE="",NFOUND=0
114 F S DATE=$O(DATEORDR(DATE),SDIR) Q:(DATE="")!(NFOUND=NOCC) D
115 . S IND=0
116 . F S IND=$O(DATEORDR(DATE,IND)) Q:(IND="")!(NFOUND=NOCC) D
117 .. S NFOUND=NFOUND+1
118 .. M FIEVAL(NFOUND)=FIEVTL(IND)
119 ;Save the finding result.
120 D SFRES^PXRMUTIL(SDIR,NFOUND,.FIEVAL)
121 Q
122 ;
123 ;==================================================
124GETPDR(DFN,RXTYL,DRBEG,DREND,POIBEG,POIEND) ;Return the beginning drug and
125 ;ending drug for a patient.
126 N IBEG,IEND,OBEG,OEND
127 I $D(RXTYL("I")) D
128 . S IBEG=+$O(^PXRMINDX(55,"PI",DFN,0))
129 . S IEND=+$O(^PXRMINDX(55,"PI",DFN,""),-1)
130 E S (IBEG,IEND)=0
131 I $D(RXTYL("O")) D
132 . S OBEG=+$O(^PXRMINDX(52,"PI",DFN,0))
133 . S OEND=+$O(^PXRMINDX(52,"PI",DFN,""),-1)
134 E S (OBEG,OEND)=0
135 S DRBEG=$S(IBEG<OBEG:IBEG,1:OBEG)
136 S DREND=$S(IEND>OEND:IEND,1:OEND)
137 I $D(RXTYL("N")) D
138 . S POIBEG=+$O(^PXRMINDX("55NVA","PI",DFN,0))
139 . S POIEND=+$O(^PXRMINDX("55NVA","PI",DFN,""),-1)
140 E S (POIBEG,POIEND)=0
141 Q
142 ;
143 ;==================================================
144GPLIST(DRGRIEN,PFINDPA,XREF,PLIST) ;
145 N DATE,DFN,DRUGIEN,FILENUM,IND,ITEM,NFOUND,NOCC,POI,RXTYL
146 N TF,TEMP,TGLIST,TLIST
147 S TGLIST="GPLIST_PXRMDRGR"
148 K ^TMP($J,TGLIST)
149 ;Determine where we search.
150 D SRXTYL^PXRMRXTY(PFINDPA(0),.RXTYL)
151 S DRUGIEN=0
152 F S DRUGIEN=$O(^PSDRUG(XREF,DRGRIEN,DRUGIEN)) Q:+DRUGIEN=0 D
153 . ;DBIA #221
154 . S POI=$P($G(^PSDRUG(DRUGIEN,2)),U,1)
155 . I $D(RXTYL("I")) D GPLIST^PXRMINDL(55,"IP",DRUGIEN,.PFINDPA,TGLIST)
156 . I $D(RXTYL("N")),POI'="" D GPLIST^PXRMINDL("55NVA","IP",POI,.PFINDPA,TGLIST)
157 . I $D(RXTYL("O")) D GPLIST^PXRMINDL(52,"IP",DRUGIEN,.PFINDPA,TGLIST)
158 ;Return the NOCC most recent results for each DFN.
159 S NOCC=$P(FINDPA(0),U,14)
160 S NOCC=$S(NOCC<0:-NOCC,NOCC="":1,1:NOCC)
161 F TF=0,1 D
162 . S DFN=0
163 . F S DFN=$O(^TMP($J,TGLIST,TF,DFN)) Q:DFN="" D
164 .. K TLIST
165 .. S ITEM=""
166 .. F S ITEM=$O(^TMP($J,TGLIST,TF,DFN,ITEM)) Q:ITEM="" D
167 ... S NFOUND=""
168 ... F S NFOUND=$O(^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND)) Q:NFOUND="" D
169 .... S FILENUM=""
170 .... F S FILENUM=$O(^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND,FILENUM)) Q:FILENUM="" D
171 ..... S TEMP=^TMP($J,TGLIST,TF,DFN,ITEM,NFOUND,FILENUM)
172 ..... S DATE=+$P(TEMP,U,3)
173 ..... S TLIST(TF,DATE,ITEM,NFOUND,FILENUM)=""
174 .. S DATE="",NFOUND=0
175 .. F S DATE=$O(TLIST(TF,DATE),-1) Q:(DATE="")!(NFOUND=NOCC) D
176 ... S ITEM=""
177 ... F S ITEM=$O(TLIST(TF,DATE,ITEM)) Q:(ITEM="")!(NFOUND=NOCC) D
178 .... S IND=""
179 .... F S IND=$O(TLIST(TF,DATE,ITEM,IND)) Q:(IND="")!(NFOUND=NOCC) D
180 ..... S FILENUM=""
181 ..... F S FILENUM=$O(TLIST(TF,DATE,ITEM,IND,FILENUM)) Q:(FILENUM="")!(NFOUND=NOCC) D
182 ...... S NFOUND=NFOUND+1
183 ...... S ^TMP($J,PLIST,TF,DFN,ITEM,NFOUND,FILENUM)=^TMP($J,TGLIST,TF,DFN,ITEM,IND,FILENUM)
184 K ^TMP($J,TGLIST)
185 Q
186 ;
187 ;==================================================
188ONLIST(FIEVTL,IND,FIEVT) ;Return true if FIEVT(IND) is already on
189 ;FIEVTL.
190 N JND,ONLIST
191 S (JND,ONLIST)=0
192 F S JND=$O(FIEVTL(JND)) Q:(ONLIST)!(JND="") D
193 . I FIEVTL(JND,"FILE NUMBER")'=FIEVT(IND,"FILE NUMBER") Q
194 . I FIEVTL(JND,"DAS")'=FIEVT(IND,"DAS") Q
195 . S ONLIST=1
196 Q ONLIST
197 ;
Note: See TracBrowser for help on using the repository browser.