SCRPEC2 ;ALB/CMM - Detail List of Pts & Enroll Clinics Continued ; 29 Jun 99 04:11PM
;;5.3;Scheduling;**41,140,174,177,526**;AUG 13, 1993;Build 8
;
;Detailed Listing of Patients and Their Enrolled Clinics Report
;
PAT(TIEN,PTLIST) ;
;TIEN - team ien
;PTLIST - array holding patients assigned to team TIEN
;
N PTIEN,ENT,NODE,OKAY,CLLIST,ERR,PC
S ENT=0,CLLIST="LIST2",ERR="ERROR2"
K @CLLIST
F S ENT=$O(@PTLIST@(ENT)) Q:ENT=""!(ENT'?.N) D
.S NODE=$G(@PTLIST@(ENT))
.Q:NODE=""
.S PTIEN=+$P(NODE,"^") ;patient ien
.S PC=$$PCASSIGN(PTIEN,TIEN)
.Q:PC'=ASSUN ;not selected assigned/unassigned primary care
.K @CLLIST
.S OKAY=$$CLPT^SCAPMC29(PTIEN,"","",.CLLIST,.ERR)
.;all clinics for patient PTIEN
.Q:'OKAY
.D KEEP(TIEN,PTIEN,.CLLIST)
K @CLLIST
Q
;
KEEP(TIEN,PTIEN,CLLIST) ;keep data for report
;TIEN - team ien
;PTIEN - patient ien
;CLLIST - array holding clinics for patient PTIEN
;
N ENT,TNAME,INS,NODE,INAME,PDATA,NODE,CIEN,CNAME,PNAME
N SCPCPR,SCPCAP,SCI,PCLIST
S TNAME=$P($G(^SCTM(404.51,TIEN,0)),"^") ;team name
S INS=+$P($G(^SCTM(404.51,TIEN,0)),"^",7) ;institution ien
S INAME=$P($G(^DIC(4,INS,0)),"^") ;institution name
S PNAME=$P($G(^DPT(PTIEN,0)),"^") ;patient name
K ^TMP("SC",$J,PTIEN)
S SCI=$$GETALL^SCAPMCA(PTIEN) D
.;Name of PC Provider
.S SCPCPR=$P($G(^TMP("SC",$J,PTIEN,"PCPR",1)),U,2)
.;Name of Associate Provider
.S SCPCAP=$P($G(^TMP("SC",$J,PTIEN,"PCAP",1)),U,2)
.Q
;
S ENT=0
F S ENT=$O(@CLLIST@(ENT)) Q:ENT=""!(ENT'?.N) D
.S NODE=$G(@CLLIST@(ENT))
.S CIEN=+$P(NODE,"^") ;clinic ien
.I CLINIC'=1,'$D(CLINIC(CIEN)) Q
.S CNAME=$P(NODE,"^",2) ;clinic name
.D SETUP(INS,INAME,TIEN,TNAME,PTIEN,PNAME,CIEN,CNAME)
.S PDATA=$$PDATA^SCRPEC(PTIEN,CIEN,1)
.S $P(PDATA,U,9)=SCPCPR,$P(PDATA,U,10)=SCPCAP
.;name^pid^mt^pelig^pstat^statd^last^next^pc prov.^assoc. prov.
.D FORMAT(PTIEN,INS,TIEN,PDATA,CNAME,CIEN)
Q
;
SETUP(INS,INAME,TIEN,TNAME,PTIEN,PNAME,CIEN,CNAME) ;
;INS - institution ien
;INAME - institution name
;TIEN - team ien
;TNAME - team name
;PTIEN - patient ien
;PNAME - patient name
;CIEN - clinic ien
;CNAME - clinic name
;
I INAME="" S INAME="[BAD DATA]"
I TNAME="" S TNAME="[BAD DATA]"
I CNAME="" S CNAME="[BAD DATA]"
I PNAME="" S PNAME="[BAD DATA]"
I '$D(@STORE@("I",INAME,INS)) S @STORE@("I",INAME,INS)="",@STORE@(INS)="Division: "_INAME
I '$D(@STORE@("T",INS,TNAME,TIEN)) S @STORE@("T",INS,TNAME,TIEN)="",@STORE@(INS,TIEN)="Team: "_TNAME
I '$D(@STORE@("C",INS,TIEN,CNAME,CIEN)) S @STORE@("C",INS,TIEN,CNAME,CIEN)="" ;D HEADER(INS,TIEN,CIEN)
I '$D(@STORE@("PT",INS,TIEN,CIEN,PNAME,PTIEN)) S @STORE@("PT",INS,TIEN,CIEN,PNAME,PTIEN)=""
Q
;
PCASSIGN(DFN,TIEN) ;patient assigned to team as primary care
;DFN - patient ien
;TIEN - team ien
;1 - yes
;0 - no
;
N ADATE,ENTRY,PC
S PC=0
I '$D(^SCPT(404.42,"AIDT",DFN,TIEN)) Q PC
S ADATE=$O(^SCPT(404.42,"AIDT",DFN,TIEN,"")) ; -team assignemtn date
S ENTRY=$O(^SCPT(404.42,"AIDT",DFN,TIEN,ADATE,"")) ;patient team assignemtn ien
I $P($G(^SCPT(404.42,+ENTRY,0)),"^",8)=1 S PC=1
Q PC
;
N HLD
S HLD="H0"
S $E(@STORE@("SUBHEADER",HLD),25)="M.T."
S $E(@STORE@("SUBHEADER",HLD),31)="Prim"
;Removed by patch 174
;S $E(@STORE@("SUBHEADER",HLD),31)="Pat"
;S $E(@STORE@("SUBHEADER",HLD),36)="Status"
S $E(@STORE@("SUBHEADER",HLD),42)="Last"
S $E(@STORE@("SUBHEADER",HLD),54)="Next"
S $E(@STORE@("SUBHEADER",HLD),66)="Enrolled"
S $E(@STORE@("SUBHEADER",HLD),95)="Primary Care"
S $E(@STORE@("SUBHEADER",HLD),115)="Associate"
S HLD="H1"
S @STORE@("SUBHEADER",HLD)="Patient Name"
S $E(@STORE@("SUBHEADER",HLD),16)="Pt ID"
S $E(@STORE@("SUBHEADER",HLD),25)="Stat"
S $E(@STORE@("SUBHEADER",HLD),31)="Elig"
;Removed by patch 174
;S $E(@STORE@("SUBHEADER",HLD),31)="Stat"
;S $E(@STORE@("SUBHEADER",HLD),36)="Date"
S $E(@STORE@("SUBHEADER",HLD),42)="Appt"
S $E(@STORE@("SUBHEADER",HLD),54)="Appt"
S $E(@STORE@("SUBHEADER",HLD),66)="Clinic"
S $E(@STORE@("SUBHEADER",HLD),95)="Provider"
S $E(@STORE@("SUBHEADER",HLD),115)="Provider"
S HLD="H2"
S $P(@STORE@("SUBHEADER",HLD),"=",133)=""
Q
;
FORMAT(PTIEN,INS,TIEN,PDATA,CNAME,CIEN) ;format data for report
;PTIEN - patient ien
;INS - institution ien
;TIEN - team ien
;PDATA - pt name^pid^mt^pelig^pstat^statd^last^next^pc prov.^assoc. prov.
;CNAME - clinic name
;CIEN - clinic ien
;
S @STORE@(INS,TIEN,CIEN,PTIEN)=$E($P(PDATA,"^"),1,12) ;patient name
S $E(@STORE@(INS,TIEN,CIEN,PTIEN),14)=$P(PDATA,"^",2) ;primary long id 9 digit
S $E(@STORE@(INS,TIEN,CIEN,PTIEN),26)=$P(PDATA,"^",3) ;means test category
S $E(@STORE@(INS,TIEN,CIEN,PTIEN),31)=$P(PDATA,"^",4) ;primary eligibility
;Removed by patch 174
;S $E(@STORE@(INS,TIEN,CIEN,PTIEN),31)=$P(PDATA,"^",5) ;patient status
;S $E(@STORE@(INS,TIEN,CIEN,PTIEN),35)=$P(PDATA,"^",6) ;status date
S $E(@STORE@(INS,TIEN,CIEN,PTIEN),42)=$P(PDATA,"^",7) ;last appointment
S $E(@STORE@(INS,TIEN,CIEN,PTIEN),54)=$P(PDATA,"^",8) ;next appointment
S $E(@STORE@(INS,TIEN,CIEN,PTIEN),66)=$E(CNAME,1,27) ;clinic name
S $E(@STORE@(INS,TIEN,CIEN,PTIEN),95)=$E($P(PDATA,U,9),1,18) ;PC prov.
S $E(@STORE@(INS,TIEN,CIEN,PTIEN),115)=$E($P(PDATA,U,10),1,18) ;Assoc. Prov.
Q
;
CHEAD(INS,TEAM,CLINIC) ;
;column headings
;
N EN,NEWP
W !
S NEWP=0
I IOST'?1"C-".E,$Y+5>(IOSL-6) D NEWP1^SCRPU3(.PAGE,TITL) S NEWP=1
I IOST?1"C-".E,$Y+5>(IOSL-6) D HOLD^SCRPU3(.PAGE,TITL) S NEWP=1
I STOP Q
I NEWP W !,$G(@STORE@(INS)),!!,$G(@STORE@(INS,TEAM)),!
CH2 F EN="H0","H1","H2" W !,$G(@STORE@("SUBHEADER",EN))
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPEC2 5651 printed Apr 09, 2024@21:41:21 Page 2
SCRPEC2 ;ALB/CMM - Detail List of Pts & Enroll Clinics Continued ; 29 Jun 99 04:11PM
+1 ;;5.3;Scheduling;**41,140,174,177,526**;AUG 13, 1993;Build 8
+2 ;
+3 ;Detailed Listing of Patients and Their Enrolled Clinics Report
+4 ;
PAT(TIEN,PTLIST) ;
+1 ;TIEN - team ien
+2 ;PTLIST - array holding patients assigned to team TIEN
+3 ;
+4 NEW PTIEN,ENT,NODE,OKAY,CLLIST,ERR,PC
+5 SET ENT=0
SET CLLIST="LIST2"
SET ERR="ERROR2"
+6 KILL @CLLIST
+7 FOR
SET ENT=$ORDER(@PTLIST@(ENT))
if ENT=""!(ENT'?.N)
QUIT
Begin DoDot:1
+8 SET NODE=$GET(@PTLIST@(ENT))
+9 if NODE=""
QUIT
+10 ;patient ien
SET PTIEN=+$PIECE(NODE,"^")
+11 SET PC=$$PCASSIGN(PTIEN,TIEN)
+12 ;not selected assigned/unassigned primary care
if PC'=ASSUN
QUIT
+13 KILL @CLLIST
+14 SET OKAY=$$CLPT^SCAPMC29(PTIEN,"","",.CLLIST,.ERR)
+15 ;all clinics for patient PTIEN
+16 if 'OKAY
QUIT
+17 DO KEEP(TIEN,PTIEN,.CLLIST)
End DoDot:1
+18 KILL @CLLIST
+19 QUIT
+20 ;
KEEP(TIEN,PTIEN,CLLIST) ;keep data for report
+1 ;TIEN - team ien
+2 ;PTIEN - patient ien
+3 ;CLLIST - array holding clinics for patient PTIEN
+4 ;
+5 NEW ENT,TNAME,INS,NODE,INAME,PDATA,NODE,CIEN,CNAME,PNAME
+6 NEW SCPCPR,SCPCAP,SCI,PCLIST
+7 ;team name
SET TNAME=$PIECE($GET(^SCTM(404.51,TIEN,0)),"^")
+8 ;institution ien
SET INS=+$PIECE($GET(^SCTM(404.51,TIEN,0)),"^",7)
+9 ;institution name
SET INAME=$PIECE($GET(^DIC(4,INS,0)),"^")
+10 ;patient name
SET PNAME=$PIECE($GET(^DPT(PTIEN,0)),"^")
+11 KILL ^TMP("SC",$JOB,PTIEN)
+12 SET SCI=$$GETALL^SCAPMCA(PTIEN)
Begin DoDot:1
+13 ;Name of PC Provider
+14 SET SCPCPR=$PIECE($GET(^TMP("SC",$JOB,PTIEN,"PCPR",1)),U,2)
+15 ;Name of Associate Provider
+16 SET SCPCAP=$PIECE($GET(^TMP("SC",$JOB,PTIEN,"PCAP",1)),U,2)
+17 QUIT
End DoDot:1
+18 ;
+19 SET ENT=0
+20 FOR
SET ENT=$ORDER(@CLLIST@(ENT))
if ENT=""!(ENT'?.N)
QUIT
Begin DoDot:1
+21 SET NODE=$GET(@CLLIST@(ENT))
+22 ;clinic ien
SET CIEN=+$PIECE(NODE,"^")
+23 IF CLINIC'=1
IF '$DATA(CLINIC(CIEN))
QUIT
+24 ;clinic name
SET CNAME=$PIECE(NODE,"^",2)
+25 DO SETUP(INS,INAME,TIEN,TNAME,PTIEN,PNAME,CIEN,CNAME)
+26 SET PDATA=$$PDATA^SCRPEC(PTIEN,CIEN,1)
+27 SET $PIECE(PDATA,U,9)=SCPCPR
SET $PIECE(PDATA,U,10)=SCPCAP
+28 ;name^pid^mt^pelig^pstat^statd^last^next^pc prov.^assoc. prov.
+29 DO FORMAT(PTIEN,INS,TIEN,PDATA,CNAME,CIEN)
End DoDot:1
+30 QUIT
+31 ;
SETUP(INS,INAME,TIEN,TNAME,PTIEN,PNAME,CIEN,CNAME) ;
+1 ;INS - institution ien
+2 ;INAME - institution name
+3 ;TIEN - team ien
+4 ;TNAME - team name
+5 ;PTIEN - patient ien
+6 ;PNAME - patient name
+7 ;CIEN - clinic ien
+8 ;CNAME - clinic name
+9 ;
+10 IF INAME=""
SET INAME="[BAD DATA]"
+11 IF TNAME=""
SET TNAME="[BAD DATA]"
+12 IF CNAME=""
SET CNAME="[BAD DATA]"
+13 IF PNAME=""
SET PNAME="[BAD DATA]"
+14 IF '$DATA(@STORE@("I",INAME,INS))
SET @STORE@("I",INAME,INS)=""
SET @STORE@(INS)="Division: "_INAME
+15 IF '$DATA(@STORE@("T",INS,TNAME,TIEN))
SET @STORE@("T",INS,TNAME,TIEN)=""
SET @STORE@(INS,TIEN)="Team: "_TNAME
+16 ;D HEADER(INS,TIEN,CIEN)
IF '$DATA(@STORE@("C",INS,TIEN,CNAME,CIEN))
SET @STORE@("C",INS,TIEN,CNAME,CIEN)=""
+17 IF '$DATA(@STORE@("PT",INS,TIEN,CIEN,PNAME,PTIEN))
SET @STORE@("PT",INS,TIEN,CIEN,PNAME,PTIEN)=""
+18 QUIT
+19 ;
PCASSIGN(DFN,TIEN) ;patient assigned to team as primary care
+1 ;DFN - patient ien
+2 ;TIEN - team ien
+3 ;1 - yes
+4 ;0 - no
+5 ;
+6 NEW ADATE,ENTRY,PC
+7 SET PC=0
+8 IF '$DATA(^SCPT(404.42,"AIDT",DFN,TIEN))
QUIT PC
+9 ; -team assignemtn date
SET ADATE=$ORDER(^SCPT(404.42,"AIDT",DFN,TIEN,""))
+10 ;patient team assignemtn ien
SET ENTRY=$ORDER(^SCPT(404.42,"AIDT",DFN,TIEN,ADATE,""))
+11 IF $PIECE($GET(^SCPT(404.42,+ENTRY,0)),"^",8)=1
SET PC=1
+12 QUIT PC
+13 ;
+1 NEW HLD
+2 SET HLD="H0"
+3 SET $EXTRACT(@STORE@("SUBHEADER",HLD),25)="M.T."
+4 SET $EXTRACT(@STORE@("SUBHEADER",HLD),31)="Prim"
+5 ;Removed by patch 174
+6 ;S $E(@STORE@("SUBHEADER",HLD),31)="Pat"
+7 ;S $E(@STORE@("SUBHEADER",HLD),36)="Status"
+8 SET $EXTRACT(@STORE@("SUBHEADER",HLD),42)="Last"
+9 SET $EXTRACT(@STORE@("SUBHEADER",HLD),54)="Next"
+10 SET $EXTRACT(@STORE@("SUBHEADER",HLD),66)="Enrolled"
+11 SET $EXTRACT(@STORE@("SUBHEADER",HLD),95)="Primary Care"
+12 SET $EXTRACT(@STORE@("SUBHEADER",HLD),115)="Associate"
+13 SET HLD="H1"
+14 SET @STORE@("SUBHEADER",HLD)="Patient Name"
+15 SET $EXTRACT(@STORE@("SUBHEADER",HLD),16)="Pt ID"
+16 SET $EXTRACT(@STORE@("SUBHEADER",HLD),25)="Stat"
+17 SET $EXTRACT(@STORE@("SUBHEADER",HLD),31)="Elig"
+18 ;Removed by patch 174
+19 ;S $E(@STORE@("SUBHEADER",HLD),31)="Stat"
+20 ;S $E(@STORE@("SUBHEADER",HLD),36)="Date"
+21 SET $EXTRACT(@STORE@("SUBHEADER",HLD),42)="Appt"
+22 SET $EXTRACT(@STORE@("SUBHEADER",HLD),54)="Appt"
+23 SET $EXTRACT(@STORE@("SUBHEADER",HLD),66)="Clinic"
+24 SET $EXTRACT(@STORE@("SUBHEADER",HLD),95)="Provider"
+25 SET $EXTRACT(@STORE@("SUBHEADER",HLD),115)="Provider"
+26 SET HLD="H2"
+27 SET $PIECE(@STORE@("SUBHEADER",HLD),"=",133)=""
+28 QUIT
+29 ;
FORMAT(PTIEN,INS,TIEN,PDATA,CNAME,CIEN) ;format data for report
+1 ;PTIEN - patient ien
+2 ;INS - institution ien
+3 ;TIEN - team ien
+4 ;PDATA - pt name^pid^mt^pelig^pstat^statd^last^next^pc prov.^assoc. prov.
+5 ;CNAME - clinic name
+6 ;CIEN - clinic ien
+7 ;
+8 ;patient name
SET @STORE@(INS,TIEN,CIEN,PTIEN)=$EXTRACT($PIECE(PDATA,"^"),1,12)
+9 ;primary long id 9 digit
SET $EXTRACT(@STORE@(INS,TIEN,CIEN,PTIEN),14)=$PIECE(PDATA,"^",2)
+10 ;means test category
SET $EXTRACT(@STORE@(INS,TIEN,CIEN,PTIEN),26)=$PIECE(PDATA,"^",3)
+11 ;primary eligibility
SET $EXTRACT(@STORE@(INS,TIEN,CIEN,PTIEN),31)=$PIECE(PDATA,"^",4)
+12 ;Removed by patch 174
+13 ;S $E(@STORE@(INS,TIEN,CIEN,PTIEN),31)=$P(PDATA,"^",5) ;patient status
+14 ;S $E(@STORE@(INS,TIEN,CIEN,PTIEN),35)=$P(PDATA,"^",6) ;status date
+15 ;last appointment
SET $EXTRACT(@STORE@(INS,TIEN,CIEN,PTIEN),42)=$PIECE(PDATA,"^",7)
+16 ;next appointment
SET $EXTRACT(@STORE@(INS,TIEN,CIEN,PTIEN),54)=$PIECE(PDATA,"^",8)
+17 ;clinic name
SET $EXTRACT(@STORE@(INS,TIEN,CIEN,PTIEN),66)=$EXTRACT(CNAME,1,27)
+18 ;PC prov.
SET $EXTRACT(@STORE@(INS,TIEN,CIEN,PTIEN),95)=$EXTRACT($PIECE(PDATA,U,9),1,18)
+19 ;Assoc. Prov.
SET $EXTRACT(@STORE@(INS,TIEN,CIEN,PTIEN),115)=$EXTRACT($PIECE(PDATA,U,10),1,18)
+20 QUIT
+21 ;
CHEAD(INS,TEAM,CLINIC) ;
+1 ;column headings
+2 ;
+3 NEW EN,NEWP
+4 WRITE !
+5 SET NEWP=0
+6 IF IOST'?1"C-".E
IF $Y+5>(IOSL-6)
DO NEWP1^SCRPU3(.PAGE,TITL)
SET NEWP=1
+7 IF IOST?1"C-".E
IF $Y+5>(IOSL-6)
DO HOLD^SCRPU3(.PAGE,TITL)
SET NEWP=1
+8 IF STOP
QUIT
+9 IF NEWP
WRITE !,$GET(@STORE@(INS)),!!,$GET(@STORE@(INS,TEAM)),!
CH2 FOR EN="H0","H1","H2"
WRITE !,$GET(@STORE@("SUBHEADER",EN))
+1 QUIT
+2 ;
