SCRPTP ;ALB/CMM - List of Team's Patients ; 29 Jun 99 04:11PM
;;5.3;Scheduling;**41,48,174,177,526,520,1015**;AUG 13, 1993;Build 21
;IHS/ANMC/LJF 11/03/2000 changed 132 column message
; added call to list template
; changed spacing of patient data lines
;
PROMPTS ;Prompt for Institution, Team, Role, Patient Status and Print device
N QTIME,PRNT,VAUTD,VAUTT,VAUTR,VAUTPS,NUMBER
K SCUP
S QTIME=""
W ! D INST^SCRPU1 I Y=-1 G ERR
W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR
W ! K Y D ROLE^SCRPU1 I '$D(VAUTR) G ERR
W ! K Y D PTSTAT^SCRPU2 I '$D(VAUTPS) G ERR
W ! K Y S SORT=$$SORT2^SCRPU2()
I SORT<1 G ERR
;W !!,"This report requires 132 column output!" ;IHS/ANMC/LJF 11/03/2000
W !!,"This report, when printed on paper, requires wide paper or condensed print!" ;IHS/ANMC/LJF 11/03/2000
D QUE(.VAUTD,.VAUTT,.VAUTR,VAUTPS,SORT) Q
;
QUE(INST,TEAM,ROLE,PSTAT,SORT,IOP,ZTDTH) ;queue report
;INST - institutions selected (variable and array)
;TEAM - teams selected (variable and array)
;ROLE - roles selected (variable and array)
;PSTAT - patient status - 1=all or OPT or AC
;SORT - 1=d,t,ptname 2=d,t,Pt ID 3=d,t,pract,pt name 4=d,t,pract,Pt ID
N ZTSAVE,II
F II="INST","TEAM","ROLE","ROLE(","SORT","PSTAT","INST(","TEAM(" S ZTSAVE(II)=""
W ! D EN^XUTMDEVQ("QENTRY^SCRPTP","Team Patient Listing",.ZTSAVE)
Q
;
ENTRY2(INST,TEAM,ROLE,PSTAT,SORT,IOP,ZTDTH) ;Second entry point for GUI to use
;INST - institutions selected (variable and array)
;TEAM - teams selected (variable and array)
;ROLE - roles selected (variable and array)
;PSTAT - patient status - 1=all or OPT or AC
;SORT - 1=d,t,ptname 2=d,t,Pt ID 3=d,t,pract,pt name 4=d,t,pract,Pt ID
;IOP - print device
;ZTDTH - queue time (optional)
;
;validate parameters
I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$D(PSTAT)!'$D(SORT)!'$D(IOP)!(IOP="") Q
N NUMBER
S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^")
I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2)
I IOST?1"C-".E D QENTRY G RET
I ZTDTH="" S ZTDTH=$H
S ZTRTN="QENTRY^SCRPTP"
S ZTDESC="List of Team's Patients",ZTIO=IOP
N II
F II="INST","TEAM","ROLE","ROLE(","SORT","PSTAT","INST(","TEAM(","IOP" S ZTSAVE(II)=""
D ^%ZTLOAD
RET S NUMBER=0
I $D(ZTSK) S NUMBER=ZTSK
D EXIT1
Q NUMBER
;
QENTRY ;driver entry point
I $E(IOST,1,2)="C-" D ^BSDSCTP Q ;IHS/ANMC/LJF 11/03/2000
IHS ;EP; entry point for list template ;IHS/ANMC/LJF 11/03/2000
S TITL="Team Patient Listing",STORE="^TMP("_$J_",""SCRPTP"")"
K @STORE
S @STORE=0
D FIND
I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL)
I '$D(NODATA) D PRINTIT^SCRPTP2(STORE,TITL)
D EXIT2
Q
ERR ;
EXIT1 ;
K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,SCUP
Q
EXIT2 ;
K @STORE
K STOP,STORE,TITL,IOP,TEAM,INST,ROLE,PSTAT,SORT,NODATA
Q
FIND ;
N TIEN,ERR,LIST,OKAY
I TEAM=1 D TALL^SCRPPAT3 ;gets all teams for all divisions selected
S TIEN="",LIST="^TMP("_$J_",""SCRPTP ARRAY"")",ERR="ERROR"
K @LIST,@ERR
F S TIEN=$O(TEAM(TIEN)) Q:TIEN="" D
.;TIEN - team ien
.S OKAY=$$PTTM^SCAPMC2(TIEN,"",LIST,ERR)
.; gets all patients for given team
.D HITS^SCRPTP3(LIST,TIEN)
.K @LIST,@ERR
K @LIST,@ERR
Q
TINF(TIEN) ;team information
;TIEN - team ien
;returns: institution ien ^ team name ^ primary care ^ team phone
N PC,PHONE,TNODE,TNAME
S TNODE=$G(^SCTM(404.51,TIEN,0))
S TNAME=$P(TNODE,"^") ;team name
S PC=$S($P(TNODE,"^",5)=1:"YES",1:"NO") ;primary care team
S PHONE=$P(TNODE,"^",2) ;team phone
S INS=+$P(TNODE,"^",7) ;institution ien
D TDESC^SCRPITP2(TIEN,INS) ;gets team description
Q INS_"^"_TNAME_"^"_PC_"^"_PHONE
;
PST(PTIEN,CLIEN) ;
;PTIEN - patient ien
;CLIEN - associated clinic ien
;returns 1=selected patient status, 0=not selected patient status
;
N EN,NXT,FOUND,ENODE
S EN="",(FOUND,NXT)=0
Q:'$D(^DPT(PTIEN,"DE","B",CLIEN)) FOUND
S EN=$O(^DPT(PTIEN,"DE","B",CLIEN,""))
I EN=""&(PSTAT=1) S FOUND=1 Q FOUND
Q:EN=""!'$D(^DPT(PTIEN,"DE",EN,1)) FOUND
F S NXT=$O(^DPT(PTIEN,"DE",EN,1,NXT)) Q:(FOUND)!(NXT="")!(NXT'?.N) D
.;check if active enrollment
.S ENODE=$G(^DPT(PTIEN,"DE",EN,1,NXT,0))
.I $P(ENODE,"^",3)'="",$P(ENODE,"^",3)<DT+1!$P(ENODE,"^")>DT Q ;not active enrollment
.; ^ discharge date ^ enrollment date
.Q:$P(ENODE,"^",2)'=$E(PSTAT,1)&(PSTAT'=1) ;not selected patient status
.S FOUND=1
Q FOUND
;
FORMAT(INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,CNAME,PINF,ROLN,PCAP) ;Format column information
;INS - Institution ien
;TIEN - team ien
;PTIEN - patient ien
;PTNAME - patient name
;PID - SSN
;PIEN - practitioner ien
;PNAME - practitioner name
;CNAME - clinic name
;LAST - last appointment
;NEXT - next appointment
;ROLN - role name
;PCAP - PC?
;
N SEC,TRD
I PNAME="" S PNAME="[BAD DATA]"
I PTNAME="" S PTNAME="[BAD DATA]"
I PID="" S PID="*********"
S @STORE@("P",INS,TIEN,PNAME,PIEN)="" ;practitioner
S @STORE@("PT",INS,TIEN,PTNAME,PTIEN)="" ;patient
S @STORE@("PID",INS,TIEN,PID,PTIEN)=""
I (SORT=1)!(SORT=2) S SEC=PTIEN,TRD=PIEN ;sort doesn't include practitioner
I (SORT=3)!(SORT=4) S SEC=PIEN,TRD=PTIEN ;sort includes practitioner
S @STORE@(INS,TIEN,SEC,TRD)=$E(PTNAME,1,15) ;patient name
S $E(@STORE@(INS,TIEN,SEC,TRD),18)=PID ;9 digit pid
;S $E(@STORE@(INS,TIEN,SEC,TRD),32)=$E(PNAME,1,22) ;practitioner name;IHS/ANMC/LJF 11/03/2000
S $E(@STORE@(INS,TIEN,SEC,TRD),34)=$E(PNAME,1,22) ;practitioner name;IHS/ANMC/LJF 11/03/2000
S $E(@STORE@(INS,TIEN,SEC,TRD),56)=$E($G(ROLN),1,22) ;role name
S $E(@STORE@(INS,TIEN,SEC,TRD),80)=$G(PCAP) ;PC?
S $E(@STORE@(INS,TIEN,SEC,TRD),85)=$P(PINF,"^",8) ;last appointment
;S $E(@STORE@(INS,TIEN,SEC,TRD),97)=NEXT ;next appointment;IHS/ANMC/LJF 11/03/2000
S $E(@STORE@(INS,TIEN,SEC,TRD),105)=NEXT ;next appointment;IHS/ANMC/LJF 11/03/2000
;S $E(@STORE@(INS,TIEN,SEC,TRD),109)=$E(CNAME,1,24) ;clinic name;IHS/ANMC/LJF 11/03/2000
Q
FORMATAC(SCCNT,CNAME,PINF,INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,ROLN,PCAP) ;Format MULTIPLES
;INS - Institution ien
;TIEN - team ien
;PTIEN - patient ien
;PTNAME - patient name
;PID - last 4 PID - includes pseudo notation as 5th
;PIEN - practitioner ien
;PNAME - practitioner name
;CNAME - clinic name
;LAST - last appointment
;NEXT - next appointment
;ROLN - role name
;PCAP - PC?
;
N SEC,TRD
I PNAME="" S PNAME="[BAD DATA]"
I PTNAME="" S PTNAME="[BAD DATA]"
I PID="" S PID="****"
S @STORE@("P",INS,TIEN,PNAME,PIEN)="" ;practitioner
S @STORE@("PT",INS,TIEN,PTNAME,PTIEN)="" ;patient
S @STORE@("PID",INS,TIEN,PID,PTIEN)="" ;last 4 pid
N TRD
I (SORT=1)!(SORT=2) S SEC=PTIEN,TRD=PIEN ;sort doesn't include practitioner
I (SORT=3)!(SORT=4) S SEC=PIEN,TRD=PTIEN ;sort includes practitioner
I '$D(@STORE@(INS,TIEN,SEC,TRD,SCCNT)) D
.S $E(@STORE@(INS,TIEN,SEC,TRD,SCCNT),85)=$P(PINF,"^",8) ;last appointment
.S $E(@STORE@(INS,TIEN,SEC,TRD,SCCNT),97)=$P(PINF,"^",9) ;next appointment
.S $E(@STORE@(INS,TIEN,SEC,TRD,SCCNT),109)=$E(CNAME,1,24) ;clinic name
.Q
Q
SCRPTP ;ALB/CMM - List of Team's Patients ; 29 Jun 99 04:11PM
+1 ;;5.3;Scheduling;**41,48,174,177,526,520,1015**;AUG 13, 1993;Build 21
+2 ;IHS/ANMC/LJF 11/03/2000 changed 132 column message
+3 ; added call to list template
+4 ; changed spacing of patient data lines
+5 ;
PROMPTS ;Prompt for Institution, Team, Role, Patient Status and Print device
+1 NEW QTIME,PRNT,VAUTD,VAUTT,VAUTR,VAUTPS,NUMBER
+2 KILL SCUP
+3 SET QTIME=""
+4 WRITE !
DO INST^SCRPU1
IF Y=-1
GOTO ERR
+5 WRITE !
KILL Y
DO PRMTT^SCRPU1
IF '$DATA(VAUTT)
GOTO ERR
+6 WRITE !
KILL Y
DO ROLE^SCRPU1
IF '$DATA(VAUTR)
GOTO ERR
+7 WRITE !
KILL Y
DO PTSTAT^SCRPU2
IF '$DATA(VAUTPS)
GOTO ERR
+8 WRITE !
KILL Y
SET SORT=$$SORT2^SCRPU2()
+9 IF SORT<1
GOTO ERR
+10 ;W !!,"This report requires 132 column output!" ;IHS/ANMC/LJF 11/03/2000
+11 ;IHS/ANMC/LJF 11/03/2000
WRITE !!,"This report, when printed on paper, requires wide paper or condensed print!"
+12 DO QUE(.VAUTD,.VAUTT,.VAUTR,VAUTPS,SORT)
QUIT
+13 ;
QUE(INST,TEAM,ROLE,PSTAT,SORT,IOP,ZTDTH) ;queue report
+1 ;INST - institutions selected (variable and array)
+2 ;TEAM - teams selected (variable and array)
+3 ;ROLE - roles selected (variable and array)
+4 ;PSTAT - patient status - 1=all or OPT or AC
+5 ;SORT - 1=d,t,ptname 2=d,t,Pt ID 3=d,t,pract,pt name 4=d,t,pract,Pt ID
+6 NEW ZTSAVE,II
+7 FOR II="INST","TEAM","ROLE","ROLE(","SORT","PSTAT","INST(","TEAM("
SET ZTSAVE(II)=""
+8 WRITE !
DO EN^XUTMDEVQ("QENTRY^SCRPTP","Team Patient Listing",.ZTSAVE)
+9 QUIT
+10 ;
ENTRY2(INST,TEAM,ROLE,PSTAT,SORT,IOP,ZTDTH) ;Second entry point for GUI to use
+1 ;INST - institutions selected (variable and array)
+2 ;TEAM - teams selected (variable and array)
+3 ;ROLE - roles selected (variable and array)
+4 ;PSTAT - patient status - 1=all or OPT or AC
+5 ;SORT - 1=d,t,ptname 2=d,t,Pt ID 3=d,t,pract,pt name 4=d,t,pract,Pt ID
+6 ;IOP - print device
+7 ;ZTDTH - queue time (optional)
+8 ;
+9 ;validate parameters
+10 IF '$DATA(INST)!'$DATA(TEAM)!'$DATA(ROLE)!'$DATA(PSTAT)!'$DATA(SORT)!'$DATA(IOP)!(IOP="")
QUIT
+11 NEW NUMBER
+12 SET IOST=$PIECE(IOP,"^",2)
SET IOP=$PIECE(IOP,"^")
+13 IF IOP?1"Q;".E
SET IOP=$PIECE(IOP,"Q;",2)
+14 IF IOST?1"C-".E
DO QENTRY
GOTO RET
+15 IF ZTDTH=""
SET ZTDTH=$HOROLOG
+16 SET ZTRTN="QENTRY^SCRPTP"
+17 SET ZTDESC="List of Team's Patients"
SET ZTIO=IOP
+18 NEW II
+19 FOR II="INST","TEAM","ROLE","ROLE(","SORT","PSTAT","INST(","TEAM(","IOP"
SET ZTSAVE(II)=""
+20 DO ^%ZTLOAD
RET SET NUMBER=0
+1 IF $DATA(ZTSK)
SET NUMBER=ZTSK
+2 DO EXIT1
+3 QUIT NUMBER
+4 ;
QENTRY ;driver entry point
+1 ;IHS/ANMC/LJF 11/03/2000
IF $EXTRACT(IOST,1,2)="C-"
DO ^BSDSCTP
QUIT
IHS ;EP; entry point for list template ;IHS/ANMC/LJF 11/03/2000
+1 SET TITL="Team Patient Listing"
SET STORE="^TMP("_$JOB_",""SCRPTP"")"
+2 KILL @STORE
+3 SET @STORE=0
+4 DO FIND
+5 IF $ORDER(@STORE@(0))=""
SET NODATA=$$NODATA^SCRPU3(TITL)
+6 IF '$DATA(NODATA)
DO PRINTIT^SCRPTP2(STORE,TITL)
+7 DO EXIT2
+8 QUIT
ERR ;
EXIT1 ;
+1 KILL ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,SCUP
+2 QUIT
EXIT2 ;
+1 KILL @STORE
+2 KILL STOP,STORE,TITL,IOP,TEAM,INST,ROLE,PSTAT,SORT,NODATA
+3 QUIT
FIND ;
+1 NEW TIEN,ERR,LIST,OKAY
+2 ;gets all teams for all divisions selected
IF TEAM=1
DO TALL^SCRPPAT3
+3 SET TIEN=""
SET LIST="^TMP("_$JOB_",""SCRPTP ARRAY"")"
SET ERR="ERROR"
+4 KILL @LIST,@ERR
+5 FOR
SET TIEN=$ORDER(TEAM(TIEN))
IF TIEN=""
QUIT
Begin DoDot:1
+6 ;TIEN - team ien
+7 SET OKAY=$$PTTM^SCAPMC2(TIEN,"",LIST,ERR)
+8 ; gets all patients for given team
+9 DO HITS^SCRPTP3(LIST,TIEN)
+10 KILL @LIST,@ERR
End DoDot:1
+11 KILL @LIST,@ERR
+12 QUIT
TINF(TIEN) ;team information
+1 ;TIEN - team ien
+2 ;returns: institution ien ^ team name ^ primary care ^ team phone
+3 NEW PC,PHONE,TNODE,TNAME
+4 SET TNODE=$GET(^SCTM(404.51,TIEN,0))
+5 ;team name
SET TNAME=$PIECE(TNODE,"^")
+6 ;primary care team
SET PC=$SELECT($PIECE(TNODE,"^",5)=1:"YES",1:"NO")
+7 ;team phone
SET PHONE=$PIECE(TNODE,"^",2)
+8 ;institution ien
SET INS=+$PIECE(TNODE,"^",7)
+9 ;gets team description
DO TDESC^SCRPITP2(TIEN,INS)
+10 QUIT INS_"^"_TNAME_"^"_PC_"^"_PHONE
+11 ;
PST(PTIEN,CLIEN) ;
+1 ;PTIEN - patient ien
+2 ;CLIEN - associated clinic ien
+3 ;returns 1=selected patient status, 0=not selected patient status
+4 ;
+5 NEW EN,NXT,FOUND,ENODE
+6 SET EN=""
SET (FOUND,NXT)=0
+7 IF '$DATA(^DPT(PTIEN,"DE","B",CLIEN))
QUIT FOUND
+8 SET EN=$ORDER(^DPT(PTIEN,"DE","B",CLIEN,""))
+9 IF EN=""&(PSTAT=1)
SET FOUND=1
QUIT FOUND
+10 IF EN=""!'$DATA(^DPT(PTIEN,"DE",EN,1))
QUIT FOUND
+11 FOR
SET NXT=$ORDER(^DPT(PTIEN,"DE",EN,1,NXT))
IF (FOUND)!(NXT="")!(NXT'?.N)
QUIT
Begin DoDot:1
+12 ;check if active enrollment
+13 SET ENODE=$GET(^DPT(PTIEN,"DE",EN,1,NXT,0))
+14 ;not active enrollment
IF $PIECE(ENODE,"^",3)'=""
IF $PIECE(ENODE,"^",3)<DT+1!$PIECE(ENODE,"^")>DT
QUIT
+15 ; ^ discharge date ^ enrollment date
+16 ;not selected patient status
IF $PIECE(ENODE,"^",2)'=$EXTRACT(PSTAT,1)&(PSTAT'=1)
QUIT
+17 SET FOUND=1
End DoDot:1
+18 QUIT FOUND
+19 ;
FORMAT(INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,CNAME,PINF,ROLN,PCAP) ;Format column information
+1 ;INS - Institution ien
+2 ;TIEN - team ien
+3 ;PTIEN - patient ien
+4 ;PTNAME - patient name
+5 ;PID - SSN
+6 ;PIEN - practitioner ien
+7 ;PNAME - practitioner name
+8 ;CNAME - clinic name
+9 ;LAST - last appointment
+10 ;NEXT - next appointment
+11 ;ROLN - role name
+12 ;PCAP - PC?
+13 ;
+14 NEW SEC,TRD
+15 IF PNAME=""
SET PNAME="[BAD DATA]"
+16 IF PTNAME=""
SET PTNAME="[BAD DATA]"
+17 IF PID=""
SET PID="*********"
+18 ;practitioner
SET @STORE@("P",INS,TIEN,PNAME,PIEN)=""
+19 ;patient
SET @STORE@("PT",INS,TIEN,PTNAME,PTIEN)=""
+20 SET @STORE@("PID",INS,TIEN,PID,PTIEN)=""
+21 ;sort doesn't include practitioner
IF (SORT=1)!(SORT=2)
SET SEC=PTIEN
SET TRD=PIEN
+22 ;sort includes practitioner
IF (SORT=3)!(SORT=4)
SET SEC=PIEN
SET TRD=PTIEN
+23 ;patient name
SET @STORE@(INS,TIEN,SEC,TRD)=$EXTRACT(PTNAME,1,15)
+24 ;9 digit pid
SET $EXTRACT(@STORE@(INS,TIEN,SEC,TRD),18)=PID
+25 ;S $E(@STORE@(INS,TIEN,SEC,TRD),32)=$E(PNAME,1,22) ;practitioner name;IHS/ANMC/LJF 11/03/2000
+26 ;practitioner name;IHS/ANMC/LJF 11/03/2000
SET $EXTRACT(@STORE@(INS,TIEN,SEC,TRD),34)=$EXTRACT(PNAME,1,22)
+27 ;role name
SET $EXTRACT(@STORE@(INS,TIEN,SEC,TRD),56)=$EXTRACT($GET(ROLN),1,22)
+28 ;PC?
SET $EXTRACT(@STORE@(INS,TIEN,SEC,TRD),80)=$GET(PCAP)
+29 ;last appointment
SET $EXTRACT(@STORE@(INS,TIEN,SEC,TRD),85)=$PIECE(PINF,"^",8)
+30 ;S $E(@STORE@(INS,TIEN,SEC,TRD),97)=NEXT ;next appointment;IHS/ANMC/LJF 11/03/2000
+31 ;next appointment;IHS/ANMC/LJF 11/03/2000
SET $EXTRACT(@STORE@(INS,TIEN,SEC,TRD),105)=NEXT
+32 ;S $E(@STORE@(INS,TIEN,SEC,TRD),109)=$E(CNAME,1,24) ;clinic name;IHS/ANMC/LJF 11/03/2000
+33 QUIT
FORMATAC(SCCNT,CNAME,PINF,INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,ROLN,PCAP) ;Format MULTIPLES
+1 ;INS - Institution ien
+2 ;TIEN - team ien
+3 ;PTIEN - patient ien
+4 ;PTNAME - patient name
+5 ;PID - last 4 PID - includes pseudo notation as 5th
+6 ;PIEN - practitioner ien
+7 ;PNAME - practitioner name
+8 ;CNAME - clinic name
+9 ;LAST - last appointment
+10 ;NEXT - next appointment
+11 ;ROLN - role name
+12 ;PCAP - PC?
+13 ;
+14 NEW SEC,TRD
+15 IF PNAME=""
SET PNAME="[BAD DATA]"
+16 IF PTNAME=""
SET PTNAME="[BAD DATA]"
+17 IF PID=""
SET PID="****"
+18 ;practitioner
SET @STORE@("P",INS,TIEN,PNAME,PIEN)=""
+19 ;patient
SET @STORE@("PT",INS,TIEN,PTNAME,PTIEN)=""
+20 ;last 4 pid
SET @STORE@("PID",INS,TIEN,PID,PTIEN)=""
+21 NEW TRD
+22 ;sort doesn't include practitioner
IF (SORT=1)!(SORT=2)
SET SEC=PTIEN
SET TRD=PIEN
+23 ;sort includes practitioner
IF (SORT=3)!(SORT=4)
SET SEC=PIEN
SET TRD=PTIEN
+24 IF '$DATA(@STORE@(INS,TIEN,SEC,TRD,SCCNT))
Begin DoDot:1
+25 ;last appointment
SET $EXTRACT(@STORE@(INS,TIEN,SEC,TRD,SCCNT),85)=$PIECE(PINF,"^",8)
+26 ;next appointment
SET $EXTRACT(@STORE@(INS,TIEN,SEC,TRD,SCCNT),97)=$PIECE(PINF,"^",9)
+27 ;clinic name
SET $EXTRACT(@STORE@(INS,TIEN,SEC,TRD,SCCNT),109)=$EXTRACT(CNAME,1,24)
+28 QUIT
End DoDot:1
+29 QUIT
