source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPITP.m

SCRPITP ;ALB/CMM - Individual Team Profile ; 29 Jun 99  04:11PM
 ;;5.3;Scheduling;**41,52,177**;AUG 13, 1993
 ;
 ;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
 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
 ...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 !
 I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR
 Q