- 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 Feb 19, 2025@00:07:19 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