Changeset 623 for WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPITP.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPITP.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPITP.m
r613 r623 1 SCRPITP ;ALB/CMM - Individual Team Profile ; 29 Jun 99 04:11PM 2 ;;5.3;Scheduling;**41,52,177,520**;AUG 13, 1993;Build 26 3 ; 4 ;Individual Team Profile 5 ; 6 PROMPTS ; 7 ;Prompt for Institution, Team, and Print device 8 ; 9 N QTIME,PRNT,VAUTD,VAUTT,Y,NUMBER 10 K VAUTD,VAUTT,SCUP 11 S QTIME="" 12 W ! D INST^SCRPU1 I Y=-1 G ERR 13 W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR 14 W !!,"This report requires 132 column output!" 15 D QUE(.VAUTD,.VAUTT) Q 16 ; 17 QUE(INST,TEAM) ;queue report 18 ;Input Parameters: 19 ;INST - institutions selected (variable and array) 20 ;TEAM - teams selected (variable and array) 21 N ZTSAVE,II 22 F II="INST","TEAM","INST(","TEAM(" S ZTSAVE(II)="" 23 W ! D EN^XUTMDEVQ("QENTRY^SCRPITP","Individual Team Profile",.ZTSAVE) 24 Q 25 ; 26 ENTRY2(INST,TEAM,IOP,ZTDTH) ; 27 ;Second entry point for GUI to use 28 ;Input Parameters: 29 ;INST - institutions selected (variable and array) 30 ;TEAM - teams selected (variable and array) 31 ;IOP - print device 32 ;ZTDTH - queue time (optional) 33 ; 34 ;validate parameters 35 I '$D(INST)!'$D(TEAM)!'$D(IOP)!(IOP="") Q 36 ; 37 N NUMBER 38 S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^") 39 I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2) 40 I IOST?1"C-".E D QENTRY G RET 41 I ZTDTH="" S ZTDTH=$H 42 S ZTRTN="QENTRY^SCRPITP" 43 S ZTDESC="iIndividual Team Profile",ZTIO=IOP 44 N II 45 F II="INST","TEAM","INST(","TEAM(","IOP" S ZTSAVE(II)="" 46 D ^%ZTLOAD 47 RET S NUMBER=0 48 I $D(ZTSK) S NUMBER=ZTSK 49 D EXIT1 50 Q NUMBER 51 ; 52 QENTRY ; 53 ;driver entry point 54 S TITL="Individual Team Profile" 55 S STORE="^TMP("_$J_",""SCRPITP"")" 56 K @STORE 57 S @STORE=0 58 I TEAM=1 D TALL^SCRPPAT3 S TEAM=0 59 D FIND 60 I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL) 61 I '$D(NODATA) D PRINTIT(STORE,TITL) 62 D EXIT2 63 Q 64 ; 65 ERR ; 66 EXIT1 ; 67 K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE 68 Q 69 ; 70 EXIT2 ; 71 K @STORE 72 K STOP,STORE,TITL,IOP,TEAM,INST,NODATA 73 Q 74 ; 75 FIND ; 76 N TM,EN,NODE,TMP,TPNAME 77 S TM="" K ^TMP("SCRATCH",$J) 78 F S TM=$O(^SCTM(404.57,"C",TM)) Q:TM="" D 79 .;$O through team position file 80 .I '$D(TEAM(TM))&(TEAM'=1) Q 81 .;Q above, not a selected team 82 .;selected team 83 .S EN="" 84 .F S EN=$O(^SCTM(404.57,"C",TM,EN)) Q:EN="" D 85 ..I '$D(^SCTM(404.57,EN,0)) Q 86 ..S NODE=$G(^SCTM(404.57,EN,0)) 87 ..Q:NODE="" 88 ..;active or inactive position 89 ..S TMP=$$DATES^SCAPMCU1(404.59,EN,DT) 90 ..S TPNAME=$P(NODE,U) S:'$L(TPNAME) TPNAME="~~~" 91 ..S ^TMP("SCRATCH",$J,TPNAME,EN)=NODE 92 ..I +TMP S ^TMP("SCRATCH",$J,TM,TPNAME,EN)=NODE 93 ..Q 94 .Q 95 S TM="" 96 F S TM=$O(^TMP("SCRATCH",$J,TM)) Q:TM="" S TPNAME="" D 97 .F S TPNAME=$O(^TMP("SCRATCH",$J,TM,TPNAME)) Q:TPNAME="" S EN="" D 98 ..F S EN=$O(^TMP("SCRATCH",$J,TM,TPNAME,EN)) Q:EN="" D 99 ...S NODE=^TMP("SCRATCH",$J,TM,TPNAME,EN) 100 ...D KEEP^SCRPITP2(NODE,EN,TM) 101 ...Q 102 ..Q 103 .Q 104 Q 105 ; 106 PRINTIT(STORE,TITL) ; 107 N INST,EINST,ETEAM,TEM,NEW,PAGE,TNAME,TIEN,EN,SUB,POS,CIEN,INF,ACL 108 S (INST,EINST)="",STOP=0,(PAGE,NEW)=1 W:$E(IOST)="C" @IOF 109 D FORHEAD^SCRPITP2 110 F S EINST=$O(@STORE@("I",EINST)) Q:EINST=""!(STOP) D 111 .S INST=$O(@STORE@("I",EINST,"")) 112 .I INST="" Q 113 .I STOP Q 114 .;write team info 115 .S TNAME="" 116 .F S TNAME=$O(@STORE@("T",INST,TNAME)) Q:TNAME=""!(STOP) D 117 ..D:NEW TITLE^SCRPU3(.PAGE,TITL,132) 118 ..I 'NEW,$E(IOST)'="C" D NEWP1^SCRPU3(.PAGE,TITL,132) 119 ..I 'NEW,$E(IOST)="C" D HOLD^SCRPU3(.PAGE,TITL,132) 120 ..W !,$G(@STORE@(INST)),! S NEW="" 121 ..S TIEN=$O(@STORE@("T",INST,TNAME,"")) 122 ..I TIEN="" Q 123 ..F SUB="TI","D" D 124 ...Q:STOP 125 ...I '$D(@STORE@(INST,TIEN,SUB)) Q 126 ...S EN="" 127 ...F S EN=$O(@STORE@(INST,TIEN,SUB,EN)) Q:EN=""!(STOP) D 128 ....I IOST'?1"C-".E,$Y>(IOSL-5) D NEWP1^SCRPU3(.PAGE,TITL,132) 129 ....I IOST?1"C-".E,$Y>(IOSL-5) D HOLD^SCRPU3(.PAGE,TITL,132) 130 ....I STOP Q 131 ....I '$D(NEW) W !,$G(@STORE@(INST)),!,$G(@STORE@(INST,TIEN)),! 132 ....W !,$G(@STORE@(INST,TIEN,SUB,EN)) 133 ...W ! 134 ..;write position info 135 ..S POS="" 136 ..I $Y<IOSL-10 D COLUMN^SCRPITP2 137 ..F S POS=$O(@STORE@(INST,TIEN,"P",POS)) Q:POS=""!(STOP) D 138 ...W !,$G(@STORE@(INST,TIEN,"P",POS)) 139 ...S ACL="" 140 ...F S ACL=$O(@STORE@(INST,TIEN,"P",POS,ACL)) Q:ACL=""!(STOP) D 141 ....W !,$G(@STORE@(INST,TIEN,"P",POS,ACL)) 142 ....I IOST'?1"C-".E,$Y>(IOSL-5) D NEWP1^SCRPU3(.PAGE,TITL,132) Q:STOP D CONT^SCRPITP2 143 ....I IOST?1"C-".E,$Y>(IOSL-5) D HOLD^SCRPU3(.PAGE,TITL,132) Q:STOP D CONT^SCRPITP2 144 ....I STOP Q 145 ...;W !,$G(@STORE@(INST,TIEN,"P",POS)) 146 ...;W !,$G(@STORE@(INST,TIEN,"P",POS,ACL)) 147 ...W ! 148 I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR 149 Q 1 SCRPITP ;ALB/CMM - Individual Team Profile ; 29 Jun 99 04:11PM 2 ;;5.3;Scheduling;**41,52,177**;AUG 13, 1993 3 ; 4 ;Individual Team Profile 5 ; 6 PROMPTS ; 7 ;Prompt for Institution, Team, and Print device 8 ; 9 N QTIME,PRNT,VAUTD,VAUTT,Y,NUMBER 10 K VAUTD,VAUTT,SCUP 11 S QTIME="" 12 W ! D INST^SCRPU1 I Y=-1 G ERR 13 W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR 14 W !!,"This report requires 132 column output!" 15 D QUE(.VAUTD,.VAUTT) Q 16 ; 17 QUE(INST,TEAM) ;queue report 18 ;Input Parameters: 19 ;INST - institutions selected (variable and array) 20 ;TEAM - teams selected (variable and array) 21 N ZTSAVE,II 22 F II="INST","TEAM","INST(","TEAM(" S ZTSAVE(II)="" 23 W ! D EN^XUTMDEVQ("QENTRY^SCRPITP","Individual Team Profile",.ZTSAVE) 24 Q 25 ; 26 ENTRY2(INST,TEAM,IOP,ZTDTH) ; 27 ;Second entry point for GUI to use 28 ;Input Parameters: 29 ;INST - institutions selected (variable and array) 30 ;TEAM - teams selected (variable and array) 31 ;IOP - print device 32 ;ZTDTH - queue time (optional) 33 ; 34 ;validate parameters 35 I '$D(INST)!'$D(TEAM)!'$D(IOP)!(IOP="") Q 36 ; 37 N NUMBER 38 S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^") 39 I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2) 40 I IOST?1"C-".E D QENTRY G RET 41 I ZTDTH="" S ZTDTH=$H 42 S ZTRTN="QENTRY^SCRPITP" 43 S ZTDESC="iIndividual Team Profile",ZTIO=IOP 44 N II 45 F II="INST","TEAM","INST(","TEAM(","IOP" S ZTSAVE(II)="" 46 D ^%ZTLOAD 47 RET S NUMBER=0 48 I $D(ZTSK) S NUMBER=ZTSK 49 D EXIT1 50 Q NUMBER 51 ; 52 QENTRY ; 53 ;driver entry point 54 S TITL="Individual Team Profile" 55 S STORE="^TMP("_$J_",""SCRPITP"")" 56 K @STORE 57 S @STORE=0 58 I TEAM=1 D TALL^SCRPPAT3 S TEAM=0 59 D FIND 60 I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL) 61 I '$D(NODATA) D PRINTIT(STORE,TITL) 62 D EXIT2 63 Q 64 ; 65 ERR ; 66 EXIT1 ; 67 K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE 68 Q 69 ; 70 EXIT2 ; 71 K @STORE 72 K STOP,STORE,TITL,IOP,TEAM,INST,NODATA 73 Q 74 ; 75 FIND ; 76 N TM,EN,NODE,TMP,TPNAME 77 S TM="" K ^TMP("SCRATCH",$J) 78 F S TM=$O(^SCTM(404.57,"C",TM)) Q:TM="" D 79 .;$O through team position file 80 .I '$D(TEAM(TM))&(TEAM'=1) Q 81 .;Q above, not a selected team 82 .;selected team 83 .S EN="" 84 .F S EN=$O(^SCTM(404.57,"C",TM,EN)) Q:EN="" D 85 ..I '$D(^SCTM(404.57,EN,0)) Q 86 ..S NODE=$G(^SCTM(404.57,EN,0)) 87 ..Q:NODE="" 88 ..;active or inactive position 89 ..S TMP=$$DATES^SCAPMCU1(404.59,EN,DT) 90 ..S TPNAME=$P(NODE,U) S:'$L(TPNAME) TPNAME="~~~" 91 ..S ^TMP("SCRATCH",$J,TPNAME,EN)=NODE 92 ..I +TMP S ^TMP("SCRATCH",$J,TM,TPNAME,EN)=NODE 93 ..Q 94 .Q 95 S TM="" 96 F S TM=$O(^TMP("SCRATCH",$J,TM)) Q:TM="" S TPNAME="" D 97 .F S TPNAME=$O(^TMP("SCRATCH",$J,TM,TPNAME)) Q:TPNAME="" S EN="" D 98 ..F S EN=$O(^TMP("SCRATCH",$J,TM,TPNAME,EN)) Q:EN="" D 99 ...S NODE=^TMP("SCRATCH",$J,TM,TPNAME,EN) 100 ...D KEEP^SCRPITP2(NODE,EN,TM) 101 ...Q 102 ..Q 103 .Q 104 Q 105 ; 106 PRINTIT(STORE,TITL) ; 107 N INST,EINST,ETEAM,TEM,NEW,PAGE,TNAME,TIEN,EN,SUB,POS,CIEN,INF 108 S (INST,EINST)="",STOP=0,(PAGE,NEW)=1 W:$E(IOST)="C" @IOF 109 D FORHEAD^SCRPITP2 110 F S EINST=$O(@STORE@("I",EINST)) Q:EINST=""!(STOP) D 111 .S INST=$O(@STORE@("I",EINST,"")) 112 .I INST="" Q 113 .I STOP Q 114 .;write team info 115 .S TNAME="" 116 .F S TNAME=$O(@STORE@("T",INST,TNAME)) Q:TNAME=""!(STOP) D 117 ..D:NEW TITLE^SCRPU3(.PAGE,TITL,132) 118 ..I 'NEW,$E(IOST)'="C" D NEWP1^SCRPU3(.PAGE,TITL,132) 119 ..I 'NEW,$E(IOST)="C" D HOLD^SCRPU3(.PAGE,TITL,132) 120 ..W !,$G(@STORE@(INST)),! S NEW="" 121 ..S TIEN=$O(@STORE@("T",INST,TNAME,"")) 122 ..I TIEN="" Q 123 ..F SUB="TI","D" D 124 ...Q:STOP 125 ...I '$D(@STORE@(INST,TIEN,SUB)) Q 126 ...S EN="" 127 ...F S EN=$O(@STORE@(INST,TIEN,SUB,EN)) Q:EN=""!(STOP) D 128 ....I IOST'?1"C-".E,$Y>(IOSL-5) D NEWP1^SCRPU3(.PAGE,TITL,132) 129 ....I IOST?1"C-".E,$Y>(IOSL-5) D HOLD^SCRPU3(.PAGE,TITL,132) 130 ....I STOP Q 131 ....I '$D(NEW) W !,$G(@STORE@(INST)),!,$G(@STORE@(INST,TIEN)),! 132 ....W !,$G(@STORE@(INST,TIEN,SUB,EN)) 133 ...W ! 134 ..;write position info 135 ..S POS="" 136 ..I $Y<IOSL-10 D COLUMN^SCRPITP2 137 ..F S POS=$O(@STORE@(INST,TIEN,"P",POS)) Q:POS=""!(STOP) D 138 ...I IOST'?1"C-".E,$Y>(IOSL-5) D NEWP1^SCRPU3(.PAGE,TITL,132) Q:STOP D CONT^SCRPITP2 139 ...I IOST?1"C-".E,$Y>(IOSL-5) D HOLD^SCRPU3(.PAGE,TITL,132) Q:STOP D CONT^SCRPITP2 140 ...I STOP Q 141 ...W !,$G(@STORE@(INST,TIEN,"P",POS)) 142 ..W ! 143 I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR 144 Q
Note:
See TracChangeset
for help on using the changeset viewer.
