SCRPTP2 ;ALB/CMM - List of Team's Patients ; 29 Jun 99 04:11PM
;;5.3;Scheduling;**41,53,52,174,177,231,526,520**;AUG 13, 1993;Build 26
;
;List of Team's Patients Report
;
TFORMAT(INST,INAME,TIEN,TNAME,PHONE,PC) ; Format team information
;INST - institution ien
;INAME - institution name
;TIEN - team ien
;TNAME - team name
;PHONE - team phone
;PC - primary care team (yes/no)
;
I INAME="" S INAME="[BAD DATA]"
I TNAME="" S TNAME="[BAD DATA]"
S @STORE@("I",INAME,INST)=""
S @STORE@("T",INST,TNAME,TIEN)=""
S @STORE@(INST)="Division: "_INAME
S @STORE@(INST,TIEN)="Team: "_TNAME
S $E(@STORE@(INST,TIEN),45)="Team Phone: "_PHONE
S @STORE@(INST,TIEN,1)="Primary Care Team: "_PC
Q
;
PRINTIT(STORE,TITL) ;
N INST,INAME,TNAME,TIEN
S (NEW,PAGE)=1,STOP=0 W:$E(IOST)="C" @IOF
D TITLE^SCRPU3(.PAGE,TITL,132) ;write title
D SETH
;
S INAME=""
F S INAME=$O(@STORE@("I",INAME)) Q:INAME=""!(STOP) D
.S INST=$O(@STORE@("I",INAME,""))
.Q:INST=""
.I ('NEW)&(IOST'?1"C-".E) D NEWP1^SCRPU3(.PAGE,TITL,132)
.I ('NEW)&(IOST?1"C-".E) D HOLD^SCRPU3(.PAGE,TITL,132)
.Q:STOP
.W !,$G(@STORE@(INST)) ;write institution
.S TNAME=""
.F S TNAME=$O(@STORE@("T",INST,TNAME)) Q:TNAME=""!(STOP) D
..S TIEN=$O(@STORE@("T",INST,TNAME,""))
..Q:TIEN=""
..D TPRINT(INST,TIEN) ;writes team info
..Q:STOP
..;
..I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132)
..I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132)
..Q:STOP
..D HEADER
..I (SORT=3)!(SORT=4) D PRACT(INST,TIEN,.NEW)
..I (SORT=1)!(SORT=2) D PTP(INST,TIEN,.NEW)
K NEW,PAGE
I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR
Q
;
PRACT(INST,TIEN,NEW) ;Print by practitioner/patient
N PNAME,PIEN,SEC2,ST1,TRD,TRDI
S PNAME="",PIEN=""
F S PNAME=$O(@STORE@("P",INST,TIEN,PNAME)) Q:PNAME=""!(STOP) D
. F S PIEN=$O(@STORE@("P",INST,TIEN,PNAME,PIEN)) Q:PIEN=""!(STOP) D
. . I (SORT=1)!(SORT=3) S SEC2="""PT""" ;sort by patient name
. . I (SORT=2)!(SORT=4) S SEC2="""PID""" ;sort by last 4 PID
. . S ST1=$E(STORE,1,$L(STORE)-1)_","_SEC2_")"
. . I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER
. . Q:STOP
. . I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER
. . Q:STOP
. . S (TRDI,TRD)=""
. . F S TRD=$O(@ST1@(INST,TIEN,TRD)) Q:TRD=""!(STOP) D
. . . F S TRDI=$O(@ST1@(INST,TIEN,TRD,TRDI)) Q:TRDI=""!(STOP) D
. . . . I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER
. . . . Q:STOP
. . . . I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER
. . . . Q:STOP
. . . . I $D(@STORE@(INST,TIEN,PIEN,TRDI)) W !,$G(@STORE@(INST,TIEN,PIEN,TRDI)) ;write column data
. . . . N SCACL
. . . . S SCACL="" F S SCACL=$O(@STORE@(INST,TIEN,PIEN,TRDI,SCACL)) Q:SCACL="" D
. . . . . W !,$G(@STORE@(INST,TIEN,PIEN,TRDI,SCACL))
. S NEW=0
Q
;
PTP(INST,TIEN,NEW) ;Print by patient/practitioner
N SEC2,ST1,TRDI,TRD,PNAME,PIEN
I (SORT=1)!(SORT=3) S SEC2="""PT""" ;sort by patient name
I (SORT=2)!(SORT=4) S SEC2="""PID""" ;sort by last 4 PID
S ST1=$E(STORE,1,$L(STORE)-1)_","_SEC2_")"
I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132)
I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132)
Q:STOP
S (TRDI,TRD)=""
F S TRD=$O(@ST1@(INST,TIEN,TRD)) Q:TRD=""!(STOP) D
. F S TRDI=$O(@ST1@(INST,TIEN,TRD,TRDI)) Q:TRDI=""!(STOP) D
. . I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER
. . Q:STOP
. . I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER
. . Q:STOP
. . S PNAME="",PIEN=""
. . F S PNAME=$O(@STORE@("P",INST,TIEN,PNAME)) Q:PNAME=""!(STOP)!(PIEN=0) D
. . . F S PIEN=$O(@STORE@("P",INST,TIEN,PNAME,PIEN)) Q:PIEN=""!(STOP) D
. . . . I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER
. . . . Q:STOP
. . . . I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER
. . . . Q:STOP
. . . . I $D(@STORE@(INST,TIEN,TRDI,PIEN)) W !,$G(@STORE@(INST,TIEN,TRDI,PIEN)) ;write column data
. . . . N SCACL
. . . . S SCACL="" F S SCACL=$O(@STORE@(INST,TIEN,TRDI,PIEN,SCACL)) Q:SCACL="" D
. . . . . W !,$G(@STORE@(INST,TIEN,TRDI,PIEN,SCACL))
. S NEW=0
Q
;
TPRINT(INST,TIEN) ;
;prints team data
N NXT
I (IOST'?1"C-".E)&($Y>(IOSL-13)) D NEWP1^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INST))
I (IOST?1"C-".E)&($Y>(IOSL-13)) D HOLD^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INST))
Q:STOP
W !!,$G(@STORE@(INST,TIEN))
S NXT=0
W !,$G(@STORE@(INST,TIEN,1)) ;write team info
Q:'$D(@STORE@(INST,TIEN,"D")) W !
S NXT=""
;write team description
F S NXT=$O(@STORE@(INST,TIEN,"D",NXT)) Q:NXT=""!(STOP) D
.I (IOST'?1"C-".E)&$Y>(IOSL-13) D NEWP1^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INST))
.I (IOST?1"C-".E)&$Y>(IOSL-13) D HOLD^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INST))
.Q:STOP
.W !,$G(@STORE@(INST,TIEN,"D",NXT))
W !!,"[Not Assigned] = Patient assigned to Team but not to a position/provider"
W !,"[Inactive Position] = Patient assigned to Team & Position but has no active provider"
Q
;
N NXT
F NXT="H1","H2","H3" D
.W !,$G(@STORE@(NXT))
Q
;
SETH ;sets column headings
S @STORE@("H2")="Patient Name"
S $E(@STORE@("H2"),18)="Pt ID"
S $E(@STORE@("H2"),32)="Practitioner"
S $E(@STORE@("H2"),56)="Role"
S $E(@STORE@("H2"),80)="PC?"
S $E(@STORE@("H1"),85)="Last"
S $E(@STORE@("H2"),85)="Appt."
S $E(@STORE@("H1"),97)="Next"
S $E(@STORE@("H2"),97)="Appt."
S $E(@STORE@("H2"),109)="Associated Clinic"
S $P(@STORE@("H3"),"=",133)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPTP2 5700 printed Apr 09, 2024@21:54:35 Page 2
SCRPTP2 ;ALB/CMM - List of Team's Patients ; 29 Jun 99 04:11PM
+1 ;;5.3;Scheduling;**41,53,52,174,177,231,526,520**;AUG 13, 1993;Build 26
+2 ;
+3 ;List of Team's Patients Report
+4 ;
TFORMAT(INST,INAME,TIEN,TNAME,PHONE,PC) ; Format team information
+1 ;INST - institution ien
+2 ;INAME - institution name
+3 ;TIEN - team ien
+4 ;TNAME - team name
+5 ;PHONE - team phone
+6 ;PC - primary care team (yes/no)
+7 ;
+8 IF INAME=""
SET INAME="[BAD DATA]"
+9 IF TNAME=""
SET TNAME="[BAD DATA]"
+10 SET @STORE@("I",INAME,INST)=""
+11 SET @STORE@("T",INST,TNAME,TIEN)=""
+12 SET @STORE@(INST)="Division: "_INAME
+13 SET @STORE@(INST,TIEN)="Team: "_TNAME
+14 SET $EXTRACT(@STORE@(INST,TIEN),45)="Team Phone: "_PHONE
+15 SET @STORE@(INST,TIEN,1)="Primary Care Team: "_PC
+16 QUIT
+17 ;
PRINTIT(STORE,TITL) ;
+1 NEW INST,INAME,TNAME,TIEN
+2 SET (NEW,PAGE)=1
SET STOP=0
if $EXTRACT(IOST)="C"
WRITE @IOF
+3 ;write title
DO TITLE^SCRPU3(.PAGE,TITL,132)
+4 DO SETH
+5 ;
+6 SET INAME=""
+7 FOR
SET INAME=$ORDER(@STORE@("I",INAME))
if INAME=""!(STOP)
QUIT
Begin DoDot:1
+8 SET INST=$ORDER(@STORE@("I",INAME,""))
+9 if INST=""
QUIT
+10 IF ('NEW)&(IOST'?1"C-".E)
DO NEWP1^SCRPU3(.PAGE,TITL,132)
+11 IF ('NEW)&(IOST?1"C-".E)
DO HOLD^SCRPU3(.PAGE,TITL,132)
+12 if STOP
QUIT
+13 ;write institution
WRITE !,$GET(@STORE@(INST))
+14 SET TNAME=""
+15 FOR
SET TNAME=$ORDER(@STORE@("T",INST,TNAME))
if TNAME=""!(STOP)
QUIT
Begin DoDot:2
+16 SET TIEN=$ORDER(@STORE@("T",INST,TNAME,""))
+17 if TIEN=""
QUIT
+18 ;writes team info
DO TPRINT(INST,TIEN)
+19 if STOP
QUIT
+20 ;
+21 IF (IOST'?1"C-".E)&($Y>(IOSL-4))
DO NEWP1^SCRPU3(.PAGE,TITL,132)
+22 IF (IOST?1"C-".E)&($Y>(IOSL-4))
DO HOLD^SCRPU3(.PAGE,TITL,132)
+23 if STOP
QUIT
+24 DO HEADER
+25 IF (SORT=3)!(SORT=4)
DO PRACT(INST,TIEN,.NEW)
+26 IF (SORT=1)!(SORT=2)
DO PTP(INST,TIEN,.NEW)
End DoDot:2
End DoDot:1
+27 KILL NEW,PAGE
+28 IF 'STOP
IF $EXTRACT(IOST)="C"
NEW DIR
SET DIR(0)="E"
WRITE !
DO ^DIR
+29 QUIT
+30 ;
PRACT(INST,TIEN,NEW) ;Print by practitioner/patient
+1 NEW PNAME,PIEN,SEC2,ST1,TRD,TRDI
+2 SET PNAME=""
SET PIEN=""
+3 FOR
SET PNAME=$ORDER(@STORE@("P",INST,TIEN,PNAME))
if PNAME=""!(STOP)
QUIT
Begin DoDot:1
+4 FOR
SET PIEN=$ORDER(@STORE@("P",INST,TIEN,PNAME,PIEN))
if PIEN=""!(STOP)
QUIT
Begin DoDot:2
+5 ;sort by patient name
IF (SORT=1)!(SORT=3)
SET SEC2="""PT"""
+6 ;sort by last 4 PID
IF (SORT=2)!(SORT=4)
SET SEC2="""PID"""
+7 SET ST1=$EXTRACT(STORE,1,$LENGTH(STORE)-1)_","_SEC2_")"
+8 IF (IOST'?1"C-".E)&($Y>(IOSL-4))
DO NEWP1^SCRPU3(.PAGE,TITL,132)
if 'STOP
DO HEADER
+9 if STOP
QUIT
+10 IF (IOST?1"C-".E)&($Y>(IOSL-4))
DO HOLD^SCRPU3(.PAGE,TITL,132)
if 'STOP
DO HEADER
+11 if STOP
QUIT
+12 SET (TRDI,TRD)=""
+13 FOR
SET TRD=$ORDER(@ST1@(INST,TIEN,TRD))
if TRD=""!(STOP)
QUIT
Begin DoDot:3
+14 FOR
SET TRDI=$ORDER(@ST1@(INST,TIEN,TRD,TRDI))
if TRDI=""!(STOP)
QUIT
Begin DoDot:4
+15 IF (IOST'?1"C-".E)&($Y>(IOSL-4))
DO NEWP1^SCRPU3(.PAGE,TITL,132)
if 'STOP
DO HEADER
+16 if STOP
QUIT
+17 IF (IOST?1"C-".E)&($Y>(IOSL-4))
DO HOLD^SCRPU3(.PAGE,TITL,132)
if 'STOP
DO HEADER
+18 if STOP
QUIT
+19 ;write column data
IF $DATA(@STORE@(INST,TIEN,PIEN,TRDI))
WRITE !,$GET(@STORE@(INST,TIEN,PIEN,TRDI))
+20 NEW SCACL
+21 SET SCACL=""
FOR
SET SCACL=$ORDER(@STORE@(INST,TIEN,PIEN,TRDI,SCACL))
if SCACL=""
QUIT
Begin DoDot:5
+22 WRITE !,$GET(@STORE@(INST,TIEN,PIEN,TRDI,SCACL))
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+23 SET NEW=0
End DoDot:1
+24 QUIT
+25 ;
PTP(INST,TIEN,NEW) ;Print by patient/practitioner
+1 NEW SEC2,ST1,TRDI,TRD,PNAME,PIEN
+2 ;sort by patient name
IF (SORT=1)!(SORT=3)
SET SEC2="""PT"""
+3 ;sort by last 4 PID
IF (SORT=2)!(SORT=4)
SET SEC2="""PID"""
+4 SET ST1=$EXTRACT(STORE,1,$LENGTH(STORE)-1)_","_SEC2_")"
+5 IF (IOST'?1"C-".E)&($Y>(IOSL-4))
DO NEWP1^SCRPU3(.PAGE,TITL,132)
+6 IF (IOST?1"C-".E)&($Y>(IOSL-4))
DO HOLD^SCRPU3(.PAGE,TITL,132)
+7 if STOP
QUIT
+8 SET (TRDI,TRD)=""
+9 FOR
SET TRD=$ORDER(@ST1@(INST,TIEN,TRD))
if TRD=""!(STOP)
QUIT
Begin DoDot:1
+10 FOR
SET TRDI=$ORDER(@ST1@(INST,TIEN,TRD,TRDI))
if TRDI=""!(STOP)
QUIT
Begin DoDot:2
+11 IF (IOST'?1"C-".E)&($Y>(IOSL-4))
DO NEWP1^SCRPU3(.PAGE,TITL,132)
if 'STOP
DO HEADER
+12 if STOP
QUIT
+13 IF (IOST?1"C-".E)&($Y>(IOSL-4))
DO HOLD^SCRPU3(.PAGE,TITL,132)
if 'STOP
DO HEADER
+14 if STOP
QUIT
+15 SET PNAME=""
SET PIEN=""
+16 FOR
SET PNAME=$ORDER(@STORE@("P",INST,TIEN,PNAME))
if PNAME=""!(STOP)!(PIEN=0)
QUIT
Begin DoDot:3
+17 FOR
SET PIEN=$ORDER(@STORE@("P",INST,TIEN,PNAME,PIEN))
if PIEN=""!(STOP)
QUIT
Begin DoDot:4
+18 IF (IOST'?1"C-".E)&($Y>(IOSL-4))
DO NEWP1^SCRPU3(.PAGE,TITL,132)
if 'STOP
DO HEADER
+19 if STOP
QUIT
+20 IF (IOST?1"C-".E)&($Y>(IOSL-4))
DO HOLD^SCRPU3(.PAGE,TITL,132)
if 'STOP
DO HEADER
+21 if STOP
QUIT
+22 ;write column data
IF $DATA(@STORE@(INST,TIEN,TRDI,PIEN))
WRITE !,$GET(@STORE@(INST,TIEN,TRDI,PIEN))
+23 NEW SCACL
+24 SET SCACL=""
FOR
SET SCACL=$ORDER(@STORE@(INST,TIEN,TRDI,PIEN,SCACL))
if SCACL=""
QUIT
Begin DoDot:5
+25 WRITE !,$GET(@STORE@(INST,TIEN,TRDI,PIEN,SCACL))
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+26 SET NEW=0
End DoDot:1
+27 QUIT
+28 ;
TPRINT(INST,TIEN) ;
+1 ;prints team data
+2 NEW NXT
+3 IF (IOST'?1"C-".E)&($Y>(IOSL-13))
DO NEWP1^SCRPU3(.PAGE,TITL,132)
if 'STOP
WRITE !,$GET(@STORE@(INST))
+4 IF (IOST?1"C-".E)&($Y>(IOSL-13))
DO HOLD^SCRPU3(.PAGE,TITL,132)
if 'STOP
WRITE !,$GET(@STORE@(INST))
+5 if STOP
QUIT
+6 WRITE !!,$GET(@STORE@(INST,TIEN))
+7 SET NXT=0
+8 ;write team info
WRITE !,$GET(@STORE@(INST,TIEN,1))
+9 if '$DATA(@STORE@(INST,TIEN,"D"))
QUIT
WRITE !
+10 SET NXT=""
+11 ;write team description
+12 FOR
SET NXT=$ORDER(@STORE@(INST,TIEN,"D",NXT))
if NXT=""!(STOP)
QUIT
Begin DoDot:1
+13 IF (IOST'?1"C-".E)&$Y>(IOSL-13)
DO NEWP1^SCRPU3(.PAGE,TITL,132)
if 'STOP
WRITE !,$GET(@STORE@(INST))
+14 IF (IOST?1"C-".E)&$Y>(IOSL-13)
DO HOLD^SCRPU3(.PAGE,TITL,132)
if 'STOP
WRITE !,$GET(@STORE@(INST))
+15 if STOP
QUIT
+16 WRITE !,$GET(@STORE@(INST,TIEN,"D",NXT))
End DoDot:1
+17 WRITE !!,"[Not Assigned] = Patient assigned to Team but not to a position/provider"
+18 WRITE !,"[Inactive Position] = Patient assigned to Team & Position but has no active provider"
+19 QUIT
+20 ;
+1 NEW NXT
+2 FOR NXT="H1","H2","H3"
Begin DoDot:1
+3 WRITE !,$GET(@STORE@(NXT))
End DoDot:1
+4 QUIT
+5 ;
SETH ;sets column headings
+1 SET @STORE@("H2")="Patient Name"
+2 SET $EXTRACT(@STORE@("H2"),18)="Pt ID"
+3 SET $EXTRACT(@STORE@("H2"),32)="Practitioner"
+4 SET $EXTRACT(@STORE@("H2"),56)="Role"
+5 SET $EXTRACT(@STORE@("H2"),80)="PC?"
+6 SET $EXTRACT(@STORE@("H1"),85)="Last"
+7 SET $EXTRACT(@STORE@("H2"),85)="Appt."
+8 SET $EXTRACT(@STORE@("H1"),97)="Next"
+9 SET $EXTRACT(@STORE@("H2"),97)="Appt."
+10 SET $EXTRACT(@STORE@("H2"),109)="Associated Clinic"
+11 SET $PIECE(@STORE@("H3"),"=",133)=""
+12 QUIT
