SCRPSLT ;ALB/CMM - Summary Listing of Teams ; 29 Jun 99 04:11PM
;;5.3;Scheduling;**41,52,177,231,520,1015**;AUG 13, 1993;Build 21
;IHS/ANMC/LJF 11/02/2000 changed 132 column message
; added call to list template
;
;Summary Listing of Teams Report
;
PROMPTS ;
;Prompt for Institution, Team, Role and Print device
;
N VAUTD,VAUTT,VAUTR,QTIME,PRNT,NUMBER
K VAUTD,VAUTT,VAUTR,SCUP
S QTIME=""
W ! D INST^SCRPU1 I Y=-1 G ERR
W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR
W ! K Y D ROLE^SCRPU1 I '$D(VAUTR) G ERR
;W !!,"This report requires 132 column output!" ;IHS/ANMC/LJF 11/02/2000
W !!,"This report, when printed on paper, requires wide paper or condensed print!" ;IHS/ANMC/LJF 11/02/2000
D QUE(.VAUTD,.VAUTT,.VAUTR) Q
;
QUE(INST,TEAM,ROLE) ;queue report
;Input Parameters:
;INST - institutions selected (variable and array)
;TEAM - teams selected (variable and array)
;ROLE - roles selected (variable and array)
N ZTSAVE,II
F II="INST","TEAM","ROLE","INST(","TEAM(","ROLE(" S ZTSAVE(II)=""
W ! D EN^XUTMDEVQ("QENTRY^SCRPSLT","Summary Listing of Teams",.ZTSAVE)
Q
;
ENTRY2(INST,TEAM,ROLE,IOP,ZTDTH) ;
;Second entry point for GUI to use
;Input Parameters:
;INST - institutions selected (variable and array)
;TEAM - teams selected (variable and array)
;ROLE - roles selected (variable and array)
;IOP - print device
;ZTDTH - queue time (optional)
;
;validate parameters
I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$D(IOP)!(IOP="") Q
;
N NUMBER
S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^")
I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2)
I IOST?1"C-".E D QENTRY G RET
I ZTDTH="" S ZTDTH=$H
S ZTRTN="QENTRY^SCRPSLT"
S ZTDESC="Summary Listing Of Teams",ZTIO=IOP
N II
F II="INST","TEAM","ROLE","INST(","TEAM(","ROLE(","IOP" S ZTSAVE(II)=""
D ^%ZTLOAD
RET S NUMBER=0
I $D(ZTSK) S NUMBER=ZTSK
D EXIT1
Q NUMBER
;
QENTRY ;
I $E(IOST,1,2)="C-" D ^BSDSCSLT Q ;IHS/ANMC/LJF 11/02/2000
IHS ;EP; entry point for list template ;IHS/ANMC/LJF 11/02/2000
;driver entry point
S TITL="Summary Listing of Teams"
S STORE="^TMP("_$J_",""SCRPSLT"")"
K @STORE
S @STORE=0
I TEAM=1 D TALL^SCRPPAT3 S TEAM=0
D FIND
I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL)
I '$D(NODATA) D PRINTIT(STORE,TITL)
D EXIT2
Q
;
ERR ;
EXIT1 ;
K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,SCUP
Q
;
EXIT2 ;
K @STORE
K STOP,STORE,TITL,IOP,TEAM,INST,ROLE,NODATA
Q
;
FIND ;
N TM,EN2,EN,ROL,NODE,TEND,ACT,INA,TPASS,TPCN,TMAX,TMP,TOA,TNPC
S TM=""
F S TM=$O(^SCTM(404.57,"C",TM)) Q:TM="" D
.;$O through team position file
.I '$D(TEAM(TM))&(TEAM'=1) Q
.;Q above, not a selected team
.;selected team
.S EN=""
.S TPASS(TM)=0,TMAX(TM)=0,TPCN(TM)=0
.F S EN=$O(^SCTM(404.57,"C",TM,EN)) Q:EN="" D
..I '$D(^SCTM(404.57,EN,0)) Q
..S NODE=$G(^SCTM(404.57,EN,0))
..Q:NODE=""
..S ROL=+$P(NODE,"^",3) ;role ien
..I '$D(ROLE(ROL))&(ROLE'=1) Q
..;Q above not a selected role
..;find active position during date range
..S TMP=$$DATES^SCAPMCU1(404.52,EN,DT)
..I +TMP=0 Q
..S EN2=+$P(TMP,"^",4)
..D KEEP^SCRPSLT2(NODE,EN,EN2,ROL,TM,.TPCN,.TNPC)
..S TPASS(TM)=$$TEAMCNT^SCAPMCU1(TM,DT)
..S TMAX(TM)=+$P($G(^SCTM(404.51,+TM,0)),U,8)
..S TOA(TM)=TMAX(TM)-TPASS(TM) S:TOA(TM)<0 TOA(TM)=0
..D TEAMT^SCRPSLT2(TM,.TPASS,.TMAX,.TPCN,.TOA,.TNPC)
Q
;
PRINTIT(STORE,TITL) ;
N INST,EINST,ETEAM,TEM,EPRACT,PRACT,NXT,PAGE,NPAGE,NEW,POS,SCAC
S (INST,EINST)="",(NPAGE,STOP)=0,PAGE=1 W:$E(IOST)="C" @IOF
D TITLE^SCRPU3(.PAGE,TITL)
D FORHEAD^SCRPSLT2
F S EINST=$O(@STORE@("I",EINST)) Q:EINST=""!(STOP) D
.S INST=$O(@STORE@("I",EINST,""))
.I INST="" Q
.S (TEM,ETEAM)=""
.F S ETEAM=$O(@STORE@("T",INST,ETEAM)) Q:ETEAM=""!(STOP) D
..S TEM=$O(@STORE@("T",INST,ETEAM,""))
..I TEM="" Q
..K NEW
..I NPAGE,(IOST'?1"C-".E) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE) S NEW=""
..I NPAGE,(IOST?1"C-".E) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM) S NEW=""
..S NPAGE=1 I STOP Q
..I IOST'?1"C-".E,$Y>(IOSL-8) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE) S NEW=""
..I IOST?1"C-".E,$Y>(IOSL-8) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM) S NEW=""
..I STOP Q
..I '$D(NEW) D HEADER^SCRPSLT2(INST,TEM)
..S (PRACT,EPRACT)=""
..F S EPRACT=$O(@STORE@("PN",INST,TEM,EPRACT)) Q:EPRACT=""!(STOP) D
...S PRACT=$O(@STORE@("PN",INST,TEM,EPRACT,""))
...I PRACT="" Q
...S POS=""
...F S POS=$O(@STORE@(INST,TEM,PRACT,POS)) Q:POS=""!(STOP) D
....W !,$G(@STORE@(INST,TEM,PRACT,POS))
....S SCAC=""
....F S SCAC=$O(@STORE@(INST,TEM,PRACT,POS,SCAC)) Q:SCAC=""!(STOP) D
.....W !,$G(@STORE@(INST,TEM,PRACT,POS,SCAC))
.....I IOST'?1"C-".E,$Y>(IOSL-4) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE)
.....I IOST?1"C-".E,$Y>(IOSL-4) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM)
.....I STOP Q
....;W !,$G(@STORE@(INST,TEM,PRACT,POS)) ;writes info
..Q:STOP
..I IOST'?1"C-".E,$Y>(IOSL-8) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE,1)
..I IOST?1"C-".E,$Y>(IOSL-8) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM,1)
..D TOTAL^SCRPSLT2(INST,TEM)
.I STOP Q
.S NPAGE=1
I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" D ^DIR
Q
SCRPSLT ;ALB/CMM - Summary Listing of Teams ; 29 Jun 99 04:11PM
+1 ;;5.3;Scheduling;**41,52,177,231,520,1015**;AUG 13, 1993;Build 21
+2 ;IHS/ANMC/LJF 11/02/2000 changed 132 column message
+3 ; added call to list template
+4 ;
+5 ;Summary Listing of Teams Report
+6 ;
PROMPTS ;
+1 ;Prompt for Institution, Team, Role and Print device
+2 ;
+3 NEW VAUTD,VAUTT,VAUTR,QTIME,PRNT,NUMBER
+4 KILL VAUTD,VAUTT,VAUTR,SCUP
+5 SET QTIME=""
+6 WRITE !
DO INST^SCRPU1
IF Y=-1
GOTO ERR
+7 WRITE !
KILL Y
DO PRMTT^SCRPU1
IF '$DATA(VAUTT)
GOTO ERR
+8 WRITE !
KILL Y
DO ROLE^SCRPU1
IF '$DATA(VAUTR)
GOTO ERR
+9 ;W !!,"This report requires 132 column output!" ;IHS/ANMC/LJF 11/02/2000
+10 ;IHS/ANMC/LJF 11/02/2000
WRITE !!,"This report, when printed on paper, requires wide paper or condensed print!"
+11 DO QUE(.VAUTD,.VAUTT,.VAUTR)
QUIT
+12 ;
QUE(INST,TEAM,ROLE) ;queue report
+1 ;Input Parameters:
+2 ;INST - institutions selected (variable and array)
+3 ;TEAM - teams selected (variable and array)
+4 ;ROLE - roles selected (variable and array)
+5 NEW ZTSAVE,II
+6 FOR II="INST","TEAM","ROLE","INST(","TEAM(","ROLE("
SET ZTSAVE(II)=""
+7 WRITE !
DO EN^XUTMDEVQ("QENTRY^SCRPSLT","Summary Listing of Teams",.ZTSAVE)
+8 QUIT
+9 ;
ENTRY2(INST,TEAM,ROLE,IOP,ZTDTH) ;
+1 ;Second entry point for GUI to use
+2 ;Input Parameters:
+3 ;INST - institutions selected (variable and array)
+4 ;TEAM - teams selected (variable and array)
+5 ;ROLE - roles selected (variable and array)
+6 ;IOP - print device
+7 ;ZTDTH - queue time (optional)
+8 ;
+9 ;validate parameters
+10 IF '$DATA(INST)!'$DATA(TEAM)!'$DATA(ROLE)!'$DATA(IOP)!(IOP="")
QUIT
+11 ;
+12 NEW NUMBER
+13 SET IOST=$PIECE(IOP,"^",2)
SET IOP=$PIECE(IOP,"^")
+14 IF IOP?1"Q;".E
SET IOP=$PIECE(IOP,"Q;",2)
+15 IF IOST?1"C-".E
DO QENTRY
GOTO RET
+16 IF ZTDTH=""
SET ZTDTH=$HOROLOG
+17 SET ZTRTN="QENTRY^SCRPSLT"
+18 SET ZTDESC="Summary Listing Of Teams"
SET ZTIO=IOP
+19 NEW II
+20 FOR II="INST","TEAM","ROLE","INST(","TEAM(","ROLE(","IOP"
SET ZTSAVE(II)=""
+21 DO ^%ZTLOAD
RET SET NUMBER=0
+1 IF $DATA(ZTSK)
SET NUMBER=ZTSK
+2 DO EXIT1
+3 QUIT NUMBER
+4 ;
QENTRY ;
+1 ;IHS/ANMC/LJF 11/02/2000
IF $EXTRACT(IOST,1,2)="C-"
DO ^BSDSCSLT
QUIT
IHS ;EP; entry point for list template ;IHS/ANMC/LJF 11/02/2000
+1 ;driver entry point
+2 SET TITL="Summary Listing of Teams"
+3 SET STORE="^TMP("_$JOB_",""SCRPSLT"")"
+4 KILL @STORE
+5 SET @STORE=0
+6 IF TEAM=1
DO TALL^SCRPPAT3
SET TEAM=0
+7 DO FIND
+8 IF $ORDER(@STORE@(0))=""
SET NODATA=$$NODATA^SCRPU3(TITL)
+9 IF '$DATA(NODATA)
DO PRINTIT(STORE,TITL)
+10 DO EXIT2
+11 QUIT
+12 ;
ERR ;
EXIT1 ;
+1 KILL ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,SCUP
+2 QUIT
+3 ;
EXIT2 ;
+1 KILL @STORE
+2 KILL STOP,STORE,TITL,IOP,TEAM,INST,ROLE,NODATA
+3 QUIT
+4 ;
FIND ;
+1 NEW TM,EN2,EN,ROL,NODE,TEND,ACT,INA,TPASS,TPCN,TMAX,TMP,TOA,TNPC
+2 SET TM=""
+3 FOR
SET TM=$ORDER(^SCTM(404.57,"C",TM))
IF TM=""
QUIT
Begin DoDot:1
+4 ;$O through team position file
+5 IF '$DATA(TEAM(TM))&(TEAM'=1)
QUIT
+6 ;Q above, not a selected team
+7 ;selected team
+8 SET EN=""
+9 SET TPASS(TM)=0
SET TMAX(TM)=0
SET TPCN(TM)=0
+10 FOR
SET EN=$ORDER(^SCTM(404.57,"C",TM,EN))
IF EN=""
QUIT
Begin DoDot:2
+11 IF '$DATA(^SCTM(404.57,EN,0))
QUIT
+12 SET NODE=$GET(^SCTM(404.57,EN,0))
+13 IF NODE=""
QUIT
+14 ;role ien
SET ROL=+$PIECE(NODE,"^",3)
+15 IF '$DATA(ROLE(ROL))&(ROLE'=1)
QUIT
+16 ;Q above not a selected role
+17 ;find active position during date range
+18 SET TMP=$$DATES^SCAPMCU1(404.52,EN,DT)
+19 IF +TMP=0
QUIT
+20 SET EN2=+$PIECE(TMP,"^",4)
+21 DO KEEP^SCRPSLT2(NODE,EN,EN2,ROL,TM,.TPCN,.TNPC)
+22 SET TPASS(TM)=$$TEAMCNT^SCAPMCU1(TM,DT)
+23 SET TMAX(TM)=+$PIECE($GET(^SCTM(404.51,+TM,0)),U,8)
+24 SET TOA(TM)=TMAX(TM)-TPASS(TM)
IF TOA(TM)<0
SET TOA(TM)=0
+25 DO TEAMT^SCRPSLT2(TM,.TPASS,.TMAX,.TPCN,.TOA,.TNPC)
End DoDot:2
End DoDot:1
+26 QUIT
+27 ;
PRINTIT(STORE,TITL) ;
+1 NEW INST,EINST,ETEAM,TEM,EPRACT,PRACT,NXT,PAGE,NPAGE,NEW,POS,SCAC
+2 SET (INST,EINST)=""
SET (NPAGE,STOP)=0
SET PAGE=1
IF $EXTRACT(IOST)="C"
WRITE @IOF
+3 DO TITLE^SCRPU3(.PAGE,TITL)
+4 DO FORHEAD^SCRPSLT2
+5 FOR
SET EINST=$ORDER(@STORE@("I",EINST))
IF EINST=""!(STOP)
QUIT
Begin DoDot:1
+6 SET INST=$ORDER(@STORE@("I",EINST,""))
+7 IF INST=""
QUIT
+8 SET (TEM,ETEAM)=""
+9 FOR
SET ETEAM=$ORDER(@STORE@("T",INST,ETEAM))
IF ETEAM=""!(STOP)
QUIT
Begin DoDot:2
+10 SET TEM=$ORDER(@STORE@("T",INST,ETEAM,""))
+11 IF TEM=""
QUIT
+12 KILL NEW
+13 IF NPAGE
IF (IOST'?1"C-".E)
DO NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE)
SET NEW=""
+14 IF NPAGE
IF (IOST?1"C-".E)
DO HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM)
SET NEW=""
+15 SET NPAGE=1
IF STOP
QUIT
+16 IF IOST'?1"C-".E
IF $Y>(IOSL-8)
DO NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE)
SET NEW=""
+17 IF IOST?1"C-".E
IF $Y>(IOSL-8)
DO HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM)
SET NEW=""
+18 IF STOP
QUIT
+19 IF '$DATA(NEW)
DO HEADER^SCRPSLT2(INST,TEM)
+20 SET (PRACT,EPRACT)=""
+21 FOR
SET EPRACT=$ORDER(@STORE@("PN",INST,TEM,EPRACT))
IF EPRACT=""!(STOP)
QUIT
Begin DoDot:3
+22 SET PRACT=$ORDER(@STORE@("PN",INST,TEM,EPRACT,""))
+23 IF PRACT=""
QUIT
+24 SET POS=""
+25 FOR
SET POS=$ORDER(@STORE@(INST,TEM,PRACT,POS))
IF POS=""!(STOP)
QUIT
Begin DoDot:4
+26 WRITE !,$GET(@STORE@(INST,TEM,PRACT,POS))
+27 SET SCAC=""
+28 FOR
SET SCAC=$ORDER(@STORE@(INST,TEM,PRACT,POS,SCAC))
IF SCAC=""!(STOP)
QUIT
Begin DoDot:5
+29 WRITE !,$GET(@STORE@(INST,TEM,PRACT,POS,SCAC))
+30 IF IOST'?1"C-".E
IF $Y>(IOSL-4)
DO NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE)
+31 IF IOST?1"C-".E
IF $Y>(IOSL-4)
DO HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM)
+32 IF STOP
QUIT
End DoDot:5
+33 ;W !,$G(@STORE@(INST,TEM,PRACT,POS)) ;writes info
End DoDot:4
End DoDot:3
+34 IF STOP
QUIT
+35 IF IOST'?1"C-".E
IF $Y>(IOSL-8)
DO NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE,1)
+36 IF IOST?1"C-".E
IF $Y>(IOSL-8)
DO HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM,1)
+37 DO TOTAL^SCRPSLT2(INST,TEM)
End DoDot:2
+38 IF STOP
QUIT
+39 SET NPAGE=1
End DoDot:1
+40 IF 'STOP
IF $EXTRACT(IOST)="C"
NEW DIR
SET DIR(0)="E"
DO ^DIR
+41 QUIT
