Changeset 623 for WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTM.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTM.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTM.m
r613 r623 1 SCRPTM ;ALB/CMM - List of Team's Members Report ; 29 Jun 99 04:11PM 2 ;;5.3;Scheduling;**41,48,52,181,177,520**;AUG 13, 1993;Build 26 3 ; 4 ;List of Team's Members Report 5 ; 6 PROMPTS ; 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 ; 20 QUE(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 ; 32 ENTRY2(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 56 RET S NUMBER=0 57 I $D(ZTSK) S NUMBER=ZTSK 58 D EXIT1 59 Q NUMBER 60 ; 61 QENTRY ; 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 ; 73 ERR ; 74 EXIT1 ; 75 K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,SCUP 76 Q 77 EXIT2 ; 78 K @STORE 79 K STOP,STORE,TITL,IOP,TEAM,INST,NODATA,RANGE,ROLE,USERC 80 Q 81 ; 82 BUILD ;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 ; 107 TALL ; 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 ; 119 PRINTIT(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 ; 154 PRNTD(INST,TEM,PRACT,POS,TITL,PAGE,HEAD) ; 155 ; 156 N CNT,SCAC 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 .S SCAC="" I CNT=4 D 164 ..F S SCAC=$O(@STORE@(INST,TEM,PRACT,POS,4,SCAC)) Q:SCAC=""!(STOP) D 165 ...W !,$G(@STORE@(INST,TEM,PRACT,POS,4,SCAC)) 166 Q 1 SCRPTM ;ALB/CMM - List of Team's Members Report ; 29 Jun 99 04:11PM 2 ;;5.3;Scheduling;**41,48,52,181,177**;AUG 13, 1993 3 ; 4 ;List of Team's Members Report 5 ; 6 PROMPTS ; 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 ; 20 QUE(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 ; 32 ENTRY2(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 56 RET S NUMBER=0 57 I $D(ZTSK) S NUMBER=ZTSK 58 D EXIT1 59 Q NUMBER 60 ; 61 QENTRY ; 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 ; 73 ERR ; 74 EXIT1 ; 75 K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,SCUP 76 Q 77 EXIT2 ; 78 K @STORE 79 K STOP,STORE,TITL,IOP,TEAM,INST,NODATA,RANGE,ROLE,USERC 80 Q 81 ; 82 BUILD ;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 ; 107 TALL ; 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 ; 119 PRINTIT(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 ; 154 PRNTD(INST,TEM,PRACT,POS,TITL,PAGE,HEAD) ; 155 ; 156 N CNT 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 TracChangeset
for help on using the changeset viewer.
