source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCCV4.m@ 949

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

initial load of FOIAVistA 6/30/08 version
File size: 9.1 KB
Line 
1SCMCCV4 ; bp-ciofo/vad - PCMM PC Attending Assignments Report ; 05 May 99 9:05 AM
2 ;;5.3;Scheduling;**195**;AUG 13, 1993
3 ;
4 ; List those assignments that are for PC Attending. This is to easily
5 ; inform the user of these assignments since they are no longer valid
6 ; as a result of the enhancements from the PCMM Phase II (177) release.
7 ;
8 ; This report is sent to the user as a Mailman Message.
9 ;
10 ; This routine is part of a Pre-Release Patch to 177. The Pre-Release
11 ; Patch number is 195.
12 ; -------------------------------------------------------------------
13 ;
14 Q
15 ;
16 ;
17 ; -------------------------------------------------------------------
18MAIN ; Main module to drive this routine
19 ; -------------------------------------------------------------------
20 K SCY
21 S SCY(1)=""
22 S SCY(2)="PCMM PC Attending Assignments Report"
23 S SCY(3)=$$DTU^SCMCCV3()
24 S SCY(4)="------------------------------------"
25 S SCY(5)=$$QIT
26 K ZTSK
27 S SCY(6)=""
28 D EN^DDIOL(.SCY)
29 Q
30 ;
31 ; -------------------------------------------------------------------
32QIT() ; Module to QUEUE and Run this job in the Background.
33 ; -------------------------------------------------------------------
34 N SCX,ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE
35 S ZTRTN="MAINQ^SCMCCV4"
36 S ZTDESC="PCMM PC Attending Assignments Report"
37 S ZTDTH=$H
38 S ZTIO=""
39 S SCMCSTOP=$$ASKTEAM()
40 F SCX="SCMCSTOP","SCMCTM","SCMCTM(","SCTMNAM","SCTMNAM(" S ZTSAVE(SCX)=""
41 D ^%ZTLOAD
42 Q "==> "_$S(+ZTSK:" Queued - Task # "_ZTSK,1:" Not Queued!")
43 ;
44 ; -------------------------------------------------------------------
45MAINQ ; Main module to drive this routine
46 ; -------------------------------------------------------------------
47 S STORE="^TMP(""SCMCCV4"",$J)"
48 S REPORT="^TMP(""SCMC-RPT"",$J)"
49 K @STORE,@REPORT
50 I SCMCSTOP D EXIT Q
51 ;
52 D RUNIT
53 ;
54 Q
55 ;
56 ; -------------------------------------------------------------------
57RUNIT ; Module to gather the data and print the report.
58 ; -------------------------------------------------------------------
59 D SCPTLP ; Process thru the ^SCPT(404.43) global.
60 D PRINT ; Store the Report in a Temp array.
61 I 'SCGOTONE D ; No data to print.
62 . F I=1:1:3 S STRING=" " X SCLNUP
63 . S STRING=$E(SCBLK,1,5)_"Zero Team Position Assignments were found based upon selection criteria."
64 . X SCLNUP
65 ;
66 D MAILIT ; Queue the report as a Mailman Message.
67 D EXIT
68 Q
69 ;
70 ; -------------------------------------------------------------------
71ASKTEAM() ; Prompt for "A"ll or "S"elected Teams.
72 ; -------------------------------------------------------------------
73 ; Sets up the SCMCTM and SCTMNAM arrays.
74 ; Returns a "1" to STOP, or a "0" to CONTINUE.
75 ;
76 N STOP
77 K SCMCTM,SCTMNAM
78 S (STOP,SCMCTM,SCTMNAM)=0
79 S SCMCTYPE=$$TYPE() ; Gets the type of selections (all or selected)
80 I SCMCTYPE=0 S STOP=1 Q STOP
81 ;
82 I SCMCTYPE="A" Q STOP
83 ;
84 I SCMCTYPE="S" D TMLP S:'+SCMCTM STOP=1
85 Q STOP
86 ;
87 ; -------------------------------------------------------------------
88TYPE() ; Ask the user to enter "A"ll or "S"elected teams.
89 ; -------------------------------------------------------------------
90 ; "A" means All Teams.
91 ; "S" means Select Teams.
92 ; Returns a "0" to quit or a "1" to continue.
93 ;
94 N DIR
95 S DIR(0)="SM^A:All Teams;S:Specific Teams"
96 S DIR("?",1)="Select A for a report of All Teams"
97 S DIR("?",2)="Select S for a report of Specific Teams"
98 S DIR("?",3)=" "
99 ;
100 D ^DIR
101 Q $S($D(DIRUT):0,1:Y)
102 ;
103 ; -------------------------------------------------------------------
104TMLP ; Allow the user to select multiple teams.
105 ; -------------------------------------------------------------------
106 ; Sets up the SCMCTM and SCTMNAM arrays with the teams.
107 ; Sets SCSTOP=1 to stop selection.
108 ;
109 N SCSTOP,SCCTR,SCTMREC
110 S (SCSTOP,SCCTR)=0
111 F D I SCSTOP Q
112 . N TM
113 . S TM=$$TEAM^SCMCMU(DT)
114 . I (TM>0),'$D(SCMCTM(TM)) D
115 . . S SCMCTM(TM)="",SCCTR=SCCTR+1
116 . . S SCTMREC=$G(^SCTM(404.51,TM,0))
117 . . S SCTMNAM($P(SCTMREC,U,1))=TM
118 . E S SCSTOP=1
119 . Q
120 S (SCMCTM,SCTMNAM)=SCCTR
121 Q
122 ;
123 ; -------------------------------------------------------------------
124SCPTLP ; Process the ^SCPT(404.43) global to gather reportable data.
125 ; -------------------------------------------------------------------
126 N SCTNAME,SCMCVAR,SCZZPROV,SCMCERR,SCG,SCG2
127 S (DFN,SCACTDT,SCTMPOS,SCTNAME,SCSEQ1,SCSTATUS)=""
128 F S SCTNAME=$O(SCTMNAM(SCTNAME)) Q:SCTNAME="" D
129 . S @STORE@("B",SCTNAME)=0
130 ;
131 S SCG="^SCPT(404.43,""APCPOS"")"
132 F S DFN=$O(@SCG@(DFN)) Q:DFN="" D
133 . I '$D(@SCG@(DFN,2)) Q ; Attending only
134 . N VA,VADM,VAERR
135 . D DEM^VADPT
136 . S SCPTNM=$G(VADM(1),"Invalid Name:"_DFN) ;patient name
137 . S SCPTSSN=$G(VA("PID"),"Invalid PID:"_DFN) ;patient SSN
138 . ;
139 . S SCG2="^SCPT(404.43,""APCPOS"","_DFN_",2)"
140 . F S SCACTDT=$O(@SCG2@(SCACTDT)) Q:SCACTDT="" D
141 . . F S SCTMPOS=$O(@SCG2@(SCACTDT,SCTMPOS)) Q:SCTMPOS="" D
142 . . . F S SCSEQ1=$O(@SCG2@(SCACTDT,SCTMPOS,SCSEQ1)) Q:SCSEQ1="" D
143 . . . . S SCREC1=$G(^SCPT(404.43,SCSEQ1,0))
144 . . . . I +$P(SCREC1,U,4),$P(SCREC1,U,4)<DT Q ;no old discharges
145 . . . . S Y=$P(SCREC1,U,3)
146 . . . . S SCASNDT=$$FMTE^DILIBF(Y,"6U") ;mm-dd-yyyy
147 . . . . ;
148 . . . . S SCREC2=$G(^SCTM(404.57,SCTMPOS,0))
149 . . . . S SCPOSNM=$P(SCREC2,U,1)
150 . . . . S SCTMNO=$P(SCREC2,U,2)
151 . . . . Q:(+SCTMNO<1)!('$D(^SCTM(404.51,SCTMNO,0)))
152 . . . . ;
153 . . . . I +SCMCTM,'$D(SCMCTM(SCTMNO)) Q ;not a selected Team
154 . . . . ;
155 . . . . S SCREC3=$G(^SCTM(404.51,SCTMNO,0))
156 . . . . S SCTMNM=$P(SCREC3,U,1)
157 . . . . ;
158 . . . . N SCMCVAR,SCDATES,SCZZPROV,SCMCERR
159 . . . . S SCMCVAR=$$PRTP^SCAPMC8(SCTMPOS,"SCDATES","SCZZPROV","SCMCERR")
160 . . . . I 'SCMCVAR Q
161 . . . . I '$D(SCZZPROV(1)) Q
162 . . . . ; There should be only one provider for this day
163 . . . . S SCPHYPOS=$P(SCZZPROV(1),U,4)_" ("_$P(SCZZPROV(1),U,2)_")"
164 . . . . ; Store a data record.
165 . . . . N SCCNT
166 . . . . S SCCNT=+$G(@STORE@(SCTMNO,0))+1
167 . . . . S @STORE@("B",SCTMNM)=SCTMNO
168 . . . . S @STORE@(SCTMNO,0)=SCCNT
169 . . . . S @STORE@(SCTMNO,1,SCPHYPOS,2,SCPTNM,DFN,SCACTDT,SCCNT)=""
170 . . . . S @STORE@(SCTMNO,SCCNT)=SCTMNM_U_SCPHYPOS_U_SCPTNM_U_SCPTSSN_U_SCASNDT
171 . . . . Q
172 . . . Q
173 . . Q
174 . Q
175 Q
176 ;
177 ; -------------------------------------------------------------------
178PRINT ; Store the report in temp array prior to a Mailman Message.
179 ; -------------------------------------------------------------------
180 S (SCTMNM,SCPHYPOS,SCPTNM,SCPTSSN,SCASNDT)=""
181 S (SCGOTONE,SCSTOP,SCLNSEQ)=0
182 S SCLNUP="S SCLNSEQ=SCLNSEQ+1,@REPORT@(SCLNSEQ)=STRING"
183 S SCRPDT=$$FMTE^XLFDT($$NOW^XLFDT())
184 S SCBLK=" ",$P(SCBLK," ",80)=" "
185 S SCDSH="-",$P(SCDSH,"-",80)="-"
186 S SCDBL="=",$P(SCDBL,"=",80)="="
187 ;
188 S STRING=$E(SCBLK,1,15)_"PCMM PC Attending Assignments Report - "_SCRPDT
189 X SCLNUP
190 S STRING=$E(SCBLK,1,$S(+SCMCTM:26,1:23))_"Selection Criteria: "_$S(+SCMCTM:"SELECTED",1:"ALL")_" TEAMS"
191 X SCLNUP
192 ;
193 F S SCTMNM=$O(@STORE@("B",SCTMNM)) Q:SCTMNM="" D
194 . D PRTTMHDR
195 . S SCTMNO=@STORE@("B",SCTMNM)
196 . I SCTMNO=0 D Q
197 . . S STRING=$E(SCBLK,1,5)_"Zero Team Position Assignments were found within this team."
198 . . X SCLNUP
199 . ;
200 . S SCPHYPOS=""
201 . F S SCPHYPOS=$O(@STORE@(SCTMNO,1,SCPHYPOS)) Q:SCPHYPOS="" D
202 . . D PRTPHHDR
203 . . S SCPTNM=""
204 . . F S SCPTNM=$O(@STORE@(SCTMNO,1,SCPHYPOS,2,SCPTNM)) Q:SCPTNM="" D
205 . . . S DFN=0
206 . . . F S DFN=$O(@STORE@(SCTMNO,1,SCPHYPOS,2,SCPTNM,DFN)) Q:'DFN D
207 . . . . S SCACTDT=0
208 . . . . F S SCACTDT=$O(@STORE@(SCTMNO,1,SCPHYPOS,2,SCPTNM,DFN,SCACTDT)) Q:'SCACTDT D
209 . . . . . S SCCNT=$O(^(SCACTDT,0))
210 . . . . . S SCX=@STORE@(SCTMNO,SCCNT)
211 . . . . . ; Print a Detail Line.
212 . . . . . S STRING=$$LJ("",10)_$$LJ(SCPTNM,29)_$$LJ($P(SCX,U,4),18)_$P(SCX,U,5)
213 . . . . . X SCLNUP
214 . . . . . ;
215 . . . . . S SCGOTONE=1
216 . . . . . Q
217 . . . . Q
218 . . . Q
219 . . Q
220 . Q
221 Q
222 ;
223LJ(STRING,LENGTH) Q $$LJ^XLFSTR(STRING,LENGTH)
224 ;
225 ; -------------------------------------------------------------------
226PRTTMHDR ; Print the Team Sub-heading.
227 ; -------------------------------------------------------------------
228 N STRING
229 ;
230 S STRING=" " F I=1:1:2 X SCLNUP
231 S STRING=$E(SCDBL,1,11+$L(SCTMNM)) X SCLNUP
232 S STRING="TEAM NAME: "_SCTMNM X SCLNUP
233 S STRING=$E(SCDBL,1,11+$L(SCTMNM)) X SCLNUP
234 S STRING=" " X SCLNUP
235 S STRING=$E(SCBLK,1,5)_"Positions" X SCLNUP
236 S STRING=$E(SCBLK,1,5)_$E(SCDSH,1,9) X SCLNUP
237 Q
238 ;
239 ; -------------------------------------------------------------------
240PRTPHHDR ; Print the Physician Sub-heading.
241 ; -------------------------------------------------------------------
242 N STRING
243 ;
244 S STRING=" " X SCLNUP
245 S STRING=$E(SCBLK,1,5)_SCPHYPOS X SCLNUP
246 S STRING=$E(SCBLK,1,5)_$E(SCDSH,1,$L(SCPHYPOS)) X SCLNUP
247 ;
248 ;
249 S STRING=" " X SCLNUP
250 S STRING=$E(SCBLK,1,10)_"Patient Name"_$E(SCBLK,1,17)_"SSN"_$E(SCBLK,1,12)_"Date Assigned"
251 X SCLNUP
252 S STRING=$E(SCBLK,1,10)_$E(SCDSH,1,12)_$E(SCBLK,1,17)_"---"_$E(SCBLK,1,12)_$E(SCDSH,1,13)
253 X SCLNUP
254 Q
255 ;
256 ; -------------------------------------------------------------------
257MAILIT ; Queue the report as a MailMan Message.
258 ; -------------------------------------------------------------------
259 N XMY,XMDUZ,XMSUB,XMTEXT
260 S XMDUZ=.5
261 S (XMY(DUZ),XMY(XMDUZ))=""
262 S XMSUB="PCMM PC Attending Assignments Report"
263 S XMTEXT="^TMP(""SCMC-RPT"",$J,"
264 D ^XMD
265 Q
266 ;
267 ; -------------------------------------------------------------------
268EXIT ; Clean up and Exit
269 ; -------------------------------------------------------------------
270 K @STORE,@REPORT
271 D KILL^XUSCLEAN
272 Q
Note: See TracBrowser for help on using the repository browser.