- SCRPEC3 ;ALB/CMM - Detail List of Pts & Enroll Clinics ; 29 Jun 99 04:11PM
- ;;5.3;Scheduling;**41,48,52,177,1015**;AUG 13, 1993;Build 21
- ;
- ;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
- SCRPEC3 ;ALB/CMM - Detail List of Pts & Enroll Clinics ; 29 Jun 99 04:11PM
- +1 ;;5.3;Scheduling;**41,48,52,177,1015**;AUG 13, 1993;Build 21
- +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
