SCRPRAC ;ALB/CMM - Practitioner Demographics ; 29 Jun 99 04:11PM
;;5.3;Scheduling;**41,52,177,1015**;AUG 13, 1993;Build 21
;IHS/ANMC/LJF 11/02/2000 added call to list template
; removed title line for list template
; added blank lines between providers
;
;Practitioner Demographics Report
;
PROMPTS ;
;Prompt for Practioner and Print device
;
K SCUP
N QTIME,PRNT,VAUTP,Y,VAUTCI,NUMBER
S QTIME=""
;S VAUTPO="" ;only can select one practitioner
S VAUTNA="" ;all not allowed
S VAUTT=1 ;all teams
W ! D PRACT^SCRPU1
I '$D(VAUTP) G ERR
D QUE(.VAUTP) Q
;
QUE(PRACT) ;queue report
;Input: PRACT=array of providers
N ZTSAVE,II
F II="PRACT(","PRACT" S ZTSAVE(II)=""
W ! D EN^XUTMDEVQ("QENTRY^SCRPRAC","Practitioner Demographics",.ZTSAVE)
Q
;
ENTRY2(PRACT,IOP,ZTDTH) ;
;Second entry point for GUI to use
;Input Parameters:
;PRACT - practitioner ien new person file
;IOP - print device
;ZTDTH - queue time (optional)
;
;validate parameters
I '$D(PRACT)!'$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^SCRPRAC"
S ZTDESC="Practitioner Demographics",ZTIO=IOP
N II
F II="PRACT(","PRACT","IOP" S ZTSAVE(II)=""
D ^%ZTLOAD
RET S NUMBER=0
I $D(ZTSK) S NUMBER=ZTSK
D EXIT1
Q NUMBER
;
QENTRY ;
I $E(IOST,1,2)="C-" D ^BSDSCRAC Q ;IHS/ANMC/LJF 11/2/2000
IHS ;EP; entry point for list template ;IHS/ANMC/LJF 11/2/2000
;driver entry point
S TITL="Practitioner Demographics"
S STORE="^TMP("_$J_",""SCRPRAC"")"
K @STORE
S @STORE=0
D DRIVE
I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL)
I '$D(NODATA) D PRINTIT(STORE,TITL)
D EXIT2
Q
;
ERR ;
EXIT1 ;
K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,VAUTPO,VAUTT,VAUTP,SCUP,VAUTNA
Q
;
EXIT2 ;
K @STORE
K STORE,TITL,IOP,PRACT,NODATA,STOP
Q
;
DRIVE ;
;driver module
N PRAC,INF,ARRY,ERROR
S ARRY="ARRAY",ERROR="ERR"
K @ARRY,@ERROR
S PRAC=0 F S PRAC=$O(PRACT(PRAC)) Q:PRAC="" D
.S INF=$$TPPR^SCAPMC12(PRAC,,,,ARRY,ERROR) ;get practitioner positions
.I INF=0 Q
.D GATHER^SCRPRAC2(.ARRY,PRAC)
.K @ERROR,@ARRY
Q
;
PRINTIT(STORE,TITL) ;
N PNAME,PIEN,PAGE,STOP,NEW,SCI
S PNAME="",(NEW,PAGE)=1,STOP=0 W:$E(IOST)="C" @IOF
F S PNAME=$O(@STORE@(PNAME)) Q:PNAME=""!(STOP) S PIEN=0 D
.F S PIEN=$O(@STORE@(PNAME,PIEN)) Q:'PIEN!(STOP) D
..;I NEW D TITLE^SCRPU3(.PAGE,TITL) ;IHS/ANMC/LJF 11/2/2000
..I '$G(VALM),NEW D TITLE^SCRPU3(.PAGE,TITL) ;IHS/ANMC/LJF 11/2/2000
..;I 'NEW,$E(IOST)="C" D HOLD^SCRPU3(.PAGE,TITL)
..;I 'NEW,$E(IOST)'="C"
..;I 'NEW D NEWP1^SCRPU3(.PAGE,TITL) ;IHS/ANMC/LJF 11/2/2000
..I '$G(VALM),'NEW D NEWP1^SCRPU3(.PAGE,TITL) ;IHS/ANMC/LJF 11/2/2000
..I 'NEW W !! ;IHS/ANMC/LJF 11/2/2000
..Q:STOP S (NEW,SCI)=0
..F S SCI=$O(@STORE@(PNAME,PIEN,SCI)) Q:'SCI!(STOP) D
...I $E(IOST)="C",$Y>(IOSL-3) D HOLD^SCRPU3(.PAGE,TITL) Q:STOP D CONT
...I $E(IOST)'="C",$Y>(IOSL-3) D NEWP1^SCRPU3(.PAGE,TITL) Q:STOP D CONT
...W !,@STORE@(PNAME,PIEN,SCI)
...Q
..I $E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR S STOP=Y'=1
..Q
.Q
Q
;
CONT W !,"Provider '",PNAME,"' continued...",! Q
SCRPRAC ;ALB/CMM - Practitioner Demographics ; 29 Jun 99 04:11PM
+1 ;;5.3;Scheduling;**41,52,177,1015**;AUG 13, 1993;Build 21
+2 ;IHS/ANMC/LJF 11/02/2000 added call to list template
+3 ; removed title line for list template
+4 ; added blank lines between providers
+5 ;
+6 ;Practitioner Demographics Report
+7 ;
PROMPTS ;
+1 ;Prompt for Practioner and Print device
+2 ;
+3 KILL SCUP
+4 NEW QTIME,PRNT,VAUTP,Y,VAUTCI,NUMBER
+5 SET QTIME=""
+6 ;S VAUTPO="" ;only can select one practitioner
+7 ;all not allowed
SET VAUTNA=""
+8 ;all teams
SET VAUTT=1
+9 WRITE !
DO PRACT^SCRPU1
+10 IF '$DATA(VAUTP)
GOTO ERR
+11 DO QUE(.VAUTP)
QUIT
+12 ;
QUE(PRACT) ;queue report
+1 ;Input: PRACT=array of providers
+2 NEW ZTSAVE,II
+3 FOR II="PRACT(","PRACT"
SET ZTSAVE(II)=""
+4 WRITE !
DO EN^XUTMDEVQ("QENTRY^SCRPRAC","Practitioner Demographics",.ZTSAVE)
+5 QUIT
+6 ;
ENTRY2(PRACT,IOP,ZTDTH) ;
+1 ;Second entry point for GUI to use
+2 ;Input Parameters:
+3 ;PRACT - practitioner ien new person file
+4 ;IOP - print device
+5 ;ZTDTH - queue time (optional)
+6 ;
+7 ;validate parameters
+8 IF '$DATA(PRACT)!'$DATA(IOP)!(IOP="")
QUIT
+9 ;
+10 NEW NUMBER
+11 SET IOST=$PIECE(IOP,"^",2)
SET IOP=$PIECE(IOP,"^")
+12 IF IOP?1"Q;".E
SET IOP=$PIECE(IOP,"Q;",2)
+13 IF IOST?1"C-".E
DO QENTRY
GOTO RET
+14 IF ZTDTH=""
SET ZTDTH=$HOROLOG
+15 SET ZTRTN="QENTRY^SCRPRAC"
+16 SET ZTDESC="Practitioner Demographics"
SET ZTIO=IOP
+17 NEW II
+18 FOR II="PRACT(","PRACT","IOP"
SET ZTSAVE(II)=""
+19 DO ^%ZTLOAD
RET SET NUMBER=0
+1 IF $DATA(ZTSK)
SET NUMBER=ZTSK
+2 DO EXIT1
+3 QUIT NUMBER
+4 ;
QENTRY ;
+1 ;IHS/ANMC/LJF 11/2/2000
IF $EXTRACT(IOST,1,2)="C-"
DO ^BSDSCRAC
QUIT
IHS ;EP; entry point for list template ;IHS/ANMC/LJF 11/2/2000
+1 ;driver entry point
+2 SET TITL="Practitioner Demographics"
+3 SET STORE="^TMP("_$JOB_",""SCRPRAC"")"
+4 KILL @STORE
+5 SET @STORE=0
+6 DO DRIVE
+7 IF $ORDER(@STORE@(0))=""
SET NODATA=$$NODATA^SCRPU3(TITL)
+8 IF '$DATA(NODATA)
DO PRINTIT(STORE,TITL)
+9 DO EXIT2
+10 QUIT
+11 ;
ERR ;
EXIT1 ;
+1 KILL ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,VAUTPO,VAUTT,VAUTP,SCUP,VAUTNA
+2 QUIT
+3 ;
EXIT2 ;
+1 KILL @STORE
+2 KILL STORE,TITL,IOP,PRACT,NODATA,STOP
+3 QUIT
+4 ;
DRIVE ;
+1 ;driver module
+2 NEW PRAC,INF,ARRY,ERROR
+3 SET ARRY="ARRAY"
SET ERROR="ERR"
+4 KILL @ARRY,@ERROR
+5 SET PRAC=0
FOR
SET PRAC=$ORDER(PRACT(PRAC))
IF PRAC=""
QUIT
Begin DoDot:1
+6 ;get practitioner positions
SET INF=$$TPPR^SCAPMC12(PRAC,,,,ARRY,ERROR)
+7 IF INF=0
QUIT
+8 DO GATHER^SCRPRAC2(.ARRY,PRAC)
+9 KILL @ERROR,@ARRY
End DoDot:1
+10 QUIT
+11 ;
PRINTIT(STORE,TITL) ;
+1 NEW PNAME,PIEN,PAGE,STOP,NEW,SCI
+2 SET PNAME=""
SET (NEW,PAGE)=1
SET STOP=0
IF $EXTRACT(IOST)="C"
WRITE @IOF
+3 FOR
SET PNAME=$ORDER(@STORE@(PNAME))
IF PNAME=""!(STOP)
QUIT
SET PIEN=0
Begin DoDot:1
+4 FOR
SET PIEN=$ORDER(@STORE@(PNAME,PIEN))
IF 'PIEN!(STOP)
QUIT
Begin DoDot:2
+5 ;I NEW D TITLE^SCRPU3(.PAGE,TITL) ;IHS/ANMC/LJF 11/2/2000
+6 ;IHS/ANMC/LJF 11/2/2000
IF '$GET(VALM)
IF NEW
DO TITLE^SCRPU3(.PAGE,TITL)
+7 ;I 'NEW,$E(IOST)="C" D HOLD^SCRPU3(.PAGE,TITL)
+8 ;I 'NEW,$E(IOST)'="C"
+9 ;I 'NEW D NEWP1^SCRPU3(.PAGE,TITL) ;IHS/ANMC/LJF 11/2/2000
+10 ;IHS/ANMC/LJF 11/2/2000
IF '$GET(VALM)
IF 'NEW
DO NEWP1^SCRPU3(.PAGE,TITL)
+11 ;IHS/ANMC/LJF 11/2/2000
IF 'NEW
WRITE !!
+12 IF STOP
QUIT
SET (NEW,SCI)=0
+13 FOR
SET SCI=$ORDER(@STORE@(PNAME,PIEN,SCI))
IF 'SCI!(STOP)
QUIT
Begin DoDot:3
+14 IF $EXTRACT(IOST)="C"
IF $Y>(IOSL-3)
DO HOLD^SCRPU3(.PAGE,TITL)
IF STOP
QUIT
DO CONT
+15 IF $EXTRACT(IOST)'="C"
IF $Y>(IOSL-3)
DO NEWP1^SCRPU3(.PAGE,TITL)
IF STOP
QUIT
DO CONT
+16 WRITE !,@STORE@(PNAME,PIEN,SCI)
+17 QUIT
End DoDot:3
+18 IF $EXTRACT(IOST)="C"
NEW DIR
SET DIR(0)="E"
WRITE !
DO ^DIR
SET STOP=Y'=1
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 QUIT
+22 ;
CONT WRITE !,"Provider '",PNAME,"' continued...",!
QUIT
