Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SCMCMHHT

SCMCMHHT.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; copied from SCRPO6 and modified to only display information for
  1. ; mental health teams
  1. ;
  1. EN ;Queue report
  1. N LIST,RTN,DESC
  1. S SUMON=0
  1. W !,"Print Final Summary Only" S %=2 D YN^DICN I %=1 S SUMON=1
  1. ;Patch 589 - need to screen for Mental Health teams only, see below
  1. ;S LIST="DIV,TEAM"
  1. S LIST="DIV"
  1. S RTN="RUN^SCMCMHHT"
  1. S DESC="Historical Mental Health Team Assignment Summary"
  1. D PROMPT(LIST,RTN,DESC) Q
  1. ;
  1. PROMPT(LIST,SCRTN,SCDESC) ;Prompt for report parameters, queue report
  1. ;Input: LIST=comma delimited string of list subscripts to prompt for
  1. ;Input: SCRTN=report routine entry point
  1. ;Input: SCDESC=tasked job description
  1. ;
  1. N SCDIV,SCBDT,SCEDT,SC,SCI,SCX,SCOUT,SCT
  1. S SC="^TMP(""SC"",$J)" K @SC S SCOUT=0
  1. D TITL^SCRPW50(SCDESC)
  1. D SUBT^SCRPW50("**** Date Range Selection ****")
  1. S (SCBDT("B"),SCEDT("B"))="TODAY"
  1. G:'$$DTR^SCRPO(.SC,.SCBDT,.SCEDT) END
  1. D SUBT^SCRPW50("**** Report Parameter Selection ****")
  1. F SCI=1:1:$L(LIST,",") S SCX=$P(LIST,",",SCI) D Q:SCOUT
  1. .S SCOUT='$$LIST^SCRPO(.SC,SCX,1)
  1. .Q
  1. ;Patch 589 - need to screen for Mental Health teams only,modified LIST from SCRPO
  1. S SCOUT='$$LIST(.SC,"TEAM",1)
  1. ;
  1. G:SCOUT END
  1. S SCT(1)="**** Report Parameters Selected ****" D SUBT^SCRPW50(SCT(1))
  1. G:'$$PPAR^SCRPO(.SC,1,.SCT) END
  1. W !!,"This report requires 132 column output!"
  1. W ! N ZTSAVE S ZTSAVE("^TMP(""SC"",$J,")="",ZTSAVE("SC")="",ZTSAVE("SUMON")=""
  1. D EN^XUTMDEVQ(SCRTN,SCDESC,.ZTSAVE)
  1. END K ^TMP("SC",$J) D DISP0^SCRPW23,END^SCRPW50 Q
  1. ;
  1. STOP ;Check for stop task request
  1. S:$D(ZTQUEUED) (SCOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q
  1. ;
  1. RUN ;Print report
  1. N SCI,SCOUT
  1. K ^TMP("SCRPT",$J)
  1. S SCOUT=0
  1. ;patch 589 changed SCRPO7 to SCMCMHO7
  1. D BUILD Q:SCOUT D COUNT^SCMCMHO7 D STOP Q:SCOUT
  1. D PRINT
  1. K ^TMP("SCRPT",$J),^TMP("SCRATCH",$J) Q
  1. ;
  1. BUILD ;gather report information
  1. N SCTM
  1. ;build from list of teams
  1. I $O(^TMP("SC",$J,"TEAM",0)) S SCTM=0 D Q
  1. .F S SCTM=$O(^TMP("SC",$J,"TEAM",SCTM)) Q:'SCTM!SCOUT D
  1. ..;patch 589 changed SCRPO7 to SCMCMH07
  1. ..D CKTEAM^SCMCMHO7(SCTM),STOP
  1. ..Q
  1. .Q
  1. ;build from all teams
  1. S SCTM=0 F S SCTM=$O(^SCTM(404.51,SCTM)) Q:'SCTM!SCOUT D
  1. .; Patch 589 - only include Mental Health teams
  1. .I $$GET1^DIQ(404.51,SCTM,.03)'="MENTAL HEALTH TREATMENT" Q
  1. .;patch 589 changed SCRPO7 to SCMCMH07
  1. .D CKTEAM^SCMCMHO7(SCTM),STOP
  1. .Q
  1. Q
  1. ;
  1. PRINT ;Print report
  1. N SCLF,SCFF,SCLINE,SCPAGE,SCPNOW,SCTITL
  1. S (SCLF,SCFF)=0
  1. D HINI D:$E(IOST)="C" DISP0^SCRPW23
  1. S SCTITL(2)=$$HDRX("P") D HDR^SCRPO(.SCTITL,132) Q:SCOUT S SCOUT=$$PPAR^SCRPO(.SC,,.SCTITL)=0
  1. Q:SCOUT
  1. I '$D(^TMP("SCRPT",$J,0)) D Q
  1. .K SCTITL(2) D HDR^SCRPO(.SCTITL,132) Q:SCOUT
  1. .S SCX="No team or team position assignments found within selected report parameters!"
  1. .W !!?(132-$L(SCX)\2),SCX
  1. .Q
  1. S SCPAGE=1
  1. S SCTITL(2)=$$HDRX("S") D HDR^SCRPO(.SCTITL,132),SHDR("S") Q:SCOUT
  1. S SCDIV="" F S SCDIV=$O(^TMP("SCRPT",$J,1,SCDIV)) Q:SCDIV=""!SCOUT D
  1. .S SCX=^TMP("SCRPT",$J,1,SCDIV) D SLINE(SCDIV,SCX,12,.SCLF) S SCTEAM=""
  1. .F S SCTEAM=$O(^TMP("SCRPT",$J,1,SCDIV,"TEAM",SCTEAM)) Q:SCTEAM=""!SCOUT D
  1. ..S SCX=^TMP("SCRPT",$J,1,SCDIV,"TEAM",SCTEAM)
  1. ..D SLINE(" "_SCTEAM,SCX,10,.SCLF)
  1. ..Q
  1. .Q
  1. Q:SCOUT
  1. S SCX=^TMP("SCRPT",$J,0,0) D SLINE("REPORT TOTAL:",SCX,12,.SCLF)
  1. ; patch 589 - removed doing the footer
  1. Q:SCOUT ; D FOOT^SCRPO7
  1. Q:$G(SUMON)
  1. I $D(^TMP("SCRPT",$J,0,0,"TLIST")) D
  1. .S SCTITL(2)=$$HDRX("T") D HDR^SCRPO(.SCTITL,132),SHDR("T") Q:SCOUT
  1. .S SCDIV=""
  1. .F S SCDIV=$O(^TMP("SCRPT",$J,0,0,"TLIST",SCDIV)) Q:SCDIV=""!SCOUT D
  1. ..S SCTEAM=""
  1. ..F S SCTEAM=$O(^TMP("SCRPT",$J,0,0,"TLIST",SCDIV,SCTEAM)) Q:SCTEAM=""!SCOUT D
  1. ...S SCPNAM=""
  1. ...F S SCPNAM=$O(^TMP("SCRPT",$J,0,0,"TLIST",SCDIV,SCTEAM,SCPNAM)) Q:SCPNAM=""!SCOUT D
  1. ....S SCI=0
  1. ....F S SCI=$O(^TMP("SCRPT",$J,0,0,"TLIST",SCDIV,SCTEAM,SCPNAM,SCI)) Q:'SCI!SCOUT D
  1. .....S SCX=^TMP("SCRPT",$J,0,0,"TLIST",SCDIV,SCTEAM,SCPNAM,SCI)
  1. .....D TLINE(SCDIV,SCTEAM,SCPNAM,SCX)
  1. .....Q
  1. ....Q
  1. ...Q
  1. ..Q
  1. .Q
  1. Q:SCOUT I $D(^TMP("SCRPT",$J,0,0,"PLIST")) D
  1. .S SCTITL(2)=$$HDRX("TP") D HDR^SCRPO(.SCTITL,132),SHDR("P") Q:SCOUT
  1. .S SCDIV=""
  1. .F S SCDIV=$O(^TMP("SCRPT",$J,0,0,"PLIST",SCDIV)) Q:SCDIV=""!SCOUT D
  1. ..S SCTEAM=""
  1. ..F S SCTEAM=$O(^TMP("SCRPT",$J,0,0,"PLIST",SCDIV,SCTEAM)) Q:SCTEAM=""!SCOUT D
  1. ...S SCPNAM=""
  1. ...F S SCPNAM=$O(^TMP("SCRPT",$J,0,0,"PLIST",SCDIV,SCTEAM,SCPNAM)) Q:SCPNAM=""!SCOUT D
  1. ....S SCI=0
  1. ....F S SCI=$O(^TMP("SCRPT",$J,0,0,"PLIST",SCDIV,SCTEAM,SCPNAM,SCI)) Q:'SCI!SCOUT D
  1. .....S SCX=^TMP("SCRPT",$J,0,0,"PLIST",SCDIV,SCTEAM,SCPNAM,SCI)
  1. .....D PLINE(SCDIV,SCTEAM,SCPNAM,SCX)
  1. .....Q
  1. ....Q
  1. ...Q
  1. ..Q
  1. .Q
  1. I 'SCOUT,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR
  1. Q
  1. ;
  1. SLINE(SCN,SCX,SCPF,SCLF) ;Print summary line
  1. ;Input: SCN=name of item to print
  1. ;Input: SCX=string of item values
  1. ;Input: SCPF=minimum lines without page feed
  1. ;Input: SCLF=extra line feed flag
  1. ;
  1. N SCI,SCY
  1. S SCY="2^3^6^11^12^" ; Patch 589 - removed fields no longer printing
  1. ; removed D FOOT^SCRPO7 - don't do footer, patch 589
  1. ;I $Y>(IOSL-SCPF) D FOOT^SCRPO7,HDR^SCRPO(.SCTITL,132),SHDR("S") S SCLF=0
  1. I $Y>(IOSL-SCPF) D HDR^SCRPO(.SCTITL,132),SHDR("S") S SCLF=0
  1. Q:SCOUT W:SCPF>10&SCLF !
  1. ;Patch 589 - removed If/Else, no longer need to print the PC column
  1. W !,$E($P(SCN,U),1,28)
  1. ; changed from 1:1:11 patch 589
  1. F SCI=1:1:5 W ?(27+(9*SCI)),$J(+$P(SCX,U,$P(SCY,U,SCI)),6,0)
  1. S SCLF=1
  1. Q
  1. ;
  1. TLINE(SCDIV,SCTEAM,SCPNAM,SCX) ;Print broken team assignment line
  1. ;Input: SCDIV=division
  1. ;Input: SCTEAM=team
  1. ;Input: SCPNAM=patient name
  1. ;Input: SCX=string of patient assignment data
  1. ;
  1. N SCI,Y
  1. F SCI=3,4 S Y=$P($P(SCX,U,SCI),".") X ^DD("DD") S $P(SCX,U,SCI)=Y
  1. I $Y>(IOSL-4) D HDR^SCRPO(.SCTITL,132),SHDR("T") Q:SCOUT
  1. W !,$P(SCDIV,U),?32,$P(SCTEAM,U),?64,SCPNAM
  1. ; Patch 589 added "xxxxx" + $E to print the last 4 of the SSN
  1. W ?96,"xxxxx"_$E($TR($P(SCX,U,2),"-",""),6,9),?108,$P(SCX,U,3),?121,$P(SCX,U,4)
  1. Q
  1. ;
  1. PLINE(SCDIV,SCTEAM,SCPNAM,SCX) ;Print broken team assignment line
  1. ;Input: SCDIV=division
  1. ;Input: SCTEAM=team
  1. ;Input: SCPNAM=patient name
  1. ;Input: SCX=string of patient assignment data
  1. ;
  1. N SCI,Y
  1. F SCI=3,4 S Y=$P($P(SCX,U,SCI),".") X ^DD("DD") S $P(SCX,U,SCI)=Y
  1. I $Y>(IOSL-4) D HDR^SCRPO(.SCTITL,132),SHDR("P") Q:SCOUT
  1. ; Patch 589 - added "xxxxx" + $E to print the last 4 of the SSN
  1. W !,$P(SCDIV,U),?24,$P(SCTEAM,U),?48,SCPNAM,?72,"xxxxx"_$E($TR($P(SCX,U,2),"-",""),6,9)
  1. W ?84,$P(SCX,U,5),?108,$P(SCX,U,3),?121,$P(SCX,U,4)
  1. Q
  1. ;
  1. HDRX(SCX) ;extra header line
  1. ;Input: SCX='P' for parameters, 'S' for summary, 'T' for broken team
  1. ; assignments, 'TP' for broken team position assignments
  1. ;
  1. Q:SCX="P" "Selected Report Parameters"
  1. Q:SCX="S" "Summary of Team and Team Position Assignments Effective: "_^TMP("SC",$J,"DTR","PBDT")_" to "_^TMP("SC",$J,"DTR","PEDT")
  1. Q:SCX="T" "Team Assignments Without Active Position Assignments Effective: "_^TMP("SC",$J,"DTR","PBDT")_" to "_^TMP("SC",$J,"DTR","PEDT")
  1. Q:SCX="TP" "Position Assignments Without Active Team Assignments Effective: "_^TMP("SC",$J,"DTR","PBDT")_" to "_^TMP("SC",$J,"DTR","PEDT")
  1. Q:""
  1. ;
  1. HINI ;Initialize header variables
  1. N Y
  1. S SCTITL(1)="<*> MH HISTORICAL TEAM ASSIGNMENT SUMMARY <*>"
  1. S SCLINE="",$P(SCLINE,"-",133)="",SCPAGE=1
  1. S Y=$$NOW^XLFDT() X ^DD("DD") S SCPNOW=$P(Y,":",1,2)
  1. Q
  1. ;
  1. SHDR(X) ;Print subheader
  1. Q:SCOUT
  1. N SCI
  1. I X="S" D Q
  1. .; modified for 589
  1. .W !?63,"Pts w/o Pts w/o"
  1. .W !,"Division",?38,"Max. MH Team Open MHTC MH Team"
  1. .W !?2,"MH Team",?38,"Pts. Assign. ",?47,"Slots Assign. Assign."
  1. .W !,$E(SCLINE,1,28),?37," ---- " F SCI=0:1:3 W ?(45+(9*SCI)),"-------"
  1. .Q
  1. I X="T" D Q
  1. .W !,"Division",?32,"MH Team",?64,"Patient Name",?96,"SSN",?108,"Active Date",?121,"Inact. Date"
  1. .W ! F SCI=1:1:3 W $E(SCLINE,1,30)," "
  1. .W "---------- ----------- -----------"
  1. .Q
  1. I X="P" D Q
  1. .W !,"Division",?24,"MH Team",?48,"Patient Name",?72,"SSN",?84,"MH Team Position",?108,"Active Date",?121,"Inact. Date"
  1. .W ! F SCI=1:1:3 W $E(SCLINE,1,22)," "
  1. .W "---------- ",$E(SCLINE,1,22)," ----------- -----------"
  1. .Q
  1. Q
  1. ;
  1. ;copied from SCRPO, modified to only return Mental Health teams
  1. ;
  1. LIST(SC,WHAT,SUBH,LIMIT) ;Get list of entries from a file
  1. ;Input: SC=array to return values (pass by reference)
  1. ; @SC@(WHAT)="ALL" for all entries, or,
  1. ; @SC@(WHAT,ifn)=name of record
  1. ; @SC@(WHAT,name,ifn)=""
  1. ;Input: WHAT="TEAM"
  1. ;Input: SUBH='1' to display category subheader (optional)
  1. ;Input: LIMIT=maximum selections (optional, default 20)
  1. ;Output: '1' for success, '0' otherwise
  1. ;
  1. N SCW,SCI,SCOUT,DIC,X,Y,SCA,SCB,SCQUIT,SCS,DTOUT,DUOUT
  1. Q:'$L(WHAT) 0 S:'$G(LIMIT) LIMIT=20 S (SCOUT,SCQUIT)=0
  1. F SCI="TEAM" S SCW(SCI)=""
  1. Q:'$D(SCW(WHAT)) 0
  1. D @WHAT S DIC(0)="AEMQ"
  1. I $G(SUBH) D SUBT^SCRPW50("**** "_SCA_" Selection ****")
  1. S SCB=$J("Select "_SCA_": ",29),DIC("A")=SCB_"ALL// "
  1. I $L($G(SCS)) S DIC("S")=SCS
  1. F SCI=1:1:LIMIT D Q:SCOUT!SCQUIT
  1. .W ! D ^DIC I $D(DTOUT)!$D(DUOUT) S SCQUIT=1 Q
  1. .I SCI=1,X="" W " (ALL)" S @SC@(WHAT)="ALL",SCOUT=1 Q
  1. .I X="" S SCOUT=1 Q
  1. .I Y>0 S @SC@(WHAT,+Y)=$P(Y,U,2),@SC@(WHAT,$P(Y,U,2),+Y)=""
  1. .S DIC("A")=SCB
  1. .Q
  1. D XR(.SC,WHAT,SCA) Q 'SCQUIT
  1. Q
  1. ;
  1. 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
  1. ;
  1. XR(SC,SUB,VAL) ;Create x-ref for printing parameters
  1. ;Input: SC=array to return parameters
  1. ;Input: SUB=name of subscript holding parameters being x-ref'd
  1. ;Input: VAL=value for item subtitle (optional)
  1. ;
  1. S @SC@("XR")=$G(@SC@("XR"))+1,@SC@("XR",@SC@("XR"),SUB)=$G(VAL)
  1. Q