Changeset 623 for WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTA.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTA.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTA.m
r613 r623 1 SCRPTA 2 ;;5.3;Scheduling;**41,48,52,114,174,181,177,526**;AUG 13, 1993;Build 8 3 4 5 6 PROMPTS 7 8 9 10 11 12 13 14 15 16 17 18 19 QUE(INST,TEAM,ROLE,PRACT) 20 21 22 23 24 25 26 27 28 29 30 ENTRY2(INST,TEAM,ROLE,PRACT,IOP,ZTDTH) 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 RET 54 55 56 57 58 QENTRY 59 60 61 62 63 64 65 66 67 68 69 70 71 ERR 72 EXIT1 73 74 75 76 EXIT2 77 78 79 80 81 FIND 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 PRINTIT(STORE,TITL) 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 PRNT(INT,TM,PR,POS) 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 HEADER 142 143 144 145 146 147 148 SHEAD 149 150 151 S $E(@STORE@("H2"),19)="Pt ID"152 153 154 155 156 157 158 159 160 1 SCRPTA ;ALB/CMM - Patient Listing w/Team Assignment Data ; 29 Jun 99 04:11PM 2 ;;5.3;Scheduling;**41,48,52,114,174,181,177**;AUG 13, 1993 3 ; 4 ;Patient Listing w/Team Assignment Data Report 5 ; 6 PROMPTS ; 7 ;Prompt for Institution, Team, Role, Practitioner and Print device 8 ; 9 N PRNT,QTIME,NUMBER 10 K VAUTD,VAUTT,VAUTR,VAUTP,VAUTPP,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 ! K Y D ROLE^SCRPU1 I '$D(VAUTR) G ERR 15 W ! K Y S VAUTPP="" D PRACT^SCRPU1 K VAUTPP I '$D(VAUTP) G ERR 16 W !!,"This report requires 132 column output!" 17 D QUE(.VAUTD,.VAUTT,.VAUTR,.VAUTP) Q 18 ; 19 QUE(INST,TEAM,ROLE,PRACT) ; 20 ;Input Parameters: 21 ;INST - institutions selected (variable and array) 22 ;TEAM - teams selected (variable and array) 23 ;ROLE - roles selected (variable and array) 24 ;PRACT - practitioners selected (variable and array) 25 N ZTSAVE,II 26 F II="INST","TEAM","ROLE","INST(","TEAM(","PRACT","PRACT(","ROLE(" S ZTSAVE(II)="" 27 W ! D EN^XUTMDEVQ("QENTRY^SCRPTA","Patient Listing for Team Assignments",.ZTSAVE) 28 Q 29 ; 30 ENTRY2(INST,TEAM,ROLE,PRACT,IOP,ZTDTH) ; 31 ;Second entry point for GUI to use 32 ;Input Parameters: 33 ;INST - institutions selected (variable and array) 34 ;TEAM - teams selected (variable and array) 35 ;ROLE - roles selected (variable and array) 36 ;PRACT - practitioners selected (variable and array) 37 ;IOP - print device 38 ;ZTDTH - queue time (optional) 39 ; 40 ;validate parameters 41 I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$D(PRACT)!'$D(IOP)!(IOP="") Q 42 ; 43 N NUMBER 44 S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^") 45 I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2) 46 I IOST?1"C-".E D QENTRY G RET 47 I ZTDTH="" S ZTDTH=$H 48 S ZTRTN="QENTRY^SCRPTA" 49 S ZTDESC="Patient Listing w/Team Assignment",ZTIO=IOP 50 N II 51 F II="INST","TEAM","ROLE","INST(","TEAM(","PRACT","PRACT(","ROLE(","IOP" S ZTSAVE(II)="" 52 D ^%ZTLOAD 53 RET S NUMBER=0 54 I $D(ZTSK) S NUMBER=ZTSK 55 D EXIT1 56 Q NUMBER 57 ; 58 QENTRY ; 59 ;driver entry point 60 S TITL="Patient Listing For Team Assignments" 61 S STORE="^TMP("_$J_",""SCRPTA"")" 62 K @STORE 63 S @STORE=0 64 I TEAM=1 D TALL^SCRPPAT3 S TEAM=0 65 D FIND 66 I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL) 67 I '$D(NODATA) D PRINTIT(STORE,TITL) 68 D EXIT2 69 Q 70 ; 71 ERR ; 72 EXIT1 ; 73 K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,Y,SCUP 74 Q 75 ; 76 EXIT2 ; 77 K @STORE 78 K STOP,STORE,TITL,IOP,TEAM,INST,ROLE,NODATA,PRACT 79 Q 80 ; 81 FIND ; 82 N NXT,TLIST,TERR,CNT,ERR1,TNODE,NODE1,PIEN,PTAIEN 83 S NXT=0,TLIST="^TMP("_$J_",""SCRPTA"",""LIST1"")",TERR="ERR1" 84 K @TLIST,@TERR 85 F S NXT=$O(TEAM(NXT)) Q:NXT=""!(NXT'?.N) D 86 .S ERR1=$$PTTM^SCAPMC2(NXT,,.TLIST,.TERR) ;Patients assigned to team NXT 87 .Q:ERR1=0 88 .S CNT=0 89 .F S CNT=$O(@TLIST@(CNT)) Q:CNT=""!(CNT'?.N) D 90 ..S TNODE=$G(@TLIST@(CNT)) 91 ..Q:TNODE="" 92 ..S PIEN=+$P(TNODE,"^") ;patient ien 93 ..S PTAIEN=+$P(TNODE,"^",3) ;ien Patient Team Assignment #404.42 94 ..D CHK^SCRPTA2(PTAIEN,PIEN) 95 .K @TLIST,@TERR 96 K @TLIST,@TERR 97 Q 98 ; 99 PRINTIT(STORE,TITL) ; 100 N NXT,PAGE,NPAGE,INTN,TMN,INT,TM,PRN,PR,POS 101 S (NPAGE,STOP,PAGE)=0,INTN="" W:$E(IOST)="C" @IOF 102 D SHEAD ;setup headers 103 F S INTN=$O(@STORE@("I",INTN)) Q:INTN=""!(STOP) D 104 .S INT=$O(@STORE@("I",INTN,"")) ;institution 105 .Q:INT="" 106 .S TMN="" 107 .F S TMN=$O(@STORE@("T",INT,TMN)) Q:TMN=""!(STOP) D 108 ..S TM=$O(@STORE@("T",INT,TMN,"")) ;team 109 ..Q:TM="" 110 ..D NEWP1^SCRPU3(.PAGE,TITL,132) W !,$G(@STORE@(INT)),!!,$G(@STORE@(INT,TM)) 111 ..Q:STOP 112 ..S PRN="" 113 ..D HEADER 114 ..F S PRN=$O(@STORE@("P",INT,TM,PRN)) Q:PRN=""!(STOP) D 115 ...S PR=$O(@STORE@("P",INT,TM,PRN,"")) ;practitioner 116 ...Q:PR="" 117 ...S POS="" 118 ...F S POS=$O(@STORE@("P",INT,TM,PRN,PR,POS)) Q:POS=""!(STOP) D 119 ....D PRNT(INT,TM,PR,POS) 120 I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR 121 Q 122 ; 123 PRNT(INT,TM,PR,POS) ; 124 ;INT - institution ien 125 ;TM - team ien 126 ;PR - practitioner ien 127 ;POS - position ien 128 ; 129 N PTIEN,PTNAME 130 S PTNAME="" 131 F S PTNAME=$O(@STORE@(INT,TM,PR,POS,PTNAME)) Q:PTNAME=""!(STOP) D 132 .S PTIEN="" 133 .F S PTIEN=$O(@STORE@(INT,TM,PR,POS,PTNAME,PTIEN)) Q:PTIEN=""!(STOP) D 134 ..I (IOST'?1"C-".E),$Y>(IOSL-4) D NEWP1^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INT)),!!,$G(@STORE@(INT,TM)) D:'STOP HEADER 135 ..I (IOST?1"C-".E),$Y>(IOSL-4) D HOLD^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INT)),!!,$G(@STORE@(INT,TM)) D:'STOP HEADER 136 ..Q:STOP 137 ..W !,$G(@STORE@(INT,TM,PR,POS,PTNAME,PTIEN)) 138 .Q 139 Q 140 ; 141 HEADER ; 142 ;write column headers 143 N EN 144 W ! 145 F EN="H1","H2","H3" D 146 .W !,$G(@STORE@(EN)) 147 Q 148 SHEAD ; 149 ;setup column headers 150 S @STORE@("H2")="Patient Name" 151 S $E(@STORE@("H2"),24)="Pt ID" 152 S $E(@STORE@("H1"),31)="Date" 153 S $E(@STORE@("H2"),31)="Assigned" 154 S $E(@STORE@("H2"),43)="PC?" 155 S $E(@STORE@("H2"),49)="Practitioner" 156 S $E(@STORE@("H2"),70)="Position" 157 S $E(@STORE@("H2"),92)="Standard Role" 158 S $E(@STORE@("H2"),113)="Preceptor" 159 S $P(@STORE@("H3"),"=",133)="" 160 Q
Note:
See TracChangeset
for help on using the changeset viewer.
