SCRPO6 ;BP-CIOFO/KEITH - Historical Team Assignment Summary ; 9/14/99 10:07am
;;5.3;Scheduling;**177,297,1015**;AUG 13, 1993;Build 21
;IHS/ANMC/LJF 11/02/2000 added call to list template
; changed 132 column message
; changed footer code for list template
; moved IO variables kill to list template
; changed SSN to HRCN
;
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
S LIST="DIV,TEAM"
S RTN="RUN^SCRPO6"
S DESC="Historical 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
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!" ;IHS/ANMC/LJF 11/2/2000
W !!,"This report, when printed on paper, requires wide paper or condensed print!" ;IHS/ANMC/LJF 11/2/2000
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 ;IHS/ANMC/LJF 11/2/2000
K ^TMP("SC",$J) D DISP0^SCRPW23 Q ;IHS/ANMC/LJF 11/2/2000
;
STOP ;Check for stop task request
S:$D(ZTQUEUED) (SCOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q
;
RUN ;Print report
I $E(IOST,1,2)="C-" D ^BSDSCO6 Q ;IHS/ANMC/LJF 11/2/2000
IHS ;EP; entry point for list template ;IHS/ANMC/LJF 11/2/2000
N SCI,SCOUT
K ^TMP("SCRPT",$J)
S SCOUT=0
D BUILD Q:SCOUT D COUNT^SCRPO7 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
..D CKTEAM^SCRPO7(SCTM),STOP
..Q
.Q
;build from all teams
S SCTM=0 F S SCTM=$O(^SCTM(404.51,SCTM)) Q:'SCTM!SCOUT D
.D CKTEAM^SCRPO7(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)
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^7^5^4^9^8^10^6^11^12"
;I $Y>(IOSL-SCPF) D FOOT^SCRPO7,HDR^SCRPO(.SCTITL,132),SHDR("S") S SCLF=0 ;IHS/ANMC/LJF 11/2/2000
I '$G(VALM),$Y>(IOSL-SCPF) D FOOT^SCRPO7,HDR^SCRPO(.SCTITL,132),SHDR("S") S SCLF=0 ;IHS/ANMC/LJF 11/2/2000
Q:SCOUT W:SCPF>10&SCLF !
;bp/djb Omit PC? column from REPORT TOTAL line.
;Old code start
;W !,$E($P(SCN,U),1,28),?30,$S($P(SCX,U)="":"NO",1:$P(SCX,U))
;Old code end
;New code start
I SCN["REPORT TOTAL" W !,$E($P(SCN,U),1,28)
E W !,$E($P(SCN,U),1,28),?30,$S($P(SCX,U)="":"NO",1:$P(SCX,U))
;New code end
F SCI=1:1:11 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
W ?96,$TR($P(SCX,U,2),"-",""),?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
W !,$P(SCDIV,U),?24,$P(SCTEAM,U),?48,SCPNAM,?72,$TR($P(SCX,U,2),"-","")
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)="<*> 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
.W !?56,"Team --Team Position- --Team Position- Total",?116,"Pts w/o Pts w/o"
.W !,"Division",?38,"Max. Team Assign. ---Assignments-- ---Unique Pts.-- Unique Open Pos. Team"
.W !?2,"Team",?30,"PC? Pts. Assign. Uniques PC",?72,"Non-PC PC",?90,"Non-PC Pts. Slots Assign. Assign."
.W !,$E(SCLINE,1,28)," ---" F SCI=0:1:10 W ?(35+(9*SCI)),"-------"
.Q
I X="T" D Q
.;W !,"Division",?32,"Team",?64,"Patient Name",?96,"SSN",?108,"Active Date",?121,"Inact. Date" ;IHS/ANMC/LJF 11/2/2000
.W !,"Division",?32,"Team",?64,"Patient Name",?96,"HRCN",?108,"Active Date",?121,"Inact. Date" ;IHS/ANMC/LJF 11/2/2000
.W ! F SCI=1:1:3 W $E(SCLINE,1,30)," "
.W "---------- ----------- -----------"
.Q
I X="P" D Q
.;W !,"Division",?24,"Team",?48,"Patient Name",?72,"SSN",?84,"Team Position",?108,"Active Date",?121,"Inact. Date" ;IHS/ANMC/LJF 11/2/2000
.W !,"Division",?24,"Team",?48,"Patient Name",?72,"HRCN",?84,"Team Position",?108,"Active Date",?121,"Inact. Date" ;IHS/ANMC/LJF 11/2/2000
.W ! F SCI=1:1:3 W $E(SCLINE,1,22)," "
.W "---------- ",$E(SCLINE,1,22)," ----------- -----------"
.Q
Q
SCRPO6 ;BP-CIOFO/KEITH - Historical Team Assignment Summary ; 9/14/99 10:07am
+1 ;;5.3;Scheduling;**177,297,1015**;AUG 13, 1993;Build 21
+2 ;IHS/ANMC/LJF 11/02/2000 added call to list template
+3 ; changed 132 column message
+4 ; changed footer code for list template
+5 ; moved IO variables kill to list template
+6 ; changed SSN to HRCN
+7 ;
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 SET LIST="DIV,TEAM"
+5 SET RTN="RUN^SCRPO6"
+6 SET DESC="Historical Team Assignment Summary"
+7 DO PROMPT(LIST,RTN,DESC)
QUIT
+8 ;
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 IF SCOUT
GOTO END
+16 SET SCT(1)="**** Report Parameters Selected ****"
DO SUBT^SCRPW50(SCT(1))
+17 IF '$$PPAR^SCRPO(.SC,1,.SCT)
GOTO END
+18 ;W !!,"This report requires 132 column output!" ;IHS/ANMC/LJF 11/2/2000
+19 ;IHS/ANMC/LJF 11/2/2000
WRITE !!,"This report, when printed on paper, requires wide paper or condensed print!"
+20 WRITE !
NEW ZTSAVE
SET ZTSAVE("^TMP(""SC"",$J,")=""
SET ZTSAVE("SC")=""
SET ZTSAVE("SUMON")=""
+21 DO EN^XUTMDEVQ(SCRTN,SCDESC,.ZTSAVE)
END ;K ^TMP("SC",$J) D DISP0^SCRPW23,END^SCRPW50 Q ;IHS/ANMC/LJF 11/2/2000
+1 ;IHS/ANMC/LJF 11/2/2000
KILL ^TMP("SC",$JOB)
DO DISP0^SCRPW23
QUIT
+2 ;
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 ;IHS/ANMC/LJF 11/2/2000
IF $EXTRACT(IOST,1,2)="C-"
DO ^BSDSCO6
QUIT
IHS ;EP; entry point for list template ;IHS/ANMC/LJF 11/2/2000
+1 NEW SCI,SCOUT
+2 KILL ^TMP("SCRPT",$JOB)
+3 SET SCOUT=0
+4 DO BUILD
IF SCOUT
QUIT
DO COUNT^SCRPO7
DO STOP
IF SCOUT
QUIT
+5 DO PRINT
+6 KILL ^TMP("SCRPT",$JOB),^TMP("SCRATCH",$JOB)
QUIT
+7 ;
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 DO CKTEAM^SCRPO7(SCTM)
DO STOP
+6 QUIT
End DoDot:2
+7 QUIT
End DoDot:1
QUIT
+8 ;build from all teams
+9 SET SCTM=0
FOR
SET SCTM=$ORDER(^SCTM(404.51,SCTM))
IF 'SCTM!SCOUT
QUIT
Begin DoDot:1
+10 DO CKTEAM^SCRPO7(SCTM)
DO STOP
+11 QUIT
End DoDot:1
+12 QUIT
+13 ;
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 IF SCOUT
QUIT
DO FOOT^SCRPO7
+23 IF $GET(SUMON)
QUIT
+24 IF $DATA(^TMP("SCRPT",$JOB,0,0,"TLIST"))
Begin DoDot:1
+25 SET SCTITL(2)=$$HDRX("T")
DO HDR^SCRPO(.SCTITL,132)
DO SHDR("T")
IF SCOUT
QUIT
+26 SET SCDIV=""
+27 FOR
SET SCDIV=$ORDER(^TMP("SCRPT",$JOB,0,0,"TLIST",SCDIV))
IF SCDIV=""!SCOUT
QUIT
Begin DoDot:2
+28 SET SCTEAM=""
+29 FOR
SET SCTEAM=$ORDER(^TMP("SCRPT",$JOB,0,0,"TLIST",SCDIV,SCTEAM))
IF SCTEAM=""!SCOUT
QUIT
Begin DoDot:3
+30 SET SCPNAM=""
+31 FOR
SET SCPNAM=$ORDER(^TMP("SCRPT",$JOB,0,0,"TLIST",SCDIV,SCTEAM,SCPNAM))
IF SCPNAM=""!SCOUT
QUIT
Begin DoDot:4
+32 SET SCI=0
+33 FOR
SET SCI=$ORDER(^TMP("SCRPT",$JOB,0,0,"TLIST",SCDIV,SCTEAM,SCPNAM,SCI))
IF 'SCI!SCOUT
QUIT
Begin DoDot:5
+34 SET SCX=^TMP("SCRPT",$JOB,0,0,"TLIST",SCDIV,SCTEAM,SCPNAM,SCI)
+35 DO TLINE(SCDIV,SCTEAM,SCPNAM,SCX)
+36 QUIT
End DoDot:5
+37 QUIT
End DoDot:4
+38 QUIT
End DoDot:3
+39 QUIT
End DoDot:2
+40 QUIT
End DoDot:1
+41 IF SCOUT
QUIT
IF $DATA(^TMP("SCRPT",$JOB,0,0,"PLIST"))
Begin DoDot:1
+42 SET SCTITL(2)=$$HDRX("TP")
DO HDR^SCRPO(.SCTITL,132)
DO SHDR("P")
IF SCOUT
QUIT
+43 SET SCDIV=""
+44 FOR
SET SCDIV=$ORDER(^TMP("SCRPT",$JOB,0,0,"PLIST",SCDIV))
IF SCDIV=""!SCOUT
QUIT
Begin DoDot:2
+45 SET SCTEAM=""
+46 FOR
SET SCTEAM=$ORDER(^TMP("SCRPT",$JOB,0,0,"PLIST",SCDIV,SCTEAM))
IF SCTEAM=""!SCOUT
QUIT
Begin DoDot:3
+47 SET SCPNAM=""
+48 FOR
SET SCPNAM=$ORDER(^TMP("SCRPT",$JOB,0,0,"PLIST",SCDIV,SCTEAM,SCPNAM))
IF SCPNAM=""!SCOUT
QUIT
Begin DoDot:4
+49 SET SCI=0
+50 FOR
SET SCI=$ORDER(^TMP("SCRPT",$JOB,0,0,"PLIST",SCDIV,SCTEAM,SCPNAM,SCI))
IF 'SCI!SCOUT
QUIT
Begin DoDot:5
+51 SET SCX=^TMP("SCRPT",$JOB,0,0,"PLIST",SCDIV,SCTEAM,SCPNAM,SCI)
+52 DO PLINE(SCDIV,SCTEAM,SCPNAM,SCX)
+53 QUIT
End DoDot:5
+54 QUIT
End DoDot:4
+55 QUIT
End DoDot:3
+56 QUIT
End DoDot:2
+57 QUIT
End DoDot:1
+58 IF 'SCOUT
IF $EXTRACT(IOST)="C"
NEW DIR
SET DIR(0)="E"
WRITE !
DO ^DIR
+59 QUIT
+60 ;
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 SET SCY="2^3^7^5^4^9^8^10^6^11^12"
+8 ;I $Y>(IOSL-SCPF) D FOOT^SCRPO7,HDR^SCRPO(.SCTITL,132),SHDR("S") S SCLF=0 ;IHS/ANMC/LJF 11/2/2000
+9 ;IHS/ANMC/LJF 11/2/2000
IF '$GET(VALM)
IF $Y>(IOSL-SCPF)
DO FOOT^SCRPO7
DO HDR^SCRPO(.SCTITL,132)
DO SHDR("S")
SET SCLF=0
+10 IF SCOUT
QUIT
IF SCPF>10&SCLF
WRITE !
+11 ;bp/djb Omit PC? column from REPORT TOTAL line.
+12 ;Old code start
+13 ;W !,$E($P(SCN,U),1,28),?30,$S($P(SCX,U)="":"NO",1:$P(SCX,U))
+14 ;Old code end
+15 ;New code start
+16 IF SCN["REPORT TOTAL"
WRITE !,$EXTRACT($PIECE(SCN,U),1,28)
+17 IF '$TEST
WRITE !,$EXTRACT($PIECE(SCN,U),1,28),?30,$SELECT($PIECE(SCX,U)="":"NO",1:$PIECE(SCX,U))
+18 ;New code end
+19 FOR SCI=1:1:11
WRITE ?(27+(9*SCI)),$JUSTIFY(+$PIECE(SCX,U,$PIECE(SCY,U,SCI)),6,0)
+20 SET SCLF=1
+21 QUIT
+22 ;
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 WRITE ?96,$TRANSLATE($PIECE(SCX,U,2),"-",""),?108,$PIECE(SCX,U,3),?121,$PIECE(SCX,U,4)
+11 QUIT
+12 ;
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 WRITE !,$PIECE(SCDIV,U),?24,$PIECE(SCTEAM,U),?48,SCPNAM,?72,$TRANSLATE($PIECE(SCX,U,2),"-","")
+10 WRITE ?84,$PIECE(SCX,U,5),?108,$PIECE(SCX,U,3),?121,$PIECE(SCX,U,4)
+11 QUIT
+12 ;
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)="<*> 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 WRITE !?56,"Team --Team Position- --Team Position- Total",?116,"Pts w/o Pts w/o"
+5 WRITE !,"Division",?38,"Max. Team Assign. ---Assignments-- ---Unique Pts.-- Unique Open Pos. Team"
+6 WRITE !?2,"Team",?30,"PC? Pts. Assign. Uniques PC",?72,"Non-PC PC",?90,"Non-PC Pts. Slots Assign. Assign."
+7 WRITE !,$EXTRACT(SCLINE,1,28)," ---"
FOR SCI=0:1:10
WRITE ?(35+(9*SCI)),"-------"
+8 QUIT
End DoDot:1
QUIT
+9 IF X="T"
Begin DoDot:1
+10 ;W !,"Division",?32,"Team",?64,"Patient Name",?96,"SSN",?108,"Active Date",?121,"Inact. Date" ;IHS/ANMC/LJF 11/2/2000
+11 ;IHS/ANMC/LJF 11/2/2000
WRITE !,"Division",?32,"Team",?64,"Patient Name",?96,"HRCN",?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 ;W !,"Division",?24,"Team",?48,"Patient Name",?72,"SSN",?84,"Team Position",?108,"Active Date",?121,"Inact. Date" ;IHS/ANMC/LJF 11/2/2000
+17 ;IHS/ANMC/LJF 11/2/2000
WRITE !,"Division",?24,"Team",?48,"Patient Name",?72,"HRCN",?84,"Team Position",?108,"Active Date",?121,"Inact. Date"
+18 WRITE !
FOR SCI=1:1:3
WRITE $EXTRACT(SCLINE,1,22)," "
+19 WRITE "---------- ",$EXTRACT(SCLINE,1,22)," ----------- -----------"
+20 QUIT
End DoDot:1
QUIT
+21 QUIT
