source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCMCMU4.m@ 1800

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

initial load of FOIAVistA 6/30/08 version
File size: 5.1 KB
Line 
1SCMCMU4 ;ALB/MJK - PCMM Mass Team/Position Unassignment Bulletin ; 10-JUL-1998
2 ;;5.3;Scheduling;**148**;AUG 13, 1993
3 ;
4BULL ; -- send bulletin
5 N SCLCNT,XMY,XMTEXT,XMSUB,XMDUZ,SCINFO
6 D INIT
7 D TEXT
8 D ^XMD
9 D FINAL
10 Q
11 ;
12INIT ; -- set vars for bulletin
13 N SCCLN
14 S XMDUZ=.5
15 S XMY($S($G(DUZ):DUZ,1:XMDUZ))=""
16 S XMSUB="Mass Team"_$S(SCMUTYPE="P":"Position",1:"")_" Unassignment Information"
17 K ^TMP("SCMUTEXT",$J) S XMTEXT="^TMP(""SCMUTEXT"",$J,",SCLCNT=0
18 ;
19 S SCINFO("NAME","TEAM")=$P($G(^SCTM(404.51,+$G(SCTEAM),0),"Unknown"),U)
20 ;
21 IF SCMUTYPE="P" D
22 . S SCPOS0=$G(^SCTM(404.57,+$G(SCPOS),0),"Unknown")
23 . S SCINFO("NAME","POSITION")=$P(SCPOS0,U)
24 . S SCCLN=+$P(SCPOS0,U,9)
25 . IF SCCLN S SCINFO("NAME","CLINIC")=$P($G(^SC(SCCLN,0),""),U)
26 . Q
27 ;
28 S SCINFO("NAME","USER")=$P($G(^VA(200,XMDUZ,0),"Unknown"),U)
29 S SCINFO("DATE","EFFECTIVE")=$$FMTE^XLFDT($E(SCDATE,1,7),"5Z")
30 ;
31 Q
32 ;
33FINAL ; -- clean up
34 K ^TMP("SCMUTEXT",$J)
35 Q
36 ;
37TEXT ; -- set of mm array
38 D SET("Mass Team"_$S(SCMUTYPE="P":"-Position",1:"")_" Unassignment has been completed.")
39 D SET("")
40 D SET(" Team: "_SCINFO("NAME","TEAM"))
41 ;
42 IF SCMUTYPE="P" D
43 . D SET(" Position: "_SCINFO("NAME","POSITION"))
44 . IF $G(SCINFO("NAME","CLINIC"))]"" D SET(" Clinic: "_SCINFO("NAME","CLINIC"))
45 . Q
46 ;
47 D SET(" User: "_SCINFO("NAME","USER"))
48 D SET(" Effective Date: "_SCINFO("DATE","EFFECTIVE"))
49 ;
50 D SET("")
51 D SET(" Patients Processed")
52 D SET(" Unassigned : "_SCUNCNT)
53 D SET(" Errors/Warnings: "_SCASCNT_" (still assigned)")
54 D SET(" Total : "_SCSELCNT)
55 ;
56 D CLINIC
57 D SET("")
58 ;
59 ; -- list pats that remain assigned
60 D ERRARY
61 ;
62 D SET("")
63 D SET("")
64 ;
65 ; -- list pats unassigned
66 D OKARY
67 Q
68 ;
69SET(X) ;
70 S SCLCNT=SCLCNT+1,^TMP("SCMUTEXT",$J,SCLCNT,0)=X
71 Q
72 ;
73ERRARY ; -- process error array
74 N SCNT,SCX,SCER,SCERI
75 ;
76 D SET(" Error List:")
77 D SET(" ===========")
78 ;
79 IF '$O(@SCBADAR@(0)) D Q
80 . D SET(" No errors to report.")
81 . Q
82 ;
83 D HDR
84 ;
85 S SCNT=0
86 F S SCNT=$O(@SCBADAR@(SCNT)) Q:'SCNT D
87 . S SCX=@SCBADAR@(SCNT)
88 . D PT(SCNT)
89 . ;
90 . IF '$D(@SCERRAR@(SCNT)) Q
91 . S SCERI=0
92 . F S SCERI=$O(@SCERRAR@(SCNT,"TEAM",SCTEAM,SCERI)) Q:'SCERI D
93 . . S SCER=$G(@SCERRAR@(SCNT,"TEAM",SCTEAM,SCERI))
94 . . D SET(" >>> "_SCER)
95 . . Q
96 . ;
97 . IF '$O(@SCERRAR@(SCNT,"POS",0)) Q
98 . S SCPOS=0
99 . F S SCPOS=$O(@SCERRAR@(SCNT,"POS",SCPOS)) Q:'SCPOS D
100 . . IF SCMUTYPE="T" D SET(" >>> Position: "_$P($G(^SCTM(404.57,SCPOS,0),"Unknown"),U))
101 . . S SCERI=0
102 . . F S SCERI=$O(@SCERRAR@(SCNT,"POS",SCPOS,SCERI)) Q:'SCERI D
103 . . . S SCER=$G(@SCERRAR@(SCNT,"POS",SCPOS,SCERI))
104 . . . D SET(" >>>> "_SCER)
105 . . . Q
106 . . Q
107 . D SET("")
108 . Q
109 Q
110 ;
111OKARY ; -- process ok array
112 N SCNT,SCPT,SCX
113 D SET(" Unassigned List:")
114 D SET(" ================")
115 ;
116 IF '$O(@SCOKAR@(0)) D Q
117 . D SET(" No patients unassigned.")
118 . Q
119 ;
120 D HDR
121 ;
122 S SCNT=0
123 F S SCNT=$O(@SCOKAR@(SCNT)) Q:'SCNT D
124 . D PT(SCNT)
125 . D TM(SCNT)
126 . D POS(SCNT)
127 . Q
128 Q
129 ;
130HDR ; -- send patient info header
131 S X=""
132 S X=$$SETSTR^VALM1("Patient",X,2,7)
133 S X=$$SETSTR^VALM1("ID",X,40,2)
134 D SET(X)
135 ;
136 S X=""
137 S X=$$SETSTR^VALM1("-------",X,2,7)
138 S X=$$SETSTR^VALM1("--",X,40,2)
139 D SET(X)
140 Q
141 ;
142PT(SCNT) ; -- send patient info
143 N NAME,ID,X,SCPT,SCX
144 S SCPT=$G(@SCPTINFO@(SCNT))
145 S NAME=$P(SCPT,U,2)
146 S ID=$P(SCPT,U,6)
147 S X=""
148 S X=$$SETSTR^VALM1(NAME,X,2,30)
149 S X=$$SETSTR^VALM1(ID,X,40,15)
150 D SET(X)
151 Q
152 ;
153TM(SCNT) ; -- show any team info for patient
154 N SCTMMSG
155 S SCTMMSG=$G(@SCOKAR@(SCNT,"TEAM",SCTEAM,1))
156 D INFO("TEAM",SCTEAM)
157 Q
158 ;
159POS(SCNT) ; -- send position (for team unassignment) & clinic discharge info
160 N SCPOS,SCTPMSG,SCCLNM,SCPOS0,SCLNX,SCI
161 S SCPOS=0
162 F S SCPOS=$O(@SCOKAR@(SCNT,"POS",SCPOS)) Q:'SCPOS D
163 . S SCTPMSG=$G(@SCOKAR@(SCNT,"POS",SCPOS,1))
164 . S SCLNX=$G(@SCOKAR@(SCNT,"CLINIC",SCPOS,1))
165 . S SCPOS0=$G(^SCTM(404.57,SCPOS,0))
166 . ;
167 . IF SCMUTYPE="T" D
168 . . D SET(" >>> Position assignment to "_$P(SCPOS0,U)_$S(SCTPMSG="":" was unassigned.",1:":"))
169 . D INFO("POS",SCPOS)
170 . ;
171 . IF SCLNX]"",$D(SCTPDIS(SCPOS)) D
172 . . S SCCLNM=$P($G(^SC(+$P(SCPOS0,U,9),0),"Unkown"),U)
173 . . IF +SCLNX=1 D SET(" >>> Discharged from '"_SCCLNM_"' clinic")
174 . . IF +SCLNX=2 D
175 . . . D SET(" Still enrolled in '"_SCCLNM_"' clinic")
176 . . . D SET(" Reason: "_$P(SCLNX,U,2))
177 . . Q
178 . Q
179 Q
180 ;
181CLINIC ; -- display clinic to be discharged from
182 N SCPOS,SCX,Y
183 D SET(" ")
184 IF '$O(SCTPDIS(0)) D G CLINICQ
185 . D SET(" Clinic Discharges: None")
186 . Q
187 ;
188 S Y=""
189 S Y=$$SETSTR^VALM1("Clinic Discharges:",Y,2,20)
190 S Y=$$SETSTR^VALM1("Position",Y,25,25)
191 S Y=$$SETSTR^VALM1("Associated Clinic",Y,55,25)
192 D SET(Y)
193 S Y=""
194 S Y=$$SETSTR^VALM1("--------",Y,25,25)
195 S Y=$$SETSTR^VALM1("-----------------",Y,55,25)
196 D SET(Y)
197 ;
198 S SCPOS=0
199 F S SCPOS=$O(SCTPDIS(SCPOS)) Q:'SCPOS D
200 . S SCX=$G(^SCTM(404.57,SCPOS,0),"Unknown")
201 . S Y=""
202 . S Y=$$SETSTR^VALM1($E($P(SCX,U),1,25),Y,25,25)
203 . S Y=$$SETSTR^VALM1($E($P($G(^SC(+$P(SCX,U,9),0),"Unknown"),U),1,25),Y,55,25)
204 . D SET(Y)
205 . Q
206 ;
207CLINICQ Q
208 ;
209INFO(TYPE,SCIEN) ; -- load ok info text
210 N SCI
211 S SCI=0
212 F S SCI=$O(@SCOKAR@(SCNT,TYPE,SCIEN,SCI)) Q:'SCI D
213 . S X=$G(@SCOKAR@(SCNT,TYPE,SCIEN,SCI))
214 . IF X]"" D SET(" "_X)
215 . Q
216 Q
217 ;
Note: See TracBrowser for help on using the repository browser.