- 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 Jan 18, 2025@03:44:16 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