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