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

SCRPTA.m

Go to the documentation of this file. 
  1. SCRPTA ;ALB/CMM - Patient Listing w/Team Assignment Data ; 29 Jun 99  04:11PM
  1.  ;;5.3;Scheduling;**41,48,52,114,174,181,177,526,1015**;AUG 13, 1993;Build 21
  1.  ;IHS/ANMC/LJF 11/02/2000 changed 132 column message
  1.  ;                        added call to list template
  1.  ;                        moved PT ID column to fit 6 digits
  1.  ;
  1.  ;Patient Listing w/Team Assignment Data Report
  1.  ;
  1. PROMPTS ;
  1.  ;Prompt for Institution, Team, Role, Practitioner and Print device
  1.  ;
  1.  N PRNT,QTIME,NUMBER
  1.  K VAUTD,VAUTT,VAUTR,VAUTP,VAUTPP,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 ! K Y S VAUTPP="" D PRACT^SCRPU1 K VAUTPP I '$D(VAUTP) G ERR
  1.  ;W !!,"This report requires 132 column output!"  ;IHS/ANMC/LJF 11/2/2000
  1.  W !!,"This report, when printed on paper, requires wide paper or condensed print!"  ;IHS/ANMC/LJF 11/2/2000
  1.  D QUE(.VAUTD,.VAUTT,.VAUTR,.VAUTP) Q 
  1.  ;
  1. QUE(INST,TEAM,ROLE,PRACT) ; 
  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.  ;PRACT - practitioners selected (variable and array) 
  1.  N ZTSAVE,II
  1.  F II="INST","TEAM","ROLE","INST(","TEAM(","PRACT","PRACT(","ROLE(" S ZTSAVE(II)=""
  1.  W ! D EN^XUTMDEVQ("QENTRY^SCRPTA","Patient Listing for Team Assignments",.ZTSAVE)
  1.  Q
  1.  ;
  1. ENTRY2(INST,TEAM,ROLE,PRACT,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.  ;PRACT - practitioners 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(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^SCRPTA"
  1.  S ZTDESC="Patient Listing w/Team Assignment",ZTIO=IOP
  1.  N II
  1.  F II="INST","TEAM","ROLE","INST(","TEAM(","PRACT","PRACT(","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 ^BSDSCTA Q    ;IHS/ANMC/LJF 11/2/2000
  1. IHS ;EP; entry point for list template  ;IHS/ANMC/LJF 11/2/2000
  1.  ;driver entry point
  1.  S TITL="Patient Listing For Team Assignments"
  1.  S STORE="^TMP("_$J_",""SCRPTA"")"
  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,Y,SCUP
  1.  Q
  1.  ;
  1. EXIT2 ;
  1.  K @STORE
  1.  K STOP,STORE,TITL,IOP,TEAM,INST,ROLE,NODATA,PRACT
  1.  Q
  1.  ;
  1. FIND ;
  1.  N NXT,TLIST,TERR,CNT,ERR1,TNODE,NODE1,PIEN,PTAIEN
  1.  S NXT=0,TLIST="^TMP("_$J_",""SCRPTA"",""LIST1"")",TERR="ERR1"
  1.  K @TLIST,@TERR
  1.  F  S NXT=$O(TEAM(NXT)) Q:NXT=""!(NXT'?.N)  D
  1.  .S ERR1=$$PTTM^SCAPMC2(NXT,,.TLIST,.TERR) ;Patients assigned to team NXT
  1.  .Q:ERR1=0
  1.  .S CNT=0
  1.  .F  S CNT=$O(@TLIST@(CNT)) Q:CNT=""!(CNT'?.N)  D
  1.  ..S TNODE=$G(@TLIST@(CNT))
  1.  ..Q:TNODE=""
  1.  ..S PIEN=+$P(TNODE,"^") ;patient ien
  1.  ..S PTAIEN=+$P(TNODE,"^",3) ;ien Patient Team Assignment #404.42
  1.  ..D CHK^SCRPTA2(PTAIEN,PIEN)
  1.  .K @TLIST,@TERR
  1.  K @TLIST,@TERR
  1.  Q
  1.  ;
  1. PRINTIT(STORE,TITL) ;
  1.  N NXT,PAGE,NPAGE,INTN,TMN,INT,TM,PRN,PR,POS
  1.  S (NPAGE,STOP,PAGE)=0,INTN="" W:$E(IOST)="C" @IOF
  1.  D SHEAD ;setup headers
  1.  F  S INTN=$O(@STORE@("I",INTN)) Q:INTN=""!(STOP)  D
  1.  .S INT=$O(@STORE@("I",INTN,"")) ;institution
  1.  .Q:INT=""
  1.  .S TMN=""
  1.  .F  S TMN=$O(@STORE@("T",INT,TMN)) Q:TMN=""!(STOP)  D
  1.  ..S TM=$O(@STORE@("T",INT,TMN,"")) ;team
  1.  ..Q:TM=""
  1.  ..D NEWP1^SCRPU3(.PAGE,TITL,132) W !,$G(@STORE@(INT)),!!,$G(@STORE@(INT,TM))
  1.  ..Q:STOP
  1.  ..S PRN=""
  1.  ..D HEADER
  1.  ..F  S PRN=$O(@STORE@("P",INT,TM,PRN)) Q:PRN=""!(STOP)  D
  1.  ...S PR=$O(@STORE@("P",INT,TM,PRN,"")) ;practitioner
  1.  ...Q:PR=""
  1.  ...S POS=""
  1.  ...F  S POS=$O(@STORE@("P",INT,TM,PRN,PR,POS)) Q:POS=""!(STOP)  D
  1.  ....D PRNT(INT,TM,PR,POS)
  1.  I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR
  1.  Q
  1.  ;
  1. PRNT(INT,TM,PR,POS) ;
  1.  ;INT - institution ien
  1.  ;TM - team ien
  1.  ;PR - practitioner ien
  1.  ;POS - position ien
  1.  ;
  1.  N PTIEN,PTNAME
  1.  S PTNAME=""
  1.  F  S PTNAME=$O(@STORE@(INT,TM,PR,POS,PTNAME)) Q:PTNAME=""!(STOP)  D
  1.  .S PTIEN=""
  1.  .F  S PTIEN=$O(@STORE@(INT,TM,PR,POS,PTNAME,PTIEN)) Q:PTIEN=""!(STOP)  D
  1.  ..I (IOST'?1"C-".E),$Y>(IOSL-4) D NEWP1^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INT)),!!,$G(@STORE@(INT,TM)) D:'STOP HEADER
  1.  ..I (IOST?1"C-".E),$Y>(IOSL-4) D HOLD^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INT)),!!,$G(@STORE@(INT,TM)) D:'STOP HEADER
  1.  ..Q:STOP
  1.  ..W !,$G(@STORE@(INT,TM,PR,POS,PTNAME,PTIEN))
  1.  .Q
  1.  Q
  1.  ;
  1.  ;write column headers
  1.  N EN
  1.  W !
  1.  F EN="H1","H2","H3" D
  1.  .W !,$G(@STORE@(EN))
  1.  Q
  1. SHEAD ;
  1.  ;setup column headers
  1.  S @STORE@("H2")="Patient Name"
  1.  ;S $E(@STORE@("H2"),19)="Pt ID"
  1.  S $E(@STORE@("H2"),23)="Pt ID"  ;IHS/ANMC/LJF 11/2/2000
  1.  S $E(@STORE@("H1"),31)="Date"
  1.  S $E(@STORE@("H2"),31)="Assigned"
  1.  S $E(@STORE@("H2"),43)="PC?"
  1.  S $E(@STORE@("H2"),49)="Practitioner"
  1.  S $E(@STORE@("H2"),70)="Position"
  1.  S $E(@STORE@("H2"),92)="Standard Role"
  1.  S $E(@STORE@("H2"),113)="Preceptor"
  1.  S $P(@STORE@("H3"),"=",133)=""
  1.  Q