Changeset 623 for WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPU1.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPU1.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPU1.m
r613 r623 1 SCRPU1 2 ;;5.3;Scheduling;**41,45,130,520**;AUG 13, 1993;Build 26 3 4 INST 5 6 7 8 9 PRMTT 10 11 12 13 14 15 CLINIC 16 17 18 19 20 21 22 23 24 USER 25 26 27 28 29 30 31 USRCL() 32 33 34 35 36 37 38 39 40 41 42 43 44 45 ROLE 46 47 48 49 50 51 RL() 52 53 54 55 56 57 58 59 60 61 62 63 PRACT 64 65 66 67 68 69 PRACS() 70 71 72 73 74 75 76 77 78 79 80 81 82 FIRST 83 84 85 REDO 86 87 88 89 90 91 92 93 94 95 96 SET 97 98 99 100 101 ERR 102 QUIT 103 104 105 106 107 CLSC() 108 109 110 111 F S EN=$O(^SCTM(404.57,"E",+Y,EN)) Q:EN=""!(TRUE) D112 113 114 115 116 117 CLSC2() 118 119 120 121 CLSC2OLD() 122 123 124 125 126 127 128 129 130 131 1 SCRPU1 ;ALB/CMM - GENERIC PROMPTS FOR PCMM REPORTS ;1/12/96 2 ;;5.3;Scheduling;**41,45,130**;AUG 13, 1993 3 ; 4 INST ;Prompt for institution 5 S VAUTVB="VAUTD",DIC="^DIC(4,",DIC("S")="I $D(^SCTM(404.51,""AINST"",+Y))" 6 S VAUTNI=2,VAUTSTR="Division" 7 G FIRST^VAUTOMA 8 ; 9 PRMTT ;Prompt for team. Set VAUTTN to allow not assigned to a team as a selection 10 I '$D(VAUTD) G ERR 11 S VAUTVB="VAUTT",DIC="^SCTM(404.51,",VAUTNI=2,VAUTSTR="Team",DIC("B")="" 12 S DIC("S")="I VAUTD=1!($D(VAUTD(+$P(^(0),U,7))))" 13 G FIRST 14 ; 15 CLINIC ;Prompt for Clinic 16 I '$D(VAUTT)&'$D(VAUTCA) G ERR 17 S VAUTVB="VAUTC",VAUTSTR="Clinic",VAUTNI=2,DIC="^SC(" 18 ;Set screen to only allow clinics and clinics that are associated to the teams selected 19 I '$D(VAUTCA) S DIC("S")="I $$CLSC^SCRPU1()" 20 ;VAUTCA allows for selection of any clinic in the selected 21 I $D(VAUTCA) S DIC("S")="I $$CLSC2^SCRPU1()" 22 G FIRST 23 ; 24 USER ;Prompt for User Class 25 I '$D(VAUTT) G ERR 26 I $P($G(^SD(404.91,1,"PCMM")),"^")'=1 Q ;user class turned off 27 S VAUTVB="VAUTUC",DIC="^USR(8930,",VAUTSTR="User Class",VAUTNI=2 28 S DIC("S")="I $$USRCL^SCRPU1" 29 G FIRST 30 ; 31 USRCL() ;Screen for user class - must be related to teams selected 32 N STOP,ENT,NODE,TIEN 33 I '+$P(^(0),U,3) Q 0 34 ;check for active/exiting user class 35 S ENT=0,STOP=0 36 F S ENT=$O(^SCTM(404.57,"AUSR",+Y,ENT)) Q:ENT=""!(STOP) D 37 .S NODE=$G(^SCTM(404.57,ENT,0)) 38 .I NODE="" S STOP=0 Q 39 .S TIEN=+$P(NODE,"^",2) ;team ien 40 .I $D(VAUTT(TIEN))!(VAUTT=1) S STOP=1 Q 41 .I VAUTT=""&(TIEN="") S STOP=1 Q ;no team selected, no team assigned 42 .I VAUTT'=1&('$D(VAUTT(TIEN))) S STOP=0 43 Q STOP 44 ; 45 ROLE ;Prompt for Role 46 I '$D(VAUTT) G ERR 47 S VAUTVB="VAUTR",DIC="^SD(403.46,",VAUTSTR="Role",VAUTNI=2 48 S DIC("S")="I $$RL^SCRPU1()" 49 G FIRST 50 ; 51 RL() ;Screen for Role - screen on team 52 N EN,STOP,ACT,TEAM 53 S EN="",STOP=0 54 I $D(^SCTM(404.57,"AC",+Y)) D 55 .F S EN=$O(^SCTM(404.57,"AC",+Y,EN)) Q:EN=""!(STOP) D 56 ..S ACT=+$$ACTTP^SCMCTPU(EN) ;currently active? 57 ..I 'ACT!('$D(^SCTM(404.57,EN,0))) Q 58 ..S TEAM=$P(^SCTM(404.57,EN,0),"^",2) 59 ..I $D(VAUTT(TEAM))!(VAUTT=1) S STOP=1 60 ..I VAUTT=""&(TEAM="") S STOP=1 61 Q STOP 62 ; 63 PRACT ; Prompt for One (set VAUTPO) or One,Many,All,None Practitioner(s) 64 I '$D(VAUTT) G ERR 65 S VAUTVB="VAUTP",VAUTSTR="Practitioner",VAUTNI=2,DIC="^VA(200," 66 S DIC("S")="I $$PRACS^SCRPU1()" 67 G FIRST 68 ; 69 PRACS() ;Practitioner screen - off of team selection 70 N EN,STOP,NODE,TEAM 71 S EN="",STOP=0 72 I '$D(^SCTM(404.52,"C",+Y)) Q 0 73 ;Position Assignment History file 74 F S EN=$O(^SCTM(404.52,"C",+Y,EN)) Q:EN=""!(STOP) D 75 .I '$D(^SCTM(404.52,EN)) Q 76 .S NODE=$G(^SCTM(404.52,EN,0)) 77 .S TEAM=+$P($G(^SCTM(404.57,$P(NODE,"^"),0)),"^",2) 78 .I $P(NODE,"^",4),$D(VAUTT(TEAM)) S STOP=1 79 .I VAUTT=1 S STOP=1 80 Q STOP 81 ; 82 FIRST ; 83 S DIC(0)="EQMNZ",DIC("A")="Select "_VAUTSTR_": " K @VAUTVB 84 S (@VAUTVB,Y)=0 85 REDO W !,DIC("A") R X:DTIME G ERR:(X="^")!'$T D:X["?"!(X=""&('$G(SCOKNULL))) HELP^SCRPU3 86 G:$G(SCOKNULL)&(X="") QUIT 87 I X="A"!(X="ALL")&'$D(VAUTNA) S @VAUTVB=1 G QUIT 88 ;VAUTNA doesn't allow all to be selected 89 ;VAUTTN allows 'Not assigned to a team' as a selection 90 I X="N"!(X="NOT")!(X="NONE") I $D(VAUTTN)!($D(VAUTPP)) S @VAUTVB="" G QUIT 91 ;VAUTPP allows 'Not assigned to a practitioner' as a selection 92 S DIC("A")="Select another "_VAUTSTR_": " D ^DIC G:Y'>0 FIRST D SET 93 I '$D(VAUTPO) F VAI=1:0:19 W !,DIC("A") R X:DTIME G ERR:(X="")!(X="^")!'$T K Y D HELP^SCRPU3:X["?" S:$E(X)="-" VAUTX=X,X=$E(VAUTX,2,999) D ^DIC I Y>0 D SET G:VAX REDO S:'VAERR VAI=VAI+1 94 ;VAUTPO - only one practitioner allowed to be selected 95 G QUIT 96 SET S VAX=0 I $D(VAUTX) S J=$S(VAUTNI=2:+Y,1:$P(Y(0),"^")) K VAUTX S VAERR=$S($D(@VAUTVB@(J)):0,1:1) W $S('VAERR:"...removed from list...",1:"...not on list...can't remove") Q:VAERR S VAI=VAI-1 K @VAUTVB@(J) S:$O(@VAUTVB@(0))']"" VAX=1 Q 97 S VAERR=0 I $S($D(@VAUTVB@($P(Y(0),U))):1,$D(@VAUTVB@(+Y)):1,1:0) W !?3,*7,"You have already selected that ",VAUTSTR,". Try again." S VAERR=1 98 S @VAUTVB@(+Y)=$P(Y(0),U) 99 Q 100 ; 101 ERR S Y=-1 I $O(@VAUTVB@(0))="" K @VAUTVB I X="^" S SCUP="" 102 QUIT S:'$D(Y) Y=1 103 I $D(@VAUTVB),VAUTSTR="Team",@VAUTVB=1 D:'$G(DGQUIET) EN^DDIOL("All Teams selected, this report may take some time...","","!,?10") 104 K DIC,J,VAERR,VAI,VAJ,VAJ1,VAX,VAUTNI,VAUTSTR,VAUTVB,X 105 Q 106 ; 107 CLSC() ;screen on clinic selection, must be related to team prompt 108 I $P(^(0),U,3)'="C" Q 0 109 N TRUE,EN,TEAM 110 S TRUE=0,EN="" 111 F S EN=$O(^SCTM(404.57,"D",+Y,EN)) Q:EN=""!(TRUE) D 112 .S TEAM=+$P($G(^SCTM(404.57,EN,0)),"^",2) 113 .I $D(VAUTT(TEAM))!(VAUTT=1) S TRUE=1 114 I VAUTT="" S TRUE=1 115 Q TRUE 116 ; 117 CLSC2() ;screen on clinic selection, must be a clinic 118 I $P(^(0),U,3)'="C" Q 0 119 Q 1 120 ; 121 CLSC2OLD() ;screen on clinic selection, must be related to division prompt 122 I $P(^(0),U,3)'="C" Q 0 123 N TRUE,EN,INST,TDIV 124 S TRUE=0,EN="" 125 S TDIV=+$P(^(0),U,15) ;clinic's division 126 Q:TDIV=0 0 127 S INST=+$P(^DG(40.8,TDIV,0),U,7) 128 I '$D(VAUTD(INST))&(VAUTD'="") S TRUE=0 129 I $D(VAUTD(INST)) S TRUE=1 130 I VAUTD=1 S TRUE=1 131 Q TRUE
Note:
See TracChangeset
for help on using the changeset viewer.
