source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMRBK.m@ 1185

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

initial load of FOIAVistA 6/30/08 version

File size: 8.1 KB
Line 
1SCMRBK ;ALB/SCK - Broker Utilities for multiple patient reassignments; 4/8/96
2 ;;5.3;Scheduling;**148,157,204**;AUG 13, 1993
3 ;
4 Q
5 ;
6PTGET(SCDATA,SC) ; Return a block of patients to the client
7 ; 'SC GET PAT BLOCK'
8 ;
9 ; SCJOB = $J for the ^TMP global
10 ; SCJOBID = The second subscript id for the ^TMP global
11 ; SCSTART = Beginning entry number for the block retrieval in the ^TMP global
12 ; SCEND = The ending entry number for the block retrieval
13 ; SCLAST = The last entry number in the ^TMP global
14 ;
15 ; This RPC returns a list of patients from the temp global that was built by
16 ; by the call to either SCMC BLD POS PAT LIST or SCMC BLD TEAM PAT LIST
17 ;
18 N SCJOB,SCSTART,SCEND,I,SCLAST,SCJOBID
19 ;
20 D CHK^SCUTBK
21 D TMP^SCUTBK
22 ;
23 D PARSE^SCMCBK1(.SC)
24 ;
25 F I=SCSTART:1:SCEND Q:'$G(^TMP(SCJOB,SCJOBID,I),0) D
26 . S SCDATA(I)=^TMP(SCJOB,SCJOBID,I)
27 I SCEND>SCLAST K ^TMP(SCJOB,SCJOBID)
28 ;
29 D CLRVAR^SCMCBK1
30 Q
31 ;
32 ; This is invoked after the Save button is clicked in Patient reasignment-both team and pos
33 ; RPC - SC BLD REASSIGN PAT LST
34PTLSTBLD(SCOK,SCVAL) ; Build the list of patients to be assigned in the ^TMP($J,"SCPATIENT LIST",DFN) global
35 ; 'SC BLD PAT LIST'
36 ;
37 N SCJOB,SCDFN
38 ;
39 D CHK^SCUTBK
40 D TMP^SCUTBK
41 ;
42 S SCOK=0
43 I SCVAL["Start" D G PTBLDQ
44 . S SCOK=$J
45 . K ^TMP(SCOK,"SC PATIENT LIST")
46 ;
47 S SCJOB=$P(SCVAL,U,1)
48 S SCDFN=$P(SCVAL,U,2)
49 S ^TMP(SCJOB,"SC PATIENT LIST",SCDFN)=$P(SCVAL,U,3) ; equals assignment IEN (PDR)
50 S SCOK=1
51PTBLDQ ;
52 Q
53 ;
54 ; This is invoked by RPC (SC FILE PAT TM REASGN) for team reasignment
55 ;
56PTFILE(SCOK,SC) ; File the patient assignments in the ^TMP($J,"SC TEAM ASSIGN",SCDFN) global
57 ; 'SCMC FILE PAT TM REASGN'
58 ;
59 N SCADDFLD,SCTEAM,SCFILE,SCJOB,SCNEW,SCOLD,SCBAD,SCERMSG,SCX,SCDTVAR,SCOTH
60 N ZTPRI,ZTRTN,ZTDESC,ZTDTH,SCNOW
61 ;
62 D CHK^SCUTBK
63 D TMP^SCUTBK ; this sets up a DUZ=.5 and a DT of the current date
64 D NOW^%DTC
65 S SCNOW=% ; get actual FM date/time for enter/edit documentation
66 ;
67 D PARSE^SCMCBK1(.SC)
68 G:+$G(SCJOB)=0 FILEQ
69 ;
70 ; Additional fields for 404.42 PATIENT TEAM ASSIGNMENT FILE
71 S SCADDFLD(.08)=$G(SC("TYPE"),99)
72 S SCADDFLD(.1)=$G(SC("RESTRICT"),0)
73 ; note, the fields below are not appropriate if team is being activated or modified. Be sure
74 ; to kill as necessary before filing, and to add edit by and edit D/T where necessary - PDR
75 S SCADDFLD(.11)=DUZ ; user entering
76 S SCADDFLD(.12)=SCNOW ; entry date/time (changed from =DT - PDR)
77 ;
78 I $G(SC("BKG"))="1" D BKG(1) Q ;Bail out to run in background
79 ;
80BKGTM ; Run Team Reassignment Filer in BKG
81 I $D(ZTQUEUED) S SCJOB=$J ; want to use Task Manager assigned $J if BKG
82 S SCX=$$ACPTRATM^SCAPMR6("^TMP(SCJOB,""SC PATIENT LIST"")",SCTEAM,SCFRMTM,.SCOTH,"SCADDFLD",SCDTVAR,"SCERMSG","SCNEW","SCOLD","SCBAD")
83 I '$D(ZTQUEUED) D
84 . D BAD^SCMCBK1(.SCBAD,.SCOLD,.SCOK) ; this sets up RPC return var SCOK for error report dialog
85 . S SCOK(.1)=SCX_U_"FORE"
86 ;
87 K ^TMP(SCJOB,"SC PATIENT LIST")
88 D CLRVAR^SCMCBK1
89 ;
90FILEQ Q
91 ;
92 ; This is invoked by RPC ('SC FILE PAT POS REASGN') for position reasignment
93POSFILE(SCOK,SC) ; File the patient assignments in the ^TMP($J,"SC PATIENT LIST") global
94 ; ' SCMC FILE PAT POS REASGN '
95 ;
96 N SCADDFLD,SCTEAM,SCFILE,SCJOB,SCNEW,SCOLD,SCBAD,SCERMSG,SCX
97 N SCPOSTO,SCPOSFRM,SCDTVAR,SCMAFLD,SCADTM,SCNEW1,SCNOW
98 ;
99 D CHK^SCUTBK
100 D TMP^SCUTBK
101 S SCNOW=$$NOW^XLFDT
102 ;
103 D PARSE^SCMCBK1(.SC)
104 S SCPOSTO=SC("POSITION")
105 S SCPOSFRM=SC("FROMPOSITION")
106 G:+$G(SCJOB)=0 FILEQ
107 S SCADTM=1
108 ;
109 S SCADDFLD(.05)=$G(SC("TYPE"),0)
110 S SCADDFLD(.06)=DUZ
111 S SCADDFLD(.07)=SCNOW
112 ;
113 I $G(SC("BKG"))="1" D BKG(2) Q
114 ;
115BKGPOS ; BACKGROUND JOB ENTRY POINT
116 I $D(ZTQUEUED) S SCJOB=$J ; want to use Task Manager assigned $J if BKG
117 S SCX=$$ACPTATP^SCAPMR21("^TMP(SCJOB,""SC PATIENT LIST"")",SCPOSTO,SCPOSFRM,"SCADDFLD",SCDTVAR,"SCERMSG",SCADTM,"","SCNEW","SCNEW1","SCOLD","SCBAD")
118 ;
119 I '$D(ZTQUEUED) D
120 . D BAD2^SCMCBK1(.SCBAD,.SCOLD,.SCOK) ; this sets up RPC return var SCOK for error report dialog
121 . S SCOK(.1)=SCX_U_"FORE"
122 ;
123 K ^TMP(SCJOB,"SC PATIENT LIST")
124 D CLRVAR^SCMCBK1
125 Q
126 ;
127BLKPOS ;
128 N SCX
129 S SCX=$G(SCDTRNG("END"))
130 S SCDTRNG("END")=3990101 ;check forever
131 S SCOK1=$$PTTP^SCAPMC(SCBLOCK,"SCDTRNG","^TMP(""SCMC"",$J,""EXCLUDE PT"")","SCER2")
132 S SCDTRNG("END")=SCX
133 Q
134 ;
135BLKTM ;
136 N SCX
137 S SCX=$G(SCDTRNG("END"))
138 S SCDTRNG("END")=3990101 ;check forever
139 S SCOK1=$$PTTM^SCAPMC(SCBLOCK,"SCDTRNG","^TMP(""SCMC"",$J,""EXCLUDE PT"")","SCER2")
140 S SCDTRNG("END")=SCX
141 Q
142 ;
143 ; This is used to get the patient list to fill the list box after team and position selection
144 ;
145PTPOSLST(SCOK,SC) ; Get a list of of patients for a team position
146 ; RPC:'SCMC BLD POS PAT LIST'
147 ;
148 N PD,FD,TD,ASNST,FC
149 D NEWVAR^SCMCBK1
150 D CHK^SCUTBK
151 D TMP^SCUTBK
152 S FD=SC("FROMDATE")
153 S TD=SC("TODATE")
154 S ASNSTAT=SC("ASSIGNSTAT") ; 0=assigned only, 1=Discharged only, 2=both
155 ;
156 D PARSE^SCMCBK1(.SC)
157 ;
158 K ^TMP($J,"SCPOS")
159 ;
160 S SCOK=0
161 ; This date setting could be accomplished on GUI using the .MULT[] broker array, and
162 ; loaded into SCDTRNG via the call to parse. I've opted to set the array explicitly
163 ; here.
164 S SCDTRNG("BEGIN")=FD
165 S SCDTRNG("END")=TD
166 S SCDTRNG("INCL")=0
167 ; get list of pt active for time period specified
168 ; future discharges included
169 S SCOK=$$PTTP^SCAPMC11(SCFRMPOS,"SCDTRNG",.SCLOC,.SCERMSG)
170 K ^TMP("SCMC",$J,"EXCLUDE PT")
171 M ^TMP($J,"SC PCMM IN")=@SCLOC
172 ;
173 S I1=$G(^TMP($J,"SC PCMM IN",0))
174 S FC=0 ; initialize filtered count of patients
175 F I=1:1:I1 D
176 . S PD=$G(^TMP($J,"SC PCMM IN",I)) ; get the discharge date
177 . Q:$$FILTOUT(+$P(PD,U,5),+$P(PD,U,4))
178 . S ^TMP($J,"PCMM TMP",I)=$G(^TMP($J,"SC PCMM IN",I))
179 . S FC=FC+1
180 D ALPHA^SCAPMCU2("^TMP($J,""PCMM TMP"")","^TMP($J,""SCPOS"")")
181 S SCOK=$J_U_FC_U_SCOK
182 ;
183 D CLRVAR^SCMCBK1
184 Q
185 ;
186FILTOUT(DD,AD) ; FILTER OUT CANDIDATE PATIENTS
187 ;bp/cmf 204t0 -- SCDTVAR(def = dt) replaces DT
188 ; Want actives only
189 Q:ASNSTAT=0 ((DD)&(DD'>SCDTVAR))!(AD>SCDTVAR)
190 ; ; disch date before tomorrow, or assign date greater than today
191 ;
192 ; Want discharges between dates only
193 Q:ASNSTAT=1 (DD>TD)!(DD<FD)
194 ; ; disch date is after TO date, or discharge date is before FROM date
195 ;
196 ; Want discharges and actives from date
197 Q:ASNSTAT=2 (DD&(DD<FD))!(AD>SCDTVAR)
198 ; ; disch date less than FROM date, or assign date > dtvar
199 Q 0
200 ;
201 ;
202 ; used to get the patient list after a team selection
203 ;
204PTTMLST(SCOK,SC) ; ; Get a list of of patients for a team - FILTER FOR ACTIVE
205 ; RPC:'SCMC BLD TEAM PAT LIST'
206 ;
207 ;bp/cmf 204t0 -- SCDTVAR(def = dt) replaces DT
208 N TD,SCDD
209 D NEWVAR^SCMCBK1
210 D CHK^SCUTBK
211 D TMP^SCUTBK
212 ;
213 D PARSE^SCMCBK1(.SC)
214 K ^TMP($J,"SCTEAM")
215 ;
216 S SCOK=0
217 ; get list of patient team assignments ordered by q
218 S SCOK=$$PTTM^SCAPMC2(SCFRMTM,"SCDTRNG",.SCLOC,"SCERMSG") ; SCLOC = ^TMP("SCTMP LIST",$J)
219 K ^TMP("SCMC",$J,"EXCLUDE PT")
220 M ^TMP($J,"SC PCMM IN")=@SCLOC
221 ;
222 S I=""
223 F S I=$O(^TMP($J,"SC PCMM IN",I)) Q:'I D
224 . S TD=^TMP($J,"SC PCMM IN",I)
225 . S SCDD=$P(TD,U,5)
226 . Q:(SCDD'="")&(SCDD'>SCDTVAR) ; filter discharged assignments
227 . Q:$P(TD,U,4)>SCDTVAR ; filter future assignments
228 . S ^TMP($J,"PCMM TMP",I)=^TMP($J,"SC PCMM IN",I)
229 ;
230 D ALPHA^SCAPMCU2("^TMP($J,""PCMM TMP"")","^TMP($J,""SCTEAM"")")
231 ;
232 S SCOK=$J_U_+$O(^TMP($J,"SCTEAM",""),-1)_U_SCOK
233 ;
234 D CLRVAR^SCMCBK1
235 Q
236 ;
237DISCHPOS(SCOK,SC) ; DISCHARGE POSITIONS FOR A TEAM - RPC: PDR SC DIS TEAM POS
238 ; SC("DFN") = ptr to patient file
239 ; SC("TMASGN") = ptr to team assignment file 404.42
240 ; SC("DATE") = file date (date selected on client)
241 N SCBEGIN,SCEND,SCINCL,SCDATES,SCERR
242 D CHK^SCUTBK
243 D TMP^SCUTBK
244 S SCOK=1
245 S SCERR="SCERRMSG"
246 K @SCERR ;;bp/cmf 204 clean error array!!!!!!!!!! [iow-0899-40854]
247 D DISCHPOS^SCRPMTA(SC("DFN"),SC("TMASGN"),SC("DATE"),SCERR)
248 S SCOK='$D(@SCERR)
249 Q
250 ;
251BKG(SCX) ;hand off to taskman
252 ;input SCX=toggle between team/position reassignment
253 ;
254 S ZTPRI=10
255 S ZTRTN=$P($$S(SCX),"::")
256 S ZTDESC=$P($$S(SCX),"::",2)
257 S ZTDTH=$H
258 S ZTSAVE("SC*")=""
259 S ZTSAVE("^TMP($J,")=""
260 I '$G(SC("NOP")) D ^%ZTLOAD ; define NOP on GUI side if don't want BKG
261 S SCOK(0)=1_U_"BKG"_$G(ZTSK)
262 S SCOK(.1)=$$PASSCNT^SCMCBK5($$S(3))_U_"BKG"_U_$G(SC("NOP"))
263 Q
264 ;
265S(SCX) Q $P($T(T+SCX),";;",2)
266 ;
267T ;;
268 ;;BKGTM^SCMRBK::PCMM TEAM REASSIGN BKG
269 ;;BKGPOS^SCMRBK::PCMM POSITION REASSIGN BKG
270 ;;^TMP($J,"SC PATIENT LIST")
271 ;
Note: See TracBrowser for help on using the repository browser.