SCRPTA ;ALB/CMM - Patient Listing w/Team Assignment Data ; 29 Jun 99 04:11PM
;;5.3;Scheduling;**41,48,52,114,174,181,177,526,1015**;AUG 13, 1993;Build 21
;IHS/ANMC/LJF 11/02/2000 changed 132 column message
; added call to list template
; moved PT ID column to fit 6 digits
;
;Patient Listing w/Team Assignment Data Report
;
PROMPTS ;
;Prompt for Institution, Team, Role, Practitioner and Print device
;
N PRNT,QTIME,NUMBER
K VAUTD,VAUTT,VAUTR,VAUTP,VAUTPP,SCUP
S QTIME=""
W ! D INST^SCRPU1 I Y=-1 G ERR
W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR
W ! K Y D ROLE^SCRPU1 I '$D(VAUTR) G ERR
W ! K Y S VAUTPP="" D PRACT^SCRPU1 K VAUTPP I '$D(VAUTP) G ERR
;W !!,"This report requires 132 column output!" ;IHS/ANMC/LJF 11/2/2000
W !!,"This report, when printed on paper, requires wide paper or condensed print!" ;IHS/ANMC/LJF 11/2/2000
D QUE(.VAUTD,.VAUTT,.VAUTR,.VAUTP) Q
;
QUE(INST,TEAM,ROLE,PRACT) ;
;Input Parameters:
;INST - institutions selected (variable and array)
;TEAM - teams selected (variable and array)
;ROLE - roles selected (variable and array)
;PRACT - practitioners selected (variable and array)
N ZTSAVE,II
F II="INST","TEAM","ROLE","INST(","TEAM(","PRACT","PRACT(","ROLE(" S ZTSAVE(II)=""
W ! D EN^XUTMDEVQ("QENTRY^SCRPTA","Patient Listing for Team Assignments",.ZTSAVE)
Q
;
ENTRY2(INST,TEAM,ROLE,PRACT,IOP,ZTDTH) ;
;Second entry point for GUI to use
;Input Parameters:
;INST - institutions selected (variable and array)
;TEAM - teams selected (variable and array)
;ROLE - roles selected (variable and array)
;PRACT - practitioners selected (variable and array)
;IOP - print device
;ZTDTH - queue time (optional)
;
;validate parameters
I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$D(PRACT)!'$D(IOP)!(IOP="") Q
;
N NUMBER
S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^")
I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2)
I IOST?1"C-".E D QENTRY G RET
I ZTDTH="" S ZTDTH=$H
S ZTRTN="QENTRY^SCRPTA"
S ZTDESC="Patient Listing w/Team Assignment",ZTIO=IOP
N II
F II="INST","TEAM","ROLE","INST(","TEAM(","PRACT","PRACT(","ROLE(","IOP" S ZTSAVE(II)=""
D ^%ZTLOAD
RET S NUMBER=0
I $D(ZTSK) S NUMBER=ZTSK
D EXIT1
Q NUMBER
;
QENTRY ;
I $E(IOST,1,2)="C-" D ^BSDSCTA Q ;IHS/ANMC/LJF 11/2/2000
IHS ;EP; entry point for list template ;IHS/ANMC/LJF 11/2/2000
;driver entry point
S TITL="Patient Listing For Team Assignments"
S STORE="^TMP("_$J_",""SCRPTA"")"
K @STORE
S @STORE=0
I TEAM=1 D TALL^SCRPPAT3 S TEAM=0
D FIND
I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL)
I '$D(NODATA) D PRINTIT(STORE,TITL)
D EXIT2
Q
;
ERR ;
EXIT1 ;
K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,Y,SCUP
Q
;
EXIT2 ;
K @STORE
K STOP,STORE,TITL,IOP,TEAM,INST,ROLE,NODATA,PRACT
Q
;
FIND ;
N NXT,TLIST,TERR,CNT,ERR1,TNODE,NODE1,PIEN,PTAIEN
S NXT=0,TLIST="^TMP("_$J_",""SCRPTA"",""LIST1"")",TERR="ERR1"
K @TLIST,@TERR
F S NXT=$O(TEAM(NXT)) Q:NXT=""!(NXT'?.N) D
.S ERR1=$$PTTM^SCAPMC2(NXT,,.TLIST,.TERR) ;Patients assigned to team NXT
.Q:ERR1=0
.S CNT=0
.F S CNT=$O(@TLIST@(CNT)) Q:CNT=""!(CNT'?.N) D
..S TNODE=$G(@TLIST@(CNT))
..Q:TNODE=""
..S PIEN=+$P(TNODE,"^") ;patient ien
..S PTAIEN=+$P(TNODE,"^",3) ;ien Patient Team Assignment #404.42
..D CHK^SCRPTA2(PTAIEN,PIEN)
.K @TLIST,@TERR
K @TLIST,@TERR
Q
;
PRINTIT(STORE,TITL) ;
N NXT,PAGE,NPAGE,INTN,TMN,INT,TM,PRN,PR,POS
S (NPAGE,STOP,PAGE)=0,INTN="" W:$E(IOST)="C" @IOF
D SHEAD ;setup headers
F S INTN=$O(@STORE@("I",INTN)) Q:INTN=""!(STOP) D
.S INT=$O(@STORE@("I",INTN,"")) ;institution
.Q:INT=""
.S TMN=""
.F S TMN=$O(@STORE@("T",INT,TMN)) Q:TMN=""!(STOP) D
..S TM=$O(@STORE@("T",INT,TMN,"")) ;team
..Q:TM=""
..D NEWP1^SCRPU3(.PAGE,TITL,132) W !,$G(@STORE@(INT)),!!,$G(@STORE@(INT,TM))
..Q:STOP
..S PRN=""
..D HEADER
..F S PRN=$O(@STORE@("P",INT,TM,PRN)) Q:PRN=""!(STOP) D
...S PR=$O(@STORE@("P",INT,TM,PRN,"")) ;practitioner
...Q:PR=""
...S POS=""
...F S POS=$O(@STORE@("P",INT,TM,PRN,PR,POS)) Q:POS=""!(STOP) D
....D PRNT(INT,TM,PR,POS)
I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR
Q
;
PRNT(INT,TM,PR,POS) ;
;INT - institution ien
;TM - team ien
;PR - practitioner ien
;POS - position ien
;
N PTIEN,PTNAME
S PTNAME=""
F S PTNAME=$O(@STORE@(INT,TM,PR,POS,PTNAME)) Q:PTNAME=""!(STOP) D
.S PTIEN=""
.F S PTIEN=$O(@STORE@(INT,TM,PR,POS,PTNAME,PTIEN)) Q:PTIEN=""!(STOP) D
..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
..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
..Q:STOP
..W !,$G(@STORE@(INT,TM,PR,POS,PTNAME,PTIEN))
.Q
Q
;
;write column headers
N EN
W !
F EN="H1","H2","H3" D
.W !,$G(@STORE@(EN))
Q
SHEAD ;
;setup column headers
S @STORE@("H2")="Patient Name"
;S $E(@STORE@("H2"),19)="Pt ID"
S $E(@STORE@("H2"),23)="Pt ID" ;IHS/ANMC/LJF 11/2/2000
S $E(@STORE@("H1"),31)="Date"
S $E(@STORE@("H2"),31)="Assigned"
S $E(@STORE@("H2"),43)="PC?"
S $E(@STORE@("H2"),49)="Practitioner"
S $E(@STORE@("H2"),70)="Position"
S $E(@STORE@("H2"),92)="Standard Role"
S $E(@STORE@("H2"),113)="Preceptor"
S $P(@STORE@("H3"),"=",133)=""
Q
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
+2 ;IHS/ANMC/LJF 11/02/2000 changed 132 column message
+3 ; added call to list template
+4 ; moved PT ID column to fit 6 digits
+5 ;
+6 ;Patient Listing w/Team Assignment Data Report
+7 ;
PROMPTS ;
+1 ;Prompt for Institution, Team, Role, Practitioner and Print device
+2 ;
+3 NEW PRNT,QTIME,NUMBER
+4 KILL VAUTD,VAUTT,VAUTR,VAUTP,VAUTPP,SCUP
+5 SET QTIME=""
+6 WRITE !
DO INST^SCRPU1
IF Y=-1
GOTO ERR
+7 WRITE !
KILL Y
DO PRMTT^SCRPU1
IF '$DATA(VAUTT)
GOTO ERR
+8 WRITE !
KILL Y
DO ROLE^SCRPU1
IF '$DATA(VAUTR)
GOTO ERR
+9 WRITE !
KILL Y
SET VAUTPP=""
DO PRACT^SCRPU1
KILL VAUTPP
IF '$DATA(VAUTP)
GOTO ERR
+10 ;W !!,"This report requires 132 column output!" ;IHS/ANMC/LJF 11/2/2000
+11 ;IHS/ANMC/LJF 11/2/2000
WRITE !!,"This report, when printed on paper, requires wide paper or condensed print!"
+12 DO QUE(.VAUTD,.VAUTT,.VAUTR,.VAUTP)
QUIT
+13 ;
QUE(INST,TEAM,ROLE,PRACT) ;
+1 ;Input Parameters:
+2 ;INST - institutions selected (variable and array)
+3 ;TEAM - teams selected (variable and array)
+4 ;ROLE - roles selected (variable and array)
+5 ;PRACT - practitioners selected (variable and array)
+6 NEW ZTSAVE,II
+7 FOR II="INST","TEAM","ROLE","INST(","TEAM(","PRACT","PRACT(","ROLE("
SET ZTSAVE(II)=""
+8 WRITE !
DO EN^XUTMDEVQ("QENTRY^SCRPTA","Patient Listing for Team Assignments",.ZTSAVE)
+9 QUIT
+10 ;
ENTRY2(INST,TEAM,ROLE,PRACT,IOP,ZTDTH) ;
+1 ;Second entry point for GUI to use
+2 ;Input Parameters:
+3 ;INST - institutions selected (variable and array)
+4 ;TEAM - teams selected (variable and array)
+5 ;ROLE - roles selected (variable and array)
+6 ;PRACT - practitioners selected (variable and array)
+7 ;IOP - print device
+8 ;ZTDTH - queue time (optional)
+9 ;
+10 ;validate parameters
+11 IF '$DATA(INST)!'$DATA(TEAM)!'$DATA(ROLE)!'$DATA(PRACT)!'$DATA(IOP)!(IOP="")
QUIT
+12 ;
+13 NEW NUMBER
+14 SET IOST=$PIECE(IOP,"^",2)
SET IOP=$PIECE(IOP,"^")
+15 IF IOP?1"Q;".E
SET IOP=$PIECE(IOP,"Q;",2)
+16 IF IOST?1"C-".E
DO QENTRY
GOTO RET
+17 IF ZTDTH=""
SET ZTDTH=$HOROLOG
+18 SET ZTRTN="QENTRY^SCRPTA"
+19 SET ZTDESC="Patient Listing w/Team Assignment"
SET ZTIO=IOP
+20 NEW II
+21 FOR II="INST","TEAM","ROLE","INST(","TEAM(","PRACT","PRACT(","ROLE(","IOP"
SET ZTSAVE(II)=""
+22 DO ^%ZTLOAD
RET SET NUMBER=0
+1 IF $DATA(ZTSK)
SET NUMBER=ZTSK
+2 DO EXIT1
+3 QUIT NUMBER
+4 ;
QENTRY ;
+1 ;IHS/ANMC/LJF 11/2/2000
IF $EXTRACT(IOST,1,2)="C-"
DO ^BSDSCTA
QUIT
IHS ;EP; entry point for list template ;IHS/ANMC/LJF 11/2/2000
+1 ;driver entry point
+2 SET TITL="Patient Listing For Team Assignments"
+3 SET STORE="^TMP("_$JOB_",""SCRPTA"")"
+4 KILL @STORE
+5 SET @STORE=0
+6 IF TEAM=1
DO TALL^SCRPPAT3
SET TEAM=0
+7 DO FIND
+8 IF $ORDER(@STORE@(0))=""
SET NODATA=$$NODATA^SCRPU3(TITL)
+9 IF '$DATA(NODATA)
DO PRINTIT(STORE,TITL)
+10 DO EXIT2
+11 QUIT
+12 ;
ERR ;
EXIT1 ;
+1 KILL ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,Y,SCUP
+2 QUIT
+3 ;
EXIT2 ;
+1 KILL @STORE
+2 KILL STOP,STORE,TITL,IOP,TEAM,INST,ROLE,NODATA,PRACT
+3 QUIT
+4 ;
FIND ;
+1 NEW NXT,TLIST,TERR,CNT,ERR1,TNODE,NODE1,PIEN,PTAIEN
+2 SET NXT=0
SET TLIST="^TMP("_$JOB_",""SCRPTA"",""LIST1"")"
SET TERR="ERR1"
+3 KILL @TLIST,@TERR
+4 FOR
SET NXT=$ORDER(TEAM(NXT))
IF NXT=""!(NXT'?.N)
QUIT
Begin DoDot:1
+5 ;Patients assigned to team NXT
SET ERR1=$$PTTM^SCAPMC2(NXT,,.TLIST,.TERR)
+6 IF ERR1=0
QUIT
+7 SET CNT=0
+8 FOR
SET CNT=$ORDER(@TLIST@(CNT))
IF CNT=""!(CNT'?.N)
QUIT
Begin DoDot:2
+9 SET TNODE=$GET(@TLIST@(CNT))
+10 IF TNODE=""
QUIT
+11 ;patient ien
SET PIEN=+$PIECE(TNODE,"^")
+12 ;ien Patient Team Assignment #404.42
SET PTAIEN=+$PIECE(TNODE,"^",3)
+13 DO CHK^SCRPTA2(PTAIEN,PIEN)
End DoDot:2
+14 KILL @TLIST,@TERR
End DoDot:1
+15 KILL @TLIST,@TERR
+16 QUIT
+17 ;
PRINTIT(STORE,TITL) ;
+1 NEW NXT,PAGE,NPAGE,INTN,TMN,INT,TM,PRN,PR,POS
+2 SET (NPAGE,STOP,PAGE)=0
SET INTN=""
IF $EXTRACT(IOST)="C"
WRITE @IOF
+3 ;setup headers
DO SHEAD
+4 FOR
SET INTN=$ORDER(@STORE@("I",INTN))
IF INTN=""!(STOP)
QUIT
Begin DoDot:1
+5 ;institution
SET INT=$ORDER(@STORE@("I",INTN,""))
+6 IF INT=""
QUIT
+7 SET TMN=""
+8 FOR
SET TMN=$ORDER(@STORE@("T",INT,TMN))
IF TMN=""!(STOP)
QUIT
Begin DoDot:2
+9 ;team
SET TM=$ORDER(@STORE@("T",INT,TMN,""))
+10 IF TM=""
QUIT
+11 DO NEWP1^SCRPU3(.PAGE,TITL,132)
WRITE !,$GET(@STORE@(INT)),!!,$GET(@STORE@(INT,TM))
+12 IF STOP
QUIT
+13 SET PRN=""
+14 DO HEADER
+15 FOR
SET PRN=$ORDER(@STORE@("P",INT,TM,PRN))
IF PRN=""!(STOP)
QUIT
Begin DoDot:3
+16 ;practitioner
SET PR=$ORDER(@STORE@("P",INT,TM,PRN,""))
+17 IF PR=""
QUIT
+18 SET POS=""
+19 FOR
SET POS=$ORDER(@STORE@("P",INT,TM,PRN,PR,POS))
IF POS=""!(STOP)
QUIT
Begin DoDot:4
+20 DO PRNT(INT,TM,PR,POS)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+21 IF 'STOP
IF $EXTRACT(IOST)="C"
NEW DIR
SET DIR(0)="E"
WRITE !
DO ^DIR
+22 QUIT
+23 ;
PRNT(INT,TM,PR,POS) ;
+1 ;INT - institution ien
+2 ;TM - team ien
+3 ;PR - practitioner ien
+4 ;POS - position ien
+5 ;
+6 NEW PTIEN,PTNAME
+7 SET PTNAME=""
+8 FOR
SET PTNAME=$ORDER(@STORE@(INT,TM,PR,POS,PTNAME))
IF PTNAME=""!(STOP)
QUIT
Begin DoDot:1
+9 SET PTIEN=""
+10 FOR
SET PTIEN=$ORDER(@STORE@(INT,TM,PR,POS,PTNAME,PTIEN))
IF PTIEN=""!(STOP)
QUIT
Begin DoDot:2
+11 IF (IOST'?1"C-".E)
IF $Y>(IOSL-4)
DO NEWP1^SCRPU3(.PAGE,TITL,132)
IF 'STOP
WRITE !,$GET(@STORE@(INT)),!!,$GET(@STORE@(INT,TM))
IF 'STOP
DO HEADER
+12 IF (IOST?1"C-".E)
IF $Y>(IOSL-4)
DO HOLD^SCRPU3(.PAGE,TITL,132)
IF 'STOP
WRITE !,$GET(@STORE@(INT)),!!,$GET(@STORE@(INT,TM))
IF 'STOP
DO HEADER
+13 IF STOP
QUIT
+14 WRITE !,$GET(@STORE@(INT,TM,PR,POS,PTNAME,PTIEN))
End DoDot:2
+15 QUIT
End DoDot:1
+16 QUIT
+17 ;
+1 ;write column headers
+2 NEW EN
+3 WRITE !
+4 FOR EN="H1","H2","H3"
Begin DoDot:1
+5 WRITE !,$GET(@STORE@(EN))
End DoDot:1
+6 QUIT
SHEAD ;
+1 ;setup column headers
+2 SET @STORE@("H2")="Patient Name"
+3 ;S $E(@STORE@("H2"),19)="Pt ID"
+4 ;IHS/ANMC/LJF 11/2/2000
SET $EXTRACT(@STORE@("H2"),23)="Pt ID"
+5 SET $EXTRACT(@STORE@("H1"),31)="Date"
+6 SET $EXTRACT(@STORE@("H2"),31)="Assigned"
+7 SET $EXTRACT(@STORE@("H2"),43)="PC?"
+8 SET $EXTRACT(@STORE@("H2"),49)="Practitioner"
+9 SET $EXTRACT(@STORE@("H2"),70)="Position"
+10 SET $EXTRACT(@STORE@("H2"),92)="Standard Role"
+11 SET $EXTRACT(@STORE@("H2"),113)="Preceptor"
+12 SET $PIECE(@STORE@("H3"),"=",133)=""
+13 QUIT
