SCMCMHHT ;BP-CIOFO/LLH - Historical Team Assign Sum for Mental Health ; 2/6/12 10:00am
;;5.3;Scheduling;**589**;AUG 13, 1993;Build 41
;
; copied from SCRPO6 and modified to only display information for
; mental health teams
;
EN ;Queue report
N LIST,RTN,DESC
S SUMON=0
W !,"Print Final Summary Only" S %=2 D YN^DICN I %=1 S SUMON=1
;Patch 589 - need to screen for Mental Health teams only, see below
;S LIST="DIV,TEAM"
S LIST="DIV"
S RTN="RUN^SCMCMHHT"
S DESC="Historical Mental Health Team Assignment Summary"
D PROMPT(LIST,RTN,DESC) Q
;
PROMPT(LIST,SCRTN,SCDESC) ;Prompt for report parameters, queue report
;Input: LIST=comma delimited string of list subscripts to prompt for
;Input: SCRTN=report routine entry point
;Input: SCDESC=tasked job description
;
N SCDIV,SCBDT,SCEDT,SC,SCI,SCX,SCOUT,SCT
S SC="^TMP(""SC"",$J)" K @SC S SCOUT=0
D TITL^SCRPW50(SCDESC)
D SUBT^SCRPW50("**** Date Range Selection ****")
S (SCBDT("B"),SCEDT("B"))="TODAY"
G:'$$DTR^SCRPO(.SC,.SCBDT,.SCEDT) END
D SUBT^SCRPW50("**** Report Parameter Selection ****")
F SCI=1:1:$L(LIST,",") S SCX=$P(LIST,",",SCI) D Q:SCOUT
.S SCOUT='$$LIST^SCRPO(.SC,SCX,1)
.Q
;Patch 589 - need to screen for Mental Health teams only,modified LIST from SCRPO
S SCOUT='$$LIST(.SC,"TEAM",1)
;
G:SCOUT END
S SCT(1)="**** Report Parameters Selected ****" D SUBT^SCRPW50(SCT(1))
G:'$$PPAR^SCRPO(.SC,1,.SCT) END
W !!,"This report requires 132 column output!"
W ! N ZTSAVE S ZTSAVE("^TMP(""SC"",$J,")="",ZTSAVE("SC")="",ZTSAVE("SUMON")=""
D EN^XUTMDEVQ(SCRTN,SCDESC,.ZTSAVE)
END K ^TMP("SC",$J) D DISP0^SCRPW23,END^SCRPW50 Q
;
STOP ;Check for stop task request
S:$D(ZTQUEUED) (SCOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q
;
RUN ;Print report
N SCI,SCOUT
K ^TMP("SCRPT",$J)
S SCOUT=0
;patch 589 changed SCRPO7 to SCMCMHO7
D BUILD Q:SCOUT D COUNT^SCMCMHO7 D STOP Q:SCOUT
D PRINT
K ^TMP("SCRPT",$J),^TMP("SCRATCH",$J) Q
;
BUILD ;gather report information
N SCTM
;build from list of teams
I $O(^TMP("SC",$J,"TEAM",0)) S SCTM=0 D Q
.F S SCTM=$O(^TMP("SC",$J,"TEAM",SCTM)) Q:'SCTM!SCOUT D
..;patch 589 changed SCRPO7 to SCMCMH07
..D CKTEAM^SCMCMHO7(SCTM),STOP
..Q
.Q
;build from all teams
S SCTM=0 F S SCTM=$O(^SCTM(404.51,SCTM)) Q:'SCTM!SCOUT D
.; Patch 589 - only include Mental Health teams
.I $$GET1^DIQ(404.51,SCTM,.03)'="MENTAL HEALTH TREATMENT" Q
.;patch 589 changed SCRPO7 to SCMCMH07
.D CKTEAM^SCMCMHO7(SCTM),STOP
.Q
Q
;
PRINT ;Print report
N SCLF,SCFF,SCLINE,SCPAGE,SCPNOW,SCTITL
S (SCLF,SCFF)=0
D HINI D:$E(IOST)="C" DISP0^SCRPW23
S SCTITL(2)=$$HDRX("P") D HDR^SCRPO(.SCTITL,132) Q:SCOUT S SCOUT=$$PPAR^SCRPO(.SC,,.SCTITL)=0
Q:SCOUT
I '$D(^TMP("SCRPT",$J,0)) D Q
.K SCTITL(2) D HDR^SCRPO(.SCTITL,132) Q:SCOUT
.S SCX="No team or team position assignments found within selected report parameters!"
.W !!?(132-$L(SCX)\2),SCX
.Q
S SCPAGE=1
S SCTITL(2)=$$HDRX("S") D HDR^SCRPO(.SCTITL,132),SHDR("S") Q:SCOUT
S SCDIV="" F S SCDIV=$O(^TMP("SCRPT",$J,1,SCDIV)) Q:SCDIV=""!SCOUT D
.S SCX=^TMP("SCRPT",$J,1,SCDIV) D SLINE(SCDIV,SCX,12,.SCLF) S SCTEAM=""
.F S SCTEAM=$O(^TMP("SCRPT",$J,1,SCDIV,"TEAM",SCTEAM)) Q:SCTEAM=""!SCOUT D
..S SCX=^TMP("SCRPT",$J,1,SCDIV,"TEAM",SCTEAM)
..D SLINE(" "_SCTEAM,SCX,10,.SCLF)
..Q
.Q
Q:SCOUT
S SCX=^TMP("SCRPT",$J,0,0) D SLINE("REPORT TOTAL:",SCX,12,.SCLF)
; patch 589 - removed doing the footer
Q:SCOUT ; D FOOT^SCRPO7
Q:$G(SUMON)
I $D(^TMP("SCRPT",$J,0,0,"TLIST")) D
.S SCTITL(2)=$$HDRX("T") D HDR^SCRPO(.SCTITL,132),SHDR("T") Q:SCOUT
.S SCDIV=""
.F S SCDIV=$O(^TMP("SCRPT",$J,0,0,"TLIST",SCDIV)) Q:SCDIV=""!SCOUT D
..S SCTEAM=""
..F S SCTEAM=$O(^TMP("SCRPT",$J,0,0,"TLIST",SCDIV,SCTEAM)) Q:SCTEAM=""!SCOUT D
...S SCPNAM=""
...F S SCPNAM=$O(^TMP("SCRPT",$J,0,0,"TLIST",SCDIV,SCTEAM,SCPNAM)) Q:SCPNAM=""!SCOUT D
....S SCI=0
....F S SCI=$O(^TMP("SCRPT",$J,0,0,"TLIST",SCDIV,SCTEAM,SCPNAM,SCI)) Q:'SCI!SCOUT D
.....S SCX=^TMP("SCRPT",$J,0,0,"TLIST",SCDIV,SCTEAM,SCPNAM,SCI)
.....D TLINE(SCDIV,SCTEAM,SCPNAM,SCX)
.....Q
....Q
...Q
..Q
.Q
Q:SCOUT I $D(^TMP("SCRPT",$J,0,0,"PLIST")) D
.S SCTITL(2)=$$HDRX("TP") D HDR^SCRPO(.SCTITL,132),SHDR("P") Q:SCOUT
.S SCDIV=""
.F S SCDIV=$O(^TMP("SCRPT",$J,0,0,"PLIST",SCDIV)) Q:SCDIV=""!SCOUT D
..S SCTEAM=""
..F S SCTEAM=$O(^TMP("SCRPT",$J,0,0,"PLIST",SCDIV,SCTEAM)) Q:SCTEAM=""!SCOUT D
...S SCPNAM=""
...F S SCPNAM=$O(^TMP("SCRPT",$J,0,0,"PLIST",SCDIV,SCTEAM,SCPNAM)) Q:SCPNAM=""!SCOUT D
....S SCI=0
....F S SCI=$O(^TMP("SCRPT",$J,0,0,"PLIST",SCDIV,SCTEAM,SCPNAM,SCI)) Q:'SCI!SCOUT D
.....S SCX=^TMP("SCRPT",$J,0,0,"PLIST",SCDIV,SCTEAM,SCPNAM,SCI)
.....D PLINE(SCDIV,SCTEAM,SCPNAM,SCX)
.....Q
....Q
...Q
..Q
.Q
I 'SCOUT,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR
Q
;
SLINE(SCN,SCX,SCPF,SCLF) ;Print summary line
;Input: SCN=name of item to print
;Input: SCX=string of item values
;Input: SCPF=minimum lines without page feed
;Input: SCLF=extra line feed flag
;
N SCI,SCY
S SCY="2^3^6^11^12^" ; Patch 589 - removed fields no longer printing
; removed D FOOT^SCRPO7 - don't do footer, patch 589
;I $Y>(IOSL-SCPF) D FOOT^SCRPO7,HDR^SCRPO(.SCTITL,132),SHDR("S") S SCLF=0
I $Y>(IOSL-SCPF) D HDR^SCRPO(.SCTITL,132),SHDR("S") S SCLF=0
Q:SCOUT W:SCPF>10&SCLF !
;Patch 589 - removed If/Else, no longer need to print the PC column
W !,$E($P(SCN,U),1,28)
; changed from 1:1:11 patch 589
F SCI=1:1:5 W ?(27+(9*SCI)),$J(+$P(SCX,U,$P(SCY,U,SCI)),6,0)
S SCLF=1
Q
;
TLINE(SCDIV,SCTEAM,SCPNAM,SCX) ;Print broken team assignment line
;Input: SCDIV=division
;Input: SCTEAM=team
;Input: SCPNAM=patient name
;Input: SCX=string of patient assignment data
;
N SCI,Y
F SCI=3,4 S Y=$P($P(SCX,U,SCI),".") X ^DD("DD") S $P(SCX,U,SCI)=Y
I $Y>(IOSL-4) D HDR^SCRPO(.SCTITL,132),SHDR("T") Q:SCOUT
W !,$P(SCDIV,U),?32,$P(SCTEAM,U),?64,SCPNAM
; Patch 589 added "xxxxx" + $E to print the last 4 of the SSN
W ?96,"xxxxx"_$E($TR($P(SCX,U,2),"-",""),6,9),?108,$P(SCX,U,3),?121,$P(SCX,U,4)
Q
;
PLINE(SCDIV,SCTEAM,SCPNAM,SCX) ;Print broken team assignment line
;Input: SCDIV=division
;Input: SCTEAM=team
;Input: SCPNAM=patient name
;Input: SCX=string of patient assignment data
;
N SCI,Y
F SCI=3,4 S Y=$P($P(SCX,U,SCI),".") X ^DD("DD") S $P(SCX,U,SCI)=Y
I $Y>(IOSL-4) D HDR^SCRPO(.SCTITL,132),SHDR("P") Q:SCOUT
; Patch 589 - added "xxxxx" + $E to print the last 4 of the SSN
W !,$P(SCDIV,U),?24,$P(SCTEAM,U),?48,SCPNAM,?72,"xxxxx"_$E($TR($P(SCX,U,2),"-",""),6,9)
W ?84,$P(SCX,U,5),?108,$P(SCX,U,3),?121,$P(SCX,U,4)
Q
;
HDRX(SCX) ;extra header line
;Input: SCX='P' for parameters, 'S' for summary, 'T' for broken team
; assignments, 'TP' for broken team position assignments
;
Q:SCX="P" "Selected Report Parameters"
Q:SCX="S" "Summary of Team and Team Position Assignments Effective: "_^TMP("SC",$J,"DTR","PBDT")_" to "_^TMP("SC",$J,"DTR","PEDT")
Q:SCX="T" "Team Assignments Without Active Position Assignments Effective: "_^TMP("SC",$J,"DTR","PBDT")_" to "_^TMP("SC",$J,"DTR","PEDT")
Q:SCX="TP" "Position Assignments Without Active Team Assignments Effective: "_^TMP("SC",$J,"DTR","PBDT")_" to "_^TMP("SC",$J,"DTR","PEDT")
Q:""
;
HINI ;Initialize header variables
N Y
S SCTITL(1)="<*> MH HISTORICAL TEAM ASSIGNMENT SUMMARY <*>"
S SCLINE="",$P(SCLINE,"-",133)="",SCPAGE=1
S Y=$$NOW^XLFDT() X ^DD("DD") S SCPNOW=$P(Y,":",1,2)
Q
;
SHDR(X) ;Print subheader
Q:SCOUT
N SCI
I X="S" D Q
.; modified for 589
.W !?63,"Pts w/o Pts w/o"
.W !,"Division",?38,"Max. MH Team Open MHTC MH Team"
.W !?2,"MH Team",?38,"Pts. Assign. ",?47,"Slots Assign. Assign."
.W !,$E(SCLINE,1,28),?37," ---- " F SCI=0:1:3 W ?(45+(9*SCI)),"-------"
.Q
I X="T" D Q
.W !,"Division",?32,"MH Team",?64,"Patient Name",?96,"SSN",?108,"Active Date",?121,"Inact. Date"
.W ! F SCI=1:1:3 W $E(SCLINE,1,30)," "
.W "---------- ----------- -----------"
.Q
I X="P" D Q
.W !,"Division",?24,"MH Team",?48,"Patient Name",?72,"SSN",?84,"MH Team Position",?108,"Active Date",?121,"Inact. Date"
.W ! F SCI=1:1:3 W $E(SCLINE,1,22)," "
.W "---------- ",$E(SCLINE,1,22)," ----------- -----------"
.Q
Q
;
;copied from SCRPO, modified to only return Mental Health teams
;
LIST(SC,WHAT,SUBH,LIMIT) ;Get list of entries from a file
;Input: SC=array to return values (pass by reference)
; @SC@(WHAT)="ALL" for all entries, or,
; @SC@(WHAT,ifn)=name of record
; @SC@(WHAT,name,ifn)=""
;Input: WHAT="TEAM"
;Input: SUBH='1' to display category subheader (optional)
;Input: LIMIT=maximum selections (optional, default 20)
;Output: '1' for success, '0' otherwise
;
N SCW,SCI,SCOUT,DIC,X,Y,SCA,SCB,SCQUIT,SCS,DTOUT,DUOUT
Q:'$L(WHAT) 0 S:'$G(LIMIT) LIMIT=20 S (SCOUT,SCQUIT)=0
F SCI="TEAM" S SCW(SCI)=""
Q:'$D(SCW(WHAT)) 0
D @WHAT S DIC(0)="AEMQ"
I $G(SUBH) D SUBT^SCRPW50("**** "_SCA_" Selection ****")
S SCB=$J("Select "_SCA_": ",29),DIC("A")=SCB_"ALL// "
I $L($G(SCS)) S DIC("S")=SCS
F SCI=1:1:LIMIT D Q:SCOUT!SCQUIT
.W ! D ^DIC I $D(DTOUT)!$D(DUOUT) S SCQUIT=1 Q
.I SCI=1,X="" W " (ALL)" S @SC@(WHAT)="ALL",SCOUT=1 Q
.I X="" S SCOUT=1 Q
.I Y>0 S @SC@(WHAT,+Y)=$P(Y,U,2),@SC@(WHAT,$P(Y,U,2),+Y)=""
.S DIC("A")=SCB
.Q
D XR(.SC,WHAT,SCA) Q 'SCQUIT
Q
;
TEAM S DIC="^SCTM(404.51,",SCA="Team",SCS="I $P(^SD(403.47,$P(^(0),U,3),0),U,1)=""MENTAL HEALTH TREATMENT""" Q
;
XR(SC,SUB,VAL) ;Create x-ref for printing parameters
;Input: SC=array to return parameters
;Input: SUB=name of subscript holding parameters being x-ref'd
;Input: VAL=value for item subtitle (optional)
;
S @SC@("XR")=$G(@SC@("XR"))+1,@SC@("XR",@SC@("XR"),SUB)=$G(VAL)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCMHHT 9840 printed Sep 23, 2025@20:17:13 Page 2
SCMCMHHT ;BP-CIOFO/LLH - Historical Team Assign Sum for Mental Health ; 2/6/12 10:00am
+1 ;;5.3;Scheduling;**589**;AUG 13, 1993;Build 41
+2 ;
+3 ; copied from SCRPO6 and modified to only display information for
+4 ; mental health teams
+5 ;
EN ;Queue report
+1 NEW LIST,RTN,DESC
+2 SET SUMON=0
+3 WRITE !,"Print Final Summary Only"
SET %=2
DO YN^DICN
IF %=1
SET SUMON=1
+4 ;Patch 589 - need to screen for Mental Health teams only, see below
+5 ;S LIST="DIV,TEAM"
+6 SET LIST="DIV"
+7 SET RTN="RUN^SCMCMHHT"
+8 SET DESC="Historical Mental Health Team Assignment Summary"
+9 DO PROMPT(LIST,RTN,DESC)
QUIT
+10 ;
PROMPT(LIST,SCRTN,SCDESC) ;Prompt for report parameters, queue report
+1 ;Input: LIST=comma delimited string of list subscripts to prompt for
+2 ;Input: SCRTN=report routine entry point
+3 ;Input: SCDESC=tasked job description
+4 ;
+5 NEW SCDIV,SCBDT,SCEDT,SC,SCI,SCX,SCOUT,SCT
+6 SET SC="^TMP(""SC"",$J)"
KILL @SC
SET SCOUT=0
+7 DO TITL^SCRPW50(SCDESC)
+8 DO SUBT^SCRPW50("**** Date Range Selection ****")
+9 SET (SCBDT("B"),SCEDT("B"))="TODAY"
+10 if '$$DTR^SCRPO(.SC,.SCBDT,.SCEDT)
GOTO END
+11 DO SUBT^SCRPW50("**** Report Parameter Selection ****")
+12 FOR SCI=1:1:$LENGTH(LIST,",")
SET SCX=$PIECE(LIST,",",SCI)
Begin DoDot:1
+13 SET SCOUT='$$LIST^SCRPO(.SC,SCX,1)
+14 QUIT
End DoDot:1
if SCOUT
QUIT
+15 ;Patch 589 - need to screen for Mental Health teams only,modified LIST from SCRPO
+16 SET SCOUT='$$LIST(.SC,"TEAM",1)
+17 ;
+18 if SCOUT
GOTO END
+19 SET SCT(1)="**** Report Parameters Selected ****"
DO SUBT^SCRPW50(SCT(1))
+20 if '$$PPAR^SCRPO(.SC,1,.SCT)
GOTO END
+21 WRITE !!,"This report requires 132 column output!"
+22 WRITE !
NEW ZTSAVE
SET ZTSAVE("^TMP(""SC"",$J,")=""
SET ZTSAVE("SC")=""
SET ZTSAVE("SUMON")=""
+23 DO EN^XUTMDEVQ(SCRTN,SCDESC,.ZTSAVE)
END KILL ^TMP("SC",$JOB)
DO DISP0^SCRPW23
DO END^SCRPW50
QUIT
+1 ;
STOP ;Check for stop task request
+1 if $DATA(ZTQUEUED)
SET (SCOUT,ZTSTOP)=$SELECT($$S^%ZTLOAD:1,1:0)
QUIT
+2 ;
RUN ;Print report
+1 NEW SCI,SCOUT
+2 KILL ^TMP("SCRPT",$JOB)
+3 SET SCOUT=0
+4 ;patch 589 changed SCRPO7 to SCMCMHO7
+5 DO BUILD
if SCOUT
QUIT
DO COUNT^SCMCMHO7
DO STOP
if SCOUT
QUIT
+6 DO PRINT
+7 KILL ^TMP("SCRPT",$JOB),^TMP("SCRATCH",$JOB)
QUIT
+8 ;
BUILD ;gather report information
+1 NEW SCTM
+2 ;build from list of teams
+3 IF $ORDER(^TMP("SC",$JOB,"TEAM",0))
SET SCTM=0
Begin DoDot:1
+4 FOR
SET SCTM=$ORDER(^TMP("SC",$JOB,"TEAM",SCTM))
if 'SCTM!SCOUT
QUIT
Begin DoDot:2
+5 ;patch 589 changed SCRPO7 to SCMCMH07
+6 DO CKTEAM^SCMCMHO7(SCTM)
DO STOP
+7 QUIT
End DoDot:2
+8 QUIT
End DoDot:1
QUIT
+9 ;build from all teams
+10 SET SCTM=0
FOR
SET SCTM=$ORDER(^SCTM(404.51,SCTM))
if 'SCTM!SCOUT
QUIT
Begin DoDot:1
+11 ; Patch 589 - only include Mental Health teams
+12 IF $$GET1^DIQ(404.51,SCTM,.03)'="MENTAL HEALTH TREATMENT"
QUIT
+13 ;patch 589 changed SCRPO7 to SCMCMH07
+14 DO CKTEAM^SCMCMHO7(SCTM)
DO STOP
+15 QUIT
End DoDot:1
+16 QUIT
+17 ;
PRINT ;Print report
+1 NEW SCLF,SCFF,SCLINE,SCPAGE,SCPNOW,SCTITL
+2 SET (SCLF,SCFF)=0
+3 DO HINI
if $EXTRACT(IOST)="C"
DO DISP0^SCRPW23
+4 SET SCTITL(2)=$$HDRX("P")
DO HDR^SCRPO(.SCTITL,132)
if SCOUT
QUIT
SET SCOUT=$$PPAR^SCRPO(.SC,,.SCTITL)=0
+5 if SCOUT
QUIT
+6 IF '$DATA(^TMP("SCRPT",$JOB,0))
Begin DoDot:1
+7 KILL SCTITL(2)
DO HDR^SCRPO(.SCTITL,132)
if SCOUT
QUIT
+8 SET SCX="No team or team position assignments found within selected report parameters!"
+9 WRITE !!?(132-$LENGTH(SCX)\2),SCX
+10 QUIT
End DoDot:1
QUIT
+11 SET SCPAGE=1
+12 SET SCTITL(2)=$$HDRX("S")
DO HDR^SCRPO(.SCTITL,132)
DO SHDR("S")
if SCOUT
QUIT
+13 SET SCDIV=""
FOR
SET SCDIV=$ORDER(^TMP("SCRPT",$JOB,1,SCDIV))
if SCDIV=""!SCOUT
QUIT
Begin DoDot:1
+14 SET SCX=^TMP("SCRPT",$JOB,1,SCDIV)
DO SLINE(SCDIV,SCX,12,.SCLF)
SET SCTEAM=""
+15 FOR
SET SCTEAM=$ORDER(^TMP("SCRPT",$JOB,1,SCDIV,"TEAM",SCTEAM))
if SCTEAM=""!SCOUT
QUIT
Begin DoDot:2
+16 SET SCX=^TMP("SCRPT",$JOB,1,SCDIV,"TEAM",SCTEAM)
+17 DO SLINE(" "_SCTEAM,SCX,10,.SCLF)
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 if SCOUT
QUIT
+21 SET SCX=^TMP("SCRPT",$JOB,0,0)
DO SLINE("REPORT TOTAL:",SCX,12,.SCLF)
+22 ; patch 589 - removed doing the footer
+23 ; D FOOT^SCRPO7
if SCOUT
QUIT
+24 if $GET(SUMON)
QUIT
+25 IF $DATA(^TMP("SCRPT",$JOB,0,0,"TLIST"))
Begin DoDot:1
+26 SET SCTITL(2)=$$HDRX("T")
DO HDR^SCRPO(.SCTITL,132)
DO SHDR("T")
if SCOUT
QUIT
+27 SET SCDIV=""
+28 FOR
SET SCDIV=$ORDER(^TMP("SCRPT",$JOB,0,0,"TLIST",SCDIV))
if SCDIV=""!SCOUT
QUIT
Begin DoDot:2
+29 SET SCTEAM=""
+30 FOR
SET SCTEAM=$ORDER(^TMP("SCRPT",$JOB,0,0,"TLIST",SCDIV,SCTEAM))
if SCTEAM=""!SCOUT
QUIT
Begin DoDot:3
+31 SET SCPNAM=""
+32 FOR
SET SCPNAM=$ORDER(^TMP("SCRPT",$JOB,0,0,"TLIST",SCDIV,SCTEAM,SCPNAM))
if SCPNAM=""!SCOUT
QUIT
Begin DoDot:4
+33 SET SCI=0
+34 FOR
SET SCI=$ORDER(^TMP("SCRPT",$JOB,0,0,"TLIST",SCDIV,SCTEAM,SCPNAM,SCI))
if 'SCI!SCOUT
QUIT
Begin DoDot:5
+35 SET SCX=^TMP("SCRPT",$JOB,0,0,"TLIST",SCDIV,SCTEAM,SCPNAM,SCI)
+36 DO TLINE(SCDIV,SCTEAM,SCPNAM,SCX)
+37 QUIT
End DoDot:5
+38 QUIT
End DoDot:4
+39 QUIT
End DoDot:3
+40 QUIT
End DoDot:2
+41 QUIT
End DoDot:1
+42 if SCOUT
QUIT
IF $DATA(^TMP("SCRPT",$JOB,0,0,"PLIST"))
Begin DoDot:1
+43 SET SCTITL(2)=$$HDRX("TP")
DO HDR^SCRPO(.SCTITL,132)
DO SHDR("P")
if SCOUT
QUIT
+44 SET SCDIV=""
+45 FOR
SET SCDIV=$ORDER(^TMP("SCRPT",$JOB,0,0,"PLIST",SCDIV))
if SCDIV=""!SCOUT
QUIT
Begin DoDot:2
+46 SET SCTEAM=""
+47 FOR
SET SCTEAM=$ORDER(^TMP("SCRPT",$JOB,0,0,"PLIST",SCDIV,SCTEAM))
if SCTEAM=""!SCOUT
QUIT
Begin DoDot:3
+48 SET SCPNAM=""
+49 FOR
SET SCPNAM=$ORDER(^TMP("SCRPT",$JOB,0,0,"PLIST",SCDIV,SCTEAM,SCPNAM))
if SCPNAM=""!SCOUT
QUIT
Begin DoDot:4
+50 SET SCI=0
+51 FOR
SET SCI=$ORDER(^TMP("SCRPT",$JOB,0,0,"PLIST",SCDIV,SCTEAM,SCPNAM,SCI))
if 'SCI!SCOUT
QUIT
Begin DoDot:5
+52 SET SCX=^TMP("SCRPT",$JOB,0,0,"PLIST",SCDIV,SCTEAM,SCPNAM,SCI)
+53 DO PLINE(SCDIV,SCTEAM,SCPNAM,SCX)
+54 QUIT
End DoDot:5
+55 QUIT
End DoDot:4
+56 QUIT
End DoDot:3
+57 QUIT
End DoDot:2
+58 QUIT
End DoDot:1
+59 IF 'SCOUT
IF $EXTRACT(IOST)="C"
NEW DIR
SET DIR(0)="E"
WRITE !
DO ^DIR
+60 QUIT
+61 ;
SLINE(SCN,SCX,SCPF,SCLF) ;Print summary line
+1 ;Input: SCN=name of item to print
+2 ;Input: SCX=string of item values
+3 ;Input: SCPF=minimum lines without page feed
+4 ;Input: SCLF=extra line feed flag
+5 ;
+6 NEW SCI,SCY
+7 ; Patch 589 - removed fields no longer printing
SET SCY="2^3^6^11^12^"
+8 ; removed D FOOT^SCRPO7 - don't do footer, patch 589
+9 ;I $Y>(IOSL-SCPF) D FOOT^SCRPO7,HDR^SCRPO(.SCTITL,132),SHDR("S") S SCLF=0
+10 IF $Y>(IOSL-SCPF)
DO HDR^SCRPO(.SCTITL,132)
DO SHDR("S")
SET SCLF=0
+11 if SCOUT
QUIT
if SCPF>10&SCLF
WRITE !
+12 ;Patch 589 - removed If/Else, no longer need to print the PC column
+13 WRITE !,$EXTRACT($PIECE(SCN,U),1,28)
+14 ; changed from 1:1:11 patch 589
+15 FOR SCI=1:1:5
WRITE ?(27+(9*SCI)),$JUSTIFY(+$PIECE(SCX,U,$PIECE(SCY,U,SCI)),6,0)
+16 SET SCLF=1
+17 QUIT
+18 ;
TLINE(SCDIV,SCTEAM,SCPNAM,SCX) ;Print broken team assignment line
+1 ;Input: SCDIV=division
+2 ;Input: SCTEAM=team
+3 ;Input: SCPNAM=patient name
+4 ;Input: SCX=string of patient assignment data
+5 ;
+6 NEW SCI,Y
+7 FOR SCI=3,4
SET Y=$PIECE($PIECE(SCX,U,SCI),".")
XECUTE ^DD("DD")
SET $PIECE(SCX,U,SCI)=Y
+8 IF $Y>(IOSL-4)
DO HDR^SCRPO(.SCTITL,132)
DO SHDR("T")
if SCOUT
QUIT
+9 WRITE !,$PIECE(SCDIV,U),?32,$PIECE(SCTEAM,U),?64,SCPNAM
+10 ; Patch 589 added "xxxxx" + $E to print the last 4 of the SSN
+11 WRITE ?96,"xxxxx"_$EXTRACT($TRANSLATE($PIECE(SCX,U,2),"-",""),6,9),?108,$PIECE(SCX,U,3),?121,$PIECE(SCX,U,4)
+12 QUIT
+13 ;
PLINE(SCDIV,SCTEAM,SCPNAM,SCX) ;Print broken team assignment line
+1 ;Input: SCDIV=division
+2 ;Input: SCTEAM=team
+3 ;Input: SCPNAM=patient name
+4 ;Input: SCX=string of patient assignment data
+5 ;
+6 NEW SCI,Y
+7 FOR SCI=3,4
SET Y=$PIECE($PIECE(SCX,U,SCI),".")
XECUTE ^DD("DD")
SET $PIECE(SCX,U,SCI)=Y
+8 IF $Y>(IOSL-4)
DO HDR^SCRPO(.SCTITL,132)
DO SHDR("P")
if SCOUT
QUIT
+9 ; Patch 589 - added "xxxxx" + $E to print the last 4 of the SSN
+10 WRITE !,$PIECE(SCDIV,U),?24,$PIECE(SCTEAM,U),?48,SCPNAM,?72,"xxxxx"_$EXTRACT($TRANSLATE($PIECE(SCX,U,2),"-",""),6,9)
+11 WRITE ?84,$PIECE(SCX,U,5),?108,$PIECE(SCX,U,3),?121,$PIECE(SCX,U,4)
+12 QUIT
+13 ;
HDRX(SCX) ;extra header line
+1 ;Input: SCX='P' for parameters, 'S' for summary, 'T' for broken team
+2 ; assignments, 'TP' for broken team position assignments
+3 ;
+4 if SCX="P"
QUIT "Selected Report Parameters"
+5 if SCX="S"
QUIT "Summary of Team and Team Position Assignments Effective: "_^TMP("SC",$JOB,"DTR","PBDT")_" to "_^TMP("SC",$JOB,"DTR","PEDT")
+6 if SCX="T"
QUIT "Team Assignments Without Active Position Assignments Effective: "_^TMP("SC",$JOB,"DTR","PBDT")_" to "_^TMP("SC",$JOB,"DTR","PEDT")
+7 if SCX="TP"
QUIT "Position Assignments Without Active Team Assignments Effective: "_^TMP("SC",$JOB,"DTR","PBDT")_" to "_^TMP("SC",$JOB,"DTR","PEDT")
+8 if ""
QUIT
+9 ;
HINI ;Initialize header variables
+1 NEW Y
+2 SET SCTITL(1)="<*> MH HISTORICAL TEAM ASSIGNMENT SUMMARY <*>"
+3 SET SCLINE=""
SET $PIECE(SCLINE,"-",133)=""
SET SCPAGE=1
+4 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET SCPNOW=$PIECE(Y,":",1,2)
+5 QUIT
+6 ;
SHDR(X) ;Print subheader
+1 if SCOUT
QUIT
+2 NEW SCI
+3 IF X="S"
Begin DoDot:1
+4 ; modified for 589
+5 WRITE !?63,"Pts w/o Pts w/o"
+6 WRITE !,"Division",?38,"Max. MH Team Open MHTC MH Team"
+7 WRITE !?2,"MH Team",?38,"Pts. Assign. ",?47,"Slots Assign. Assign."
+8 WRITE !,$EXTRACT(SCLINE,1,28),?37," ---- "
FOR SCI=0:1:3
WRITE ?(45+(9*SCI)),"-------"
+9 QUIT
End DoDot:1
QUIT
+10 IF X="T"
Begin DoDot:1
+11 WRITE !,"Division",?32,"MH Team",?64,"Patient Name",?96,"SSN",?108,"Active Date",?121,"Inact. Date"
+12 WRITE !
FOR SCI=1:1:3
WRITE $EXTRACT(SCLINE,1,30)," "
+13 WRITE "---------- ----------- -----------"
+14 QUIT
End DoDot:1
QUIT
+15 IF X="P"
Begin DoDot:1
+16 WRITE !,"Division",?24,"MH Team",?48,"Patient Name",?72,"SSN",?84,"MH Team Position",?108,"Active Date",?121,"Inact. Date"
+17 WRITE !
FOR SCI=1:1:3
WRITE $EXTRACT(SCLINE,1,22)," "
+18 WRITE "---------- ",$EXTRACT(SCLINE,1,22)," ----------- -----------"
+19 QUIT
End DoDot:1
QUIT
+20 QUIT
+21 ;
+22 ;copied from SCRPO, modified to only return Mental Health teams
+23 ;
LIST(SC,WHAT,SUBH,LIMIT) ;Get list of entries from a file
+1 ;Input: SC=array to return values (pass by reference)
+2 ; @SC@(WHAT)="ALL" for all entries, or,
+3 ; @SC@(WHAT,ifn)=name of record
+4 ; @SC@(WHAT,name,ifn)=""
+5 ;Input: WHAT="TEAM"
+6 ;Input: SUBH='1' to display category subheader (optional)
+7 ;Input: LIMIT=maximum selections (optional, default 20)
+8 ;Output: '1' for success, '0' otherwise
+9 ;
+10 NEW SCW,SCI,SCOUT,DIC,X,Y,SCA,SCB,SCQUIT,SCS,DTOUT,DUOUT
+11 if '$LENGTH(WHAT)
QUIT 0
if '$GET(LIMIT)
SET LIMIT=20
SET (SCOUT,SCQUIT)=0
+12 FOR SCI="TEAM"
SET SCW(SCI)=""
+13 if '$DATA(SCW(WHAT))
QUIT 0
+14 DO @WHAT
SET DIC(0)="AEMQ"
+15 IF $GET(SUBH)
DO SUBT^SCRPW50("**** "_SCA_" Selection ****")
+16 SET SCB=$JUSTIFY("Select "_SCA_": ",29)
SET DIC("A")=SCB_"ALL// "
+17 IF $LENGTH($GET(SCS))
SET DIC("S")=SCS
+18 FOR SCI=1:1:LIMIT
Begin DoDot:1
+19 WRITE !
DO ^DIC
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SCQUIT=1
QUIT
+20 IF SCI=1
IF X=""
WRITE " (ALL)"
SET @SC@(WHAT)="ALL"
SET SCOUT=1
QUIT
+21 IF X=""
SET SCOUT=1
QUIT
+22 IF Y>0
SET @SC@(WHAT,+Y)=$PIECE(Y,U,2)
SET @SC@(WHAT,$PIECE(Y,U,2),+Y)=""
+23 SET DIC("A")=SCB
+24 QUIT
End DoDot:1
if SCOUT!SCQUIT
QUIT
+25 DO XR(.SC,WHAT,SCA)
QUIT 'SCQUIT
+26 QUIT
+27 ;
TEAM SET DIC="^SCTM(404.51,"
SET SCA="Team"
SET SCS="I $P(^SD(403.47,$P(^(0),U,3),0),U,1)=""MENTAL HEALTH TREATMENT"""
QUIT
+1 ;
XR(SC,SUB,VAL) ;Create x-ref for printing parameters
+1 ;Input: SC=array to return parameters
+2 ;Input: SUB=name of subscript holding parameters being x-ref'd
+3 ;Input: VAL=value for item subtitle (optional)
+4 ;
+5 SET @SC@("XR")=$GET(@SC@("XR"))+1
SET @SC@("XR",@SC@("XR"),SUB)=$GET(VAL)
+6 QUIT
