SCRPEC3 ;ALB/CMM - Detail List of Pts & Enroll Clinics ; 29 Jun 99 04:11PM
;;5.3;Scheduling;**41,48,52,177**;AUG 13, 1993
;
;Detailed Listing of Patients and Their Enrolled Clinics Report
;
FIND ;
N TIEN,OKAY,PTLIST,ERR
I TEAM=1 D TALL^SCRPPAT3 ;get all teams for all divisions selected
S TIEN=0,PTLIST="^TMP(""SCLIST"","_$J_")",ERR="ERROR"
K @PTLIST
F S TIEN=$O(TEAM(TIEN)) Q:TIEN=""!(TIEN'?.N) D
.K @PTLIST,@ERR
.S OKAY=$$PTTM^SCAPMC2(TIEN,"",.PTLIST,.ERR)
.Q:'OKAY
.D PAT^SCRPEC2(TIEN,.PTLIST)
K @PTLIST
Q
;
PRINTIT(STORE,TITL) ;
;print title
N INS,EINST,ETEAM,TEAM,ECLN,CLINIC,PAGE,FIRST,PTIEN,PTNAME,CH2
S (CH2,PAGE)=1,STOP=0
W:$E(IOST)="C" @IOF
D TITLE^SCRPU3(.PAGE,TITL,132)
S (INS,EINST)=""
S FIRST=0
F S EINST=$O(@STORE@("I",EINST)) Q:EINST=""!(STOP) D
.S INS=$O(@STORE@("I",EINST,INS))
.Q:INS=""
.I FIRST,IOST'?1"C-".E D NEWP1^SCRPU3(.PAGE,TITL,132)
.I FIRST,IOST?1"C-".E D HOLD^SCRPU3(.PAGE,TITL,132)
.Q:STOP
.I IOST'?1"C-".E,$Y>(IOSL-5) D NEWP1^SCRPU3(.PAGE,TITL,132)
.I IOST?1"C-".E,$Y>(IOSL-5) D HOLD^SCRPU3(.PAGE,TITL,132)
.Q:STOP!INS=""
.W !,$G(@STORE@(INS)) ;write institution
.S FIRST=1
.S (ETEAM,TEAM)=""
.F S ETEAM=$O(@STORE@("T",INS,ETEAM)) Q:ETEAM=""!(STOP) D
..S TEAM=$O(@STORE@("T",INS,ETEAM,""))
..I IOST'?1"C-".E,$Y>(IOSL-5) D NEWP1^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INS)),!!,$G(@STORE@(INS,TEAM)) D CHEAD^SCRPEC2(INS,TEAM,CLINIC)
..I IOST?1"C-".E,$Y>(IOSL-5) D HOLD^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INS)),!!,$G(@STORE@(INS,TEAM)) D CHEAD^SCRPEC2(INS,TEAM,CLINIC)
..I STOP Q
..W !!,$G(@STORE@(INS,TEAM)) W ! D CH2^SCRPEC2 ;write team
..S (ECLN,CLINIC)=0
..F S ECLN=$O(@STORE@("C",INS,TEAM,ECLN)) Q:ECLN=""!(STOP) D
...S CLINIC=$O(@STORE@("C",INS,TEAM,ECLN,""))
...S PTNAME=""
...F S PTNAME=$O(@STORE@("PT",INS,TEAM,CLINIC,PTNAME)) Q:PTNAME=""!(STOP) D
....S PTIEN=$O(@STORE@("PT",INS,TEAM,CLINIC,PTNAME,""))
....I IOST'?1"C-".E,$Y>(IOSL-5) D NEWP1^SCRPU3(.PAGE,TITL,132) Q:STOP W !,$G(@STORE@(INS)),!!,$G(@STORE@(INS,TEAM)) D CHEAD^SCRPEC2(INS,TEAM,CLINIC)
....I IOST?1"C-".E,$Y>(IOSL-5) D HOLD^SCRPU3(.PAGE,TITL,132) Q:STOP W !,$G(@STORE@(INS)),!!,$G(@STORE@(INS,TEAM)) D CHEAD^SCRPEC2(INS,TEAM,CLINIC)
....Q:STOP
....W !,$G(@STORE@(INS,TEAM,CLINIC,PTIEN))
I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPEC3 2380 printed Dec 13, 2024@02:42:28 Page 2
SCRPEC3 ;ALB/CMM - Detail List of Pts & Enroll Clinics ; 29 Jun 99 04:11PM
+1 ;;5.3;Scheduling;**41,48,52,177**;AUG 13, 1993
+2 ;
+3 ;Detailed Listing of Patients and Their Enrolled Clinics Report
+4 ;
FIND ;
+1 NEW TIEN,OKAY,PTLIST,ERR
+2 ;get all teams for all divisions selected
IF TEAM=1
DO TALL^SCRPPAT3
+3 SET TIEN=0
SET PTLIST="^TMP(""SCLIST"","_$JOB_")"
SET ERR="ERROR"
+4 KILL @PTLIST
+5 FOR
SET TIEN=$ORDER(TEAM(TIEN))
if TIEN=""!(TIEN'?.N)
QUIT
Begin DoDot:1
+6 KILL @PTLIST,@ERR
+7 SET OKAY=$$PTTM^SCAPMC2(TIEN,"",.PTLIST,.ERR)
+8 if 'OKAY
QUIT
+9 DO PAT^SCRPEC2(TIEN,.PTLIST)
End DoDot:1
+10 KILL @PTLIST
+11 QUIT
+12 ;
PRINTIT(STORE,TITL) ;
+1 ;print title
+2 NEW INS,EINST,ETEAM,TEAM,ECLN,CLINIC,PAGE,FIRST,PTIEN,PTNAME,CH2
+3 SET (CH2,PAGE)=1
SET STOP=0
+4 if $EXTRACT(IOST)="C"
WRITE @IOF
+5 DO TITLE^SCRPU3(.PAGE,TITL,132)
+6 SET (INS,EINST)=""
+7 SET FIRST=0
+8 FOR
SET EINST=$ORDER(@STORE@("I",EINST))
if EINST=""!(STOP)
QUIT
Begin DoDot:1
+9 SET INS=$ORDER(@STORE@("I",EINST,INS))
+10 if INS=""
QUIT
+11 IF FIRST
IF IOST'?1"C-".E
DO NEWP1^SCRPU3(.PAGE,TITL,132)
+12 IF FIRST
IF IOST?1"C-".E
DO HOLD^SCRPU3(.PAGE,TITL,132)
+13 if STOP
QUIT
+14 IF IOST'?1"C-".E
IF $Y>(IOSL-5)
DO NEWP1^SCRPU3(.PAGE,TITL,132)
+15 IF IOST?1"C-".E
IF $Y>(IOSL-5)
DO HOLD^SCRPU3(.PAGE,TITL,132)
+16 if STOP!INS=""
QUIT
+17 ;write institution
WRITE !,$GET(@STORE@(INS))
+18 SET FIRST=1
+19 SET (ETEAM,TEAM)=""
+20 FOR
SET ETEAM=$ORDER(@STORE@("T",INS,ETEAM))
if ETEAM=""!(STOP)
QUIT
Begin DoDot:2
+21 SET TEAM=$ORDER(@STORE@("T",INS,ETEAM,""))
+22 IF IOST'?1"C-".E
IF $Y>(IOSL-5)
DO NEWP1^SCRPU3(.PAGE,TITL,132)
if 'STOP
WRITE !,$GET(@STORE@(INS)),!!,$GET(@STORE@(INS,TEAM))
DO CHEAD^SCRPEC2(INS,TEAM,CLINIC)
+23 IF IOST?1"C-".E
IF $Y>(IOSL-5)
DO HOLD^SCRPU3(.PAGE,TITL,132)
if 'STOP
WRITE !,$GET(@STORE@(INS)),!!,$GET(@STORE@(INS,TEAM))
DO CHEAD^SCRPEC2(INS,TEAM,CLINIC)
+24 IF STOP
QUIT
+25 ;write team
WRITE !!,$GET(@STORE@(INS,TEAM))
WRITE !
DO CH2^SCRPEC2
+26 SET (ECLN,CLINIC)=0
+27 FOR
SET ECLN=$ORDER(@STORE@("C",INS,TEAM,ECLN))
if ECLN=""!(STOP)
QUIT
Begin DoDot:3
+28 SET CLINIC=$ORDER(@STORE@("C",INS,TEAM,ECLN,""))
+29 SET PTNAME=""
+30 FOR
SET PTNAME=$ORDER(@STORE@("PT",INS,TEAM,CLINIC,PTNAME))
if PTNAME=""!(STOP)
QUIT
Begin DoDot:4
+31 SET PTIEN=$ORDER(@STORE@("PT",INS,TEAM,CLINIC,PTNAME,""))
+32 IF IOST'?1"C-".E
IF $Y>(IOSL-5)
DO NEWP1^SCRPU3(.PAGE,TITL,132)
if STOP
QUIT
WRITE !,$GET(@STORE@(INS)),!!,$GET(@STORE@(INS,TEAM))
DO CHEAD^SCRPEC2(INS,TEAM,CLINIC)
+33 IF IOST?1"C-".E
IF $Y>(IOSL-5)
DO HOLD^SCRPU3(.PAGE,TITL,132)
if STOP
QUIT
WRITE !,$GET(@STORE@(INS)),!!,$GET(@STORE@(INS,TEAM))
DO CHEAD^SCRPEC2(INS,TEAM,CLINIC)
+34 if STOP
QUIT
+35 WRITE !,$GET(@STORE@(INS,TEAM,CLINIC,PTIEN))
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+36 IF 'STOP
IF $EXTRACT(IOST)="C"
NEW DIR
SET DIR(0)="E"
WRITE !
DO ^DIR
+37 QUIT
