SCRPEC ;ALB/CMM - Detail List of Pts & Enroll Clinics ; 29 Jun 99 04:11PM
;;5.3;Scheduling;**41,140,174,177,431,526,520,1015**;AUG 13, 1993;Build 21
;IHS/ANMC/LJF 10/26/2000 changed 132 column message
; added call to list template
; changed patient ID to HRCN
; 11/01/2000 used IHS code for get next/last appts
; used all clinics within a team
;
;Detailed Listing of Patients and Their Enrolled Clinics Report
;
PROMPTS ;
;Prompt for Institution, Team, Clinic, Assigned or Unassigned to Primary
;Care, and Print device
;
N VAUTD,VAUTT,VAUTC,VAUTA,QTIME,PRNT
K VAUTD,VAUTT,VAUTC,VAUTA,VAUTCA,SCUP
S QTIME=""
W ! D INST^SCRPU1 I Y=-1 G ERR
W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR
;S VAUTCA="" ;allows for selection of any clinic in one of the selected divisions
;W ! K Y D CLINIC^SCRPU1 I '$D(VAUTC) G ERR ;IHS/ANMC/LJF 11/1/2000
S VAUTC=1 ;IHS/ANMC/LJF 11/1/2000 use all clinics within team
W ! K Y D ASSUN^SCRPU2 I '$D(VAUTA) G ERR
;W !!,"This report requires 132 column output!" ;IHS/ANMC/LJF 10/26/2000
W !!,"This report, when printed on paper, requires wide paper or condensed print!" ;IHS/ANMC/LJF 10/26/2000
D QUE(.VAUTD,.VAUTT,.VAUTC,.VAUTA) Q
;
QUE(INST,TEAM,CLINIC,ASSUN) ;queue report
;Input Parameters:
;INST - institutions selected (variable and array)
;TEAM - teams selected (variable and array)
;CLINIC - clinics selected (variable and array)
;ASSUN - Assigned or Unassigned to PC
N ZTSAVE,II
F II="INST","TEAM","CLINIC","ASSUN","INST(","TEAM(","CLINIC(" S ZTSAVE(II)=""
W ! D EN^XUTMDEVQ("QENTRY^SCRPEC","Detailed Patient Enrollments",.ZTSAVE)
Q
;
ENTRY2(INST,TEAM,CLINIC,ASSUN,IOP,ZTDTH) ;
;Second entry point for GUI to use
;Input Parameters:
;INST - institutions selected (variable and array)
;TEAM - teams selected (variable and array)
;CLINIC - clinics selected (variable and array)
;ASSUN - Assigned or Unassigned to PC
;IOP - print device
;ZTDTH - queue time (optional)
;
;validate parameters
I '$D(INST)!'$D(TEAM)!'$D(CLINIC)!'$D(ASSUN)!'$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^SCRPEC"
S ZTDESC="Detailed Patient List & Enrolled Clinics",ZTIO=IOP
N II
F II="INST","TEAM","CLINIC","ASSUN","INST(","TEAM(","CLINIC(","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 EN^BSDSCEC Q ;IHS/ANMC/LJF 10/26/2000
IHS ;EP; entry point for list template ;IHS/ANMC/LJF 10/26/2000
S VAUTTN=""
S TITL="Detailed Patient Assignments - "_$S(ASSUN=1:"Assigned PC",1:"Not Assigned PC")
S STORE="^TMP("_$J_",""SCRPEC"")"
K @STORE
S @STORE=0
D FIND^SCRPEC3
I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL)
I '$D(NODATA) D HEADER^SCRPEC2,PRINTIT^SCRPEC3(STORE,TITL)
D EXIT2
Q
;
ERR ;
EXIT1 ;
K ZTSAVE,ZTSK,ZTIO,ZTDTH,ZTRTN,ZTDESC,VAUTCA,SCUP
Q
EXIT2 ;
K @STORE
K STORE,VAUTTN,PAGE,TITL,IOP,TITL,NODATA,CLINIC,ASSUN,INST,TEAM,STOP
Q
;
PDATA(DFN,CLNEN,CNAME,FLAG) ;
;Collect and format data for report
;
N NODE,NAME,PID,PELIG,MT,PSTAT,STATD,DATA,LAST,NEXT
S DATA=""
S NODE=$G(^DPT(DFN,0))
S NAME=$P(NODE,"^") ;patient name
S PID=$P($G(^DPT(DFN,.36)),"^",3),PID=$TR(PID,"-","") ;PID without '-'s
S PID=$$HRCN^BDGF2(DFN,+$G(DUZ(2))) ;IHS/ANMC/LJF 10/26/2000
S MT=$$LST^DGMTU(DFN),MT=$P(MT,"^",4) ;means test status SD*5.3*431
S PELIG=$$ELIG^SCRPU3(DFN) ;primary eligibility
S PSTAT="N/A"
S STATD=""
;S LAST=$$GETLAST^SCRPU3(DFN,CLNEN) ;last clinic appointment
;S NEXT=$$GETNEXT^SCRPU3(DFN,CLNEN) ;next clinic appointment
S LAST=$$GETAPPT^BSDSCEC(DFN,TIEN,"LAST") ;IHS/ANMC/LJF 11/1/2000
S NEXT=$$GETAPPT^BSDSCEC(DFN,TIEN,"NEXT") ;IHS/ANMC/LJF 11/1/2000
;I '$D(FLAG) S DATA=$$FORMAT^SCRPEC2(PTIEN,INS,TIEN,PDATA,CNAME,CIEN)
I '$D(FLAG) S DATA=$$FORMAT^SCRPEC2(NAME,PID,MT,PELIG,PSTAT,STATD,LAST,NEXT,CNAME),DATA=$E(NAME,1,12)_"^"_DATA
I $D(FLAG) S DATA=$E(NAME,1,12)_"^"_PID_"^"_MT_"^"_PELIG_"^"_PSTAT_"^"_STATD_"^"_LAST_"^"_NEXT
Q DATA
;
SCRPEC ;ALB/CMM - Detail List of Pts & Enroll Clinics ; 29 Jun 99 04:11PM
+1 ;;5.3;Scheduling;**41,140,174,177,431,526,520,1015**;AUG 13, 1993;Build 21
+2 ;IHS/ANMC/LJF 10/26/2000 changed 132 column message
+3 ; added call to list template
+4 ; changed patient ID to HRCN
+5 ; 11/01/2000 used IHS code for get next/last appts
+6 ; used all clinics within a team
+7 ;
+8 ;Detailed Listing of Patients and Their Enrolled Clinics Report
+9 ;
PROMPTS ;
+1 ;Prompt for Institution, Team, Clinic, Assigned or Unassigned to Primary
+2 ;Care, and Print device
+3 ;
+4 NEW VAUTD,VAUTT,VAUTC,VAUTA,QTIME,PRNT
+5 KILL VAUTD,VAUTT,VAUTC,VAUTA,VAUTCA,SCUP
+6 SET QTIME=""
+7 WRITE !
DO INST^SCRPU1
IF Y=-1
GOTO ERR
+8 WRITE !
KILL Y
DO PRMTT^SCRPU1
IF '$DATA(VAUTT)
GOTO ERR
+9 ;S VAUTCA="" ;allows for selection of any clinic in one of the selected divisions
+10 ;W ! K Y D CLINIC^SCRPU1 I '$D(VAUTC) G ERR ;IHS/ANMC/LJF 11/1/2000
+11 ;IHS/ANMC/LJF 11/1/2000 use all clinics within team
SET VAUTC=1
+12 WRITE !
KILL Y
DO ASSUN^SCRPU2
IF '$DATA(VAUTA)
GOTO ERR
+13 ;W !!,"This report requires 132 column output!" ;IHS/ANMC/LJF 10/26/2000
+14 ;IHS/ANMC/LJF 10/26/2000
WRITE !!,"This report, when printed on paper, requires wide paper or condensed print!"
+15 DO QUE(.VAUTD,.VAUTT,.VAUTC,.VAUTA)
QUIT
+16 ;
QUE(INST,TEAM,CLINIC,ASSUN) ;queue report
+1 ;Input Parameters:
+2 ;INST - institutions selected (variable and array)
+3 ;TEAM - teams selected (variable and array)
+4 ;CLINIC - clinics selected (variable and array)
+5 ;ASSUN - Assigned or Unassigned to PC
+6 NEW ZTSAVE,II
+7 FOR II="INST","TEAM","CLINIC","ASSUN","INST(","TEAM(","CLINIC("
SET ZTSAVE(II)=""
+8 WRITE !
DO EN^XUTMDEVQ("QENTRY^SCRPEC","Detailed Patient Enrollments",.ZTSAVE)
+9 QUIT
+10 ;
ENTRY2(INST,TEAM,CLINIC,ASSUN,IOP,ZTDTH) ;
+1 ;Second entry point for GUI to use
+2 ;Input Parameters:
+3 ;INST - institutions selected (variable and array)
+4 ;TEAM - teams selected (variable and array)
+5 ;CLINIC - clinics selected (variable and array)
+6 ;ASSUN - Assigned or Unassigned to PC
+7 ;IOP - print device
+8 ;ZTDTH - queue time (optional)
+9 ;
+10 ;validate parameters
+11 IF '$DATA(INST)!'$DATA(TEAM)!'$DATA(CLINIC)!'$DATA(ASSUN)!'$DATA(IOP)!(IOP="")
QUIT
+12 ;
+13 NEW NUMBER
+14 SET IOST=$PIECE(IOP,"^",2)
SET IOP=$PIECE(IOP,"^")
+15 IF IOP?1"Q;".E
SET IOP=$PIECE(IOP,"Q;",2)
+16 IF IOST?1"C-".E
DO QENTRY
GOTO RET
+17 IF ZTDTH=""
SET ZTDTH=$HOROLOG
+18 SET ZTRTN="QENTRY^SCRPEC"
+19 SET ZTDESC="Detailed Patient List & Enrolled Clinics"
SET ZTIO=IOP
+20 NEW II
+21 FOR II="INST","TEAM","CLINIC","ASSUN","INST(","TEAM(","CLINIC(","IOP"
SET ZTSAVE(II)=""
+22 DO ^%ZTLOAD
RET SET NUMBER=0
+1 IF $DATA(ZTSK)
SET NUMBER=ZTSK
+2 DO EXIT1
+3 QUIT NUMBER
+4 ;
QENTRY ;
+1 ;driver entry point
+2 ;IHS/ANMC/LJF 10/26/2000
IF $EXTRACT(IOST,1,2)="C-"
DO EN^BSDSCEC
QUIT
IHS ;EP; entry point for list template ;IHS/ANMC/LJF 10/26/2000
+1 SET VAUTTN=""
+2 SET TITL="Detailed Patient Assignments - "_$SELECT(ASSUN=1:"Assigned PC",1:"Not Assigned PC")
+3 SET STORE="^TMP("_$JOB_",""SCRPEC"")"
+4 KILL @STORE
+5 SET @STORE=0
+6 DO FIND^SCRPEC3
+7 IF $ORDER(@STORE@(0))=""
SET NODATA=$$NODATA^SCRPU3(TITL)
+8 IF '$DATA(NODATA)
DO HEADER^SCRPEC2
DO PRINTIT^SCRPEC3(STORE,TITL)
+9 DO EXIT2
+10 QUIT
+11 ;
ERR ;
EXIT1 ;
+1 KILL ZTSAVE,ZTSK,ZTIO,ZTDTH,ZTRTN,ZTDESC,VAUTCA,SCUP
+2 QUIT
EXIT2 ;
+1 KILL @STORE
+2 KILL STORE,VAUTTN,PAGE,TITL,IOP,TITL,NODATA,CLINIC,ASSUN,INST,TEAM,STOP
+3 QUIT
+4 ;
PDATA(DFN,CLNEN,CNAME,FLAG) ;
+1 ;Collect and format data for report
+2 ;
+3 NEW NODE,NAME,PID,PELIG,MT,PSTAT,STATD,DATA,LAST,NEXT
+4 SET DATA=""
+5 SET NODE=$GET(^DPT(DFN,0))
+6 ;patient name
SET NAME=$PIECE(NODE,"^")
+7 ;PID without '-'s
SET PID=$PIECE($GET(^DPT(DFN,.36)),"^",3)
SET PID=$TRANSLATE(PID,"-","")
+8 ;IHS/ANMC/LJF 10/26/2000
SET PID=$$HRCN^BDGF2(DFN,+$GET(DUZ(2)))
+9 ;means test status SD*5.3*431
SET MT=$$LST^DGMTU(DFN)
SET MT=$PIECE(MT,"^",4)
+10 ;primary eligibility
SET PELIG=$$ELIG^SCRPU3(DFN)
+11 SET PSTAT="N/A"
+12 SET STATD=""
+13 ;S LAST=$$GETLAST^SCRPU3(DFN,CLNEN) ;last clinic appointment
+14 ;S NEXT=$$GETNEXT^SCRPU3(DFN,CLNEN) ;next clinic appointment
+15 ;IHS/ANMC/LJF 11/1/2000
SET LAST=$$GETAPPT^BSDSCEC(DFN,TIEN,"LAST")
+16 ;IHS/ANMC/LJF 11/1/2000
SET NEXT=$$GETAPPT^BSDSCEC(DFN,TIEN,"NEXT")
+17 ;I '$D(FLAG) S DATA=$$FORMAT^SCRPEC2(PTIEN,INS,TIEN,PDATA,CNAME,CIEN)
+18 IF '$DATA(FLAG)
SET DATA=$$FORMAT^SCRPEC2(NAME,PID,MT,PELIG,PSTAT,STATD,LAST,NEXT,CNAME)
SET DATA=$EXTRACT(NAME,1,12)_"^"_DATA
+19 IF $DATA(FLAG)
SET DATA=$EXTRACT(NAME,1,12)_"^"_PID_"^"_MT_"^"_PELIG_"^"_PSTAT_"^"_STATD_"^"_LAST_"^"_NEXT
+20 QUIT DATA
+21 ;
