source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCMU2.m@ 861

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

revised back to 6/30/08 version
File size: 7.5 KB
RevLine 
[623]1SCMCMU2 ;ALB/MJK - PCMM Mass Team/Position Unassignment Processing ; 10-JUL-1998
2 ;;5.3;Scheduling;**148,177**;AUG 13, 1993
3 ;
4QUE() ; -- queue mass unassignment
5 ;D START Q 99999 ; -- for interactive testing
6 N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE,ZTSK
7 S ZTRTN="START^SCMCMU2"
8 S ZTDESC=VALM("TITLE")
9 S ZTDTH=$H
10 S ZTIO=""
11 F X="SCTEAM","SCPOS","SCTPDIS(","SCMUTYPE","SCDATE","SCSELCNT" S ZTSAVE(X)=""
12 F X="^TMP(""SCMU"",$J,""SELECTED"",","^TMP(""SCMU"",$J,""PATIENT INFO""," S ZTSAVE(X)=""
13 D ^%ZTLOAD
14 Q $G(ZTSK)
15 ;
16START ; -- entry point for task
17 ; -- defined from task SCTEAM,SCPOS,SCTPDIS,SCMUTYPE,SCDATE,SCSELCNT
18 ;
19 N SCTOP,SCUNCNT,SCASCNT,SCOK
20 S SCUNCNT=0
21 S SCASCNT=SCSELCNT
22 ;
23 ; -- lock top node
24 IF SCMUTYPE="T" D
25 . S SCTOP=$NA(^SCTM(404.51,+SCTEAM,0))
26 ELSE IF SCMUTYPE="P" D
27 . S SCTOP=$NA(^SCTM(404.57,+SCPOS,0))
28 D LOCK(SCTOP)
29 ;
30 ; -- use tmp data brought in by TaskMan
31 N SCPTSEL,SCPTINFO
32 S SCPTSEL=$NA(^TMP("SCMU",$J,"SELECTED"))
33 S SCPTINFO=$NA(^TMP("SCMU",$J,"PATIENT INFO"))
34 ;
35 N SCOKAR,SCBADAR,SCERRAR,SCPTTP
36 S SCOKAR=$NA(^TMP("SCMU",$J,"OK"))
37 S SCBADAR=$NA(^TMP("SCMU",$J,"BAD"))
38 S SCERRAR=$NA(^TMP("SCMU",$J,"ERROR"))
39 S SCPTTP=$NA(^TMP("SCMU",$J,"PATIENT-POSITION"))
40 K @SCOKAR,@SCBADAR,@SCERRAR,@SCPTTP
41 ;
42 N SCNT,SCNODE,SCPTX
43 ;
44 ; -- create patient-position array for team processing
45 IF SCMUTYPE="T" D PTTPLST^SCMCMU11(SCTEAM,SCDATE,SCPTTP)
46 ;
47 S SCNT=0
48 F S SCNT=$O(@SCPTSEL@(SCNT)) Q:'SCNT D
49 . ;N SCDATE S SCDATE=2700101 ; -- use to force error/testing
50 . S SCPTX=$G(@SCPTINFO@(SCNT))
51 . IF SCPTX="" Q
52 . IF SCMUTYPE="T" S SCOK=$$TMDIS(SCDATE,SCTEAM,SCNT,SCPTX)
53 . ;
54 . IF SCMUTYPE="P" S SCOK=$$TPDIS(SCDATE,SCPOS,SCNT,SCPTX)
55 . ;
56 . ; -- if successful
57 . IF SCOK D
58 . . S @SCOKAR@(SCNT)=""
59 . . S SCUNCNT=SCUNCNT+1
60 . . S SCASCNT=SCASCNT-1
61 . ;
62 . ; -- if not sucessful
63 . ELSE D
64 . . S @SCBADAR@(SCNT)=""
65 ;
66 ; -- unlock top node
67 D UNLOCK(SCTOP)
68 ;
69 ; -- send results
70 D BULL^SCMCMU4
71 ;
72 K @SCOKAR,@SCBADAR,@SCERRAR,@SCPTTP
73 K @SCPTSEL,@SCPTINFO
74 Q
75 ;
76 ; **** May want to eventually combine TMDIS & TPDIS tags ****
77 ;
78TMDIS(SCDATE,SCTEAM,SCNT,SCPTX) ; -- team unassignment for patient
79 ; input: SCDATE := effective date
80 ; SCTEAM := ien of TEAM entry (404.51)
81 ; SCNT := entry in @SCPTINFO@ & @SCPTALL@ arrays
82 ; SCPTX := format defined by output of $$PTTM^SCAPMC2
83 ;
84 N SCNODE,SCPOS,SCPOSI,SCOK,SCERRS,DFN,SCIEN,SCASDT,SCUNDT
85 ;
86 S SCOK=1
87 S SCERRS="SCERRLST"
88 ;
89 S DFN=+SCPTX
90 S SCIEN=+$P(SCPTX,U,3)
91 S SCNODE=$NA(^SCPT(404.42,SCIEN,0))
92 S SCASDT=+$P(SCPTX,U,4)
93 S SCUNDT=+$P(SCPTX,U,5)
94 ;
95 ; -- unassign from positions first
96 S SCPOS=0
97 F S SCPOS=$O(@SCPTTP@(DFN,SCPOS)) Q:'SCPOS D Q:'SCOK
98 . S SCOK=$$TPDIS(SCDATE,SCPOS,SCNT,$G(@SCPTTP@(DFN,SCPOS)))
99 ;
100 IF 'SCOK D
101 . S @SCERRAR@(SCNT,"TEAM",SCTEAM,1)="Team still assigned to patient."
102 . S @SCERRAR@(SCNT,"TEAM",SCTEAM,2)="Not able to unassign at least one position."
103 ;
104 IF SCOK D
105 . ; -- if assignment date is in future then delete
106 . IF SCASDT>DT,SCASDT>SCDATE D Q
107 . . N DA,DIK
108 . . S DA=SCIEN,DIK="^SCPT(404.42,"
109 . . D LOCK(SCNODE)
110 . . D ^DIK
111 . . D UNLOCK(SCNODE)
112 . . S @SCOKAR@(SCNT,"TEAM",SCTEAM,1)=">>> Future team assignment deleted."
113 . . S @SCOKAR@(SCNT,"TEAM",SCTEAM,2)=" Assignment Date: "_$$FMTE^XLFDT(SCASDT,"5Z")_" Entry#: "_SCIEN
114 . . Q
115 . ;
116 . ; -- if assignment date is after effective date but before today
117 . IF SCASDT>SCDATE,SCASDT<DT D Q
118 . . S SCOK=0
119 . . S @SCERRAR@(SCNT,"TEAM",SCTEAM,1)="Patient is still assigned to team."
120 . . S @SCERRAR@(SCNT,"TEAM",SCTEAM,2)="Assignment date is after effective date but before today."
121 . . S @SCERRAR@(SCNT,"TEAM",SCTEAM,3)="Assignment Date: "_$$FMTE^XLFDT(SCASDT,"5Z")_" Entry#: "_SCIEN
122 . . Q
123 . ;
124 . ; -- if unassignment date is after effective date but before today
125 . IF SCUNDT>SCDATE,SCUNDT<DT D Q
126 . . S SCOK=0
127 . . S @SCERRAR@(SCNT,"TEAM",SCTEAM,1)="Patient is still assigned to team."
128 . . S @SCERRAR@(SCNT,"TEAM",SCTEAM,2)="Unassignment date is after effective date but before today."
129 . . S @SCERRAR@(SCNT,"TEAM",SCTEAM,3)="Unassignment Date: "_$$FMTE^XLFDT(SCUNDT,"5Z")_" Entry#: "_SCIEN
130 . . Q
131 . ;
132 . ; -- make change
133 . K @SCERRS
134 . S SCOK=$$INPTTM^SCAPMC(DFN,SCIEN,SCDATE,.SCERRS)
135 . D UNLOCK(SCNODE)
136 . M @SCERRAR@(SCNT,"TEAM",SCTEAM)=SCERRLST
137 . K @SCERRS
138 . IF SCOK D
139 . . S @SCOKAR@(SCNT,"TEAM",SCTEAM,1)=""
140 . ;
141 . ; -- set message if unassigned date changed
142 . IF SCOK,SCUNDT>SCDATE D
143 . . S @SCOKAR@(SCNT,"TEAM",SCTEAM,1)=">>> Future team unassignment date was changed."
144 . . S @SCOKAR@(SCNT,"TEAM",SCTEAM,2)=" Old Date: "_$$FMTE^XLFDT(SCUNDT,"5Z")_" New Date: "_$$FMTE^XLFDT(SCDATE,"5Z")_" Entry#: "_SCIEN_")"
145 ;
146 Q SCOK
147 ;
148TPDIS(SCDATE,SCPOS,SCNT,SCPTX) ; -- position unassignment for patient
149 ; input: SCDATE := effective date
150 ; SCTEAM := ien of TEAM POSITION entry (404.57)
151 ; SCNT := entry in @SCPTINFO@ & @SCPTALL@ arrays
152 ; SCPTX := format defined by output of $$PTTP^SCAPMC2
153 ;
154 N SCNODE,SCOK,SCERRS,DFN,SCIEN,SCASDT,SCUNDT
155 S SCASDT=+$P(SCPTX,U,4)
156 S SCUNDT=+$P(SCPTX,U,5)
157 ;
158 S SCOK=1
159 S SCERRS="SCERRLST"
160 ;
161 S DFN=+SCPTX
162 S SCIEN=+$P(SCPTX,U,3)
163 S SCNODE=$NA(^SCPT(404.43,SCIEN,0))
164 S SCASDT=+$P(SCPTX,U,4)
165 S SCUNDT=+$P(SCPTX,U,5)
166 ;
167 ; if assignment date is in future then delete
168 IF SCOK D
169 . ; -- if assignment date is in future then delete
170 . IF SCASDT>DT,SCASDT>SCDATE D Q
171 . . N DA,DIK
172 . . S DA=SCIEN,DIK="^SCPT(404.43,"
173 . . D LOCK(SCNODE)
174 . . D ^DIK
175 . . D UNLOCK(SCNODE)
176 . . S @SCOKAR@(SCNT,"POS",SCPOS,1)=" >>> Future position assignment deleted."
177 . . S @SCOKAR@(SCNT,"POS",SCPOS,2)=" Assignment Date: "_$$FMTE^XLFDT(SCASDT,"5Z")_" Entry#: "_SCIEN
178 . . Q
179 . ;
180 . ; -- if assignment date is after effective date but before today
181 . IF SCASDT>SCDATE,SCASDT<DT D Q
182 . . S SCOK=0
183 . . S @SCERRAR@(SCNT,"POS",SCPOS,1)="Patient is still assigned to position."
184 . . S @SCERRAR@(SCNT,"POS",SCPOS,2)="Assignment date is after effective date but before today."
185 . . S @SCERRAR@(SCNT,"POS",SCPOS,3)="Assignment Date: "_$$FMTE^XLFDT(SCASDT,"5Z")_" Entry#: "_SCIEN
186 . . Q
187 . ;
188 . ; -- if unassignment date is after effective date but before today
189 . IF SCUNDT>SCDATE,SCUNDT<DT D Q
190 . . S SCOK=0
191 . . S @SCERRAR@(SCNT,"POS",SCPOS,1)="Patient is still assigned to position."
192 . . S @SCERRAR@(SCNT,"POS",SCPOS,2)="Unassignment date is after effective date but before today."
193 . . S @SCERRAR@(SCNT,"POS",SCPOS,3)="Unassignment Date: "_$$FMTE^XLFDT(SCUNDT,"5Z")_" ("_SCIEN_")"
194 . . Q
195 . ;
196 . K @SCERRS
197 . D LOCK(SCNODE)
198 . S SCOK=$$INPTTP^SCAPMC(DFN,SCIEN,SCDATE,.SCERRS)
199 . D UNLOCK(SCNODE)
200 . M @SCERRAR@(SCNT,"POS",SCPOS)=SCERRLST
201 . K @SCERRS
202 . IF SCOK D
203 . . S @SCOKAR@(SCNT,"POS",SCPOS,1)=""
204 . ;
205 . ; -- set message if unassigned date changed
206 . IF SCOK,SCUNDT>SCDATE D
207 . . S @SCOKAR@(SCNT,"POS",SCPOS,1)=" >>> Future position unassignment date was changed."
208 . . S @SCOKAR@(SCNT,"POS",SCPOS,2)=" Old Date: "_$$FMTE^XLFDT(SCUNDT,"5Z")_" New Date: "_$$FMTE^XLFDT(SCDATE,"5Z")_" Entry#: "_SCIEN_")"
209 . . Q
210 ;
211 IF SCOK D
212 . S @SCOKAR@(SCNT,"CLINIC",SCPOS,1)=$$CLDIS(SCPOS)
213 . Q
214 ;
215TPDISQ Q SCOK
216 ;
217CLDIS(SCPOS) ; -- discharge from clinic
218 N SCPOS0,SCCLN,SCREA,SCRET
219 S SCRET=""
220 ;
221 ; -- if user did not request clinic discharge, quit
222 IF '$G(SCTPDIS(+SCPOS)) G CLDISQ
223 ;
224 S SCPOS0=$G(^SCTM(404.57,SCPOS,0))
225 S SCCLN=$P(SCPOS0,U,9)
226 IF SCCLN D
227 . S SCREA="Team position mass discharge"
228 . S SCRET=$$EN^SCMCMU3(DFN,SCCLN,SCDATE,SCREA)
229 . Q
230 ELSE D
231 . S SCRET="0^No clinic assignment to position"
232 . Q
233 ;
234CLDISQ Q SCRET
235 ;
236LOCK(NODE) ; -- lock node
237 F L +@NODE:5 IF $T Q
238 Q
239 ;
240UNLOCK(NODE) ; -- unlock node
241 L -@NODE
242 Q
243 ;
Note: See TracBrowser for help on using the repository browser.