source: FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMPTL.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: 6.8 KB
Line 
1PXRMPTL ; SLC/DLT,PKR,PJH - Print Clinical Reminders logic; 06/23/2006
2 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
3 ;
4 ;====================================================
5BLDFLST(RITEM,FL) ;Build the list of findings defined for this reminder.
6 N IC,TEMP,GLOB,SUB,NAME
7 ;Build a list of findings.
8 S IC=0
9 F S IC=$O(^PXD(811.9,RITEM,20,IC)) Q:+IC=0 D
10 . S TEMP=$P(^PXD(811.9,RITEM,20,IC,0),U)
11 . S GLOB=$P(TEMP,";",2),SUB=$P(TEMP,";")
12 . S NAME=$S(GLOB="":"???",1:$P($G(@(U_GLOB_SUB_",0)")),U))
13 . S FL(IC)=NAME
14 Q
15 ;
16 ;====================================================
17CDUE(CDUE,FL,NL,ARRAY) ;Expand the custom date due string into ARRAY.
18 N ARGL,FI,FREQ,IND,OPER,NARGS,PFSTACK,TEMP
19 K ARRAY
20 S OPER=","
21 D POSTFIX^PXRMSTAC(CDUE,OPER,.PFSTACK)
22 S ARRAY(1)=PFSTACK(1)_"(",NL=1
23 S NARGS=0
24 F IND=2:1:PFSTACK(0) D
25 . I PFSTACK(IND)=OPER Q
26 . S NARGS=NARGS+1,ARGL(NARGS)=PFSTACK(IND)
27 F IND=1:1:NARGS D
28 . S TEMP=ARGL(IND)
29 . S FI=$P(TEMP,"+",1)
30 . S FREQ=$P(TEMP,"+",2)
31 . S TEMP=FL(FI)_" + "_FREQ
32 . S NL=NL+1
33 . S ARRAY(NL)=$S(IND<NARGS:TEMP_", ",1:TEMP)
34 S NL=NL+1,ARRAY(NL)=")"
35 Q
36 ;
37 ;====================================================
38COHORT(DA) ;
39 N ARRAY,CNT,LINE,NODE,NLINES,OUTPUT
40 F NODE=60,61,65,66,70,71,75,76 I $D(^PXD(811.9,DA,NODE))>0 D
41 . I NODE=60 W !,"General Patient Cohort Found Text:"
42 . I NODE=61 W !,"General Patient Cohort Not Found Text:"
43 . I NODE=65 W !,"General Resolution Found Text:"
44 . I NODE=66 W !,"General Resolution Not Found Text:"
45 . I NODE=70 W !,"Summary Patient Cohort Found Text:"
46 . I NODE=71 W !,"Summary Patient Cohort Not Found Text:"
47 . I NODE=75 W !,"Summary Resolution Found Text:"
48 . I NODE=76 W !,"Summary Resolution Not Found Text:"
49 . S (CNT,LINE)=0 F S LINE=$O(^PXD(811.9,DA,NODE,LINE)) Q:LINE="" D
50 .. S CNT=CNT+1 S ARRAY(CNT)=$G(^PXD(811.9,DA,NODE,LINE,0))
51 . I $D(ARRAY)>0 D FORMAT^PXRMTEXT(5,78,CNT,.ARRAY,.NLINES,.OUTPUT)
52 . I NLINES>0 F CNT=1:1:NLINES W !,OUTPUT(CNT)
53 . W !
54 Q
55 ;
56 ;====================================================
57DISLOG ;Display the patient cohort, resolution logic, and custom date due.
58 ;Determine if this is a default adhoc logic or user modified logic
59 N CDUE,CUSTOM,FL,IND,LARRAY,LOGSTR,MAXLEN,NLOGLIN,NPL
60 N PARRAY,RITEM,SEP
61 S MAXLEN=72
62 ;Build the list of findings for this reminder.
63 S RITEM=D0
64 D BLDFLST(RITEM,.FL)
65 ;
66 ;Get the cohort logic string.
67 S LOGSTR=$G(^PXD(811.9,RITEM,30))
68 ;Otherwise use internal cohort logic
69 I LOGSTR="" S LOGSTR=$G(^PXD(811.9,RITEM,31)),CUSTOM=0
70 E S CUSTOM=1
71 ;
72 ;Remove any (0)! and (1)& entries
73 S LOGSTR=$$REMOVE(LOGSTR)
74 ;
75 ;Break the logic string into an array using the Boolean operators
76 ;and the comma as separators.
77 S SEP="'!&<>=,"
78 S NLOGLIN=$$STRARR(LOGSTR,SEP,.LARRAY)
79 ;
80 ;Print the cohort logic.
81 I CUSTOM W "Customized PATIENT COHORT LOGIC to see if the Reminder applies to a patient:"
82 E W "Default PATIENT COHORT LOGIC to see if the Reminder applies to a patient:"
83 S NPL=$$FMTARR(MAXLEN,NLOGLIN,.LARRAY,.PARRAY)
84 F IND=1:1:NPL W !,?1,PARRAY(IND)
85 ;
86 ;Expand the logic and print it.
87 D EXPAND(NLOGLIN,.LARRAY,.FL,"FI(",")")
88 S NPL=$$FMTARR(MAXLEN,NLOGLIN,.LARRAY,.PARRAY)
89 W !!,"Expanded Patient Cohort Logic:"
90 F IND=1:1:NPL W !,?1,PARRAY(IND)
91 ;
92 ;Get the resolution logic string.
93 S LOGSTR=$G(^PXD(811.9,RITEM,34))
94 ;Otherwise use internal cohort logic
95 I LOGSTR="" S LOGSTR=$G(^PXD(811.9,RITEM,35)),CUSTOM=0
96 E S CUSTOM=1
97 ;
98 ;Remove any (0)! and (1)& entries
99 S LOGSTR=$$REMOVE(LOGSTR)
100 ;
101 ;Break the logic string into an array using the Boolean operators
102 ;and the comma as separators.
103 S NLOGLIN=$$STRARR(LOGSTR,SEP,.LARRAY)
104 ;
105 ;Print the resolution logic.
106 W !!
107 I CUSTOM W "Customized RESOLUTION LOGIC defines findings that resolve the Reminder:"
108 E W "Default RESOLUTION LOGIC defines findings that resolve the Reminder:"
109 S NPL=$$FMTARR(MAXLEN,NLOGLIN,.LARRAY,.PARRAY)
110 F IND=1:1:NPL W !,?1,PARRAY(IND)
111 ;
112 ;Expand the logic and print it.
113 D EXPAND(NLOGLIN,.LARRAY,.FL,"FI(",")")
114 S NPL=$$FMTARR(MAXLEN,NLOGLIN,.LARRAY,.PARRAY)
115 W !!,"Expanded Resolution Logic:"
116 F IND=1:1:NPL W !,?1,PARRAY(IND)
117 ;
118 ;Display the custom date due string.
119 S CDUE=$G(^PXD(811.9,D0,45))
120 I CDUE="" Q
121 W !!,"Custom Date Due:"
122 W !," ",CDUE
123 D CDUE(CDUE,.FL,.NLOGLIN,.LARRAY)
124 S NPL=$$FMTARR(MAXLEN,NLOGLIN,.LARRAY,.PARRAY)
125 W !!,"Expanded Custom Date Due:"
126 F IND=1:1:NPL W !,?1,PARRAY(IND)
127 Q
128 ;
129 ;====================================================
130DISLOGF(RITEM,FINDING,FL,PARRAY) ;Expand FUNCTION FINDING logic and
131 ;return the result in PARRAY.
132 N ARGNUM,AT,FARG,FUN,FUNCTION,FUNSTR,IND,ISFUN,MAXLEN,LARRAY
133 N NAME,NLOGLIN,NPL,NUM,SEP,TEMP
134 S MAXLEN=72
135 K PARRAY
136 ;Get the function string.
137 S FUNSTR=$G(^PXD(811.9,RITEM,25,FINDING,3))
138 I FUNSTR="" Q
139 ;
140 ;Establish the list of separators that can be used in the logic
141 ;string and take it apart.
142 S SEP="'!&=><,()"
143 S NLOGLIN=$$STRARR(FUNSTR,SEP,.LARRAY)
144 ;Replace argument numbers with the finding.
145 S FARG=0
146 F IND=1:1:NLOGLIN D
147 . S TEMP=LARRAY(IND)
148 . I TEMP="" Q
149 . S FUN=$P(TEMP,"(",1)
150 . S ISFUN=$S(FUN="":0,$D(^PXRMD(802.4,"B",FUN)):1,1:0)
151 . I ISFUN S FARG=1,FUNCTION=$TR(FUN,"_",""),ARGNUM=0 Q
152 . I FARG D
153 .. S NUM=+TEMP
154 .. S ARGNUM=ARGNUM+1
155 .. S AT=$$ARGTYPE^PXRMFFAT(FUNCTION,ARGNUM)
156 .. I AT="F" D
157 ... S NAME=$S($D(FL(NUM)):FL(NUM),1:"???")
158 ... S LARRAY(IND)=$$STRREP^PXRMUTIL(LARRAY(IND),NUM,NAME)
159 ..E S LARRAY(IND)=TEMP
160 . I TEMP[")" S FARG=0
161 ;Format the array for printing.
162 S NPL=$$FMTARR(MAXLEN,NLOGLIN,.LARRAY,.PARRAY)
163 Q
164 ;
165 ;====================================================
166EXPAND(NL,ARRAY,FL,LT,RT) ;Insert findings in FI(n) format. Each element
167 ;of ARRAY will contain no more than one FI.
168 N FIE,FIS,FNUM,LEN,NAME,STRING
169 F IND=1:1:NL D
170 . S STRING=ARRAY(IND)
171 . S FIS=$F(STRING,LT)
172 . I FIS=0 Q
173 . S LEN=$L(STRING)
174 . S FIE=$F(STRING,RT,FIS)-2
175 . S FNUM=$E(STRING,FIS,FIE)
176 . S NAME=$S($D(FL(FNUM)):FL(FNUM),1:"???")
177 . S ARRAY(IND)=$E(STRING,1,FIS-1)_NAME_$E(STRING,FIE+1,LEN)
178 Q
179 ;
180 ;====================================================
181FMTARR(MAXLEN,NE,INARRAY,OUTARRAY) ;Load the output array.
182 N IC,LINNUM,SLEN
183 K OUTARRY
184 S OUTARRAY(1)=""
185 S LINNUM=1
186 F IC=1:1:NE D
187 . S SLEN=$L(OUTARRAY(LINNUM))+$L(INARRAY(IC))
188 . I SLEN>MAXLEN D
189 .. S LINNUM=LINNUM+1
190 .. S OUTARRAY(LINNUM)=INARRAY(IC)
191 . E S OUTARRAY(LINNUM)=OUTARRAY(LINNUM)_INARRAY(IC)
192 Q LINNUM
193 ;
194 ;====================================================
195STRARR(STRING,SEP,ARRAY) ;Break STRING into an array using SEP.
196 N CHAR,IC,LINNUM,NE,SLEN,TEMP
197 K OUTARRAY
198 ;Break string into pieces using SEP.
199 S SLEN=$L(STRING)
200 S LINNUM=0,TEMP=""
201 F IC=1:1:SLEN D
202 . S CHAR=$E(STRING,IC,IC)
203 . S TEMP=TEMP_CHAR
204 . I SEP[CHAR D
205 .. S LINNUM=LINNUM+1
206 .. S ARRAY(LINNUM)=TEMP
207 .. S TEMP=""
208 S LINNUM=LINNUM+1
209 S ARRAY(LINNUM)=TEMP
210 Q LINNUM
211 ;
212 ;====================================================
213REMOVE(STRING) ;Remove leading (n) entries
214 I ($E(STRING,1,4)="(0)!")!($E(STRING,1,4)="(1)&") S $E(STRING,1,4)=""
215 Q STRING
216 ;
Note: See TracBrowser for help on using the repository browser.