source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPU1.m@ 719

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

WorldVistAEHR overlayed on FOIAVistA

File size: 4.8 KB
Line 
1SCRPU1 ;ALB/CMM - GENERIC PROMPTS FOR PCMM REPORTS ;1/12/96
2 ;;5.3;Scheduling;**41,45,130**;AUG 13, 1993
3 ;
4INST ;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 ;
9PRMTT ;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 ;
15CLINIC ;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 ;
24USER ;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 ;
31USRCL() ;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 ;
45ROLE ;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 ;
51RL() ;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 ;
63PRACT ; 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 ;
69PRACS() ;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 ;
82FIRST ;
83 S DIC(0)="EQMNZ",DIC("A")="Select "_VAUTSTR_": " K @VAUTVB
84 S (@VAUTVB,Y)=0
85REDO 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
96SET 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 ;
101ERR S Y=-1 I $O(@VAUTVB@(0))="" K @VAUTVB I X="^" S SCUP=""
102QUIT 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 ;
107CLSC() ;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 ;
117CLSC2() ;screen on clinic selection, must be a clinic
118 I $P(^(0),U,3)'="C" Q 0
119 Q 1
120 ;
121CLSC2OLD() ;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 TracBrowser for help on using the repository browser.