SCRPPAT ;ALB/CMM - Practitioner's Patients ; 8/30/99 3:17pm
;;5.3;Scheduling;**41,52,177,297,1015**;AUG 13, 1993;Build 21
;IHS/ANMC/LJF 11/02/2000 added call to list template
; added reset of IOP killed by VALM rtns
; added title to summary if list template
;
;Listing of Practitioner's Patients
;
PROMPTS ;
;Prompt for division, team, role, practitioner, summary only and print device
;
N QTIME,PRNT,VAUTP,Y,VAUTD,VAUTT,VAUTR,VAUTS,SORT,NUMBER
K 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 ! D PRACT^SCRPU1 I '$D(VAUTP) G ERR
W ! S VAUTS=$$SUMM^SCRPU2() I VAUTS<0 G ERR
W ! S SORT=$$SORT^SCRPU2() I SORT<1 G ERR
S PRNT=$$PDEVICE^SCRPU3()
I PRNT=-1 G ERR
I PRNT["Q;" S QTIME=$$GETTIME^SCRPU3()
I QTIME=-1 G ERR
I PRNT'?1"Q;".E S PRNT="Q;"_PRNT
S NUMBER=$$ENTRY2(.VAUTD,.VAUTT,.VAUTR,.VAUTP,VAUTS,SORT,PRNT,QTIME)
I NUMBER>0 W !!,"Print queued, task number: ",NUMBER
Q
D QUE(.VAUTD,.VAUTT,.VAUTR,.VAUTP,VAUTS,SORT) Q
;
QUE(INST,TEAM,ROLE,PRACT,SUMM,SORT) ;queue report
;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)
;SUMM - summary info? y/n (1-yes/0-no) yes don't print patient data
;SORT - sort criteria (1-d,t,p/2-d,p,t)
N ZTSAVE,II
F II="INST","INST(","TEAM","TEAM(","ROLE","ROLE(","PRACT(","PRACT","SUMM","SORT" S ZTSAVE(II)=""
W ! D EN^XUTMDEVQ("QENTRY^SCRPPAT","Practitioner's Patients",.ZTSAVE)
Q
;
ENTRY2(INST,TEAM,ROLE,PRACT,SUMM,SORT,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 (ien new person file) - (variable and array)
;SUMM - summary info? y/n (1-yes/0-no) yes don't print patient data
;SORT - sort criteria (1-d,t,p/2-d,p,t)
;IOP - print device
;ZTDTH - queue time (optional)
;
;validate parameters
I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$D(PRACT)!'$D(SUMM)!'$D(SORT)!'$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^SCRPPAT"
S ZTDESC="Practitioner's Patients",ZTIO=IOP
N II
F II="IOSL","INST","INST(","TEAM","TEAM(","ROLE","ROLE(","PRACT(","PRACT","SUMM","IOP","SORT" 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 ^BSDSCPAT 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="Practitioner's Patients"
I SUMM S TITL=TITL_" Summary Report"
S STORE="^TMP("_$J_",""SCRPPAT"")"
K @STORE
S @STORE=0
D DRIVE^SCRPPAT2
I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL)
I '$D(IOP) S IOP=$P($G(^%ZIS(1,+$O(^%ZIS(1,"C",IO,0)),0)),U) ;IHS/ANMC/LJF 11/2/2000
I '$D(NODATA) D PRINTIT(STORE,IOP,TITL,SORT)
D EXIT2
Q
;
ERR ;
EXIT1 ;
K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,VAUTD,VAUTT,VAUTP,VAUTR
K SCUP,VAUTS,SORT
Q
;
EXIT2 ;
K @STORE
K STORE,TITL,IOP,PRACT,INST,TEAM,ROLE,SORT,SUMM,NODATA,STOP
Q
;
PRINTIT(STORE,IOP,TITL,SORT) ; Print All Data
;STORE - global location of data
;IOP - device to print to
;TITL - title of report
;SORT - sort order 1-div,team,pract/2-div,pract,team
;
N PAGE
S PAGE=1,STOP=0 W:$E(IOST)="C" @IOF
N SEC1,SEC2,SEC2,SEC3,SEC4,ST1,ST2,ST3,ST4
I SORT=1 S SEC1="""T""",SEC2="""P""",SEC3="""TN""",SEC4="""PN"""
I SORT=2!(SORT=3) S SEC1="""P""",SEC2="""T""",SEC3="""PN""",SEC4="""TN"""
;I SORT=3 S SEC4=SEC3,SEC3="""TN"""
N SEC,TRD,INS,INAME,SECN,TRDN,PT,FIRST
S (INAME,INS)="",FIRST=1
F S INAME=$O(@STORE@("I",INAME)) Q:INAME=""!(STOP) D
.S INS=$O(@STORE@("I",INAME,""))
.Q:INS=""!STOP
.D S
;I SORT=3 D
;.N I F I=0:0 S I=$O(@STORE@("P",I)) Q:'I D
;..S A="" F S A=$O(@STORE@("P",I,A)) Q:A="" S @STORE@("P1",A,$O(@STORE@("P",I,A,0)))=""
;.F S INAME=$O(@STORE@("P1",INAME)) Q:INAME=""!(STOP) D
;..S INS=$O(@STORE@("P1",INAME,""))
;..Q:INS=""!STOP
;..D S W !,STORE,!,ST1 R XXX
D S1
Q
S ;
S SECN="",ST1=$E(STORE,1,($L(STORE)-1))_","_SEC1_")"
F S SECN=$O(@ST1@(INS,SECN)) Q:SECN=""!(STOP) D
.S SEC=$O(@ST1@(INS,SECN,"")) ;ien of team or practitioner
.Q:SEC=""
.S ST3=$E(STORE,1,($L(STORE)-1))_","_SEC3_")"
.S TRDN="",ST2=$E(STORE,1,($L(STORE)-1))_","_SEC2_")"
.F S TRDN=$O(@ST2@(INS,TRDN)) Q:TRDN=""!(STOP) D
..S TRD=$O(@ST2@(INS,TRDN,"")) ;ien of team or practitioner
..Q:TRD=""
..;have first team and first practitioner ien
..S ST4=$E(STORE,1,($L(STORE)-1))_","_SEC4_")"
..D PRNT(ST4,ST3,SEC3,.PAGE,TITL,INS,SEC,TRD) Q:STOP
Q
S1 I $E(IOST)="C",'STOP W ! N DIR S DIR(0)="E" D ^DIR S STOP=Y'=1
I 'STOP,SUMM=0 S (FIRST,SUMM)=1,TITL=TITL_" Summary Report" W @IOF D PRINTIT(STORE,$G(IOP),TITL,SORT)
Q
;
PRNT(ST4,ST3,SEC3,PAGE,TITL,INS,SEC,TRD) ;
;
N POS
I (SEC3="""PN""")&($D(@ST3@(INS,SEC,TRD))) D
.;get each position for practitioner
.N MORE S POS="",MORE=0
.F S POS=$O(@ST3@(INS,SEC,TRD,POS)) Q:POS=""!(STOP) D
..I 'SUMM I SORT=3 D Q
...;I MORE ;S FIRST=0
...K @STORE@("H1") D SHEAD^SCRPPAT3
...I 'MORE I (PAGE=1)!(IOST?1"C-".E) D TITLE^SCRPU3(.PAGE,TITL)
...I 'MORE W !,$G(@ST3@(INS,SEC,TRD,POS)),!
...D PAT^SCRPPAT3(INS,SEC,TRD,SEC3,ST3,ST4,POS) S MORE=1
...I $O(@ST3@(INS,SEC,TRD,POS))="" D
....I (IOST?1"C-".E) D HOLD(.PAGE,"") S PAGE=PAGE+1 Q:STOP
....I (IOST'?1"C-".E) D NEWP1^SCRPU3(.PAGE,TITL) Q:STOP
..I SUMM D Q
...I FIRST D TITLE^SCRPU3(.PAGE,TITL),SHEAD^SCRPPAT3,SSH S FIRST=0
...I (IOST'?1"C-".E),$Y>(IOSL-4) D NEWP1^SCRPU3(.PAGE,TITL) Q:STOP D SSH
...I (IOST?1"C-".E),$Y>(IOSL-6) D HOLD^SCRPU3(.PAGE,TITL) Q:STOP D SSH
...W !,@STORE@("SUM0",INS,SEC,TRD,POS)
...W ?72,$J($G(@STORE@("TOTAL",INS,SEC,TRD,POS)),8)
...Q
..Q:SORT=3
..I FIRST D:'MORE TITLE^SCRPU3(.PAGE,TITL) D SHEAD^SCRPPAT3
..I (IOST'?1"C-".E),'SUMM,'FIRST D NEWP1^SCRPU3(.PAGE,TITL) W:'STOP !,$G(@STORE@(INS))
..I (IOST?1"C-".E),'SUMM,'FIRST D HOLD^SCRPU3(.PAGE,TITL) W:'STOP !,$G(@STORE@(INS))
..Q:STOP S FIRST=1 I 'MORE S FIRST=0
..W !,$G(@ST3@(INS,SEC,TRD,POS)) ;write practitioner (sort 1)
..I $L($G(@ST3@(INS,SEC,TRD,POS,"PRCP"))) W !,@ST3@(INS,SEC,TRD,POS,"PRCP")
..I $G(SORT)'=3 W !,$G(@ST4@(INS,TRD)) ;write team (sort 2)
..W !,$G(@STORE@(INS))
..;$o through patients for practitioner on team
..D PAT^SCRPPAT3(INS,SEC,TRD,SEC3,ST3,ST4,POS) Q:STOP
..I (IOST'?1"C-".E),$Y>(IOSL-4) D NEWP1^SCRPU3(.PAGE,TITL) Q:STOP
..I (IOST?1"C-".E),$Y>(IOSL-6) D HOLD^SCRPU3(.PAGE,TITL) Q:STOP
..D TOTAL1^SCRPPAT3(INS,SEC,TRD,POS) ;print team/practitioner total
;
I (SEC3="""TN""")&($D(@ST4@(INS,TRD,SEC))) D
.S POS=""
.F S POS=$O(@ST4@(INS,TRD,SEC,POS)) Q:POS=""!(STOP) D
..I SUMM D Q
...I FIRST D TITLE^SCRPU3(.PAGE,TITL),SHEAD^SCRPPAT3,SSH S FIRST=0
...I (IOST'?1"C-".E),$Y>(IOSL-4) D NEWP1^SCRPU3(.PAGE,TITL) Q:STOP D SSH
...I (IOST?1"C-".E),$Y>(IOSL-6) D HOLD^SCRPU3(.PAGE,TITL) Q:STOP D SSH
...W !,@STORE@("SUM0",INS,TRD,SEC,POS)
...W ?72,$J(@STORE@("TOTAL",INS,TRD,SEC,POS),8)
...Q
..I FIRST D TITLE^SCRPU3(.PAGE,TITL),SHEAD^SCRPPAT3
..I (IOST'?1"C-".E),'SUMM,'FIRST D NEWP1^SCRPU3(.PAGE,TITL)
..I (IOST?1"C-".E),'SUMM,'FIRST D HOLD^SCRPU3(.PAGE,TITL)
..Q:STOP S FIRST=0
..I $G(SORT)'=3 W !,$G(@ST3@(INS,SEC)) ;write team (sort 1)
..W !,$G(@STORE@(INS))
..I $G(SORT)'=3 W !,$G(@ST4@(INS,TRD,SEC,POS)) ;write practitioner (sort 2)
..I $L($G(@ST4@(INS,TRD,SEC,POS,"PRCP"))) W !,@ST4@(INS,TRD,SEC,POS,"PRCP")
..W !
..;$o through patients for practitioner on team
..D PAT^SCRPPAT3(INS,SEC,TRD,SEC3,ST3,ST4,POS) Q:STOP
..I (IOST'?1"C-".E),$Y>(IOSL-4) D NEWP1^SCRPU3(.PAGE,TITL) Q:STOP
..I (IOST?1"C-".E),$Y>(IOSL-6) D HOLD^SCRPU3(.PAGE,TITL) Q:STOP
..D TOTAL1^SCRPPAT3(INS,SEC,TRD,POS) ;print team/practitioner total
Q
;
SSH ;Summary subheader
I $G(VALM) W !!,"Report Summary" ;IHS/ANMC/LJF 11/2/2000
W !?72,"Patients",!,"Practitioner",?24,"Position",?48,"Team"
W ?72,"Assigned",! N SCI F SCI=1:1:80 W "="
Q
HOLD(PAGE,TIT,MARG) ;
;device is home, reached end of page
N X
S MARG=$G(MARG) S:MARG'>80 MARG=80
W !!,"Press Any Key to Continue or '^' to Quit" R X:DTIME
I '$T!(X="^") S STOP=1 Q
W @IOF
Q
SCRPPAT ;ALB/CMM - Practitioner's Patients ; 8/30/99 3:17pm
+1 ;;5.3;Scheduling;**41,52,177,297,1015**;AUG 13, 1993;Build 21
+2 ;IHS/ANMC/LJF 11/02/2000 added call to list template
+3 ; added reset of IOP killed by VALM rtns
+4 ; added title to summary if list template
+5 ;
+6 ;Listing of Practitioner's Patients
+7 ;
PROMPTS ;
+1 ;Prompt for division, team, role, practitioner, summary only and print device
+2 ;
+3 NEW QTIME,PRNT,VAUTP,Y,VAUTD,VAUTT,VAUTR,VAUTS,SORT,NUMBER
+4 KILL 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 !
DO PRACT^SCRPU1
IF '$DATA(VAUTP)
GOTO ERR
+10 WRITE !
SET VAUTS=$$SUMM^SCRPU2()
IF VAUTS<0
GOTO ERR
+11 WRITE !
SET SORT=$$SORT^SCRPU2()
IF SORT<1
GOTO ERR
+12 SET PRNT=$$PDEVICE^SCRPU3()
+13 IF PRNT=-1
GOTO ERR
+14 IF PRNT["Q;"
SET QTIME=$$GETTIME^SCRPU3()
+15 IF QTIME=-1
GOTO ERR
+16 IF PRNT'?1"Q;".E
SET PRNT="Q;"_PRNT
+17 SET NUMBER=$$ENTRY2(.VAUTD,.VAUTT,.VAUTR,.VAUTP,VAUTS,SORT,PRNT,QTIME)
+18 IF NUMBER>0
WRITE !!,"Print queued, task number: ",NUMBER
+19 QUIT
+20 DO QUE(.VAUTD,.VAUTT,.VAUTR,.VAUTP,VAUTS,SORT)
QUIT
+21 ;
QUE(INST,TEAM,ROLE,PRACT,SUMM,SORT) ;queue report
+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 ;SUMM - summary info? y/n (1-yes/0-no) yes don't print patient data
+7 ;SORT - sort criteria (1-d,t,p/2-d,p,t)
+8 NEW ZTSAVE,II
+9 FOR II="INST","INST(","TEAM","TEAM(","ROLE","ROLE(","PRACT(","PRACT","SUMM","SORT"
SET ZTSAVE(II)=""
+10 WRITE !
DO EN^XUTMDEVQ("QENTRY^SCRPPAT","Practitioner's Patients",.ZTSAVE)
+11 QUIT
+12 ;
ENTRY2(INST,TEAM,ROLE,PRACT,SUMM,SORT,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 (ien new person file) - (variable and array)
+7 ;SUMM - summary info? y/n (1-yes/0-no) yes don't print patient data
+8 ;SORT - sort criteria (1-d,t,p/2-d,p,t)
+9 ;IOP - print device
+10 ;ZTDTH - queue time (optional)
+11 ;
+12 ;validate parameters
+13 IF '$DATA(INST)!'$DATA(TEAM)!'$DATA(ROLE)!'$DATA(PRACT)!'$DATA(SUMM)!'$DATA(SORT)!'$DATA(IOP)!(IOP="")
QUIT
+14 ;
+15 NEW NUMBER
+16 SET IOST=$PIECE(IOP,"^",2)
SET IOP=$PIECE(IOP,"^")
+17 IF IOP?1"Q;".E
SET IOP=$PIECE(IOP,"Q;",2)
+18 IF IOST?1"C-".E
DO QENTRY
GOTO RET
+19 IF ZTDTH=""
SET ZTDTH=$HOROLOG
+20 SET ZTRTN="QENTRY^SCRPPAT"
+21 SET ZTDESC="Practitioner's Patients"
SET ZTIO=IOP
+22 NEW II
+23 FOR II="IOSL","INST","INST(","TEAM","TEAM(","ROLE","ROLE(","PRACT(","PRACT","SUMM","IOP","SORT"
SET ZTSAVE(II)=""
+24 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 ^BSDSCPAT
QUIT
IHS ;EP; entry point for list template ;IHS/ANMC/LJF 11/2/2000
+1 ;driver entry point
+2 SET TITL="Practitioner's Patients"
+3 IF SUMM
SET TITL=TITL_" Summary Report"
+4 SET STORE="^TMP("_$JOB_",""SCRPPAT"")"
+5 KILL @STORE
+6 SET @STORE=0
+7 DO DRIVE^SCRPPAT2
+8 IF $ORDER(@STORE@(0))=""
SET NODATA=$$NODATA^SCRPU3(TITL)
+9 ;IHS/ANMC/LJF 11/2/2000
IF '$DATA(IOP)
SET IOP=$PIECE($GET(^%ZIS(1,+$ORDER(^%ZIS(1,"C",IO,0)),0)),U)
+10 IF '$DATA(NODATA)
DO PRINTIT(STORE,IOP,TITL,SORT)
+11 DO EXIT2
+12 QUIT
+13 ;
ERR ;
EXIT1 ;
+1 KILL ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,VAUTD,VAUTT,VAUTP,VAUTR
+2 KILL SCUP,VAUTS,SORT
+3 QUIT
+4 ;
EXIT2 ;
+1 KILL @STORE
+2 KILL STORE,TITL,IOP,PRACT,INST,TEAM,ROLE,SORT,SUMM,NODATA,STOP
+3 QUIT
+4 ;
PRINTIT(STORE,IOP,TITL,SORT) ; Print All Data
+1 ;STORE - global location of data
+2 ;IOP - device to print to
+3 ;TITL - title of report
+4 ;SORT - sort order 1-div,team,pract/2-div,pract,team
+5 ;
+6 NEW PAGE
+7 SET PAGE=1
SET STOP=0
IF $EXTRACT(IOST)="C"
WRITE @IOF
+8 NEW SEC1,SEC2,SEC2,SEC3,SEC4,ST1,ST2,ST3,ST4
+9 IF SORT=1
SET SEC1="""T"""
SET SEC2="""P"""
SET SEC3="""TN"""
SET SEC4="""PN"""
+10 IF SORT=2!(SORT=3)
SET SEC1="""P"""
SET SEC2="""T"""
SET SEC3="""PN"""
SET SEC4="""TN"""
+11 ;I SORT=3 S SEC4=SEC3,SEC3="""TN"""
+12 NEW SEC,TRD,INS,INAME,SECN,TRDN,PT,FIRST
+13 SET (INAME,INS)=""
SET FIRST=1
+14 FOR
SET INAME=$ORDER(@STORE@("I",INAME))
IF INAME=""!(STOP)
QUIT
Begin DoDot:1
+15 SET INS=$ORDER(@STORE@("I",INAME,""))
+16 IF INS=""!STOP
QUIT
+17 DO S
End DoDot:1
+18 ;I SORT=3 D
+19 ;.N I F I=0:0 S I=$O(@STORE@("P",I)) Q:'I D
+20 ;..S A="" F S A=$O(@STORE@("P",I,A)) Q:A="" S @STORE@("P1",A,$O(@STORE@("P",I,A,0)))=""
+21 ;.F S INAME=$O(@STORE@("P1",INAME)) Q:INAME=""!(STOP) D
+22 ;..S INS=$O(@STORE@("P1",INAME,""))
+23 ;..Q:INS=""!STOP
+24 ;..D S W !,STORE,!,ST1 R XXX
+25 DO S1
+26 QUIT
S ;
+1 SET SECN=""
SET ST1=$EXTRACT(STORE,1,($LENGTH(STORE)-1))_","_SEC1_")"
+2 FOR
SET SECN=$ORDER(@ST1@(INS,SECN))
IF SECN=""!(STOP)
QUIT
Begin DoDot:1
+3 ;ien of team or practitioner
SET SEC=$ORDER(@ST1@(INS,SECN,""))
+4 IF SEC=""
QUIT
+5 SET ST3=$EXTRACT(STORE,1,($LENGTH(STORE)-1))_","_SEC3_")"
+6 SET TRDN=""
SET ST2=$EXTRACT(STORE,1,($LENGTH(STORE)-1))_","_SEC2_")"
+7 FOR
SET TRDN=$ORDER(@ST2@(INS,TRDN))
IF TRDN=""!(STOP)
QUIT
Begin DoDot:2
+8 ;ien of team or practitioner
SET TRD=$ORDER(@ST2@(INS,TRDN,""))
+9 IF TRD=""
QUIT
+10 ;have first team and first practitioner ien
+11 SET ST4=$EXTRACT(STORE,1,($LENGTH(STORE)-1))_","_SEC4_")"
+12 DO PRNT(ST4,ST3,SEC3,.PAGE,TITL,INS,SEC,TRD)
IF STOP
QUIT
End DoDot:2
End DoDot:1
+13 QUIT
S1 IF $EXTRACT(IOST)="C"
IF 'STOP
WRITE !
NEW DIR
SET DIR(0)="E"
DO ^DIR
SET STOP=Y'=1
+1 IF 'STOP
IF SUMM=0
SET (FIRST,SUMM)=1
SET TITL=TITL_" Summary Report"
WRITE @IOF
DO PRINTIT(STORE,$GET(IOP),TITL,SORT)
+2 QUIT
+3 ;
PRNT(ST4,ST3,SEC3,PAGE,TITL,INS,SEC,TRD) ;
+1 ;
+2 NEW POS
+3 IF (SEC3="""PN""")&($DATA(@ST3@(INS,SEC,TRD)))
Begin DoDot:1
+4 ;get each position for practitioner
+5 NEW MORE
SET POS=""
SET MORE=0
+6 FOR
SET POS=$ORDER(@ST3@(INS,SEC,TRD,POS))
IF POS=""!(STOP)
QUIT
Begin DoDot:2
+7 IF 'SUMM
IF SORT=3
Begin DoDot:3
+8 ;I MORE ;S FIRST=0
+9 KILL @STORE@("H1")
DO SHEAD^SCRPPAT3
+10 IF 'MORE
IF (PAGE=1)!(IOST?1"C-".E)
DO TITLE^SCRPU3(.PAGE,TITL)
+11 IF 'MORE
WRITE !,$GET(@ST3@(INS,SEC,TRD,POS)),!
+12 DO PAT^SCRPPAT3(INS,SEC,TRD,SEC3,ST3,ST4,POS)
SET MORE=1
+13 IF $ORDER(@ST3@(INS,SEC,TRD,POS))=""
Begin DoDot:4
+14 IF (IOST?1"C-".E)
DO HOLD(.PAGE,"")
SET PAGE=PAGE+1
IF STOP
QUIT
+15 IF (IOST'?1"C-".E)
DO NEWP1^SCRPU3(.PAGE,TITL)
IF STOP
QUIT
End DoDot:4
End DoDot:3
QUIT
+16 IF SUMM
Begin DoDot:3
+17 IF FIRST
DO TITLE^SCRPU3(.PAGE,TITL)
DO SHEAD^SCRPPAT3
DO SSH
SET FIRST=0
+18 IF (IOST'?1"C-".E)
IF $Y>(IOSL-4)
DO NEWP1^SCRPU3(.PAGE,TITL)
IF STOP
QUIT
DO SSH
+19 IF (IOST?1"C-".E)
IF $Y>(IOSL-6)
DO HOLD^SCRPU3(.PAGE,TITL)
IF STOP
QUIT
DO SSH
+20 WRITE !,@STORE@("SUM0",INS,SEC,TRD,POS)
+21 WRITE ?72,$JUSTIFY($GET(@STORE@("TOTAL",INS,SEC,TRD,POS)),8)
+22 QUIT
End DoDot:3
QUIT
+23 IF SORT=3
QUIT
+24 IF FIRST
IF 'MORE
DO TITLE^SCRPU3(.PAGE,TITL)
DO SHEAD^SCRPPAT3
+25 IF (IOST'?1"C-".E)
IF 'SUMM
IF 'FIRST
DO NEWP1^SCRPU3(.PAGE,TITL)
IF 'STOP
WRITE !,$GET(@STORE@(INS))
+26 IF (IOST?1"C-".E)
IF 'SUMM
IF 'FIRST
DO HOLD^SCRPU3(.PAGE,TITL)
IF 'STOP
WRITE !,$GET(@STORE@(INS))
+27 IF STOP
QUIT
SET FIRST=1
IF 'MORE
SET FIRST=0
+28 ;write practitioner (sort 1)
WRITE !,$GET(@ST3@(INS,SEC,TRD,POS))
+29 IF $LENGTH($GET(@ST3@(INS,SEC,TRD,POS,"PRCP")))
WRITE !,@ST3@(INS,SEC,TRD,POS,"PRCP")
+30 ;write team (sort 2)
IF $GET(SORT)'=3
WRITE !,$GET(@ST4@(INS,TRD))
+31 WRITE !,$GET(@STORE@(INS))
+32 ;$o through patients for practitioner on team
+33 DO PAT^SCRPPAT3(INS,SEC,TRD,SEC3,ST3,ST4,POS)
IF STOP
QUIT
+34 IF (IOST'?1"C-".E)
IF $Y>(IOSL-4)
DO NEWP1^SCRPU3(.PAGE,TITL)
IF STOP
QUIT
+35 IF (IOST?1"C-".E)
IF $Y>(IOSL-6)
DO HOLD^SCRPU3(.PAGE,TITL)
IF STOP
QUIT
+36 ;print team/practitioner total
DO TOTAL1^SCRPPAT3(INS,SEC,TRD,POS)
End DoDot:2
End DoDot:1
+37 ;
+38 IF (SEC3="""TN""")&($DATA(@ST4@(INS,TRD,SEC)))
Begin DoDot:1
+39 SET POS=""
+40 FOR
SET POS=$ORDER(@ST4@(INS,TRD,SEC,POS))
IF POS=""!(STOP)
QUIT
Begin DoDot:2
+41 IF SUMM
Begin DoDot:3
+42 IF FIRST
DO TITLE^SCRPU3(.PAGE,TITL)
DO SHEAD^SCRPPAT3
DO SSH
SET FIRST=0
+43 IF (IOST'?1"C-".E)
IF $Y>(IOSL-4)
DO NEWP1^SCRPU3(.PAGE,TITL)
IF STOP
QUIT
DO SSH
+44 IF (IOST?1"C-".E)
IF $Y>(IOSL-6)
DO HOLD^SCRPU3(.PAGE,TITL)
IF STOP
QUIT
DO SSH
+45 WRITE !,@STORE@("SUM0",INS,TRD,SEC,POS)
+46 WRITE ?72,$JUSTIFY(@STORE@("TOTAL",INS,TRD,SEC,POS),8)
+47 QUIT
End DoDot:3
QUIT
+48 IF FIRST
DO TITLE^SCRPU3(.PAGE,TITL)
DO SHEAD^SCRPPAT3
+49 IF (IOST'?1"C-".E)
IF 'SUMM
IF 'FIRST
DO NEWP1^SCRPU3(.PAGE,TITL)
+50 IF (IOST?1"C-".E)
IF 'SUMM
IF 'FIRST
DO HOLD^SCRPU3(.PAGE,TITL)
+51 IF STOP
QUIT
SET FIRST=0
+52 ;write team (sort 1)
IF $GET(SORT)'=3
WRITE !,$GET(@ST3@(INS,SEC))
+53 WRITE !,$GET(@STORE@(INS))
+54 ;write practitioner (sort 2)
IF $GET(SORT)'=3
WRITE !,$GET(@ST4@(INS,TRD,SEC,POS))
+55 IF $LENGTH($GET(@ST4@(INS,TRD,SEC,POS,"PRCP")))
WRITE !,@ST4@(INS,TRD,SEC,POS,"PRCP")
+56 WRITE !
+57 ;$o through patients for practitioner on team
+58 DO PAT^SCRPPAT3(INS,SEC,TRD,SEC3,ST3,ST4,POS)
IF STOP
QUIT
+59 IF (IOST'?1"C-".E)
IF $Y>(IOSL-4)
DO NEWP1^SCRPU3(.PAGE,TITL)
IF STOP
QUIT
+60 IF (IOST?1"C-".E)
IF $Y>(IOSL-6)
DO HOLD^SCRPU3(.PAGE,TITL)
IF STOP
QUIT
+61 ;print team/practitioner total
DO TOTAL1^SCRPPAT3(INS,SEC,TRD,POS)
End DoDot:2
End DoDot:1
+62 QUIT
+63 ;
SSH ;Summary subheader
+1 ;IHS/ANMC/LJF 11/2/2000
IF $GET(VALM)
WRITE !!,"Report Summary"
+2 WRITE !?72,"Patients",!,"Practitioner",?24,"Position",?48,"Team"
+3 WRITE ?72,"Assigned",!
NEW SCI
FOR SCI=1:1:80
WRITE "="
+4 QUIT
HOLD(PAGE,TIT,MARG) ;
+1 ;device is home, reached end of page
+2 NEW X
+3 SET MARG=$GET(MARG)
IF MARG'>80
SET MARG=80
+4 WRITE !!,"Press Any Key to Continue or '^' to Quit"
READ X:DTIME
+5 IF '$TEST!(X="^")
SET STOP=1
QUIT
+6 WRITE @IOF
+7 QUIT
