source: FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRRLU3.m@ 1606

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

initial load of FOIAVistA 6/30/08 version
File size: 8.7 KB
Line 
1DGRRLU3 ;alb/aas - DG Replacement and Rehosting RPC for VADPT ;8/8/05 15:38
2 ;;5.3;Registration;**538**;Aug 13, 1993
3 ;
4 QUIT
5 ; -- Get list of wards or clinics for patient lookup by ward
6 ;
7 ; -- Does not currently limit display by division, institution, etc. May need to.
8 ;
9GETLIST(RESULT,PARAM) ;
10 ; Input: PARAM("TYPE")="ward" returns a list of wards
11 ; PARAM("TYPE")="clinic" returns a list of clinics
12 ; PARAM("TYPE")="provider" returns a list of providers
13 ; PARAM("TYPE")="specialty" returns a list of specialties
14 ; PARAM("VALUE")= Beginning lookup value or null to start
15 ; at the beginning or end of the file.
16 ; PARAM("MAXNUM")= Number of records to be returned. If a
17 ; negative number, traverse backwards.
18 ;
19 NEW X,CNT,DGRRLINE,DGRRESLT,OKAY
20 SET (CNT,OKAY)=0
21 IF '$D(DT) D DT^DICRW
22 ;
23 SET DGRRLINE=0
24 K ^TMP($J,"PLU-FILTER")
25 SET DGRRESLT="^TMP($J,""PLU-FILTER"")"
26 SET RESULT=$NA(@DGRRESLT)
27 ;
28 DO ADD^DGRRUTL($$XMLHDR^DGRRUTL)
29 ;
30 IF $$UP^XLFSTR($G(PARAM("TYPE")))="WARD" S OKAY=1 D
31 . D ADD^DGRRUTL("<filterlist type='ward'>")
32 . D WLIST("ward",$G(PARAM("VALUE")),$G(PARAM("MAXNUM")))
33 . D ADD^DGRRUTL("</filterlist>")
34 ;
35 IF $$UP^XLFSTR($G(PARAM("TYPE")))="CLINIC" S OKAY=2 D
36 . D ADD^DGRRUTL("<filterlist type='clinic'>")
37 . D CLIST("clinic","C",$G(PARAM("VALUE")),$G(PARAM("MAXNUM")))
38 . D ADD^DGRRUTL("</filterlist>")
39 ;
40 IF $$UP^XLFSTR($G(PARAM("TYPE")))="PROVIDER" S OKAY=3 D
41 . D ADD^DGRRUTL("<filterlist type='provider'>")
42 . D PLIST("provider",$G(PARAM("VALUE")),$G(PARAM("MAXNUM")))
43 . D ADD^DGRRUTL("</filterlist>")
44 ;
45 IF $$UP^XLFSTR($G(PARAM("TYPE")))="SPECIALTY" S OKAY=4 D
46 . D ADD^DGRRUTL("<filterlist type='specialty'>")
47 . D SLIST("specialty",$G(PARAM("VALUE")),$G(PARAM("MAXNUM")))
48 . D ADD^DGRRUTL("</filterlist>")
49 ;
50 IF OKAY<1 D
51 . D ADD^DGRRUTL("<unspecified>")
52 . D ADD^DGRRUTL("<error message='List type not supported or not specified!'>")
53 . D ADD^DGRRUTL("</unspecified>")
54 ;
55 QUIT
56 ;
57 ; -- get list of clinics for patient lookup by clinic
58CLIST(ITEM,CHKVAL,VALUE,MAXNUM) ;
59 NEW NAME,IEN,IDATE,RDATE,DIR,CNT2,DGRRB,FLAG
60 S VALUE=$$UP^XLFSTR($G(VALUE))
61 S NAME=$G(VALUE)
62 S MAXNUM=$G(MAXNUM)
63 S DGRRB=0
64 K ^TMP("DGRRLU3-CLIST",$J)
65 I $E(MAXNUM)="-" D
66 . S DGRRB=1 ; ****
67 .I MAXNUM="-" S MAXNUM="" Q ; ****
68 .S MAXNUM=$$ABS^XLFMTH(MAXNUM)
69 S (FLAG,CNT)=0
70 I $L(NAME)>0,DGRRB=0,$D(^SC("B",NAME)) S NAME=$O(^SC("B",NAME),-1) ; ****
71 I $L(NAME)>0,DGRRB=1,$D(^SC("B",NAME)) S NAME=$O(^SC("B",NAME)) ; ****
72 I 'DGRRB D
73 . S DIR=1
74 .FOR S NAME=$O(^SC("B",NAME)) Q:NAME="" DO Q:FLAG=1
75 .. S IEN=0
76 .. FOR S IEN=$O(^SC("B",NAME,IEN)) Q:IEN<1 DO Q:FLAG=1
77 ...N STATUS
78 ...S STATUS=$$STATUS(IEN,CHKVAL)
79 ...I STATUS=1 D
80 ....S CNT=CNT+1 I MAXNUM,CNT>MAXNUM S FLAG=1 Q ; ****
81 .... ;DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
82 .... S ^TMP("DGRRLU3-CLIST",$J,CNT)=IEN_U_NAME
83 I DGRRB D
84 . S DIR=-1
85 .FOR S NAME=$O(^SC("B",NAME),-1) Q:NAME="" DO Q:FLAG=1
86 .. S IEN=0
87 .. FOR S IEN=$O(^SC("B",NAME,IEN)) Q:IEN<1 DO Q:FLAG=1
88 ...N STATUS
89 ...S STATUS=$$STATUS(IEN,CHKVAL)
90 ...I STATUS=1 D
91 ....S CNT=CNT+1 I MAXNUM,CNT>MAXNUM S FLAG=1 Q ; ****
92 .... ; DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
93 .... S ^TMP("DGRRLU3-CLIST",$J,CNT)=IEN_U_NAME
94 S CNT2="",CNT=0
95 F S CNT2=$O(^TMP("DGRRLU3-CLIST",$J,CNT2),DIR) Q:CNT2="" D
96 . S IEN=+^TMP("DGRRLU3-CLIST",$J,CNT2)
97 . S NAME=$P(^TMP("DGRRLU3-CLIST",$J,CNT2),U,2)
98 . S CNT=CNT+1
99 . DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
100 QUIT
101STATUS(IEN,CHKVAL) ;
102 N IDATE,RDATE,STATUS
103 S STATUS=0
104 IF $P($G(^SC(IEN,0)),"^",3)=CHKVAL DO ;is a clinic
105 .S IDATE=$P($G(^SC(IEN,"I")),"^",1) ;inactivate date
106 .S RDATE=$P($G(^SC(IEN,"I")),"^",2) ;reactivate date
107 .IF (IDATE="")!(IDATE'<DT)!((IDATE<DT)&(RDATE>IDATE)) S STATUS=1
108 Q STATUS
109 ;
110WLIST(ITEM,VALUE,MAXNUM) ;
111 ; Input: VALUE - Beginning value or null to start at the beginning
112 ; or end of the file.
113 ; MAXNUM - Number of entries to be returned. Defaults to
114 ; traversing forward but if MAXNUM is a negative
115 ; number, traverses through the file backwards.
116 N FLAG,ERROR,CNT,DGRRB,BACKMTCH,CNT2
117 S CNT=0
118 ;I VALUE is null and MAXNUM is set to "-" or null, all wards returned
119 S VALUE=$$UP^XLFSTR($G(VALUE))
120 S MAXNUM=$G(MAXNUM)
121 S FLAG=""
122 I $E(MAXNUM)="-" D
123 .;Set direction for traversing file to backwards and remove - from
124 .;maximum number of records returned.
125 .S FLAG="B"
126 .I MAXNUM="-" S MAXNUM="" Q
127 .S MAXNUM=$$ABS^XLFMTH(MAXNUM)
128 ;Look for exact match
129 K ^TMP("DILIST",$J)
130 I ($G(VALUE)'="") D EXMTCH
131 ;Call File Manager for remaining matches
132 ; K ^TMP("DILIST",$J)
133 I MAXNUM'=0 D LIST^DIC(42,,.01,$G(FLAG),MAXNUM,VALUE,,"B",,,,"ERROR")
134 Q:$D(ERROR)
135 N DGRRI
136 S DGRRI=""
137 I $G(BACKMTCH) D
138 . S ^TMP("DILIST",$J,2,"ZZ")=+BACKMTCH
139 . S ^TMP("DILIST",$J,1,"ZZ")=$P(BACKMTCH,U,2)
140 S DGRRB=1 ; I FLAG="B" S DGRRB=-1
141 F S DGRRI=$O(^TMP("DILIST",$J,1,DGRRI),DGRRB) Q:DGRRI="" D
142 .N IEN,NAME
143 .S CNT=CNT+1
144 .S NAME=$G(^TMP("DILIST",$J,1,DGRRI))
145 .S IEN=$G(^TMP("DILIST",$J,2,DGRRI))
146 .DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
147 ; I FLAG="B",($G(VALUE)'="") D EXMTCH
148 Q
149EXMTCH ;Look for exact match
150 I $D(^DIC(42,"B",VALUE)) D
151 .N IEN
152 .S IEN=0
153 .F S IEN=$O(^DIC(42,"B",VALUE,IEN)) Q:IEN="" D
154 ..N NAME
155 ..S NAME=$P($G(^DIC(42,+IEN,0)),U)
156 .. ; S CNT=CNT+1
157 .. I MAXNUM'="" S MAXNUM=MAXNUM-1
158 .. I FLAG'="B" S CNT=CNT+1 DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
159 .. I FLAG="B" S BACKMTCH=IEN_U_NAME
160 Q
161 ; -- get list of providers for patient lookup by provider
162 ; from ORQPTQ2
163PLIST(ITEM,VALUE,MAXNUM) ;
164 NEW NAME,IEN,DGRRB,FLAG,CNT2,DGRRSCR,DGRRFMT
165 S VALUE=$$UP^XLFSTR($G(VALUE))
166 S NAME=$G(VALUE)
167 S MAXNUM=$G(MAXNUM)
168 S DGRRB=1
169 ;K ^TMP("DGRRLU3-PLIST",$J)
170 K ^TMP("DILIST",$J)
171 I $E(MAXNUM)="-" D
172 . S DGRRB=-1 ; *****
173 . I MAXNUM="-" S MAXNUM="" Q ; *****
174 .S MAXNUM=$$ABS^XLFMTH(MAXNUM)
175 S (FLAG,CNT)=0
176 ;I $L(NAME)>0,DGRRB=1,$D(^VA(200,"B",NAME)) S NAME=$O(^VA(200,"B",NAME),-1)
177 ;I $L(NAME)>0,DGRRB=-1,$D(^VA(200,"B",NAME)) S NAME=$O(^VA(200,"B",NAME))
178 ;FOR S NAME=$O(^VA(200,"B",NAME),DGRRB) Q:NAME="" DO Q:FLAG=1
179 ;. S IEN=0
180 ;. FOR S IEN=$O(^VA(200,"B",NAME,IEN)) Q:IEN<1 DO Q:FLAG=1
181 ;.. I $D(^XUSEC("PROVIDER",IEN)),$$ACTIVE^XUSER(IEN) DO
182 ;... SET CNT=CNT+1
183 ;... S ^TMP("DGRRLU3-PLIST",$J,CNT)=IEN_U_NAME
184 ;... I MAXNUM,CNT>(MAXNUM-1) S FLAG=1
185 ;S CNT2="",CNT=0
186 ;F S CNT2=$O(^TMP("DGRRLU3-PLIST",$J,CNT2),DGRRB) Q:CNT2="" D
187 ;. S IEN=+^TMP("DGRRLU3-PLIST",$J,CNT2)
188 ;. S NAME=$P(^TMP("DGRRLU3-PLIST",$J,CNT2),U,2)
189 ;. S CNT=CNT+1
190 ;. DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
191 I $L(NAME)>0,DGRRB=1,$D(^VA(200,"AK.PROVIDER",NAME)) S NAME=$O(^VA(200,"AK.PROVIDER",NAME),-1)
192 I $L(NAME)>0,DGRRB=-1,$D(^VA(200,"AK.PROVIDER",NAME)) S NAME=$O(^VA(200,"AK.PROVIDER",NAME))
193 S DGRRSCR="I $$ACTIVE^XUSER(+Y)"
194 S DGRRFMT="P"_$S(DGRRB=-1:"B",1:"")
195 D LIST^DIC(200,,"@;.01",DGRRFMT,MAXNUM,NAME,,"AK.PROVIDER",DGRRSCR)
196 S (CNT2,CNT)=0
197 F S CNT2=$O(^TMP("DILIST",$J,CNT2)) Q:CNT2="" D
198 . S IEN=+$G(^TMP("DILIST",$J,CNT2,0))
199 . S NAME=$P($G(^TMP("DILIST",$J,CNT2,0)),U,2)
200 . S CNT=CNT+1
201 . DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
202 K ^TMP("DILIST",$J)
203 D CLEAN^DILF
204 QUIT
205 ;
206SLIST(ITEM,VALUE,MAXNUM) ;Returns active specialties in Facility TreatingSpecialty (#45.7) file
207 ;
208 N NAME,IEN,CNT,FLAG,DGRRB,DGRRD,CNT2
209 S NAME=$$UP^XLFSTR($G(VALUE))
210 ; S NAME=$G(VALUE)
211 S (FLAG,IEN,CNT)=0
212 S MAXNUM=$G(MAXNUM)
213 S DGRRB=1
214 K ^TMP("DGRRLU3-SLIST",$J)
215 I $E(MAXNUM)="-" D
216 .S DGRRB=-1
217 .S MAXNUM=$$ABS^XLFMTH(MAXNUM)
218 ;Capture exact matches
219 I $L(NAME),$D(^DIC(45.7,"B",NAME)) D
220 .N DGRRD
221 .S DGRRD=$S(DGRRB=1:-1,1:1)
222 .S NAME=$O(^DIC(45.7,"B",NAME),DGRRD)
223 F S NAME=$O(^DIC(45.7,"B",NAME),DGRRB) Q:NAME="" D Q:FLAG=1
224 .F S IEN=$O(^DIC(45.7,"B",NAME,IEN)) Q:IEN'>0 D Q:FLAG=1
225 ..I $$ACTIVE^DGACT(45.7,IEN) D
226 ...S CNT=CNT+1
227 ...I MAXNUM,(CNT>MAXNUM) S FLAG=1 Q
228 ...; DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
229 ...S ^TMP("DGRRLU3-SLIST",$J,CNT)=IEN_U_NAME
230 S CNT=1,CNT2=""
231 S DGRRD=$S(DGRRB=1:1,1:-1)
232 F S CNT2=$O(^TMP("DGRRLU3-SLIST",$J,CNT2),DGRRD) Q:CNT2="" D
233 . S IEN=+^TMP("DGRRLU3-SLIST",$J,CNT2)
234 . S NAME=$P(^TMP("DGRRLU3-SLIST",$J,CNT2),U,2)
235 . DO ADD^DGRRUTL("<lineitem number='"_CNT_"' id='"_IEN_"' name='"_$$CHARCHK^DGRRUTL(NAME)_"'></lineitem>")
236 . S CNT=CNT+1
237 Q
238 ;
239DISPLAY(RESULT) ;
240 NEW I
241 S I=-1 FOR SET I=$O(@RESULT@(I)) Q:I<1 W !!,@RESULT@(I)
242 QUIT
Note: See TracBrowser for help on using the repository browser.