SCRPTM ;ALB/CMM - List of Team's Members Report ; 29 Jun 99 04:11PM
;;5.3;Scheduling;**41,48,52,181,177,520**;AUG 13, 1993;Build 26
;
;List of Team's Members Report
;
PROMPTS ;
;Prompt for Institution, Team, Date Range, User Class, Role
;and Print device
;
N VAUTD,VAUTT,VAUTUC,VAUTR,QTIME,RANG,PRNT,NUMBER
K VAUTD,VAUTT,VAUTUC,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 S RANG=$$DTRANG^SCRPU2() I +RANG=-1 G ERR
W ! K Y D USER^SCRPU1 I '$D(VAUTUC)&($P($G(^SD(404.91,1,"PCMM")),"^")=1) G ERR
W ! K Y D ROLE^SCRPU1 I '$D(VAUTR) G ERR
D QUE(.VAUTD,.VAUTT,.VAUTUC,.VAUTR,RANG) Q
;
QUE(INST,TEAM,USERC,ROLE,RANGE) ;queue report
;Input Parameters:
;INST - institutions selected (variable and array)
;TEAM - teams selected (variable and array)
;USERC - user classes selected (variable and array)
;ROLE - roles selected (variable and array)
;RANGE - date range selected (begin date ^ end date)
N ZTSAVE,II
F II="INST","TEAM","USERC","ROLE","INST(","TEAM(","USERC(","ROLE(","RANGE" S ZTSAVE(II)=""
W ! D EN^XUTMDEVQ("QENTRY^SCRPTM","Team Member Listing",.ZTSAVE)
Q
;
ENTRY2(INST,TEAM,USERC,ROLE,RANGE,IOP,ZTDTH) ;
;Second entry point for GUI to use
;Input Parameters:
;INST - institutions selected (variable and array)
;TEAM - teams selected (variable and array)
;USERC - user classes selected (variable and array)
;ROLE - roles selected (variable and array)
;RANGE - date range selected (begin date ^ end date)
;IOP - print device
;ZTDTH - queue time (optional)
;
;validate parameters
I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$D(RANGE)!'$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^SCRPTM"
S ZTDESC="List of Team's Members",ZTIO=IOP
N II
F II="INST","TEAM","USERC","ROLE","INST(","TEAM(","USERC(","ROLE(","RANGE","IOP" S ZTSAVE(II)=""
D ^%ZTLOAD
RET S NUMBER=0
I $D(ZTSK) S NUMBER=ZTSK
D EXIT1
Q NUMBER
;
QENTRY ;
;driver entry point
S TITL="Team Member Listing"
S STORE="^TMP("_$J_",""SCRPTM"")"
K @STORE
S @STORE=0
D BUILD
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,NODATA,RANGE,ROLE,USERC
Q
;
BUILD ;get report data
;get all practitioners for all teams selected
I TEAM=1 D TALL ;all teams selected
N TIEN,OKAY,XLIST,YLIST,SCTP,SCI,SCDT,PLIST
S SCDT("BEGIN")=$P(RANGE,U),SCDT("END")=$P(RANGE,U,2)
S SCDT("INCL")=0,SCDT="SCDT"
S TIEN="",PLIST="^TMP(""SCRP"",$J,""LIST"")"
F S TIEN=$O(TEAM(TIEN)) Q:TIEN=""!(TIEN'?.N) D
.K XLIST,@PLIST
.S OKAY=$$TPTM^SCAPMC(TIEN,.SCDT,"","","XLIST","ERROR")
.S SCTP=0 F S SCTP=$O(XLIST("SCTP",TIEN,SCTP)) Q:'SCTP D
..S SCTP0=$G(^SCTM(404.57,SCTP,0)) Q:'$L(SCTP0)
..I ROLE'=1,'$D(ROLE(+$P(SCTP0,U,3))) Q ;not a selected role
..I $D(USERC),USERC'=1,'$D(USERC(+$P(SCTP0,U,13))) Q ;not a selected user class
..K YLIST
..S OKAY=$$PRTP^SCAPMC(SCTP,.SCDT,"YLIST","ERROR",1,0)
..S SCI=0 F S SCI=$O(YLIST(SCI)) Q:'SCI D
...S @PLIST@(0)=$G(@PLIST@(0))+1
...S @PLIST@(@PLIST@(0))=YLIST(SCI)
...Q
..Q
.I OKAY D PULL^SCRPTM2(TIEN,.PLIST)
.Q
Q
;
TALL ;
;get all active team for divisions selected
N NXT,IIEN,NODE
S NXT=0,IIEN=""
;$O through team file and find all active teams for selected divisions
F S IIEN=$O(^SCTM(404.51,"AINST",IIEN)) Q:IIEN="" D
.I INST=1!$D(INST(IIEN)) D
..S TIEN=0
..F S TIEN=$O(^SCTM(404.51,"AINST",IIEN,TIEN)) Q:TIEN="" D
...I $$ACTTM^SCMCTMU(TIEN) S TEAM(TIEN)=""
Q
;
PRINTIT(STORE,TITL) ;
N INST,EINST,ETEAM,TEM,EPRACT,PRACT,PAGE,NXT,NPAGE,CNT,HEAD,POS
S EINST="",(NPAGE,STOP,HEAD)=0,PAGE=1 W:$E(IOST)="C" @IOF
D TITLE^SCRPU3(.PAGE,TITL)
F S EINST=$O(@STORE@("I",EINST)) Q:EINST=""!(STOP) D
.S INST=$O(@STORE@("I",EINST,""))
.Q:INST=""
.I 'NPAGE W !,$G(@STORE@(INST)) ;write institution line
.S (ETEAM,TEM)=""
.F S ETEAM=$O(@STORE@("T",INST,ETEAM)) Q:ETEAM=""!(STOP) D
..S TEM=$O(@STORE@("T",INST,ETEAM,0))
..I TEM="" Q
..S NXT="H"
..I NPAGE,(IOST'?1"C-".E) D NEWP^SCRPTM2(INST,TEM,TITL,.PAGE,.HEAD) S NPAGE=0
..I NPAGE,(IOST?1"C-".E) D HOLD1^SCRPTM2(.PAGE,TITL,INST,TEM,.HEAD) S NPAGE=0
..I STOP Q
..I IOST'?1"C-".E,$Y>(IOSL-5) D NEWP^SCRPTM2(INST,TEM,TITL,.PAGE,.HEAD)
..I IOST?1"C-".E,$Y>(IOSL-5) D HOLD1^SCRPTM2(.PAGE,TITL,INST,TEM,.HEAD)
..I STOP Q
..F S NXT=$O(@STORE@(INST,TEM,NXT)) Q:NXT'?1"H".E!(STOP) D
...I 'HEAD W !,$G(@STORE@(INST,TEM,NXT)) S HEAD=0 ;writes team info
..S (EPRACT,PRACT)=""
..W ! ;extra line between members and practioner list
..F S EPRACT=$O(@STORE@("PN",INST,TEM,EPRACT)) Q:EPRACT=""!(STOP) D
...F S PRACT=$O(@STORE@("PN",INST,TEM,EPRACT,PRACT)) Q:PRACT=""!(STOP) D
....I PRACT="" Q
....S POS=""
....F S POS=$O(@STORE@("PN",INST,TEM,EPRACT,PRACT,POS)) Q:POS=""!(STOP) D
.....D PRNTD(INST,TEM,PRACT,POS,TITL,.PAGE,.HEAD)
.....W ! ;seperated positions
....W ! ;separates practitioners
.S NPAGE=1
I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR
Q
;
PRNTD(INST,TEM,PRACT,POS,TITL,PAGE,HEAD) ;
;
N CNT,SCAC
S CNT=""
I IOST'?1"C-".E,$Y>(IOSL-11) D NEWP^SCRPTM2(INST,TEM,TITL,.PAGE,.HEAD)
I IOST?1"C-".E,$Y>(IOSL-11) D HOLD1^SCRPTM2(.PAGE,TITL,INST,TEM,.HEAD)
I STOP Q
F S CNT=$O(@STORE@(INST,TEM,PRACT,POS,CNT)) Q:CNT=""!(STOP) D
.W !,$G(@STORE@(INST,TEM,PRACT,POS,CNT))
.S SCAC="" I CNT=4 D
..F S SCAC=$O(@STORE@(INST,TEM,PRACT,POS,4,SCAC)) Q:SCAC=""!(STOP) D
...W !,$G(@STORE@(INST,TEM,PRACT,POS,4,SCAC))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPTM 5775 printed Nov 22, 2024@17:52:58 Page 2
SCRPTM ;ALB/CMM - List of Team's Members Report ; 29 Jun 99 04:11PM
+1 ;;5.3;Scheduling;**41,48,52,181,177,520**;AUG 13, 1993;Build 26
+2 ;
+3 ;List of Team's Members Report
+4 ;
PROMPTS ;
+1 ;Prompt for Institution, Team, Date Range, User Class, Role
+2 ;and Print device
+3 ;
+4 NEW VAUTD,VAUTT,VAUTUC,VAUTR,QTIME,RANG,PRNT,NUMBER
+5 KILL VAUTD,VAUTT,VAUTUC,VAUTR,SCUP
+6 SET QTIME=""
+7 WRITE !
DO INST^SCRPU1
IF Y=-1
GOTO ERR
+8 WRITE !
KILL Y
DO PRMTT^SCRPU1
IF '$DATA(VAUTT)
GOTO ERR
+9 WRITE !
KILL Y
SET RANG=$$DTRANG^SCRPU2()
IF +RANG=-1
GOTO ERR
+10 WRITE !
KILL Y
DO USER^SCRPU1
IF '$DATA(VAUTUC)&($PIECE($GET(^SD(404.91,1,"PCMM")),"^")=1)
GOTO ERR
+11 WRITE !
KILL Y
DO ROLE^SCRPU1
IF '$DATA(VAUTR)
GOTO ERR
+12 DO QUE(.VAUTD,.VAUTT,.VAUTUC,.VAUTR,RANG)
QUIT
+13 ;
QUE(INST,TEAM,USERC,ROLE,RANGE) ;queue report
+1 ;Input Parameters:
+2 ;INST - institutions selected (variable and array)
+3 ;TEAM - teams selected (variable and array)
+4 ;USERC - user classes selected (variable and array)
+5 ;ROLE - roles selected (variable and array)
+6 ;RANGE - date range selected (begin date ^ end date)
+7 NEW ZTSAVE,II
+8 FOR II="INST","TEAM","USERC","ROLE","INST(","TEAM(","USERC(","ROLE(","RANGE"
SET ZTSAVE(II)=""
+9 WRITE !
DO EN^XUTMDEVQ("QENTRY^SCRPTM","Team Member Listing",.ZTSAVE)
+10 QUIT
+11 ;
ENTRY2(INST,TEAM,USERC,ROLE,RANGE,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 ;USERC - user classes selected (variable and array)
+6 ;ROLE - roles selected (variable and array)
+7 ;RANGE - date range selected (begin date ^ end date)
+8 ;IOP - print device
+9 ;ZTDTH - queue time (optional)
+10 ;
+11 ;validate parameters
+12 IF '$DATA(INST)!'$DATA(TEAM)!'$DATA(ROLE)!'$DATA(RANGE)!'$DATA(IOP)!(IOP="")
QUIT
+13 ;
+14 NEW NUMBER
+15 SET IOST=$PIECE(IOP,"^",2)
SET IOP=$PIECE(IOP,"^")
+16 IF IOP?1"Q;".E
SET IOP=$PIECE(IOP,"Q;",2)
+17 IF IOST?1"C-".E
DO QENTRY
GOTO RET
+18 IF ZTDTH=""
SET ZTDTH=$HOROLOG
+19 SET ZTRTN="QENTRY^SCRPTM"
+20 SET ZTDESC="List of Team's Members"
SET ZTIO=IOP
+21 NEW II
+22 FOR II="INST","TEAM","USERC","ROLE","INST(","TEAM(","USERC(","ROLE(","RANGE","IOP"
SET ZTSAVE(II)=""
+23 DO ^%ZTLOAD
RET SET NUMBER=0
+1 IF $DATA(ZTSK)
SET NUMBER=ZTSK
+2 DO EXIT1
+3 QUIT NUMBER
+4 ;
QENTRY ;
+1 ;driver entry point
+2 SET TITL="Team Member Listing"
+3 SET STORE="^TMP("_$JOB_",""SCRPTM"")"
+4 KILL @STORE
+5 SET @STORE=0
+6 DO BUILD
+7 IF $ORDER(@STORE@(0))=""
SET NODATA=$$NODATA^SCRPU3(TITL)
+8 IF '$DATA(NODATA)
DO PRINTIT(STORE,TITL)
+9 DO EXIT2
+10 QUIT
+11 ;
ERR ;
EXIT1 ;
+1 KILL ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,SCUP
+2 QUIT
EXIT2 ;
+1 KILL @STORE
+2 KILL STOP,STORE,TITL,IOP,TEAM,INST,NODATA,RANGE,ROLE,USERC
+3 QUIT
+4 ;
BUILD ;get report data
+1 ;get all practitioners for all teams selected
+2 ;all teams selected
IF TEAM=1
DO TALL
+3 NEW TIEN,OKAY,XLIST,YLIST,SCTP,SCI,SCDT,PLIST
+4 SET SCDT("BEGIN")=$PIECE(RANGE,U)
SET SCDT("END")=$PIECE(RANGE,U,2)
+5 SET SCDT("INCL")=0
SET SCDT="SCDT"
+6 SET TIEN=""
SET PLIST="^TMP(""SCRP"",$J,""LIST"")"
+7 FOR
SET TIEN=$ORDER(TEAM(TIEN))
if TIEN=""!(TIEN'?.N)
QUIT
Begin DoDot:1
+8 KILL XLIST,@PLIST
+9 SET OKAY=$$TPTM^SCAPMC(TIEN,.SCDT,"","","XLIST","ERROR")
+10 SET SCTP=0
FOR
SET SCTP=$ORDER(XLIST("SCTP",TIEN,SCTP))
if 'SCTP
QUIT
Begin DoDot:2
+11 SET SCTP0=$GET(^SCTM(404.57,SCTP,0))
if '$LENGTH(SCTP0)
QUIT
+12 ;not a selected role
IF ROLE'=1
IF '$DATA(ROLE(+$PIECE(SCTP0,U,3)))
QUIT
+13 ;not a selected user class
IF $DATA(USERC)
IF USERC'=1
IF '$DATA(USERC(+$PIECE(SCTP0,U,13)))
QUIT
+14 KILL YLIST
+15 SET OKAY=$$PRTP^SCAPMC(SCTP,.SCDT,"YLIST","ERROR",1,0)
+16 SET SCI=0
FOR
SET SCI=$ORDER(YLIST(SCI))
if 'SCI
QUIT
Begin DoDot:3
+17 SET @PLIST@(0)=$GET(@PLIST@(0))+1
+18 SET @PLIST@(@PLIST@(0))=YLIST(SCI)
+19 QUIT
End DoDot:3
+20 QUIT
End DoDot:2
+21 IF OKAY
DO PULL^SCRPTM2(TIEN,.PLIST)
+22 QUIT
End DoDot:1
+23 QUIT
+24 ;
TALL ;
+1 ;get all active team for divisions selected
+2 NEW NXT,IIEN,NODE
+3 SET NXT=0
SET IIEN=""
+4 ;$O through team file and find all active teams for selected divisions
+5 FOR
SET IIEN=$ORDER(^SCTM(404.51,"AINST",IIEN))
if IIEN=""
QUIT
Begin DoDot:1
+6 IF INST=1!$DATA(INST(IIEN))
Begin DoDot:2
+7 SET TIEN=0
+8 FOR
SET TIEN=$ORDER(^SCTM(404.51,"AINST",IIEN,TIEN))
if TIEN=""
QUIT
Begin DoDot:3
+9 IF $$ACTTM^SCMCTMU(TIEN)
SET TEAM(TIEN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
PRINTIT(STORE,TITL) ;
+1 NEW INST,EINST,ETEAM,TEM,EPRACT,PRACT,PAGE,NXT,NPAGE,CNT,HEAD,POS
+2 SET EINST=""
SET (NPAGE,STOP,HEAD)=0
SET PAGE=1
if $EXTRACT(IOST)="C"
WRITE @IOF
+3 DO TITLE^SCRPU3(.PAGE,TITL)
+4 FOR
SET EINST=$ORDER(@STORE@("I",EINST))
if EINST=""!(STOP)
QUIT
Begin DoDot:1
+5 SET INST=$ORDER(@STORE@("I",EINST,""))
+6 if INST=""
QUIT
+7 ;write institution line
IF 'NPAGE
WRITE !,$GET(@STORE@(INST))
+8 SET (ETEAM,TEM)=""
+9 FOR
SET ETEAM=$ORDER(@STORE@("T",INST,ETEAM))
if ETEAM=""!(STOP)
QUIT
Begin DoDot:2
+10 SET TEM=$ORDER(@STORE@("T",INST,ETEAM,0))
+11 IF TEM=""
QUIT
+12 SET NXT="H"
+13 IF NPAGE
IF (IOST'?1"C-".E)
DO NEWP^SCRPTM2(INST,TEM,TITL,.PAGE,.HEAD)
SET NPAGE=0
+14 IF NPAGE
IF (IOST?1"C-".E)
DO HOLD1^SCRPTM2(.PAGE,TITL,INST,TEM,.HEAD)
SET NPAGE=0
+15 IF STOP
QUIT
+16 IF IOST'?1"C-".E
IF $Y>(IOSL-5)
DO NEWP^SCRPTM2(INST,TEM,TITL,.PAGE,.HEAD)
+17 IF IOST?1"C-".E
IF $Y>(IOSL-5)
DO HOLD1^SCRPTM2(.PAGE,TITL,INST,TEM,.HEAD)
+18 IF STOP
QUIT
+19 FOR
SET NXT=$ORDER(@STORE@(INST,TEM,NXT))
if NXT'?1"H".E!(STOP)
QUIT
Begin DoDot:3
+20 ;writes team info
IF 'HEAD
WRITE !,$GET(@STORE@(INST,TEM,NXT))
SET HEAD=0
End DoDot:3
+21 SET (EPRACT,PRACT)=""
+22 ;extra line between members and practioner list
WRITE !
+23 FOR
SET EPRACT=$ORDER(@STORE@("PN",INST,TEM,EPRACT))
if EPRACT=""!(STOP)
QUIT
Begin DoDot:3
+24 FOR
SET PRACT=$ORDER(@STORE@("PN",INST,TEM,EPRACT,PRACT))
if PRACT=""!(STOP)
QUIT
Begin DoDot:4
+25 IF PRACT=""
QUIT
+26 SET POS=""
+27 FOR
SET POS=$ORDER(@STORE@("PN",INST,TEM,EPRACT,PRACT,POS))
if POS=""!(STOP)
QUIT
Begin DoDot:5
+28 DO PRNTD(INST,TEM,PRACT,POS,TITL,.PAGE,.HEAD)
+29 ;seperated positions
WRITE !
End DoDot:5
+30 ;separates practitioners
WRITE !
End DoDot:4
End DoDot:3
End DoDot:2
+31 SET NPAGE=1
End DoDot:1
+32 IF 'STOP
IF $EXTRACT(IOST)="C"
NEW DIR
SET DIR(0)="E"
WRITE !
DO ^DIR
+33 QUIT
+34 ;
PRNTD(INST,TEM,PRACT,POS,TITL,PAGE,HEAD) ;
+1 ;
+2 NEW CNT,SCAC
+3 SET CNT=""
+4 IF IOST'?1"C-".E
IF $Y>(IOSL-11)
DO NEWP^SCRPTM2(INST,TEM,TITL,.PAGE,.HEAD)
+5 IF IOST?1"C-".E
IF $Y>(IOSL-11)
DO HOLD1^SCRPTM2(.PAGE,TITL,INST,TEM,.HEAD)
+6 IF STOP
QUIT
+7 FOR
SET CNT=$ORDER(@STORE@(INST,TEM,PRACT,POS,CNT))
if CNT=""!(STOP)
QUIT
Begin DoDot:1
+8 WRITE !,$GET(@STORE@(INST,TEM,PRACT,POS,CNT))
+9 SET SCAC=""
IF CNT=4
Begin DoDot:2
+10 FOR
SET SCAC=$ORDER(@STORE@(INST,TEM,PRACT,POS,4,SCAC))
if SCAC=""!(STOP)
QUIT
Begin DoDot:3
+11 WRITE !,$GET(@STORE@(INST,TEM,PRACT,POS,4,SCAC))
End DoDot:3
End DoDot:2
End DoDot:1
+12 QUIT
