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

SCRPSLT.m

Go to the documentation of this file. 
  1. 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
  1.  ;IHS/ANMC/LJF 11/02/2000 changed 132 column message
  1.  ;                        added call to list template
  1.  ;
  1.  ;Summary Listing of Teams Report
  1.  ;
  1. PROMPTS ;
  1.  ;Prompt for Institution, Team, Role and Print device
  1.  ;
  1.  N VAUTD,VAUTT,VAUTR,QTIME,PRNT,NUMBER
  1.  K VAUTD,VAUTT,VAUTR,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 ! K Y D ROLE^SCRPU1 I '$D(VAUTR) G ERR
  1.  ;W !!,"This report requires 132 column output!"                                     ;IHS/ANMC/LJF 11/02/2000
  1.  W !!,"This report, when printed on paper, requires wide paper or condensed print!"  ;IHS/ANMC/LJF 11/02/2000
  1.  D QUE(.VAUTD,.VAUTT,.VAUTR) Q
  1.  ;
  1. QUE(INST,TEAM,ROLE) ;queue report
  1.  ;Input Parameters: 
  1.  ;INST - institutions selected (variable and array) 
  1.  ;TEAM - teams selected (variable and array) 
  1.  ;ROLE - roles selected (variable and array)
  1.  N ZTSAVE,II
  1.  F II="INST","TEAM","ROLE","INST(","TEAM(","ROLE(" S ZTSAVE(II)=""
  1.  W ! D EN^XUTMDEVQ("QENTRY^SCRPSLT","Summary Listing of Teams",.ZTSAVE)
  1.  Q
  1.  ;
  1. ENTRY2(INST,TEAM,ROLE,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.  ;ROLE - roles selected (variable and array)
  1.  ;IOP - print device
  1.  ;ZTDTH - queue time (optional)
  1.  ;
  1.  ;validate parameters
  1.  I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$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^SCRPSLT"
  1.  S ZTDESC="Summary Listing Of Teams",ZTIO=IOP
  1.  N II
  1.  F II="INST","TEAM","ROLE","INST(","TEAM(","ROLE(","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 ^BSDSCSLT Q   ;IHS/ANMC/LJF 11/02/2000
  1. IHS ;EP; entry point for list template  ;IHS/ANMC/LJF 11/02/2000
  1.  ;driver entry point
  1.  S TITL="Summary Listing of Teams"
  1.  S STORE="^TMP("_$J_",""SCRPSLT"")"
  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,SCUP
  1.  Q
  1.  ;
  1. EXIT2 ;
  1.  K @STORE
  1.  K STOP,STORE,TITL,IOP,TEAM,INST,ROLE,NODATA
  1.  Q
  1.  ;
  1. FIND ;
  1.  N TM,EN2,EN,ROL,NODE,TEND,ACT,INA,TPASS,TPCN,TMAX,TMP,TOA,TNPC
  1.  S TM=""
  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.  .S TPASS(TM)=0,TMAX(TM)=0,TPCN(TM)=0
  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.  ..S ROL=+$P(NODE,"^",3) ;role ien
  1.  ..I '$D(ROLE(ROL))&(ROLE'=1) Q
  1.  ..;Q above not a selected role
  1.  ..;find active position during date range
  1.  ..S TMP=$$DATES^SCAPMCU1(404.52,EN,DT)
  1.  ..I +TMP=0 Q
  1.  ..S EN2=+$P(TMP,"^",4)
  1.  ..D KEEP^SCRPSLT2(NODE,EN,EN2,ROL,TM,.TPCN,.TNPC)
  1.  ..S TPASS(TM)=$$TEAMCNT^SCAPMCU1(TM,DT)
  1.  ..S TMAX(TM)=+$P($G(^SCTM(404.51,+TM,0)),U,8)
  1.  ..S TOA(TM)=TMAX(TM)-TPASS(TM) S:TOA(TM)<0 TOA(TM)=0
  1.  ..D TEAMT^SCRPSLT2(TM,.TPASS,.TMAX,.TPCN,.TOA,.TNPC)
  1.  Q
  1.  ;
  1. PRINTIT(STORE,TITL) ;
  1.  N INST,EINST,ETEAM,TEM,EPRACT,PRACT,NXT,PAGE,NPAGE,NEW,POS,SCAC
  1.  S (INST,EINST)="",(NPAGE,STOP)=0,PAGE=1 W:$E(IOST)="C" @IOF
  1.  D TITLE^SCRPU3(.PAGE,TITL)
  1.  D FORHEAD^SCRPSLT2
  1.  F  S EINST=$O(@STORE@("I",EINST)) Q:EINST=""!(STOP)  D
  1.  .S INST=$O(@STORE@("I",EINST,""))
  1.  .I INST="" Q
  1.  .S (TEM,ETEAM)=""
  1.  .F  S ETEAM=$O(@STORE@("T",INST,ETEAM)) Q:ETEAM=""!(STOP)  D
  1.  ..S TEM=$O(@STORE@("T",INST,ETEAM,""))
  1.  ..I TEM="" Q
  1.  ..K NEW
  1.  ..I NPAGE,(IOST'?1"C-".E) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE) S NEW=""
  1.  ..I NPAGE,(IOST?1"C-".E) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM) S NEW=""
  1.  ..S NPAGE=1 I STOP Q
  1.  ..I IOST'?1"C-".E,$Y>(IOSL-8) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE) S NEW=""
  1.  ..I IOST?1"C-".E,$Y>(IOSL-8) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM) S NEW=""
  1.  ..I STOP Q
  1.  ..I '$D(NEW) D HEADER^SCRPSLT2(INST,TEM)
  1.  ..S (PRACT,EPRACT)=""
  1.  ..F  S EPRACT=$O(@STORE@("PN",INST,TEM,EPRACT)) Q:EPRACT=""!(STOP)  D
  1.  ...S PRACT=$O(@STORE@("PN",INST,TEM,EPRACT,""))
  1.  ...I PRACT="" Q
  1.  ...S POS=""
  1.  ...F  S POS=$O(@STORE@(INST,TEM,PRACT,POS)) Q:POS=""!(STOP)  D
  1.  ....W !,$G(@STORE@(INST,TEM,PRACT,POS))
  1.  ....S SCAC=""
  1.  ....F  S SCAC=$O(@STORE@(INST,TEM,PRACT,POS,SCAC)) Q:SCAC=""!(STOP)  D
  1.  .....W !,$G(@STORE@(INST,TEM,PRACT,POS,SCAC))
  1.  .....I IOST'?1"C-".E,$Y>(IOSL-4) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE)
  1.  .....I IOST?1"C-".E,$Y>(IOSL-4) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM)
  1.  .....I STOP Q
  1.  ....;W !,$G(@STORE@(INST,TEM,PRACT,POS)) ;writes info
  1.  ..Q:STOP
  1.  ..I IOST'?1"C-".E,$Y>(IOSL-8) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE,1)
  1.  ..I IOST?1"C-".E,$Y>(IOSL-8) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM,1)
  1.  ..D TOTAL^SCRPSLT2(INST,TEM)
  1.  .I STOP Q
  1.  .S NPAGE=1
  1.  I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" D ^DIR
  1.  Q