SCRPPAT3 ;ALB/CMM - Practitioner's Patients ; 8/30/99 3:14pm
;;5.3;PIMS;**41,52,148,174,181,177,297,526,520,1015,1016**;JUN 30, 2012;Build 20
;IHS/ANMC/LJF 11/02/2000 added call to IHS code for column headings
; added extra line between providers
;
;Listing of Practitioner's Patients
;
PAT(INS,SEC,TRD,SEC3,ST3,ST4,POS) ;
;writes patients for position/practitioner
N PTN,PT,FIRST
S PTN="",FIRST=1
I SUMM D TOTAL1^SCRPPAT3(INS,SEC,TRD,POS) Q ;Summary only
F S PTN=$O(@STORE@("PT",INS,SEC,TRD,POS,PTN)) Q:PTN=""!(STOP) D
.S PT=0
.F S PT=$O(@STORE@("PT",INS,SEC,TRD,POS,PTN,PT)) Q:'PT!(STOP) D
..I FIRST D HEADER S FIRST=0
..W !,$G(@STORE@(INS,SEC,TRD,POS,PT)) ;print patient detail line
..N SCCN
..S SCCN=""
..F S SCCN=$O(@STORE@(INS,SEC,TRD,POS,PT,SCCN)) Q:SCCN="" D
...W !,$G(@STORE@(INS,SEC,TRD,POS,PT,SCCN)) ;print patient detail line
...Q:STOP
..Q
.I (IOST'?1"C-".E),$Y>(IOSL-5) S MORE=0 D NEWP1^SCRPU3(.PAGE,TITL) D:'STOP HEAD2(INS,SEC,TRD,SEC3,ST3,ST4,POS) D:(('FIRST&'STOP)!($G(SORT)=3)) HEADER
.I (IOST?1"C-".E),$Y>(IOSL-5) S MORE=0 D HOLD^SCRPU3(.PAGE,TITL) D:'STOP HEAD2(INS,SEC,TRD,SEC3,ST3,ST4,POS) D:'FIRST&'STOP HEADER
.Q
Q
;
SPRINT(STORE,IOP,TITL,SORT) ; Summary Print Only
;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
D OPEN^SCRPU3
Q:$G(POP)
D TITLE^SCRPU3(.PAGE,TITL)
D CLOSE^SCRPU3
Q
;
TOTAL1(INS,SEC,TRD,POS) ;
;print team/practitioner total
N TEM,PRC
I SORT=1 S TEM=SEC,PRC=TRD
I SORT=2!(SORT=3) S TEM=TRD,PRC=SEC
W !!,$G(@STORE@("TH",INS,PRC,TEM,POS)),$G(@STORE@("TOTAL",INS,PRC,TEM,POS))
Q
;
HEAD2(INS,SEC,TRD,SEC3,ST3,ST4,POS) ;
I (SEC3="""TN""")&($D(@ST4@(INS,TRD,SEC))) D
.W !,$G(@ST3@(INS,SEC)) ;write team (sort 1)
.W !,$G(@STORE@(INS))
.W !,$G(@ST4@(INS,TRD,SEC,POS)) ;write practitioner (sort 2)
.I $L($G(@STORE@("PN",INS,TRD,SEC,POS,"PRCP"))) W !,@STORE@("PN",INS,TRD,SEC,POS,"PRCP")
.W !
I (SEC3="""PN""")&($D(@ST3@(INS,SEC,TRD))) D
.W !,$G(@ST3@(INS,SEC,TRD,POS)) ;write practitioner (sort 1)
.I $G(SORT)'=3 I $L($G(@STORE@("PN",INS,SEC,TRD,POS,"PRCP"))) W !,@STORE@("PN",INS,SEC,TRD,POS,"PRCP")
.I $G(SORT)'=3 W !,$G(@ST4@(INS,TRD)) ;write team (sort 2)
.W !,$G(@STORE@(INS))
Q
;
Q:$G(MORE)
I SORT=3 S MORE=1
N NXT
F NXT="H1","H2","H3" W !,$G(@STORE@(NXT))
W !
Q
;
SHEAD ;
D SHEAD^BSDSCPAT Q ;IHS/ANMC/LJF 11/2/2000
S @STORE@("H2")="Pt Name"
S $E(@STORE@("H2"),15)="Pt ID"
S $E(@STORE@("H1"),25)="M.T."
S $E(@STORE@("H2"),25)="Stat"
S $E(@STORE@("H1"),31)="Prim"
S $E(@STORE@("H2"),31)="Elig"
;Removed by patch 174
;S $E(@STORE@("H1"),39)="Pat"
;S $E(@STORE@("H2"),39)="Stat"
S $E(@STORE@("H1"),42)="Last"
S $E(@STORE@("H2"),42)="Appt"
S $E(@STORE@("H1"),54)="Next"
S $E(@STORE@("H2"),54)="Appt"
S $E(@STORE@("H2"),66)="Clinic"
S $P(@STORE@("H3"),"=",81)=""
Q
ALL ;
;get all practitioners for all teams selected
I TEAM=1 D TALL ;all teams selected
N TIEN,OKAY,XLIST,YLIST,SCTP,SCI,SCDT
S TIEN=""
F S TIEN=$O(TEAM(TIEN)) Q:TIEN=""!(TIEN'?.N) D
.I $D(TEAM(TIEN)) D
..K XLIST
..S OKAY=$$TPTM^SCAPMC(TIEN,"","","","XLIST","ERROR")
..S SCTP=0 F S SCTP=$O(XLIST("SCTP",TIEN,SCTP)) Q:'SCTP D
...K YLIST S SCDT="SCDT",(SCDT("BEGIN"),SCDT("END"))=DT,SCDT("INCL")=0
...S OKAY=$$PRTP^SCAPMC(SCTP,.SCDT,"YLIST","ERROR",1,0)
...S SCI=0 F S SCI=$O(YLIST(SCI)) Q:'SCI D
....S @TPRC@(0)=$G(@TPRC@(0))+1
....S @TPRC@(@TPRC@(0))=YLIST(SCI)
Q
;
TALL ;
;get all active team for divisions selected
N NXT,IIEN,NODE
S NXT=0,IIEN=""
;$O through team file and find all active teams for selected divisions
F S IIEN=$O(^SCTM(404.51,"AINST",IIEN)) Q:IIEN="" D
.I INST=1!$D(INST(IIEN)) D
..S TIEN=0
..F S TIEN=$O(^SCTM(404.51,"AINST",IIEN,TIEN)) Q:TIEN="" D
...I $$ACTTM^SCMCTMU(TIEN) S TEAM(TIEN)=""
Q
;
SETUP(IIEN,INAME,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP) ;
;setup data
S IIEN=+$P($G(^SCTM(404.51,TIEN,0)),"^",7) ;institution ien
S INAME=$P($G(^DIC(4,IIEN,0)),"^") ;institution name
I INAME="" S INAME="[BAD DATA]"
;
I PNAME="" S PNAME="[BAD DATA]"
I TNAME="" S TNAME="[BAD DATA]"
I $G(SORT)=3 S IIEN=1,TIEN=1
I '$D(@STORE@("PN",IIEN,PRAC,TIEN,TPI)) S @STORE@("PN",IIEN,PRAC,TIEN,TPI)="Practitioner: "_PNAME_$S(SORT=3:"",1:" ("_POSN_")")
I $L(PRCP) S @STORE@("PN",IIEN,PRAC,TIEN,TPI,"PRCP")=" Preceptor: "_PRCP
I '$D(@STORE@("TN",IIEN,$S($G(SORT)=3:1,1:TIEN))) S @STORE@("TN",IIEN,$S($G(SORT)=3:1,1:TIEN))=" Team: "_TNAME
;
I '$D(@STORE@("I",$S($G(SORT)=3:"S3",1:INAME),IIEN)) S @STORE@("I",$S($G(SORT)=3:"S3",1:INAME),IIEN)="",@STORE@(IIEN)=$S(SORT=3:"",1:" Division: "_INAME)
S @STORE@("T",IIEN,$S($G(SORT)=3:"T3",1:TNAME),$S($G(SORT)=3:1,1:TIEN))=""
I '$D(@STORE@("P",IIEN,PNAME,PRAC,TPI)) S @STORE@("P",IIEN,PNAME,PRAC,TPI)=""
I '$D(@STORE@("TOTAL",IIEN,PRAC,0)) S @STORE@("TOTAL",IIEN,PRAC,0)=0
I '$D(@STORE@("TOTAL",IIEN,PRAC,TIEN)) S @STORE@("TOTAL",IIEN,PRAC,TIEN)=0
;
S @STORE@("TH",IIEN,PRAC)="Patient Count for "_PNAME_": "
S @STORE@("TH",IIEN,PRAC,TIEN,TPI)="Patient Count for "_PNAME_": "
N SCX
S SCX=$E(PNAME,1,22),$E(SCX,25)=$E(POSN,1,22),$E(SCX,49)=$E(TNAME,1,22)
S @STORE@("SUM0",IIEN,PRAC,TIEN,TPI)=SCX
;
S @STORE@("TH",IIEN)="** Note: Patient Panel Count is a count of unique patients for each practitioner"
Q 0
SCRPPAT3 ;ALB/CMM - Practitioner's Patients ; 8/30/99 3:14pm
+1 ;;5.3;PIMS;**41,52,148,174,181,177,297,526,520,1015,1016**;JUN 30, 2012;Build 20
+2 ;IHS/ANMC/LJF 11/02/2000 added call to IHS code for column headings
+3 ; added extra line between providers
+4 ;
+5 ;Listing of Practitioner's Patients
+6 ;
PAT(INS,SEC,TRD,SEC3,ST3,ST4,POS) ;
+1 ;writes patients for position/practitioner
+2 NEW PTN,PT,FIRST
+3 SET PTN=""
SET FIRST=1
+4 ;Summary only
IF SUMM
DO TOTAL1^SCRPPAT3(INS,SEC,TRD,POS)
QUIT
+5 FOR
SET PTN=$ORDER(@STORE@("PT",INS,SEC,TRD,POS,PTN))
IF PTN=""!(STOP)
QUIT
Begin DoDot:1
+6 SET PT=0
+7 FOR
SET PT=$ORDER(@STORE@("PT",INS,SEC,TRD,POS,PTN,PT))
IF 'PT!(STOP)
QUIT
Begin DoDot:2
+8 IF FIRST
DO HEADER
SET FIRST=0
+9 ;print patient detail line
WRITE !,$GET(@STORE@(INS,SEC,TRD,POS,PT))
+10 NEW SCCN
+11 SET SCCN=""
+12 FOR
SET SCCN=$ORDER(@STORE@(INS,SEC,TRD,POS,PT,SCCN))
IF SCCN=""
QUIT
Begin DoDot:3
+13 ;print patient detail line
WRITE !,$GET(@STORE@(INS,SEC,TRD,POS,PT,SCCN))
+14 IF STOP
QUIT
End DoDot:3
+15 QUIT
End DoDot:2
+16 IF (IOST'?1"C-".E)
IF $Y>(IOSL-5)
SET MORE=0
DO NEWP1^SCRPU3(.PAGE,TITL)
IF 'STOP
DO HEAD2(INS,SEC,TRD,SEC3,ST3,ST4,POS)
IF (('FIRST&'STOP)!($GET(SORT)=3))
DO HEADER
+17 IF (IOST?1"C-".E)
IF $Y>(IOSL-5)
SET MORE=0
DO HOLD^SCRPU3(.PAGE,TITL)
IF 'STOP
DO HEAD2(INS,SEC,TRD,SEC3,ST3,ST4,POS)
IF 'FIRST&'STOP
DO HEADER
+18 QUIT
End DoDot:1
+19 QUIT
+20 ;
SPRINT(STORE,IOP,TITL,SORT) ; Summary Print Only
+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
+8 DO OPEN^SCRPU3
+9 IF $GET(POP)
QUIT
+10 DO TITLE^SCRPU3(.PAGE,TITL)
+11 DO CLOSE^SCRPU3
+12 QUIT
+13 ;
TOTAL1(INS,SEC,TRD,POS) ;
+1 ;print team/practitioner total
+2 NEW TEM,PRC
+3 IF SORT=1
SET TEM=SEC
SET PRC=TRD
+4 IF SORT=2!(SORT=3)
SET TEM=TRD
SET PRC=SEC
+5 WRITE !!,$GET(@STORE@("TH",INS,PRC,TEM,POS)),$GET(@STORE@("TOTAL",INS,PRC,TEM,POS))
+6 QUIT
+7 ;
HEAD2(INS,SEC,TRD,SEC3,ST3,ST4,POS) ;
+1 IF (SEC3="""TN""")&($DATA(@ST4@(INS,TRD,SEC)))
Begin DoDot:1
+2 ;write team (sort 1)
WRITE !,$GET(@ST3@(INS,SEC))
+3 WRITE !,$GET(@STORE@(INS))
+4 ;write practitioner (sort 2)
WRITE !,$GET(@ST4@(INS,TRD,SEC,POS))
+5 IF $LENGTH($GET(@STORE@("PN",INS,TRD,SEC,POS,"PRCP")))
WRITE !,@STORE@("PN",INS,TRD,SEC,POS,"PRCP")
+6 WRITE !
End DoDot:1
+7 IF (SEC3="""PN""")&($DATA(@ST3@(INS,SEC,TRD)))
Begin DoDot:1
+8 ;write practitioner (sort 1)
WRITE !,$GET(@ST3@(INS,SEC,TRD,POS))
+9 IF $GET(SORT)'=3
IF $LENGTH($GET(@STORE@("PN",INS,SEC,TRD,POS,"PRCP")))
WRITE !,@STORE@("PN",INS,SEC,TRD,POS,"PRCP")
+10 ;write team (sort 2)
IF $GET(SORT)'=3
WRITE !,$GET(@ST4@(INS,TRD))
+11 WRITE !,$GET(@STORE@(INS))
End DoDot:1
+12 QUIT
+13 ;
+1 IF $GET(MORE)
QUIT
+2 IF SORT=3
SET MORE=1
+3 NEW NXT
+4 FOR NXT="H1","H2","H3"
WRITE !,$GET(@STORE@(NXT))
+5 WRITE !
+6 QUIT
+7 ;
SHEAD ;
+1 ;IHS/ANMC/LJF 11/2/2000
DO SHEAD^BSDSCPAT
QUIT
+2 SET @STORE@("H2")="Pt Name"
+3 SET $EXTRACT(@STORE@("H2"),15)="Pt ID"
+4 SET $EXTRACT(@STORE@("H1"),25)="M.T."
+5 SET $EXTRACT(@STORE@("H2"),25)="Stat"
+6 SET $EXTRACT(@STORE@("H1"),31)="Prim"
+7 SET $EXTRACT(@STORE@("H2"),31)="Elig"
+8 ;Removed by patch 174
+9 ;S $E(@STORE@("H1"),39)="Pat"
+10 ;S $E(@STORE@("H2"),39)="Stat"
+11 SET $EXTRACT(@STORE@("H1"),42)="Last"
+12 SET $EXTRACT(@STORE@("H2"),42)="Appt"
+13 SET $EXTRACT(@STORE@("H1"),54)="Next"
+14 SET $EXTRACT(@STORE@("H2"),54)="Appt"
+15 SET $EXTRACT(@STORE@("H2"),66)="Clinic"
+16 SET $PIECE(@STORE@("H3"),"=",81)=""
+17 QUIT
ALL ;
+1 ;get all practitioners for all teams selected
+2 ;all teams selected
IF TEAM=1
DO TALL
+3 NEW TIEN,OKAY,XLIST,YLIST,SCTP,SCI,SCDT
+4 SET TIEN=""
+5 FOR
SET TIEN=$ORDER(TEAM(TIEN))
IF TIEN=""!(TIEN'?.N)
QUIT
Begin DoDot:1
+6 IF $DATA(TEAM(TIEN))
Begin DoDot:2
+7 KILL XLIST
+8 SET OKAY=$$TPTM^SCAPMC(TIEN,"","","","XLIST","ERROR")
+9 SET SCTP=0
FOR
SET SCTP=$ORDER(XLIST("SCTP",TIEN,SCTP))
IF 'SCTP
QUIT
Begin DoDot:3
+10 KILL YLIST
SET SCDT="SCDT"
SET (SCDT("BEGIN"),SCDT("END"))=DT
SET SCDT("INCL")=0
+11 SET OKAY=$$PRTP^SCAPMC(SCTP,.SCDT,"YLIST","ERROR",1,0)
+12 SET SCI=0
FOR
SET SCI=$ORDER(YLIST(SCI))
IF 'SCI
QUIT
Begin DoDot:4
+13 SET @TPRC@(0)=$GET(@TPRC@(0))+1
+14 SET @TPRC@(@TPRC@(0))=YLIST(SCI)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+15 QUIT
+16 ;
TALL ;
+1 ;get all active team for divisions selected
+2 NEW NXT,IIEN,NODE
+3 SET NXT=0
SET IIEN=""
+4 ;$O through team file and find all active teams for selected divisions
+5 FOR
SET IIEN=$ORDER(^SCTM(404.51,"AINST",IIEN))
IF IIEN=""
QUIT
Begin DoDot:1
+6 IF INST=1!$DATA(INST(IIEN))
Begin DoDot:2
+7 SET TIEN=0
+8 FOR
SET TIEN=$ORDER(^SCTM(404.51,"AINST",IIEN,TIEN))
IF TIEN=""
QUIT
Begin DoDot:3
+9 IF $$ACTTM^SCMCTMU(TIEN)
SET TEAM(TIEN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
SETUP(IIEN,INAME,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP) ;
+1 ;setup data
+2 ;institution ien
SET IIEN=+$PIECE($GET(^SCTM(404.51,TIEN,0)),"^",7)
+3 ;institution name
SET INAME=$PIECE($GET(^DIC(4,IIEN,0)),"^")
+4 IF INAME=""
SET INAME="[BAD DATA]"
+5 ;
+6 IF PNAME=""
SET PNAME="[BAD DATA]"
+7 IF TNAME=""
SET TNAME="[BAD DATA]"
+8 IF $GET(SORT)=3
SET IIEN=1
SET TIEN=1
+9 IF '$DATA(@STORE@("PN",IIEN,PRAC,TIEN,TPI))
SET @STORE@("PN",IIEN,PRAC,TIEN,TPI)="Practitioner: "_PNAME_$SELECT(SORT=3:"",1:" ("_POSN_")")
+10 IF $LENGTH(PRCP)
SET @STORE@("PN",IIEN,PRAC,TIEN,TPI,"PRCP")=" Preceptor: "_PRCP
+11 IF '$DATA(@STORE@("TN",IIEN,$SELECT($GET(SORT)=3:1,1:TIEN)))
SET @STORE@("TN",IIEN,$SELECT($GET(SORT)=3:1,1:TIEN))=" Team: "_TNAME
+12 ;
+13 IF '$DATA(@STORE@("I",$SELECT($GET(SORT)=3:"S3",1:INAME),IIEN))
SET @STORE@("I",$SELECT($GET(SORT)=3:"S3",1:INAME),IIEN)=""
SET @STORE@(IIEN)=$SELECT(SORT=3:"",1:" Division: "_INAME)
+14 SET @STORE@("T",IIEN,$SELECT($GET(SORT)=3:"T3",1:TNAME),$SELECT($GET(SORT)=3:1,1:TIEN))=""
+15 IF '$DATA(@STORE@("P",IIEN,PNAME,PRAC,TPI))
SET @STORE@("P",IIEN,PNAME,PRAC,TPI)=""
+16 IF '$DATA(@STORE@("TOTAL",IIEN,PRAC,0))
SET @STORE@("TOTAL",IIEN,PRAC,0)=0
+17 IF '$DATA(@STORE@("TOTAL",IIEN,PRAC,TIEN))
SET @STORE@("TOTAL",IIEN,PRAC,TIEN)=0
+18 ;
+19 SET @STORE@("TH",IIEN,PRAC)="Patient Count for "_PNAME_": "
+20 SET @STORE@("TH",IIEN,PRAC,TIEN,TPI)="Patient Count for "_PNAME_": "
+21 NEW SCX
+22 SET SCX=$EXTRACT(PNAME,1,22)
SET $EXTRACT(SCX,25)=$EXTRACT(POSN,1,22)
SET $EXTRACT(SCX,49)=$EXTRACT(TNAME,1,22)
+23 SET @STORE@("SUM0",IIEN,PRAC,TIEN,TPI)=SCX
+24 ;
+25 SET @STORE@("TH",IIEN)="** Note: Patient Panel Count is a count of unique patients for each practitioner"
+26 QUIT 0
