SCRPEC2 ;ALB/CMM - Detail List of Pts & Enroll Clinics Continued ; 29 Jun 99 04:11PM
;;5.3;Scheduling;**41,140,174,177,526,1015**;AUG 13, 1993;Build 21
;IHS/ANMC/LJF 10/26/2000 call IHS code to format patient data
; and for column headings
; 11/01/2000 added 2nd primary care provider
;
;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)
.;Name of 2nd Primary Care Provider;IHS/ANMC/LJF 11/1/2000
.S SC2PCP=$P($G(^TMP("SC",$J,PTIEN,"NPCPR",1)),U,2) ;IHS/ANMC/LJF 11/1/2000
.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
.S $P(PDATA,U,11)=SC2PCP ;IHS/ANMC/LJF 11/1/2000
.;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
;
D HEADER^BSDSCEC Q ;IHS/ANMC/LJF 10/26/2000
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
;
D FORMAT^BSDSCEC(PTIEN,INS,TIEN,PDATA,CNAME,CIEN) Q ;IHS/ANMC/LJF 10/26/2000
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
;
SCRPEC2 ;ALB/CMM - Detail List of Pts & Enroll Clinics Continued ; 29 Jun 99 04:11PM
+1 ;;5.3;Scheduling;**41,140,174,177,526,1015**;AUG 13, 1993;Build 21
+2 ;IHS/ANMC/LJF 10/26/2000 call IHS code to format patient data
+3 ; and for column headings
+4 ; 11/01/2000 added 2nd primary care provider
+5 ;
+6 ;Detailed Listing of Patients and Their Enrolled Clinics Report
+7 ;
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 ;Name of 2nd Primary Care Provider;IHS/ANMC/LJF 11/1/2000
+18 ;IHS/ANMC/LJF 11/1/2000
SET SC2PCP=$PIECE($GET(^TMP("SC",$JOB,PTIEN,"NPCPR",1)),U,2)
+19 QUIT
End DoDot:1
+20 ;
+21 SET ENT=0
+22 FOR
SET ENT=$ORDER(@CLLIST@(ENT))
IF ENT=""!(ENT'?.N)
QUIT
Begin DoDot:1
+23 SET NODE=$GET(@CLLIST@(ENT))
+24 ;clinic ien
SET CIEN=+$PIECE(NODE,"^")
+25 IF CLINIC'=1
IF '$DATA(CLINIC(CIEN))
QUIT
+26 ;clinic name
SET CNAME=$PIECE(NODE,"^",2)
+27 DO SETUP(INS,INAME,TIEN,TNAME,PTIEN,PNAME,CIEN,CNAME)
+28 SET PDATA=$$PDATA^SCRPEC(PTIEN,CIEN,1)
+29 SET $PIECE(PDATA,U,9)=SCPCPR
SET $PIECE(PDATA,U,10)=SCPCAP
+30 ;IHS/ANMC/LJF 11/1/2000
SET $PIECE(PDATA,U,11)=SC2PCP
+31 ;name^pid^mt^pelig^pstat^statd^last^next^pc prov.^assoc. prov.
+32 DO FORMAT(PTIEN,INS,TIEN,PDATA,CNAME,CIEN)
End DoDot:1
+33 QUIT
+34 ;
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 ;IHS/ANMC/LJF 10/26/2000
DO HEADER^BSDSCEC
QUIT
+2 NEW HLD
+3 SET HLD="H0"
+4 SET $EXTRACT(@STORE@("SUBHEADER",HLD),25)="M.T."
+5 SET $EXTRACT(@STORE@("SUBHEADER",HLD),31)="Prim"
+6 ;Removed by patch 174
+7 ;S $E(@STORE@("SUBHEADER",HLD),31)="Pat"
+8 ;S $E(@STORE@("SUBHEADER",HLD),36)="Status"
+9 SET $EXTRACT(@STORE@("SUBHEADER",HLD),42)="Last"
+10 SET $EXTRACT(@STORE@("SUBHEADER",HLD),54)="Next"
+11 SET $EXTRACT(@STORE@("SUBHEADER",HLD),66)="Enrolled"
+12 SET $EXTRACT(@STORE@("SUBHEADER",HLD),95)="Primary Care"
+13 SET $EXTRACT(@STORE@("SUBHEADER",HLD),115)="Associate"
+14 SET HLD="H1"
+15 SET @STORE@("SUBHEADER",HLD)="Patient Name"
+16 SET $EXTRACT(@STORE@("SUBHEADER",HLD),16)="Pt ID"
+17 SET $EXTRACT(@STORE@("SUBHEADER",HLD),25)="Stat"
+18 SET $EXTRACT(@STORE@("SUBHEADER",HLD),31)="Elig"
+19 ;Removed by patch 174
+20 ;S $E(@STORE@("SUBHEADER",HLD),31)="Stat"
+21 ;S $E(@STORE@("SUBHEADER",HLD),36)="Date"
+22 SET $EXTRACT(@STORE@("SUBHEADER",HLD),42)="Appt"
+23 SET $EXTRACT(@STORE@("SUBHEADER",HLD),54)="Appt"
+24 SET $EXTRACT(@STORE@("SUBHEADER",HLD),66)="Clinic"
+25 SET $EXTRACT(@STORE@("SUBHEADER",HLD),95)="Provider"
+26 SET $EXTRACT(@STORE@("SUBHEADER",HLD),115)="Provider"
+27 SET HLD="H2"
+28 SET $PIECE(@STORE@("SUBHEADER",HLD),"=",133)=""
+29 QUIT
+30 ;
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 ;IHS/ANMC/LJF 10/26/2000
DO FORMAT^BSDSCEC(PTIEN,INS,TIEN,PDATA,CNAME,CIEN)
QUIT
+9 ;patient name
SET @STORE@(INS,TIEN,CIEN,PTIEN)=$EXTRACT($PIECE(PDATA,"^"),1,12)
+10 ;primary long id 9 digit
SET $EXTRACT(@STORE@(INS,TIEN,CIEN,PTIEN),14)=$PIECE(PDATA,"^",2)
+11 ;means test category
SET $EXTRACT(@STORE@(INS,TIEN,CIEN,PTIEN),26)=$PIECE(PDATA,"^",3)
+12 ;primary eligibility
SET $EXTRACT(@STORE@(INS,TIEN,CIEN,PTIEN),31)=$PIECE(PDATA,"^",4)
+13 ;Removed by patch 174
+14 ;S $E(@STORE@(INS,TIEN,CIEN,PTIEN),31)=$P(PDATA,"^",5) ;patient status
+15 ;S $E(@STORE@(INS,TIEN,CIEN,PTIEN),35)=$P(PDATA,"^",6) ;status date
+16 ;last appointment
SET $EXTRACT(@STORE@(INS,TIEN,CIEN,PTIEN),42)=$PIECE(PDATA,"^",7)
+17 ;next appointment
SET $EXTRACT(@STORE@(INS,TIEN,CIEN,PTIEN),54)=$PIECE(PDATA,"^",8)
+18 ;clinic name
SET $EXTRACT(@STORE@(INS,TIEN,CIEN,PTIEN),66)=$EXTRACT(CNAME,1,27)
+19 ;PC prov.
SET $EXTRACT(@STORE@(INS,TIEN,CIEN,PTIEN),95)=$EXTRACT($PIECE(PDATA,U,9),1,18)
+20 ;Assoc. Prov.
SET $EXTRACT(@STORE@(INS,TIEN,CIEN,PTIEN),115)=$EXTRACT($PIECE(PDATA,U,10),1,18)
+21 QUIT
+22 ;
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 ;
