SCRPITP ;ALB/CMM - Individual Team Profile ; 29 Jun 99 04:11PM
;;5.3;Scheduling;**41,52,177,520**;AUG 13, 1993;Build 26
;
;Individual Team Profile
;
PROMPTS ;
;Prompt for Institution, Team, and Print device
;
N QTIME,PRNT,VAUTD,VAUTT,Y,NUMBER
K VAUTD,VAUTT,SCUP
S QTIME=""
W ! D INST^SCRPU1 I Y=-1 G ERR
W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR
W !!,"This report requires 132 column output!"
D QUE(.VAUTD,.VAUTT) Q
;
QUE(INST,TEAM) ;queue report
;Input Parameters:
;INST - institutions selected (variable and array)
;TEAM - teams selected (variable and array)
N ZTSAVE,II
F II="INST","TEAM","INST(","TEAM(" S ZTSAVE(II)=""
W ! D EN^XUTMDEVQ("QENTRY^SCRPITP","Individual Team Profile",.ZTSAVE)
Q
;
ENTRY2(INST,TEAM,IOP,ZTDTH) ;
;Second entry point for GUI to use
;Input Parameters:
;INST - institutions selected (variable and array)
;TEAM - teams selected (variable and array)
;IOP - print device
;ZTDTH - queue time (optional)
;
;validate parameters
I '$D(INST)!'$D(TEAM)!'$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^SCRPITP"
S ZTDESC="iIndividual Team Profile",ZTIO=IOP
N II
F II="INST","TEAM","INST(","TEAM(","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="Individual Team Profile"
S STORE="^TMP("_$J_",""SCRPITP"")"
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
Q
;
EXIT2 ;
K @STORE
K STOP,STORE,TITL,IOP,TEAM,INST,NODATA
Q
;
FIND ;
N TM,EN,NODE,TMP,TPNAME
S TM="" K ^TMP("SCRATCH",$J)
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=""
.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=""
..;active or inactive position
..S TMP=$$DATES^SCAPMCU1(404.59,EN,DT)
..S TPNAME=$P(NODE,U) S:'$L(TPNAME) TPNAME="~~~"
..S ^TMP("SCRATCH",$J,TPNAME,EN)=NODE
..I +TMP S ^TMP("SCRATCH",$J,TM,TPNAME,EN)=NODE
..Q
.Q
S TM=""
F S TM=$O(^TMP("SCRATCH",$J,TM)) Q:TM="" S TPNAME="" D
.F S TPNAME=$O(^TMP("SCRATCH",$J,TM,TPNAME)) Q:TPNAME="" S EN="" D
..F S EN=$O(^TMP("SCRATCH",$J,TM,TPNAME,EN)) Q:EN="" D
...S NODE=^TMP("SCRATCH",$J,TM,TPNAME,EN)
...D KEEP^SCRPITP2(NODE,EN,TM)
...Q
..Q
.Q
Q
;
PRINTIT(STORE,TITL) ;
N INST,EINST,ETEAM,TEM,NEW,PAGE,TNAME,TIEN,EN,SUB,POS,CIEN,INF,ACL
S (INST,EINST)="",STOP=0,(PAGE,NEW)=1 W:$E(IOST)="C" @IOF
D FORHEAD^SCRPITP2
F S EINST=$O(@STORE@("I",EINST)) Q:EINST=""!(STOP) D
.S INST=$O(@STORE@("I",EINST,""))
.I INST="" Q
.I STOP Q
.;write team info
.S TNAME=""
.F S TNAME=$O(@STORE@("T",INST,TNAME)) Q:TNAME=""!(STOP) D
..D:NEW TITLE^SCRPU3(.PAGE,TITL,132)
..I 'NEW,$E(IOST)'="C" D NEWP1^SCRPU3(.PAGE,TITL,132)
..I 'NEW,$E(IOST)="C" D HOLD^SCRPU3(.PAGE,TITL,132)
..W !,$G(@STORE@(INST)),! S NEW=""
..S TIEN=$O(@STORE@("T",INST,TNAME,""))
..I TIEN="" Q
..F SUB="TI","D" D
...Q:STOP
...I '$D(@STORE@(INST,TIEN,SUB)) Q
...S EN=""
...F S EN=$O(@STORE@(INST,TIEN,SUB,EN)) Q:EN=""!(STOP) D
....I IOST'?1"C-".E,$Y>(IOSL-5) D NEWP1^SCRPU3(.PAGE,TITL,132)
....I IOST?1"C-".E,$Y>(IOSL-5) D HOLD^SCRPU3(.PAGE,TITL,132)
....I STOP Q
....I '$D(NEW) W !,$G(@STORE@(INST)),!,$G(@STORE@(INST,TIEN)),!
....W !,$G(@STORE@(INST,TIEN,SUB,EN))
...W !
..;write position info
..S POS=""
..I $Y<IOSL-10 D COLUMN^SCRPITP2
..F S POS=$O(@STORE@(INST,TIEN,"P",POS)) Q:POS=""!(STOP) D
...W !,$G(@STORE@(INST,TIEN,"P",POS))
...S ACL=""
...F S ACL=$O(@STORE@(INST,TIEN,"P",POS,ACL)) Q:ACL=""!(STOP) D
....W !,$G(@STORE@(INST,TIEN,"P",POS,ACL))
....I IOST'?1"C-".E,$Y>(IOSL-5) D NEWP1^SCRPU3(.PAGE,TITL,132) Q:STOP D CONT^SCRPITP2
....I IOST?1"C-".E,$Y>(IOSL-5) D HOLD^SCRPU3(.PAGE,TITL,132) Q:STOP D CONT^SCRPITP2
....I STOP Q
...;W !,$G(@STORE@(INST,TIEN,"P",POS))
...;W !,$G(@STORE@(INST,TIEN,"P",POS,ACL))
...W !
I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPITP 4423 printed Dec 13, 2024@02:42:33 Page 2
SCRPITP ;ALB/CMM - Individual Team Profile ; 29 Jun 99 04:11PM
+1 ;;5.3;Scheduling;**41,52,177,520**;AUG 13, 1993;Build 26
+2 ;
+3 ;Individual Team Profile
+4 ;
PROMPTS ;
+1 ;Prompt for Institution, Team, and Print device
+2 ;
+3 NEW QTIME,PRNT,VAUTD,VAUTT,Y,NUMBER
+4 KILL VAUTD,VAUTT,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 !!,"This report requires 132 column output!"
+9 DO QUE(.VAUTD,.VAUTT)
QUIT
+10 ;
QUE(INST,TEAM) ;queue report
+1 ;Input Parameters:
+2 ;INST - institutions selected (variable and array)
+3 ;TEAM - teams selected (variable and array)
+4 NEW ZTSAVE,II
+5 FOR II="INST","TEAM","INST(","TEAM("
SET ZTSAVE(II)=""
+6 WRITE !
DO EN^XUTMDEVQ("QENTRY^SCRPITP","Individual Team Profile",.ZTSAVE)
+7 QUIT
+8 ;
ENTRY2(INST,TEAM,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 ;IOP - print device
+6 ;ZTDTH - queue time (optional)
+7 ;
+8 ;validate parameters
+9 IF '$DATA(INST)!'$DATA(TEAM)!'$DATA(IOP)!(IOP="")
QUIT
+10 ;
+11 NEW NUMBER
+12 SET IOST=$PIECE(IOP,"^",2)
SET IOP=$PIECE(IOP,"^")
+13 IF IOP?1"Q;".E
SET IOP=$PIECE(IOP,"Q;",2)
+14 IF IOST?1"C-".E
DO QENTRY
GOTO RET
+15 IF ZTDTH=""
SET ZTDTH=$HOROLOG
+16 SET ZTRTN="QENTRY^SCRPITP"
+17 SET ZTDESC="iIndividual Team Profile"
SET ZTIO=IOP
+18 NEW II
+19 FOR II="INST","TEAM","INST(","TEAM(","IOP"
SET ZTSAVE(II)=""
+20 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="Individual Team Profile"
+3 SET STORE="^TMP("_$JOB_",""SCRPITP"")"
+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
+2 QUIT
+3 ;
EXIT2 ;
+1 KILL @STORE
+2 KILL STOP,STORE,TITL,IOP,TEAM,INST,NODATA
+3 QUIT
+4 ;
FIND ;
+1 NEW TM,EN,NODE,TMP,TPNAME
+2 SET TM=""
KILL ^TMP("SCRATCH",$JOB)
+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 FOR
SET EN=$ORDER(^SCTM(404.57,"C",TM,EN))
if EN=""
QUIT
Begin DoDot:2
+10 IF '$DATA(^SCTM(404.57,EN,0))
QUIT
+11 SET NODE=$GET(^SCTM(404.57,EN,0))
+12 if NODE=""
QUIT
+13 ;active or inactive position
+14 SET TMP=$$DATES^SCAPMCU1(404.59,EN,DT)
+15 SET TPNAME=$PIECE(NODE,U)
if '$LENGTH(TPNAME)
SET TPNAME="~~~"
+16 SET ^TMP("SCRATCH",$JOB,TPNAME,EN)=NODE
+17 IF +TMP
SET ^TMP("SCRATCH",$JOB,TM,TPNAME,EN)=NODE
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 SET TM=""
+21 FOR
SET TM=$ORDER(^TMP("SCRATCH",$JOB,TM))
if TM=""
QUIT
SET TPNAME=""
Begin DoDot:1
+22 FOR
SET TPNAME=$ORDER(^TMP("SCRATCH",$JOB,TM,TPNAME))
if TPNAME=""
QUIT
SET EN=""
Begin DoDot:2
+23 FOR
SET EN=$ORDER(^TMP("SCRATCH",$JOB,TM,TPNAME,EN))
if EN=""
QUIT
Begin DoDot:3
+24 SET NODE=^TMP("SCRATCH",$JOB,TM,TPNAME,EN)
+25 DO KEEP^SCRPITP2(NODE,EN,TM)
+26 QUIT
End DoDot:3
+27 QUIT
End DoDot:2
+28 QUIT
End DoDot:1
+29 QUIT
+30 ;
PRINTIT(STORE,TITL) ;
+1 NEW INST,EINST,ETEAM,TEM,NEW,PAGE,TNAME,TIEN,EN,SUB,POS,CIEN,INF,ACL
+2 SET (INST,EINST)=""
SET STOP=0
SET (PAGE,NEW)=1
if $EXTRACT(IOST)="C"
WRITE @IOF
+3 DO FORHEAD^SCRPITP2
+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 IF STOP
QUIT
+8 ;write team info
+9 SET TNAME=""
+10 FOR
SET TNAME=$ORDER(@STORE@("T",INST,TNAME))
if TNAME=""!(STOP)
QUIT
Begin DoDot:2
+11 if NEW
DO TITLE^SCRPU3(.PAGE,TITL,132)
+12 IF 'NEW
IF $EXTRACT(IOST)'="C"
DO NEWP1^SCRPU3(.PAGE,TITL,132)
+13 IF 'NEW
IF $EXTRACT(IOST)="C"
DO HOLD^SCRPU3(.PAGE,TITL,132)
+14 WRITE !,$GET(@STORE@(INST)),!
SET NEW=""
+15 SET TIEN=$ORDER(@STORE@("T",INST,TNAME,""))
+16 IF TIEN=""
QUIT
+17 FOR SUB="TI","D"
Begin DoDot:3
+18 if STOP
QUIT
+19 IF '$DATA(@STORE@(INST,TIEN,SUB))
QUIT
+20 SET EN=""
+21 FOR
SET EN=$ORDER(@STORE@(INST,TIEN,SUB,EN))
if EN=""!(STOP)
QUIT
Begin DoDot:4
+22 IF IOST'?1"C-".E
IF $Y>(IOSL-5)
DO NEWP1^SCRPU3(.PAGE,TITL,132)
+23 IF IOST?1"C-".E
IF $Y>(IOSL-5)
DO HOLD^SCRPU3(.PAGE,TITL,132)
+24 IF STOP
QUIT
+25 IF '$DATA(NEW)
WRITE !,$GET(@STORE@(INST)),!,$GET(@STORE@(INST,TIEN)),!
+26 WRITE !,$GET(@STORE@(INST,TIEN,SUB,EN))
End DoDot:4
+27 WRITE !
End DoDot:3
+28 ;write position info
+29 SET POS=""
+30 IF $Y<IOSL-10
DO COLUMN^SCRPITP2
+31 FOR
SET POS=$ORDER(@STORE@(INST,TIEN,"P",POS))
if POS=""!(STOP)
QUIT
Begin DoDot:3
+32 WRITE !,$GET(@STORE@(INST,TIEN,"P",POS))
+33 SET ACL=""
+34 FOR
SET ACL=$ORDER(@STORE@(INST,TIEN,"P",POS,ACL))
if ACL=""!(STOP)
QUIT
Begin DoDot:4
+35 WRITE !,$GET(@STORE@(INST,TIEN,"P",POS,ACL))
+36 IF IOST'?1"C-".E
IF $Y>(IOSL-5)
DO NEWP1^SCRPU3(.PAGE,TITL,132)
if STOP
QUIT
DO CONT^SCRPITP2
+37 IF IOST?1"C-".E
IF $Y>(IOSL-5)
DO HOLD^SCRPU3(.PAGE,TITL,132)
if STOP
QUIT
DO CONT^SCRPITP2
+38 IF STOP
QUIT
End DoDot:4
+39 ;W !,$G(@STORE@(INST,TIEN,"P",POS))
+40 ;W !,$G(@STORE@(INST,TIEN,"P",POS,ACL))
+41 WRITE !
End DoDot:3
End DoDot:2
End DoDot:1
+42 IF 'STOP
IF $EXTRACT(IOST)="C"
NEW DIR
SET DIR(0)="E"
WRITE !
DO ^DIR
+43 QUIT
