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

SCRPRAC.m

Go to the documentation of this file. 
  1. SCRPRAC ;ALB/CMM - Practitioner Demographics ; 29 Jun 99  04:11PM
  1.  ;;5.3;Scheduling;**41,52,177**;AUG 13, 1993
  1.  ;
  1.  ;Practitioner Demographics Report
  1.  ;
  1. PROMPTS ;
  1.  ;Prompt for Practioner and Print device
  1.  ;
  1.  K SCUP
  1.  N QTIME,PRNT,VAUTP,Y,VAUTCI,NUMBER
  1.  S QTIME=""
  1.  ;S VAUTPO="" ;only can select one practitioner
  1.  S VAUTNA="" ;all not allowed
  1.  S VAUTT=1 ;all teams
  1.  W ! D PRACT^SCRPU1
  1.  I '$D(VAUTP) G ERR
  1.  D QUE(.VAUTP) Q
  1.  ;
  1. QUE(PRACT) ;queue report
  1.  ;Input: PRACT=array of providers
  1.  N ZTSAVE,II
  1.  F II="PRACT(","PRACT" S ZTSAVE(II)=""
  1.  W ! D EN^XUTMDEVQ("QENTRY^SCRPRAC","Practitioner Demographics",.ZTSAVE)
  1.  Q
  1.  ;
  1. ENTRY2(PRACT,IOP,ZTDTH) ;
  1.  ;Second entry point for GUI to use
  1.  ;Input Parameters:
  1.  ;PRACT - practitioner ien new person file
  1.  ;IOP - print device
  1.  ;ZTDTH - queue time (optional)
  1.  ;
  1.  ;validate parameters
  1.  I '$D(PRACT)!'$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^SCRPRAC"
  1.  S ZTDESC="Practitioner Demographics",ZTIO=IOP
  1.  N II
  1.  F II="PRACT(","PRACT","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.  ;driver entry point
  1.  S TITL="Practitioner Demographics"
  1.  S STORE="^TMP("_$J_",""SCRPRAC"")"
  1.  K @STORE
  1.  S @STORE=0
  1.  D DRIVE
  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,VAUTPO,VAUTT,VAUTP,SCUP,VAUTNA
  1.  Q
  1.  ;
  1. EXIT2 ;
  1.  K @STORE
  1.  K STORE,TITL,IOP,PRACT,NODATA,STOP
  1.  Q
  1.  ;
  1. DRIVE ;
  1.  ;driver module
  1.  N PRAC,INF,ARRY,ERROR
  1.  S ARRY="ARRAY",ERROR="ERR"
  1.  K @ARRY,@ERROR
  1.  S PRAC=0 F  S PRAC=$O(PRACT(PRAC)) Q:PRAC=""  D
  1.  .S INF=$$TPPR^SCAPMC12(PRAC,,,,ARRY,ERROR) ;get practitioner positions
  1.  .I INF=0 Q
  1.  .D GATHER^SCRPRAC2(.ARRY,PRAC)
  1.  .K @ERROR,@ARRY
  1.  Q
  1.  ;
  1. PRINTIT(STORE,TITL) ;
  1.  N PNAME,PIEN,PAGE,STOP,NEW,SCI
  1.  S PNAME="",(NEW,PAGE)=1,STOP=0 W:$E(IOST)="C" @IOF
  1.  F  S PNAME=$O(@STORE@(PNAME)) Q:PNAME=""!(STOP)  S PIEN=0 D
  1.  .F  S PIEN=$O(@STORE@(PNAME,PIEN)) Q:'PIEN!(STOP)  D
  1.  ..I NEW D TITLE^SCRPU3(.PAGE,TITL)
  1.  ..;I 'NEW,$E(IOST)="C" D HOLD^SCRPU3(.PAGE,TITL)
  1.  ..;I 'NEW,$E(IOST)'="C" 
  1.  ..I 'NEW D NEWP1^SCRPU3(.PAGE,TITL)
  1.  ..Q:STOP  S (NEW,SCI)=0
  1.  ..F  S SCI=$O(@STORE@(PNAME,PIEN,SCI)) Q:'SCI!(STOP)  D
  1.  ...I $E(IOST)="C",$Y>(IOSL-3) D HOLD^SCRPU3(.PAGE,TITL) Q:STOP  D CONT
  1.  ...I $E(IOST)'="C",$Y>(IOSL-3) D NEWP1^SCRPU3(.PAGE,TITL) Q:STOP  D CONT
  1.  ...W !,@STORE@(PNAME,PIEN,SCI)
  1.  ...Q
  1.  ..I $E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR S STOP=Y'=1
  1.  ..Q
  1.  .Q
  1.  Q
  1.  ;
  1. CONT W !,"Provider '",PNAME,"' continued...",! Q