SCRPU1 ;ALB/CMM - GENERIC PROMPTS FOR PCMM REPORTS ;1/12/96
;;5.3;Scheduling;**41,45,130,520**;AUG 13, 1993;Build 26
;
INST ;Prompt for institution
S VAUTVB="VAUTD",DIC="^DIC(4,",DIC("S")="I $D(^SCTM(404.51,""AINST"",+Y))"
S VAUTNI=2,VAUTSTR="Division"
G FIRST^VAUTOMA
;
PRMTT ;Prompt for team. Set VAUTTN to allow not assigned to a team as a selection
I '$D(VAUTD) G ERR
S VAUTVB="VAUTT",DIC="^SCTM(404.51,",VAUTNI=2,VAUTSTR="Team",DIC("B")=""
S DIC("S")="I VAUTD=1!($D(VAUTD(+$P(^(0),U,7))))"
G FIRST
;
CLINIC ;Prompt for Clinic
I '$D(VAUTT)&'$D(VAUTCA) G ERR
S VAUTVB="VAUTC",VAUTSTR="Clinic",VAUTNI=2,DIC="^SC("
;Set screen to only allow clinics and clinics that are associated to the teams selected
I '$D(VAUTCA) S DIC("S")="I $$CLSC^SCRPU1()"
;VAUTCA allows for selection of any clinic in the selected
I $D(VAUTCA) S DIC("S")="I $$CLSC2^SCRPU1()"
G FIRST
;
USER ;Prompt for User Class
I '$D(VAUTT) G ERR
I $P($G(^SD(404.91,1,"PCMM")),"^")'=1 Q ;user class turned off
S VAUTVB="VAUTUC",DIC="^USR(8930,",VAUTSTR="User Class",VAUTNI=2
S DIC("S")="I $$USRCL^SCRPU1"
G FIRST
;
USRCL() ;Screen for user class - must be related to teams selected
N STOP,ENT,NODE,TIEN
I '+$P(^(0),U,3) Q 0
;check for active/exiting user class
S ENT=0,STOP=0
F S ENT=$O(^SCTM(404.57,"AUSR",+Y,ENT)) Q:ENT=""!(STOP) D
.S NODE=$G(^SCTM(404.57,ENT,0))
.I NODE="" S STOP=0 Q
.S TIEN=+$P(NODE,"^",2) ;team ien
.I $D(VAUTT(TIEN))!(VAUTT=1) S STOP=1 Q
.I VAUTT=""&(TIEN="") S STOP=1 Q ;no team selected, no team assigned
.I VAUTT'=1&('$D(VAUTT(TIEN))) S STOP=0
Q STOP
;
ROLE ;Prompt for Role
I '$D(VAUTT) G ERR
S VAUTVB="VAUTR",DIC="^SD(403.46,",VAUTSTR="Role",VAUTNI=2
S DIC("S")="I $$RL^SCRPU1()"
G FIRST
;
RL() ;Screen for Role - screen on team
N EN,STOP,ACT,TEAM
S EN="",STOP=0
I $D(^SCTM(404.57,"AC",+Y)) D
.F S EN=$O(^SCTM(404.57,"AC",+Y,EN)) Q:EN=""!(STOP) D
..S ACT=+$$ACTTP^SCMCTPU(EN) ;currently active?
..I 'ACT!('$D(^SCTM(404.57,EN,0))) Q
..S TEAM=$P(^SCTM(404.57,EN,0),"^",2)
..I $D(VAUTT(TEAM))!(VAUTT=1) S STOP=1
..I VAUTT=""&(TEAM="") S STOP=1
Q STOP
;
PRACT ; Prompt for One (set VAUTPO) or One,Many,All,None Practitioner(s)
I '$D(VAUTT) G ERR
S VAUTVB="VAUTP",VAUTSTR="Practitioner",VAUTNI=2,DIC="^VA(200,"
S DIC("S")="I $$PRACS^SCRPU1()"
G FIRST
;
PRACS() ;Practitioner screen - off of team selection
N EN,STOP,NODE,TEAM
S EN="",STOP=0
I '$D(^SCTM(404.52,"C",+Y)) Q 0
;Position Assignment History file
F S EN=$O(^SCTM(404.52,"C",+Y,EN)) Q:EN=""!(STOP) D
.I '$D(^SCTM(404.52,EN)) Q
.S NODE=$G(^SCTM(404.52,EN,0))
.S TEAM=+$P($G(^SCTM(404.57,$P(NODE,"^"),0)),"^",2)
.I $P(NODE,"^",4),$D(VAUTT(TEAM)) S STOP=1
.I VAUTT=1 S STOP=1
Q STOP
;
FIRST ;
S DIC(0)="EQMNZ",DIC("A")="Select "_VAUTSTR_": " K @VAUTVB
S (@VAUTVB,Y)=0
REDO W !,DIC("A") R X:DTIME G ERR:(X="^")!'$T D:X["?"!(X=""&('$G(SCOKNULL))) HELP^SCRPU3
G:$G(SCOKNULL)&(X="") QUIT
I X="A"!(X="ALL")&'$D(VAUTNA) S @VAUTVB=1 G QUIT
;VAUTNA doesn't allow all to be selected
;VAUTTN allows 'Not assigned to a team' as a selection
I X="N"!(X="NOT")!(X="NONE") I $D(VAUTTN)!($D(VAUTPP)) S @VAUTVB="" G QUIT
;VAUTPP allows 'Not assigned to a practitioner' as a selection
S DIC("A")="Select another "_VAUTSTR_": " D ^DIC G:Y'>0 FIRST D SET
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
;VAUTPO - only one practitioner allowed to be selected
G QUIT
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
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
S @VAUTVB@(+Y)=$P(Y(0),U)
Q
;
ERR S Y=-1 I $O(@VAUTVB@(0))="" K @VAUTVB I X="^" S SCUP=""
QUIT S:'$D(Y) Y=1
I $D(@VAUTVB),VAUTSTR="Team",@VAUTVB=1 D:'$G(DGQUIET) EN^DDIOL("All Teams selected, this report may take some time...","","!,?10")
K DIC,J,VAERR,VAI,VAJ,VAJ1,VAX,VAUTNI,VAUTSTR,VAUTVB,X
Q
;
CLSC() ;screen on clinic selection, must be related to team prompt
I $P(^(0),U,3)'="C" Q 0
N TRUE,EN,TEAM
S TRUE=0,EN=""
F S EN=$O(^SCTM(404.57,"E",+Y,EN)) Q:EN=""!(TRUE) D
.S TEAM=+$P($G(^SCTM(404.57,EN,0)),"^",2)
.I $D(VAUTT(TEAM))!(VAUTT=1) S TRUE=1
I VAUTT="" S TRUE=1
Q TRUE
;
CLSC2() ;screen on clinic selection, must be a clinic
I $P(^(0),U,3)'="C" Q 0
Q 1
;
CLSC2OLD() ;screen on clinic selection, must be related to division prompt
I $P(^(0),U,3)'="C" Q 0
N TRUE,EN,INST,TDIV
S TRUE=0,EN=""
S TDIV=+$P(^(0),U,15) ;clinic's division
Q:TDIV=0 0
S INST=+$P(^DG(40.8,TDIV,0),U,7)
I '$D(VAUTD(INST))&(VAUTD'="") S TRUE=0
I $D(VAUTD(INST)) S TRUE=1
I VAUTD=1 S TRUE=1
Q TRUE
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPU1 5039 printed Sep 23, 2025@20:19:28 Page 2
SCRPU1 ;ALB/CMM - GENERIC PROMPTS FOR PCMM REPORTS ;1/12/96
+1 ;;5.3;Scheduling;**41,45,130,520**;AUG 13, 1993;Build 26
+2 ;
INST ;Prompt for institution
+1 SET VAUTVB="VAUTD"
SET DIC="^DIC(4,"
SET DIC("S")="I $D(^SCTM(404.51,""AINST"",+Y))"
+2 SET VAUTNI=2
SET VAUTSTR="Division"
+3 GOTO FIRST^VAUTOMA
+4 ;
PRMTT ;Prompt for team. Set VAUTTN to allow not assigned to a team as a selection
+1 IF '$DATA(VAUTD)
GOTO ERR
+2 SET VAUTVB="VAUTT"
SET DIC="^SCTM(404.51,"
SET VAUTNI=2
SET VAUTSTR="Team"
SET DIC("B")=""
+3 SET DIC("S")="I VAUTD=1!($D(VAUTD(+$P(^(0),U,7))))"
+4 GOTO FIRST
+5 ;
CLINIC ;Prompt for Clinic
+1 IF '$DATA(VAUTT)&'$DATA(VAUTCA)
GOTO ERR
+2 SET VAUTVB="VAUTC"
SET VAUTSTR="Clinic"
SET VAUTNI=2
SET DIC="^SC("
+3 ;Set screen to only allow clinics and clinics that are associated to the teams selected
+4 IF '$DATA(VAUTCA)
SET DIC("S")="I $$CLSC^SCRPU1()"
+5 ;VAUTCA allows for selection of any clinic in the selected
+6 IF $DATA(VAUTCA)
SET DIC("S")="I $$CLSC2^SCRPU1()"
+7 GOTO FIRST
+8 ;
USER ;Prompt for User Class
+1 IF '$DATA(VAUTT)
GOTO ERR
+2 ;user class turned off
IF $PIECE($GET(^SD(404.91,1,"PCMM")),"^")'=1
QUIT
+3 SET VAUTVB="VAUTUC"
SET DIC="^USR(8930,"
SET VAUTSTR="User Class"
SET VAUTNI=2
+4 SET DIC("S")="I $$USRCL^SCRPU1"
+5 GOTO FIRST
+6 ;
USRCL() ;Screen for user class - must be related to teams selected
+1 NEW STOP,ENT,NODE,TIEN
+2 IF '+$PIECE(^(0),U,3)
QUIT 0
+3 ;check for active/exiting user class
+4 SET ENT=0
SET STOP=0
+5 FOR
SET ENT=$ORDER(^SCTM(404.57,"AUSR",+Y,ENT))
if ENT=""!(STOP)
QUIT
Begin DoDot:1
+6 SET NODE=$GET(^SCTM(404.57,ENT,0))
+7 IF NODE=""
SET STOP=0
QUIT
+8 ;team ien
SET TIEN=+$PIECE(NODE,"^",2)
+9 IF $DATA(VAUTT(TIEN))!(VAUTT=1)
SET STOP=1
QUIT
+10 ;no team selected, no team assigned
IF VAUTT=""&(TIEN="")
SET STOP=1
QUIT
+11 IF VAUTT'=1&('$DATA(VAUTT(TIEN)))
SET STOP=0
End DoDot:1
+12 QUIT STOP
+13 ;
ROLE ;Prompt for Role
+1 IF '$DATA(VAUTT)
GOTO ERR
+2 SET VAUTVB="VAUTR"
SET DIC="^SD(403.46,"
SET VAUTSTR="Role"
SET VAUTNI=2
+3 SET DIC("S")="I $$RL^SCRPU1()"
+4 GOTO FIRST
+5 ;
RL() ;Screen for Role - screen on team
+1 NEW EN,STOP,ACT,TEAM
+2 SET EN=""
SET STOP=0
+3 IF $DATA(^SCTM(404.57,"AC",+Y))
Begin DoDot:1
+4 FOR
SET EN=$ORDER(^SCTM(404.57,"AC",+Y,EN))
if EN=""!(STOP)
QUIT
Begin DoDot:2
+5 ;currently active?
SET ACT=+$$ACTTP^SCMCTPU(EN)
+6 IF 'ACT!('$DATA(^SCTM(404.57,EN,0)))
QUIT
+7 SET TEAM=$PIECE(^SCTM(404.57,EN,0),"^",2)
+8 IF $DATA(VAUTT(TEAM))!(VAUTT=1)
SET STOP=1
+9 IF VAUTT=""&(TEAM="")
SET STOP=1
End DoDot:2
End DoDot:1
+10 QUIT STOP
+11 ;
PRACT ; Prompt for One (set VAUTPO) or One,Many,All,None Practitioner(s)
+1 IF '$DATA(VAUTT)
GOTO ERR
+2 SET VAUTVB="VAUTP"
SET VAUTSTR="Practitioner"
SET VAUTNI=2
SET DIC="^VA(200,"
+3 SET DIC("S")="I $$PRACS^SCRPU1()"
+4 GOTO FIRST
+5 ;
PRACS() ;Practitioner screen - off of team selection
+1 NEW EN,STOP,NODE,TEAM
+2 SET EN=""
SET STOP=0
+3 IF '$DATA(^SCTM(404.52,"C",+Y))
QUIT 0
+4 ;Position Assignment History file
+5 FOR
SET EN=$ORDER(^SCTM(404.52,"C",+Y,EN))
if EN=""!(STOP)
QUIT
Begin DoDot:1
+6 IF '$DATA(^SCTM(404.52,EN))
QUIT
+7 SET NODE=$GET(^SCTM(404.52,EN,0))
+8 SET TEAM=+$PIECE($GET(^SCTM(404.57,$PIECE(NODE,"^"),0)),"^",2)
+9 IF $PIECE(NODE,"^",4)
IF $DATA(VAUTT(TEAM))
SET STOP=1
+10 IF VAUTT=1
SET STOP=1
End DoDot:1
+11 QUIT STOP
+12 ;
FIRST ;
+1 SET DIC(0)="EQMNZ"
SET DIC("A")="Select "_VAUTSTR_": "
KILL @VAUTVB
+2 SET (@VAUTVB,Y)=0
REDO WRITE !,DIC("A")
READ X:DTIME
if (X="^")!'$TEST
GOTO ERR
if X["?"!(X=""&('$GET(SCOKNULL)))
DO HELP^SCRPU3
+1 if $GET(SCOKNULL)&(X="")
GOTO QUIT
+2 IF X="A"!(X="ALL")&'$DATA(VAUTNA)
SET @VAUTVB=1
GOTO QUIT
+3 ;VAUTNA doesn't allow all to be selected
+4 ;VAUTTN allows 'Not assigned to a team' as a selection
+5 IF X="N"!(X="NOT")!(X="NONE")
IF $DATA(VAUTTN)!($DATA(VAUTPP))
SET @VAUTVB=""
GOTO QUIT
+6 ;VAUTPP allows 'Not assigned to a practitioner' as a selection
+7 SET DIC("A")="Select another "_VAUTSTR_": "
DO ^DIC
if Y'>0
GOTO FIRST
DO SET
+8 IF '$DATA(VAUTPO)
FOR VAI=1:0:19
WRITE !,DIC("A")
READ X:DTIME
if (X="")!(X="^")!'$TEST
GOTO ERR
KILL Y
if X["?"
DO HELP^SCRPU3
if $EXTRACT(X)="-"
SET VAUTX=X
SET X=$EXTRACT(VAUTX,2,999)
DO ^DIC
IF Y>0
DO SET
if VAX
GOTO REDO
if 'VAERR
SET VAI=VAI+1
+9 ;VAUTPO - only one practitioner allowed to be selected
+10 GOTO QUIT
SET SET VAX=0
IF $DATA(VAUTX)
SET J=$SELECT(VAUTNI=2:+Y,1:$PIECE(Y(0),"^"))
KILL VAUTX
SET VAERR=$SELECT($DATA(@VAUTVB@(J)):0,1:1)
WRITE $SELECT('VAERR:"...removed from list...",1:"...not on list...can't remove")
if VAERR
QUIT
SET VAI=VAI-1
KILL @VAUTVB@(J)
if $ORDER(@VAUTVB@(0))']""
SET VAX=1
QUIT
+1 SET VAERR=0
IF $SELECT($DATA(@VAUTVB@($PIECE(Y(0),U))):1,$DATA(@VAUTVB@(+Y)):1,1:0)
WRITE !?3,*7,"You have already selected that ",VAUTSTR,". Try again."
SET VAERR=1
+2 SET @VAUTVB@(+Y)=$PIECE(Y(0),U)
+3 QUIT
+4 ;
ERR SET Y=-1
IF $ORDER(@VAUTVB@(0))=""
KILL @VAUTVB
IF X="^"
SET SCUP=""
QUIT if '$DATA(Y)
SET Y=1
+1 IF $DATA(@VAUTVB)
IF VAUTSTR="Team"
IF @VAUTVB=1
if '$GET(DGQUIET)
DO EN^DDIOL("All Teams selected, this report may take some time...","","!,?10")
+2 KILL DIC,J,VAERR,VAI,VAJ,VAJ1,VAX,VAUTNI,VAUTSTR,VAUTVB,X
+3 QUIT
+4 ;
CLSC() ;screen on clinic selection, must be related to team prompt
+1 IF $PIECE(^(0),U,3)'="C"
QUIT 0
+2 NEW TRUE,EN,TEAM
+3 SET TRUE=0
SET EN=""
+4 FOR
SET EN=$ORDER(^SCTM(404.57,"E",+Y,EN))
if EN=""!(TRUE)
QUIT
Begin DoDot:1
+5 SET TEAM=+$PIECE($GET(^SCTM(404.57,EN,0)),"^",2)
+6 IF $DATA(VAUTT(TEAM))!(VAUTT=1)
SET TRUE=1
End DoDot:1
+7 IF VAUTT=""
SET TRUE=1
+8 QUIT TRUE
+9 ;
CLSC2() ;screen on clinic selection, must be a clinic
+1 IF $PIECE(^(0),U,3)'="C"
QUIT 0
+2 QUIT 1
+3 ;
CLSC2OLD() ;screen on clinic selection, must be related to division prompt
+1 IF $PIECE(^(0),U,3)'="C"
QUIT 0
+2 NEW TRUE,EN,INST,TDIV
+3 SET TRUE=0
SET EN=""
+4 ;clinic's division
SET TDIV=+$PIECE(^(0),U,15)
+5 if TDIV=0
QUIT 0
+6 SET INST=+$PIECE(^DG(40.8,TDIV,0),U,7)
+7 IF '$DATA(VAUTD(INST))&(VAUTD'="")
SET TRUE=0
+8 IF $DATA(VAUTD(INST))
SET TRUE=1
+9 IF VAUTD=1
SET TRUE=1
+10 QUIT TRUE
