Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SCRPITP

SCRPITP.m

Go to the documentation of this file. 
  1. SCRPITP ;ALB/CMM - Individual Team Profile ; 29 Jun 99  04:11PM
  1.  ;;5.3;Scheduling;**41,52,177,520,1015**;AUG 13, 1993;Build 21
  1.  ;IHS/ANMC/LJF 10/26/2000 added call to list template
  1.  ;                        changed 132 column message
  1.  ;
  1.  ;Individual Team Profile
  1.  ;
  1. PROMPTS ;
  1.  ;Prompt for Institution, Team, and Print device
  1.  ;
  1.  N QTIME,PRNT,VAUTD,VAUTT,Y,NUMBER
  1.  K VAUTD,VAUTT,SCUP
  1.  S QTIME=""
  1.  W ! D INST^SCRPU1 I Y=-1 G ERR
  1.  W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR
  1.  ;W !!,"This report requires 132 column output!"  ;IHS/ANMC/LJF 10/26/2000
  1.  W !!,"This report, when printed on paper, requires wide paper or condensed print!"  ;IHS/ANMC/LJF 10/26/2000
  1.  D QUE(.VAUTD,.VAUTT) Q
  1.  ;
  1. QUE(INST,TEAM) ;queue report
  1.  ;Input Parameters: 
  1.  ;INST - institutions selected (variable and array) 
  1.  ;TEAM - teams selected (variable and array)
  1.  N ZTSAVE,II
  1.  F II="INST","TEAM","INST(","TEAM(" S ZTSAVE(II)=""
  1.  W ! D EN^XUTMDEVQ("QENTRY^SCRPITP","Individual Team Profile",.ZTSAVE)
  1.  Q
  1.  ;
  1. ENTRY2(INST,TEAM,IOP,ZTDTH) ;
  1.  ;Second entry point for GUI to use
  1.  ;Input Parameters:
  1.  ;INST - institutions selected (variable and array)
  1.  ;TEAM - teams selected (variable and array)
  1.  ;IOP - print device
  1.  ;ZTDTH - queue time (optional)
  1.  ;
  1.  ;validate parameters
  1.  I '$D(INST)!'$D(TEAM)!'$D(IOP)!(IOP="") Q
  1.  ;
  1.  N NUMBER
  1.  S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^")
  1.  I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2)
  1.  I IOST?1"C-".E D QENTRY G RET
  1.  I ZTDTH="" S ZTDTH=$H
  1.  S ZTRTN="QENTRY^SCRPITP"
  1.  S ZTDESC="iIndividual Team Profile",ZTIO=IOP
  1.  N II
  1.  F II="INST","TEAM","INST(","TEAM(","IOP" S ZTSAVE(II)=""
  1.  D ^%ZTLOAD
  1. RET S NUMBER=0
  1.  I $D(ZTSK) S NUMBER=ZTSK
  1.  D EXIT1
  1.  Q NUMBER
  1.  ;
  1. QENTRY ;
  1.  I $E(IOST,1,2)="C-" D EN^BSDSCITP Q  ;IHS/ANMC/LJF 10/26/2000
  1. IHS ;EP;  entry from list template       ;IHS/ANMC/LJF 10/26/2000
  1.  ;driver entry point
  1.  S TITL="Individual Team Profile"
  1.  S STORE="^TMP("_$J_",""SCRPITP"")"
  1.  K @STORE
  1.  S @STORE=0
  1.  I TEAM=1 D TALL^SCRPPAT3 S TEAM=0
  1.  D FIND
  1.  I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL)
  1.  I '$D(NODATA) D PRINTIT(STORE,TITL)
  1.  D EXIT2
  1.  Q
  1.  ;
  1. ERR ;
  1. EXIT1 ;
  1.  K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE
  1.  Q
  1.  ;
  1. EXIT2 ;
  1.  K @STORE
  1.  K STOP,STORE,TITL,IOP,TEAM,INST,NODATA
  1.  Q
  1.  ;
  1. FIND ;
  1.  N TM,EN,NODE,TMP,TPNAME
  1.  S TM="" K ^TMP("SCRATCH",$J)
  1.  F  S TM=$O(^SCTM(404.57,"C",TM)) Q:TM=""  D
  1.  .;$O through team position file
  1.  .I '$D(TEAM(TM))&(TEAM'=1) Q
  1.  .;Q above, not a selected team
  1.  .;selected team
  1.  .S EN=""
  1.  .F  S EN=$O(^SCTM(404.57,"C",TM,EN)) Q:EN=""  D
  1.  ..I '$D(^SCTM(404.57,EN,0)) Q
  1.  ..S NODE=$G(^SCTM(404.57,EN,0))
  1.  ..Q:NODE=""
  1.  ..;active or inactive position
  1.  ..S TMP=$$DATES^SCAPMCU1(404.59,EN,DT)
  1.  ..S TPNAME=$P(NODE,U) S:'$L(TPNAME) TPNAME="~~~"
  1.  ..S ^TMP("SCRATCH",$J,TPNAME,EN)=NODE
  1.  ..I +TMP S ^TMP("SCRATCH",$J,TM,TPNAME,EN)=NODE
  1.  ..Q
  1.  .Q
  1.  S TM=""
  1.  F  S TM=$O(^TMP("SCRATCH",$J,TM)) Q:TM=""  S TPNAME="" D
  1.  .F  S TPNAME=$O(^TMP("SCRATCH",$J,TM,TPNAME)) Q:TPNAME=""  S EN="" D
  1.  ..F  S EN=$O(^TMP("SCRATCH",$J,TM,TPNAME,EN)) Q:EN=""  D
  1.  ...S NODE=^TMP("SCRATCH",$J,TM,TPNAME,EN)
  1.  ...D KEEP^SCRPITP2(NODE,EN,TM)
  1.  ...Q
  1.  ..Q
  1.  .Q
  1.  Q
  1.  ;
  1. PRINTIT(STORE,TITL) ;
  1.  N INST,EINST,ETEAM,TEM,NEW,PAGE,TNAME,TIEN,EN,SUB,POS,CIEN,INF,ACL
  1.  S (INST,EINST)="",STOP=0,(PAGE,NEW)=1 W:$E(IOST)="C" @IOF
  1.  D FORHEAD^SCRPITP2
  1.  F  S EINST=$O(@STORE@("I",EINST)) Q:EINST=""!(STOP)  D
  1.  .S INST=$O(@STORE@("I",EINST,""))
  1.  .I INST="" Q
  1.  .I STOP Q
  1.  .;write team info
  1.  .S TNAME=""
  1.  .F  S TNAME=$O(@STORE@("T",INST,TNAME)) Q:TNAME=""!(STOP)  D
  1.  ..D:NEW TITLE^SCRPU3(.PAGE,TITL,132)
  1.  ..I 'NEW,$E(IOST)'="C" D NEWP1^SCRPU3(.PAGE,TITL,132)
  1.  ..I 'NEW,$E(IOST)="C" D HOLD^SCRPU3(.PAGE,TITL,132)
  1.  ..W !,$G(@STORE@(INST)),! S NEW=""
  1.  ..S TIEN=$O(@STORE@("T",INST,TNAME,""))
  1.  ..I TIEN="" Q
  1.  ..F SUB="TI","D" D
  1.  ...Q:STOP
  1.  ...I '$D(@STORE@(INST,TIEN,SUB)) Q
  1.  ...S EN=""
  1.  ...F  S EN=$O(@STORE@(INST,TIEN,SUB,EN)) Q:EN=""!(STOP)  D
  1.  ....I IOST'?1"C-".E,$Y>(IOSL-5) D NEWP1^SCRPU3(.PAGE,TITL,132)
  1.  ....I IOST?1"C-".E,$Y>(IOSL-5) D HOLD^SCRPU3(.PAGE,TITL,132)
  1.  ....I STOP Q
  1.  ....I '$D(NEW) W !,$G(@STORE@(INST)),!,$G(@STORE@(INST,TIEN)),!
  1.  ....W !,$G(@STORE@(INST,TIEN,SUB,EN))
  1.  ...W !
  1.  ..;write position info
  1.  ..S POS=""
  1.  ..I $Y<IOSL-10 D COLUMN^SCRPITP2
  1.  ..F  S POS=$O(@STORE@(INST,TIEN,"P",POS)) Q:POS=""!(STOP)  D
  1.  ...W !,$G(@STORE@(INST,TIEN,"P",POS))
  1.  ...S ACL=""
  1.  ...F  S ACL=$O(@STORE@(INST,TIEN,"P",POS,ACL)) Q:ACL=""!(STOP)  D
  1.  ....W !,$G(@STORE@(INST,TIEN,"P",POS,ACL))
  1.  ....I IOST'?1"C-".E,$Y>(IOSL-5) D NEWP1^SCRPU3(.PAGE,TITL,132) Q:STOP  D CONT^SCRPITP2
  1.  ....I IOST?1"C-".E,$Y>(IOSL-5) D HOLD^SCRPU3(.PAGE,TITL,132) Q:STOP  D CONT^SCRPITP2
  1.  ....I STOP Q
  1.  ...;W !,$G(@STORE@(INST,TIEN,"P",POS))
  1.  ...;W !,$G(@STORE@(INST,TIEN,"P",POS,ACL))
  1.  ...W !
  1.  I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR
  1.  Q