SCMCMHU1 ;BP-CIOFO/LLH - Mental Health Reports (cont.) ; 02/08/2012 09:15 AM
;;5.3;Scheduling;**589**;AUG 13, 1993;Build 41
;
; created to use with new Mental Health reports
;
PRMTT ;Prompt for team.
;
;This subroutine was copied from SCRPU1 and modified to return MH teams. Additionally,
;the code was modified to set all mental health teams into the VAUTT array if all was
;selected. This was done so that all other routines could be used to process the data
;
I '$D(VAUTD) G ERR
S VAUTVB="VAUTT",DIC="^SCTM(404.51,",VAUTNI=2,VAUTSTR="Team",DIC("B")=""
;screen for mental health teams
S DIC("S")="I $$MHTEAM^SCMCMHU1(Y)"
G FIRST
;
MHTEAM(IEN) ; Screen for mental health teams only
; input: IEN - internal record number for the team
;output: VALID - 1 if a valid mental health team, 0 if not
;
N VALID
I $P(^SD(403.47,$P(^SCTM(404.51,IEN,0),U,3),0),U,1)'="MENTAL HEALTH TREATMENT" Q 0
I $D(VAUTD(+$P(^SCTM(404.51,IEN,0),U,7))) Q 1
I VAUTD=1 Q 1
Q 0
;
;
PRACT ; Patch 589, Change Practitioner to Clinician/Provider
;Prompt for One (set VAUTPO) or One,Many,All,None Practitioner(s)
I '$D(VAUTT) G ERR
S VAUTVB="VAUTP",VAUTSTR="Clinician/Provider",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
;
;PRACT ; patch 589 - added subroutine, changed Practitioner to Clinician/Provider
; ;Prompt for One (set VAUTPO) or One,Many,All,None Clinician/Provider(s)
; I '$D(VAUTT) G ERR
;S VAUTVB="VAUTP",VAUTSTR="Clinician/Provider(s)",VAUTNI=2,DIC="^VA(200,"
;S DIC("S")="I $$PRACS^SCMCMHU1()"
;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
G:$G(SCOKNULL)&(X="") QUIT
;patch 589 call to GETALL is to get all Mental health teams, also must set
;VAUTVB if Clinican/Provider = All
I X="A"!(X="ALL")&'$D(VAUTNA) D G QUIT
.I VAUTVB="VAUTT" D GETALL Q
.I VAUTVB="VAUTP" S @VAUTVB=1 Q
.Q
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: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
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
;
HELP ;
W:'$D(VAUTNA) !,"ENTER:",!?5,"- A or ALL for all Mental Health ",VAUTSTR,"s, or"
W !?5,"- Select individual Mental Health "_VAUTSTR W:'$D(VAUTPO) " -- limit 20"
W !?5,"Imprecise selections will yield an additional prompt."
I $O(@VAUTVB@(0))]"" W !?5,"- An entry preceeded by a minus [-] sign to remove entry from list."
I $O(@VAUTVB@(0))]"" W !,"NOTE, you have already selected:" S VAJ=0 F VAJ1=0:0 S VAJ=$O(@VAUTVB@(VAJ)) Q:VAJ="" W !?8,$S(VAUTNI=1:VAJ,1:@VAUTVB@(VAJ))
Q
;
GETALL ; user selected all MH teams, rather than manipulate other routines
; will set all the mental health teams for the division into the team array
;
; input: none
;output: VAUTT array
;
K @VAUTVB
S @VAUTVB=0
N CNT,MHT,STR
S (CNT,MHT)=0
F S MHT=$O(^SCTM(404.51,MHT)) Q:(MHT'>0)!(CNT>20) D
.S STR=$G(^SCTM(404.51,MHT,0))
.I $P(^SD(403.47,$P(STR,U,3),0),U,1)'="MENTAL HEALTH TREATMENT" Q
.I VAUTD=1!($D(VAUTD(+$P(STR,U,7)))) S @VAUTVB@(MHT)=$P(STR,U,1),CNT=CNT+1
Q
DELOUT() ; ask user if Summary should be in a delimited output format
; input - none
;output - 1 if delimited output
; 0 if a regular report format is desired
;
N X,DTOUT,DUOUT,DIROUT,Y
S DIR("A")="Should the Summary be a '^' delimited format?",DIR("B")="N"
S DIR("?")="Enter 'Y' for '^' output, 'N' for a formatted report."
S DIR(0)="Y"
D ^DIR
;I $D(DTOUT)!(X="") S Y=$S(DIR("B")="Y":1,1:0)
I $D(DUOUT)!($D(DIROUT)) S Y=-1
K DIR
Q +Y
;
;patch 589 - copied from SORT^SCRPU2 and modified to change Practitioner with
; Clinician
SORT() ;
;Prompt for sorting by Division, Team, Clinician or Division, Practitioner, Team
;
EN1 N X
W !,"Sort By:",!?10,"[1] Division, Team, Clinician",!?10,"[2] Division, Clinician, Team"
W !?10,"[3] Clinician,Associated Clinic"
W !!,"Select 1 or 2 or 3: "
R X:DTIME
I (X="^")!'$T Q 0
I (X'="1")&(X'="2")&(X'=3) D HLP3 G EN1
I (X["?")!(X="") D HLP3 G EN1
Q X
HLP3 ;
;help prompt
W !,"Enter: ",!?5,"- 1 to sort by Division, Team, Clinician "
W !?10,"- 2 to sort by Division, Clinician, Team"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCMHU1 5908 printed Apr 09, 2024@21:53:52 Page 2
SCMCMHU1 ;BP-CIOFO/LLH - Mental Health Reports (cont.) ; 02/08/2012 09:15 AM
+1 ;;5.3;Scheduling;**589**;AUG 13, 1993;Build 41
+2 ;
+3 ; created to use with new Mental Health reports
+4 ;
PRMTT ;Prompt for team.
+1 ;
+2 ;This subroutine was copied from SCRPU1 and modified to return MH teams. Additionally,
+3 ;the code was modified to set all mental health teams into the VAUTT array if all was
+4 ;selected. This was done so that all other routines could be used to process the data
+5 ;
+6 IF '$DATA(VAUTD)
GOTO ERR
+7 SET VAUTVB="VAUTT"
SET DIC="^SCTM(404.51,"
SET VAUTNI=2
SET VAUTSTR="Team"
SET DIC("B")=""
+8 ;screen for mental health teams
+9 SET DIC("S")="I $$MHTEAM^SCMCMHU1(Y)"
+10 GOTO FIRST
+11 ;
MHTEAM(IEN) ; Screen for mental health teams only
+1 ; input: IEN - internal record number for the team
+2 ;output: VALID - 1 if a valid mental health team, 0 if not
+3 ;
+4 NEW VALID
+5 IF $PIECE(^SD(403.47,$PIECE(^SCTM(404.51,IEN,0),U,3),0),U,1)'="MENTAL HEALTH TREATMENT"
QUIT 0
+6 IF $DATA(VAUTD(+$PIECE(^SCTM(404.51,IEN,0),U,7)))
QUIT 1
+7 IF VAUTD=1
QUIT 1
+8 QUIT 0
+9 ;
+10 ;
PRACT ; Patch 589, Change Practitioner to Clinician/Provider
+1 ;Prompt for One (set VAUTPO) or One,Many,All,None Practitioner(s)
+2 IF '$DATA(VAUTT)
GOTO ERR
+3 SET VAUTVB="VAUTP"
SET VAUTSTR="Clinician/Provider"
SET VAUTNI=2
SET DIC="^VA(200,"
+4 SET DIC("S")="I $$PRACS^SCRPU1()"
+5 GOTO FIRST
+6 ;
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 ;
+13 ;PRACT ; patch 589 - added subroutine, changed Practitioner to Clinician/Provider
+14 ; ;Prompt for One (set VAUTPO) or One,Many,All,None Clinician/Provider(s)
+15 ; I '$D(VAUTT) G ERR
+16 ;S VAUTVB="VAUTP",VAUTSTR="Clinician/Provider(s)",VAUTNI=2,DIC="^VA(200,"
+17 ;S DIC("S")="I $$PRACS^SCMCMHU1()"
+18 ;G FIRST
+19 ;
+20 ;PRACS() ;Practitioner screen - off of team selection
+21 ;N EN,STOP,NODE,TEAM
+22 ;S EN="",STOP=0
+23 ;I '$D(^SCTM(404.52,"C",+Y)) Q 0
+24 ;Position Assignment History file
+25 ;F S EN=$O(^SCTM(404.52,"C",+Y,EN)) Q:EN=""!(STOP) D
+26 ;.I '$D(^SCTM(404.52,EN)) Q
+27 ;.S NODE=$G(^SCTM(404.52,EN,0))
+28 ;.S TEAM=+$P($G(^SCTM(404.57,$P(NODE,"^"),0)),"^",2)
+29 ;.I $P(NODE,"^",4),$D(VAUTT(TEAM)) S STOP=1
+30 ;.I VAUTT=1 S STOP=1
+31 ;Q STOP
+32 ;
FIRST ;
+1 SET DIC(0)="EQMNZ"
SET DIC("A")="Select "_VAUTSTR_": "
KILL @VAUTVB
+2 SET (@VAUTVB,Y)=0
+3 ;
REDO WRITE !,DIC("A")
READ X:DTIME
if (X="^")!'$TEST
GOTO ERR
if X["?"!(X=""&('$GET(SCOKNULL)))
DO HELP
+1 if $GET(SCOKNULL)&(X="")
GOTO QUIT
+2 ;patch 589 call to GETALL is to get all Mental health teams, also must set
+3 ;VAUTVB if Clinican/Provider = All
+4 IF X="A"!(X="ALL")&'$DATA(VAUTNA)
Begin DoDot:1
+5 IF VAUTVB="VAUTT"
DO GETALL
QUIT
+6 IF VAUTVB="VAUTP"
SET @VAUTVB=1
QUIT
+7 QUIT
End DoDot:1
GOTO QUIT
+8 SET DIC("A")="Select another "_VAUTSTR_": "
DO ^DIC
if Y'>0
GOTO FIRST
DO SET
+9 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
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
+10 GOTO QUIT
+11 ;
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 ;
HELP ;
+1 if '$DATA(VAUTNA)
WRITE !,"ENTER:",!?5,"- A or ALL for all Mental Health ",VAUTSTR,"s, or"
+2 WRITE !?5,"- Select individual Mental Health "_VAUTSTR
if '$DATA(VAUTPO)
WRITE " -- limit 20"
+3 WRITE !?5,"Imprecise selections will yield an additional prompt."
+4 IF $ORDER(@VAUTVB@(0))]""
WRITE !?5,"- An entry preceeded by a minus [-] sign to remove entry from list."
+5 IF $ORDER(@VAUTVB@(0))]""
WRITE !,"NOTE, you have already selected:"
SET VAJ=0
FOR VAJ1=0:0
SET VAJ=$ORDER(@VAUTVB@(VAJ))
if VAJ=""
QUIT
WRITE !?8,$SELECT(VAUTNI=1:VAJ,1:@VAUTVB@(VAJ))
+6 QUIT
+7 ;
GETALL ; user selected all MH teams, rather than manipulate other routines
+1 ; will set all the mental health teams for the division into the team array
+2 ;
+3 ; input: none
+4 ;output: VAUTT array
+5 ;
+6 KILL @VAUTVB
+7 SET @VAUTVB=0
+8 NEW CNT,MHT,STR
+9 SET (CNT,MHT)=0
+10 FOR
SET MHT=$ORDER(^SCTM(404.51,MHT))
if (MHT'>0)!(CNT>20)
QUIT
Begin DoDot:1
+11 SET STR=$GET(^SCTM(404.51,MHT,0))
+12 IF $PIECE(^SD(403.47,$PIECE(STR,U,3),0),U,1)'="MENTAL HEALTH TREATMENT"
QUIT
+13 IF VAUTD=1!($DATA(VAUTD(+$PIECE(STR,U,7))))
SET @VAUTVB@(MHT)=$PIECE(STR,U,1)
SET CNT=CNT+1
End DoDot:1
+14 QUIT
DELOUT() ; ask user if Summary should be in a delimited output format
+1 ; input - none
+2 ;output - 1 if delimited output
+3 ; 0 if a regular report format is desired
+4 ;
+5 NEW X,DTOUT,DUOUT,DIROUT,Y
+6 SET DIR("A")="Should the Summary be a '^' delimited format?"
SET DIR("B")="N"
+7 SET DIR("?")="Enter 'Y' for '^' output, 'N' for a formatted report."
+8 SET DIR(0)="Y"
+9 DO ^DIR
+10 ;I $D(DTOUT)!(X="") S Y=$S(DIR("B")="Y":1,1:0)
+11 IF $DATA(DUOUT)!($DATA(DIROUT))
SET Y=-1
+12 KILL DIR
+13 QUIT +Y
+14 ;
+15 ;patch 589 - copied from SORT^SCRPU2 and modified to change Practitioner with
+16 ; Clinician
SORT() ;
+1 ;Prompt for sorting by Division, Team, Clinician or Division, Practitioner, Team
+2 ;
EN1 NEW X
+1 WRITE !,"Sort By:",!?10,"[1] Division, Team, Clinician",!?10,"[2] Division, Clinician, Team"
+2 WRITE !?10,"[3] Clinician,Associated Clinic"
+3 WRITE !!,"Select 1 or 2 or 3: "
+4 READ X:DTIME
+5 IF (X="^")!'$TEST
QUIT 0
+6 IF (X'="1")&(X'="2")&(X'=3)
DO HLP3
GOTO EN1
+7 IF (X["?")!(X="")
DO HLP3
GOTO EN1
+8 QUIT X
HLP3 ;
+1 ;help prompt
+2 WRITE !,"Enter: ",!?5,"- 1 to sort by Division, Team, Clinician "
+3 WRITE !?10,"- 2 to sort by Division, Clinician, Team"
+4 QUIT
