source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPTM.m@ 636

Last change on this file since 636 was 636, checked in by George Lilly, 14 years ago

WorldVistAEHR overlayed on FOIAVistA
File size: 5.3 KB
RevLine 
[628]1SCRPTM ;ALB/CMM - List of Team's Members Report ; 29 Jun 99 04:11PM
[636]2 ;;5.3;Scheduling;**41,48,52,181,177**;AUG 13, 1993
[628]3 ;
4 ;List of Team's Members Report
5 ;
6PROMPTS ;
7 ;Prompt for Institution, Team, Date Range, User Class, Role
8 ;and Print device
9 ;
10 N VAUTD,VAUTT,VAUTUC,VAUTR,QTIME,RANG,PRNT,NUMBER
11 K VAUTD,VAUTT,VAUTUC,VAUTR,SCUP
12 S QTIME=""
13 W ! D INST^SCRPU1 I Y=-1 G ERR
14 W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR
15 W ! K Y S RANG=$$DTRANG^SCRPU2() I +RANG=-1 G ERR
16 W ! K Y D USER^SCRPU1 I '$D(VAUTUC)&($P($G(^SD(404.91,1,"PCMM")),"^")=1) G ERR
17 W ! K Y D ROLE^SCRPU1 I '$D(VAUTR) G ERR
18 D QUE(.VAUTD,.VAUTT,.VAUTUC,.VAUTR,RANG) Q
19 ;
20QUE(INST,TEAM,USERC,ROLE,RANGE) ;queue report
21 ;Input Parameters:
22 ;INST - institutions selected (variable and array)
23 ;TEAM - teams selected (variable and array)
24 ;USERC - user classes selected (variable and array)
25 ;ROLE - roles selected (variable and array)
26 ;RANGE - date range selected (begin date ^ end date)
27 N ZTSAVE,II
28 F II="INST","TEAM","USERC","ROLE","INST(","TEAM(","USERC(","ROLE(","RANGE" S ZTSAVE(II)=""
29 W ! D EN^XUTMDEVQ("QENTRY^SCRPTM","Team Member Listing",.ZTSAVE)
30 Q
31 ;
32ENTRY2(INST,TEAM,USERC,ROLE,RANGE,IOP,ZTDTH) ;
33 ;Second entry point for GUI to use
34 ;Input Parameters:
35 ;INST - institutions selected (variable and array)
36 ;TEAM - teams selected (variable and array)
37 ;USERC - user classes selected (variable and array)
38 ;ROLE - roles selected (variable and array)
39 ;RANGE - date range selected (begin date ^ end date)
40 ;IOP - print device
41 ;ZTDTH - queue time (optional)
42 ;
43 ;validate parameters
44 I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$D(RANGE)!'$D(IOP)!(IOP="") Q
45 ;
46 N NUMBER
47 S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^")
48 I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2)
49 I IOST?1"C-".E D QENTRY G RET
50 I ZTDTH="" S ZTDTH=$H
51 S ZTRTN="QENTRY^SCRPTM"
52 S ZTDESC="List of Team's Members",ZTIO=IOP
53 N II
54 F II="INST","TEAM","USERC","ROLE","INST(","TEAM(","USERC(","ROLE(","RANGE","IOP" S ZTSAVE(II)=""
55 D ^%ZTLOAD
56RET S NUMBER=0
57 I $D(ZTSK) S NUMBER=ZTSK
58 D EXIT1
59 Q NUMBER
60 ;
61QENTRY ;
62 ;driver entry point
63 S TITL="Team Member Listing"
64 S STORE="^TMP("_$J_",""SCRPTM"")"
65 K @STORE
66 S @STORE=0
67 D BUILD
68 I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL)
69 I '$D(NODATA) D PRINTIT(STORE,TITL)
70 D EXIT2
71 Q
72 ;
73ERR ;
74EXIT1 ;
75 K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,SCUP
76 Q
77EXIT2 ;
78 K @STORE
79 K STOP,STORE,TITL,IOP,TEAM,INST,NODATA,RANGE,ROLE,USERC
80 Q
81 ;
82BUILD ;get report data
83 ;get all practitioners for all teams selected
84 I TEAM=1 D TALL ;all teams selected
85 N TIEN,OKAY,XLIST,YLIST,SCTP,SCI,SCDT,PLIST
86 S SCDT("BEGIN")=$P(RANGE,U),SCDT("END")=$P(RANGE,U,2)
87 S SCDT("INCL")=0,SCDT="SCDT"
88 S TIEN="",PLIST="^TMP(""SCRP"",$J,""LIST"")"
89 F S TIEN=$O(TEAM(TIEN)) Q:TIEN=""!(TIEN'?.N) D
90 .K XLIST,@PLIST
91 .S OKAY=$$TPTM^SCAPMC(TIEN,.SCDT,"","","XLIST","ERROR")
92 .S SCTP=0 F S SCTP=$O(XLIST("SCTP",TIEN,SCTP)) Q:'SCTP D
93 ..S SCTP0=$G(^SCTM(404.57,SCTP,0)) Q:'$L(SCTP0)
94 ..I ROLE'=1,'$D(ROLE(+$P(SCTP0,U,3))) Q ;not a selected role
95 ..I $D(USERC),USERC'=1,'$D(USERC(+$P(SCTP0,U,13))) Q ;not a selected user class
96 ..K YLIST
97 ..S OKAY=$$PRTP^SCAPMC(SCTP,.SCDT,"YLIST","ERROR",1,0)
98 ..S SCI=0 F S SCI=$O(YLIST(SCI)) Q:'SCI D
99 ...S @PLIST@(0)=$G(@PLIST@(0))+1
100 ...S @PLIST@(@PLIST@(0))=YLIST(SCI)
101 ...Q
102 ..Q
103 .I OKAY D PULL^SCRPTM2(TIEN,.PLIST)
104 .Q
105 Q
106 ;
107TALL ;
108 ;get all active team for divisions selected
109 N NXT,IIEN,NODE
110 S NXT=0,IIEN=""
111 ;$O through team file and find all active teams for selected divisions
112 F S IIEN=$O(^SCTM(404.51,"AINST",IIEN)) Q:IIEN="" D
113 .I INST=1!$D(INST(IIEN)) D
114 ..S TIEN=0
115 ..F S TIEN=$O(^SCTM(404.51,"AINST",IIEN,TIEN)) Q:TIEN="" D
116 ...I $$ACTTM^SCMCTMU(TIEN) S TEAM(TIEN)=""
117 Q
118 ;
119PRINTIT(STORE,TITL) ;
120 N INST,EINST,ETEAM,TEM,EPRACT,PRACT,PAGE,NXT,NPAGE,CNT,HEAD,POS
121 S EINST="",(NPAGE,STOP,HEAD)=0,PAGE=1 W:$E(IOST)="C" @IOF
122 D TITLE^SCRPU3(.PAGE,TITL)
123 F S EINST=$O(@STORE@("I",EINST)) Q:EINST=""!(STOP) D
124 .S INST=$O(@STORE@("I",EINST,""))
125 .Q:INST=""
126 .I 'NPAGE W !,$G(@STORE@(INST)) ;write institution line
127 .S (ETEAM,TEM)=""
128 .F S ETEAM=$O(@STORE@("T",INST,ETEAM)) Q:ETEAM=""!(STOP) D
129 ..S TEM=$O(@STORE@("T",INST,ETEAM,0))
130 ..I TEM="" Q
131 ..S NXT="H"
132 ..I NPAGE,(IOST'?1"C-".E) D NEWP^SCRPTM2(INST,TEM,TITL,.PAGE,.HEAD) S NPAGE=0
133 ..I NPAGE,(IOST?1"C-".E) D HOLD1^SCRPTM2(.PAGE,TITL,INST,TEM,.HEAD) S NPAGE=0
134 ..I STOP Q
135 ..I IOST'?1"C-".E,$Y>(IOSL-5) D NEWP^SCRPTM2(INST,TEM,TITL,.PAGE,.HEAD)
136 ..I IOST?1"C-".E,$Y>(IOSL-5) D HOLD1^SCRPTM2(.PAGE,TITL,INST,TEM,.HEAD)
137 ..I STOP Q
138 ..F S NXT=$O(@STORE@(INST,TEM,NXT)) Q:NXT'?1"H".E!(STOP) D
139 ...I 'HEAD W !,$G(@STORE@(INST,TEM,NXT)) S HEAD=0 ;writes team info
140 ..S (EPRACT,PRACT)=""
141 ..W ! ;extra line between members and practioner list
142 ..F S EPRACT=$O(@STORE@("PN",INST,TEM,EPRACT)) Q:EPRACT=""!(STOP) D
143 ...F S PRACT=$O(@STORE@("PN",INST,TEM,EPRACT,PRACT)) Q:PRACT=""!(STOP) D
144 ....I PRACT="" Q
145 ....S POS=""
146 ....F S POS=$O(@STORE@("PN",INST,TEM,EPRACT,PRACT,POS)) Q:POS=""!(STOP) D
147 .....D PRNTD(INST,TEM,PRACT,POS,TITL,.PAGE,.HEAD)
148 .....W ! ;seperated positions
149 ....W ! ;separates practitioners
150 .S NPAGE=1
151 I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR
152 Q
153 ;
154PRNTD(INST,TEM,PRACT,POS,TITL,PAGE,HEAD) ;
155 ;
[636]156 N CNT
[628]157 S CNT=""
158 I IOST'?1"C-".E,$Y>(IOSL-11) D NEWP^SCRPTM2(INST,TEM,TITL,.PAGE,.HEAD)
159 I IOST?1"C-".E,$Y>(IOSL-11) D HOLD1^SCRPTM2(.PAGE,TITL,INST,TEM,.HEAD)
160 I STOP Q
161 F S CNT=$O(@STORE@(INST,TEM,PRACT,POS,CNT)) Q:CNT=""!(STOP) D
162 .W !,$G(@STORE@(INST,TEM,PRACT,POS,CNT))
163 Q
Note: See TracBrowser for help on using the repository browser.