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

SCRPTM.m

Go to the documentation of this file. 
  1. SCRPTM ;ALB/CMM - List of Team's Members Report ; 29 Jun 99  04:11PM
  1.  ;;5.3;Scheduling;**41,48,52,181,177,520,1015**;AUG 13, 1993;Build 21
  1.  ;IHS/ANMC/LJF 11/03/2000 added call to list template
  1.  ;
  1.  ;List of Team's Members Report
  1.  ;
  1. PROMPTS ;
  1.  ;Prompt for Institution, Team, Date Range, User Class, Role
  1.  ;and Print device
  1.  ;
  1.  N VAUTD,VAUTT,VAUTUC,VAUTR,QTIME,RANG,PRNT,NUMBER
  1.  K VAUTD,VAUTT,VAUTUC,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 S RANG=$$DTRANG^SCRPU2() I +RANG=-1 G ERR
  1.  W ! K Y D USER^SCRPU1 I '$D(VAUTUC)&($P($G(^SD(404.91,1,"PCMM")),"^")=1) G ERR
  1.  W ! K Y D ROLE^SCRPU1 I '$D(VAUTR) G ERR
  1.  D QUE(.VAUTD,.VAUTT,.VAUTUC,.VAUTR,RANG) Q
  1.  ;
  1. QUE(INST,TEAM,USERC,ROLE,RANGE) ;queue report
  1.  ;Input Parameters: 
  1.  ;INST - institutions selected (variable and array) 
  1.  ;TEAM - teams selected (variable and array) 
  1.  ;USERC - user classes selected (variable and array) 
  1.  ;ROLE - roles selected (variable and array) 
  1.  ;RANGE - date range selected (begin date ^ end date)
  1.  N ZTSAVE,II
  1.  F II="INST","TEAM","USERC","ROLE","INST(","TEAM(","USERC(","ROLE(","RANGE" S ZTSAVE(II)=""
  1.  W ! D EN^XUTMDEVQ("QENTRY^SCRPTM","Team Member Listing",.ZTSAVE)
  1.  Q
  1.  ;
  1. ENTRY2(INST,TEAM,USERC,ROLE,RANGE,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.  ;USERC - user classes selected (variable and array)
  1.  ;ROLE - roles selected (variable and array)
  1.  ;RANGE - date range selected (begin date ^ end date)
  1.  ;IOP - print device
  1.  ;ZTDTH - queue time (optional)
  1.  ;
  1.  ;validate parameters
  1.  I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$D(RANGE)!'$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^SCRPTM"
  1.  S ZTDESC="List of Team's Members",ZTIO=IOP
  1.  N II
  1.  F II="INST","TEAM","USERC","ROLE","INST(","TEAM(","USERC(","ROLE(","RANGE","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 ^BSDSCTM Q   ;IHS/ANMC/LJF 11/03/2000
  1. IHS ;EP; entry point for list template ;IHS/ANMC/LJF 11/03/2000
  1.  ;driver entry point
  1.  S TITL="Team Member Listing"
  1.  S STORE="^TMP("_$J_",""SCRPTM"")"
  1.  K @STORE
  1.  S @STORE=0
  1.  D BUILD
  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. EXIT2 ;
  1.  K @STORE
  1.  K STOP,STORE,TITL,IOP,TEAM,INST,NODATA,RANGE,ROLE,USERC
  1.  Q
  1.  ;
  1. BUILD ;get report data
  1.  ;get all practitioners for all teams selected
  1.  I TEAM=1 D TALL ;all teams selected
  1.  N TIEN,OKAY,XLIST,YLIST,SCTP,SCI,SCDT,PLIST
  1.  S SCDT("BEGIN")=$P(RANGE,U),SCDT("END")=$P(RANGE,U,2)
  1.  S SCDT("INCL")=0,SCDT="SCDT"
  1.  S TIEN="",PLIST="^TMP(""SCRP"",$J,""LIST"")"
  1.  F  S TIEN=$O(TEAM(TIEN)) Q:TIEN=""!(TIEN'?.N)  D
  1.  .K XLIST,@PLIST
  1.  .S OKAY=$$TPTM^SCAPMC(TIEN,.SCDT,"","","XLIST","ERROR")
  1.  .S SCTP=0 F  S SCTP=$O(XLIST("SCTP",TIEN,SCTP)) Q:'SCTP  D
  1.  ..S SCTP0=$G(^SCTM(404.57,SCTP,0)) Q:'$L(SCTP0)
  1.  ..I ROLE'=1,'$D(ROLE(+$P(SCTP0,U,3))) Q  ;not a selected role
  1.  ..I $D(USERC),USERC'=1,'$D(USERC(+$P(SCTP0,U,13))) Q  ;not a selected user class
  1.  ..K YLIST
  1.  ..S OKAY=$$PRTP^SCAPMC(SCTP,.SCDT,"YLIST","ERROR",1,0)
  1.  ..S SCI=0 F  S SCI=$O(YLIST(SCI)) Q:'SCI  D
  1.  ...S @PLIST@(0)=$G(@PLIST@(0))+1
  1.  ...S @PLIST@(@PLIST@(0))=YLIST(SCI)
  1.  ...Q
  1.  ..Q
  1.  .I OKAY D PULL^SCRPTM2(TIEN,.PLIST)
  1.  .Q
  1.  Q
  1.  ;
  1. TALL ;
  1.  ;get all active team for divisions selected
  1.  N NXT,IIEN,NODE
  1.  S NXT=0,IIEN=""
  1.  ;$O through team file and find all active teams for selected divisions
  1.  F  S IIEN=$O(^SCTM(404.51,"AINST",IIEN)) Q:IIEN=""  D
  1.  .I INST=1!$D(INST(IIEN)) D
  1.  ..S TIEN=0
  1.  ..F  S TIEN=$O(^SCTM(404.51,"AINST",IIEN,TIEN)) Q:TIEN=""  D
  1.  ...I $$ACTTM^SCMCTMU(TIEN) S TEAM(TIEN)=""
  1.  Q
  1.  ;
  1. PRINTIT(STORE,TITL) ;
  1.  N INST,EINST,ETEAM,TEM,EPRACT,PRACT,PAGE,NXT,NPAGE,CNT,HEAD,POS
  1.  S EINST="",(NPAGE,STOP,HEAD)=0,PAGE=1 W:$E(IOST)="C" @IOF
  1.  D TITLE^SCRPU3(.PAGE,TITL)
  1.  F  S EINST=$O(@STORE@("I",EINST)) Q:EINST=""!(STOP)  D
  1.  .S INST=$O(@STORE@("I",EINST,""))
  1.  .Q:INST=""
  1.  .I 'NPAGE W !,$G(@STORE@(INST)) ;write institution line
  1.  .S (ETEAM,TEM)=""
  1.  .F  S ETEAM=$O(@STORE@("T",INST,ETEAM)) Q:ETEAM=""!(STOP)  D
  1.  ..S TEM=$O(@STORE@("T",INST,ETEAM,0))
  1.  ..I TEM="" Q
  1.  ..S NXT="H"
  1.  ..I NPAGE,(IOST'?1"C-".E) D NEWP^SCRPTM2(INST,TEM,TITL,.PAGE,.HEAD) S NPAGE=0
  1.  ..I NPAGE,(IOST?1"C-".E) D HOLD1^SCRPTM2(.PAGE,TITL,INST,TEM,.HEAD) S NPAGE=0
  1.  ..I STOP Q
  1.  ..I IOST'?1"C-".E,$Y>(IOSL-5) D NEWP^SCRPTM2(INST,TEM,TITL,.PAGE,.HEAD)
  1.  ..I IOST?1"C-".E,$Y>(IOSL-5) D HOLD1^SCRPTM2(.PAGE,TITL,INST,TEM,.HEAD)
  1.  ..I STOP Q
  1.  ..F  S NXT=$O(@STORE@(INST,TEM,NXT)) Q:NXT'?1"H".E!(STOP)  D
  1.  ...I 'HEAD W !,$G(@STORE@(INST,TEM,NXT)) S HEAD=0 ;writes team info
  1.  ..S (EPRACT,PRACT)=""
  1.  ..W ! ;extra line between members and practioner list
  1.  ..F  S EPRACT=$O(@STORE@("PN",INST,TEM,EPRACT)) Q:EPRACT=""!(STOP)  D
  1.  ...F  S PRACT=$O(@STORE@("PN",INST,TEM,EPRACT,PRACT)) Q:PRACT=""!(STOP)  D
  1.  ....I PRACT="" Q
  1.  ....S POS=""
  1.  ....F  S POS=$O(@STORE@("PN",INST,TEM,EPRACT,PRACT,POS)) Q:POS=""!(STOP)  D
  1.  .....D PRNTD(INST,TEM,PRACT,POS,TITL,.PAGE,.HEAD)
  1.  .....W ! ;seperated positions
  1.  ....W ! ;separates practitioners
  1.  .S NPAGE=1
  1.  I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR
  1.  Q
  1.  ;
  1. PRNTD(INST,TEM,PRACT,POS,TITL,PAGE,HEAD) ;
  1.  ;
  1.  N CNT,SCAC
  1.  S CNT=""
  1.  I IOST'?1"C-".E,$Y>(IOSL-11) D NEWP^SCRPTM2(INST,TEM,TITL,.PAGE,.HEAD)
  1.  I IOST?1"C-".E,$Y>(IOSL-11) D HOLD1^SCRPTM2(.PAGE,TITL,INST,TEM,.HEAD)
  1.  I STOP Q
  1.  F  S CNT=$O(@STORE@(INST,TEM,PRACT,POS,CNT)) Q:CNT=""!(STOP)  D
  1.  .W !,$G(@STORE@(INST,TEM,PRACT,POS,CNT))
  1.  .S SCAC="" I CNT=4  D
  1.  ..F  S SCAC=$O(@STORE@(INST,TEM,PRACT,POS,4,SCAC)) Q:SCAC=""!(STOP)  D
  1.  ...W !,$G(@STORE@(INST,TEM,PRACT,POS,4,SCAC))
  1.  Q