BDGSTAT1 ; IHS/ANMC/LJF - AVERAGE DAILY PATIENT LOAD ;
;;5.3;PIMS;;APR 26, 2002
;
;
SELECT ; -- have user select report by ward or by service
NEW BDGFRM,BDGBD,BDGED,BDGIA
S BDGFRM=$$READ^BDGF("SO^1:By Ward;2:By Service","Select Format")
Q:BDGFRM<1
S BDGIA=$$READ^BDGF("Y","Include INACTIVE "_$S(BDGFRM=1:"Wards",1:"Services"),"NO")
;
S BDGBD=$$READ^BDGF("DO^::EX","Select Beginning Date") Q:BDGBD<1
S BDGED=$$READ^BDGF("DO^::EX","Select Ending Date") Q:BDGED<1
;
;
D ZIS^BDGF("PQ","EN^BDGSTAT1","ADPL REPORT","BDGFRM;BDGBD;BDGED;BDGIA")
Q
;
;
EN ;EP; entry point from queuing
I $E(IOST,1,2)="P-" D INIT,PRINT Q
NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
D EN^VALM("BDG STAT ADPL"_BDGFRM)
D CLEAR^VALM1
Q
;
HDR ; -- header code
NEW X
S X="For "_$$FMTE^XLFDT(BDGBD)_" through "_$$FMTE^XLFDT(BDGED)
S VALMHDR(1)=$$SP(75-$L(X)\2)_X
Q
;
INIT ; -- init variables and list array
NEW BDGDAYS
K ^TMP("BDGSTAT1",$J)
S VALMCNT=0
S BDGDAYS=$$FMDIFF^XLFDT(BDGED,BDGBD)+1 ;# of days in date range
;
D @BDGFRM ;gather ward or service stats for date range
;
I '$D(^TMP("BDGSTAT1",$J)) D SET("No data found",.VALMCNT)
;
Q
;
1 ; step thru ADT Census-Ward file for date range
NEW WARD,WRDNM,DATE,BDGA,X,LINE,TOTAL
S WARD=0
F S WARD=$O(^BDGCWD(WARD)) Q:'WARD D
. I BDGIA=0,'$D(^BDGWD(WARD)) Q ;old ward, no longer used
. I BDGIA=0,$$GET1^DIQ(9009016.5,WARD,.03)="INACTIVE" Q
. S WRDNM=$$GET1^DIQ(42,WARD,.01) ;ward name
. ;
. S DATE=BDGBD-.001
. F S DATE=$O(^BDGCWD(WARD,1,DATE)) Q:DATE>BDGED Q:'DATE D
.. ; count patients remaining and one day patients
.. S X=$P($G(^BDGCWD(WARD,1,DATE,0)),U,2)+$P($G(^(0)),U,8)
.. ; increment array for total inpatient days
.. S BDGA(WRDNM)=$G(BDGA(WRDNM))+X
;
; put sorted data into display array
S WARD=0 F S WARD=$O(BDGA(WARD)) Q:WARD="" D
. S LINE=$$PAD(WARD,40)_$J(BDGA(WARD),5)
. S LINE=$$PAD(LINE,65)_$J(BDGA(WARD)/BDGDAYS,5,2)
. D SET(LINE,.VALMCNT)
. ;
. ; increment totals
. S TOTAL=$G(TOTAL)+BDGA(WARD)
;
; put totals line into display array
I $G(TOTAL) D
. S LINE=$$PAD($$PAD("TOTALS",40)_$J(TOTAL,5),65)_$J(TOTAL/BDGDAYS,5,2)
. D SET($$REPEAT^XLFSTR("=",80),.VALMCNT),SET(LINE,.VALMCNT)
Q
;
2 ; step thru ADT Census-Treating Specialty file by date
NEW SRV,DATE,SRVNM,BDGA,X,LINE,TOTAL,SUBTOT
S SRV=0
F S SRV=$O(^BDGCTX(SRV)) Q:'SRV D
. ;
. ; quit if not including inactive services; check begin & end dates
. I BDGIA=0,('$$ACTSRV^BDGPAR(SRV,BDGBD)),('$$ACTSRV^BDGPAR(SRV,BDGED)) Q
. S SRVNM=$$GET1^DIQ(45.7,SRV,.01) ;service name
. ;
. S DATE=BDGBD-.001
. F S DATE=$O(^BDGCTX(SRV,1,DATE)) Q:DATE>BDGED Q:'DATE D
.. ;
.. ; count patients remaining and one day patients
.. S X=$G(^BDGCTX(SRV,1,DATE,0))
.. ;
.. ; increment by adult vs. peds for total inpt days
.. S BDGA(SRVNM,"A")=$G(BDGA(SRVNM,"A"))+$P(X,U,2)+$P(X,U,8)
.. S BDGA(SRVNM,"P")=$G(BDGA(SRVNM,"P"))+$P(X,U,12)+$P(X,U,18)
;
; put sorted data into display array
S SRV=0 F S SRV=$O(BDGA(SRV)) Q:SRV="" D
. S LINE=$$PAD(SRV,35)_$J(+$G(BDGA(SRV,"A")),5) ;adult inpt days
. S LINE=$$PAD(LINE,45)_$J(+$G(BDGA(SRV,"P")),5) ;peds inpt days
. S SUBTOT=$G(BDGA(SRV,"A"))+$G(BDGA(SRV,"P")) ;total inpt days
. S LINE=$$PAD($$PAD(LINE,55)_$J(SUBTOT,5),70)_$J(SUBTOT/BDGDAYS,5,2)
. D SET(LINE,.VALMCNT)
. ;
. ; increment totals
. S TOTAL("A")=$G(TOTAL("A"))+$G(BDGA(SRV,"A"))
. S TOTAL("P")=$G(TOTAL("P"))+$G(BDGA(SRV,"P"))
. S TOTAL=$G(TOTAL)+SUBTOT
;
; put totals line into display array
S LINE=$$PAD("TOTALS",35)_$J(+$G(TOTAL("A")),5) ;adult
S LINE=$$PAD(LINE,45)_$J(+$G(TOTAL("P")),5) ;peds
S LINE=$$PAD(LINE,55)_$J($G(TOTAL),5) ;total
S LINE=$$PAD(LINE,70)_$J($G(TOTAL)/BDGDAYS,5,2) ;adpl
D SET($$REPEAT^XLFSTR("=",80),.VALMCNT),SET(LINE,.VALMCNT)
Q
;
SET(DATA,NUM) ; put data line into display array
S NUM=NUM+1
S ^TMP("BDGSTAT1",$J,NUM,0)=DATA
Q
;
PRINT ; print report to paper
NEW BDGLN,BDGPG
U IO D INIT^BDGF,HDG
S BDGLN=0
F S BDGLN=$O(^TMP("BDGSTAT1",$J,BDGLN)) Q:'BDGLN D
. I $Y>(IOSL-4) D HDG
. W !,^TMP("BDGSTAT1",$J,BDGLN,0)
D ^%ZISC,PRTKL^BDGF,EXIT
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
Q
;
EXPND ; -- expand code
Q
;
;
HDG ; print heading on paper
S BDGPG=$G(BDGPG)+1 I BDGPG>1 W @IOF
NEW X
S X="AVERAGE DAILY PATIENT LOAD by "_$S(BDGFRM=1:"WARD",1:"SERVICE")
W !,BDGTIME,?80-$L(X)/2,X,?71,"Page: ",BDGPG
S X="For "_$$FMTE^XLFDT(BDGBD)_" through "_$$FMTE^XLFDT(BDGED)
W !,BDGDATE,?(80-$L(X)\2),X,?76,BDGUSR
W !,$$REPEAT^XLFSTR("-",80)
I BDGFRM=1 W !,"Ward",?40,"Patient Days",?65,"ADPL"
I BDGFRM=2 W !,"Service",?25,"Pat. Days: Adult",?45,"Peds",?55,"Total",?70,"ADPL"
W !,$$REPEAT^XLFSTR("=",80)
Q
;
PAD(D,L) ;EP -- SUBRTN to pad length of data
; -- D=data L=length
Q $E(D_$$REPEAT^XLFSTR(" ",L),1,L)
;
SP(N) ; -- SUBRTN to pad N number of spaces
Q $$PAD(" ",N)
BDGSTAT1 ; IHS/ANMC/LJF - AVERAGE DAILY PATIENT LOAD ;
+1 ;;5.3;PIMS;;APR 26, 2002
+2 ;
+3 ;
SELECT ; -- have user select report by ward or by service
+1 NEW BDGFRM,BDGBD,BDGED,BDGIA
+2 SET BDGFRM=$$READ^BDGF("SO^1:By Ward;2:By Service","Select Format")
+3 IF BDGFRM<1
QUIT
+4 SET BDGIA=$$READ^BDGF("Y","Include INACTIVE "_$SELECT(BDGFRM=1:"Wards",1:"Services"),"NO")
+5 ;
+6 SET BDGBD=$$READ^BDGF("DO^::EX","Select Beginning Date")
IF BDGBD<1
QUIT
+7 SET BDGED=$$READ^BDGF("DO^::EX","Select Ending Date")
IF BDGED<1
QUIT
+8 ;
+9 ;
+10 DO ZIS^BDGF("PQ","EN^BDGSTAT1","ADPL REPORT","BDGFRM;BDGBD;BDGED;BDGIA")
+11 QUIT
+12 ;
+13 ;
EN ;EP; entry point from queuing
+1 IF $EXTRACT(IOST,1,2)="P-"
DO INIT
DO PRINT
QUIT
+2 NEW VALMCNT
DO TERM^VALM0
DO CLEAR^VALM1
+3 DO EN^VALM("BDG STAT ADPL"_BDGFRM)
+4 DO CLEAR^VALM1
+5 QUIT
+6 ;
HDR ; -- header code
+1 NEW X
+2 SET X="For "_$$FMTE^XLFDT(BDGBD)_" through "_$$FMTE^XLFDT(BDGED)
+3 SET VALMHDR(1)=$$SP(75-$LENGTH(X)\2)_X
+4 QUIT
+5 ;
INIT ; -- init variables and list array
+1 NEW BDGDAYS
+2 KILL ^TMP("BDGSTAT1",$JOB)
+3 SET VALMCNT=0
+4 ;# of days in date range
SET BDGDAYS=$$FMDIFF^XLFDT(BDGED,BDGBD)+1
+5 ;
+6 ;gather ward or service stats for date range
DO @BDGFRM
+7 ;
+8 IF '$DATA(^TMP("BDGSTAT1",$JOB))
DO SET("No data found",.VALMCNT)
+9 ;
+10 QUIT
+11 ;
1 ; step thru ADT Census-Ward file for date range
+1 NEW WARD,WRDNM,DATE,BDGA,X,LINE,TOTAL
+2 SET WARD=0
+3 FOR
SET WARD=$ORDER(^BDGCWD(WARD))
IF 'WARD
QUIT
Begin DoDot:1
+4 ;old ward, no longer used
IF BDGIA=0
IF '$DATA(^BDGWD(WARD))
QUIT
+5 IF BDGIA=0
IF $$GET1^DIQ(9009016.5,WARD,.03)="INACTIVE"
QUIT
+6 ;ward name
SET WRDNM=$$GET1^DIQ(42,WARD,.01)
+7 ;
+8 SET DATE=BDGBD-.001
+9 FOR
SET DATE=$ORDER(^BDGCWD(WARD,1,DATE))
IF DATE>BDGED
QUIT
IF 'DATE
QUIT
Begin DoDot:2
+10 ; count patients remaining and one day patients
+11 SET X=$PIECE($GET(^BDGCWD(WARD,1,DATE,0)),U,2)+$PIECE($GET(^(0)),U,8)
+12 ; increment array for total inpatient days
+13 SET BDGA(WRDNM)=$GET(BDGA(WRDNM))+X
End DoDot:2
End DoDot:1
+14 ;
+15 ; put sorted data into display array
+16 SET WARD=0
FOR
SET WARD=$ORDER(BDGA(WARD))
IF WARD=""
QUIT
Begin DoDot:1
+17 SET LINE=$$PAD(WARD,40)_$JUSTIFY(BDGA(WARD),5)
+18 SET LINE=$$PAD(LINE,65)_$JUSTIFY(BDGA(WARD)/BDGDAYS,5,2)
+19 DO SET(LINE,.VALMCNT)
+20 ;
+21 ; increment totals
+22 SET TOTAL=$GET(TOTAL)+BDGA(WARD)
End DoDot:1
+23 ;
+24 ; put totals line into display array
+25 IF $GET(TOTAL)
Begin DoDot:1
+26 SET LINE=$$PAD($$PAD("TOTALS",40)_$JUSTIFY(TOTAL,5),65)_$JUSTIFY(TOTAL/BDGDAYS,5,2)
+27 DO SET($$REPEAT^XLFSTR("=",80),.VALMCNT)
DO SET(LINE,.VALMCNT)
End DoDot:1
+28 QUIT
+29 ;
2 ; step thru ADT Census-Treating Specialty file by date
+1 NEW SRV,DATE,SRVNM,BDGA,X,LINE,TOTAL,SUBTOT
+2 SET SRV=0
+3 FOR
SET SRV=$ORDER(^BDGCTX(SRV))
IF 'SRV
QUIT
Begin DoDot:1
+4 ;
+5 ; quit if not including inactive services; check begin & end dates
+6 IF BDGIA=0
IF ('$$ACTSRV^BDGPAR(SRV,BDGBD))
IF ('$$ACTSRV^BDGPAR(SRV,BDGED))
QUIT
+7 ;service name
SET SRVNM=$$GET1^DIQ(45.7,SRV,.01)
+8 ;
+9 SET DATE=BDGBD-.001
+10 FOR
SET DATE=$ORDER(^BDGCTX(SRV,1,DATE))
IF DATE>BDGED
QUIT
IF 'DATE
QUIT
Begin DoDot:2
+11 ;
+12 ; count patients remaining and one day patients
+13 SET X=$GET(^BDGCTX(SRV,1,DATE,0))
+14 ;
+15 ; increment by adult vs. peds for total inpt days
+16 SET BDGA(SRVNM,"A")=$GET(BDGA(SRVNM,"A"))+$PIECE(X,U,2)+$PIECE(X,U,8)
+17 SET BDGA(SRVNM,"P")=$GET(BDGA(SRVNM,"P"))+$PIECE(X,U,12)+$PIECE(X,U,18)
End DoDot:2
End DoDot:1
+18 ;
+19 ; put sorted data into display array
+20 SET SRV=0
FOR
SET SRV=$ORDER(BDGA(SRV))
IF SRV=""
QUIT
Begin DoDot:1
+21 ;adult inpt days
SET LINE=$$PAD(SRV,35)_$JUSTIFY(+$GET(BDGA(SRV,"A")),5)
+22 ;peds inpt days
SET LINE=$$PAD(LINE,45)_$JUSTIFY(+$GET(BDGA(SRV,"P")),5)
+23 ;total inpt days
SET SUBTOT=$GET(BDGA(SRV,"A"))+$GET(BDGA(SRV,"P"))
+24 SET LINE=$$PAD($$PAD(LINE,55)_$JUSTIFY(SUBTOT,5),70)_$JUSTIFY(SUBTOT/BDGDAYS,5,2)
+25 DO SET(LINE,.VALMCNT)
+26 ;
+27 ; increment totals
+28 SET TOTAL("A")=$GET(TOTAL("A"))+$GET(BDGA(SRV,"A"))
+29 SET TOTAL("P")=$GET(TOTAL("P"))+$GET(BDGA(SRV,"P"))
+30 SET TOTAL=$GET(TOTAL)+SUBTOT
End DoDot:1
+31 ;
+32 ; put totals line into display array
+33 ;adult
SET LINE=$$PAD("TOTALS",35)_$JUSTIFY(+$GET(TOTAL("A")),5)
+34 ;peds
SET LINE=$$PAD(LINE,45)_$JUSTIFY(+$GET(TOTAL("P")),5)
+35 ;total
SET LINE=$$PAD(LINE,55)_$JUSTIFY($GET(TOTAL),5)
+36 ;adpl
SET LINE=$$PAD(LINE,70)_$JUSTIFY($GET(TOTAL)/BDGDAYS,5,2)
+37 DO SET($$REPEAT^XLFSTR("=",80),.VALMCNT)
DO SET(LINE,.VALMCNT)
+38 QUIT
+39 ;
SET(DATA,NUM) ; put data line into display array
+1 SET NUM=NUM+1
+2 SET ^TMP("BDGSTAT1",$JOB,NUM,0)=DATA
+3 QUIT
+4 ;
PRINT ; print report to paper
+1 NEW BDGLN,BDGPG
+2 USE IO
DO INIT^BDGF
DO HDG
+3 SET BDGLN=0
+4 FOR
SET BDGLN=$ORDER(^TMP("BDGSTAT1",$JOB,BDGLN))
IF 'BDGLN
QUIT
Begin DoDot:1
+5 IF $Y>(IOSL-4)
DO HDG
+6 WRITE !,^TMP("BDGSTAT1",$JOB,BDGLN,0)
End DoDot:1
+7 DO ^%ZISC
DO PRTKL^BDGF
DO EXIT
+8 QUIT
+9 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 QUIT
+2 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
+3 ;
HDG ; print heading on paper
+1 SET BDGPG=$GET(BDGPG)+1
IF BDGPG>1
WRITE @IOF
+2 NEW X
+3 SET X="AVERAGE DAILY PATIENT LOAD by "_$SELECT(BDGFRM=1:"WARD",1:"SERVICE")
+4 WRITE !,BDGTIME,?80-$LENGTH(X)/2,X,?71,"Page: ",BDGPG
+5 SET X="For "_$$FMTE^XLFDT(BDGBD)_" through "_$$FMTE^XLFDT(BDGED)
+6 WRITE !,BDGDATE,?(80-$LENGTH(X)\2),X,?76,BDGUSR
+7 WRITE !,$$REPEAT^XLFSTR("-",80)
+8 IF BDGFRM=1
WRITE !,"Ward",?40,"Patient Days",?65,"ADPL"
+9 IF BDGFRM=2
WRITE !,"Service",?25,"Pat. Days: Adult",?45,"Peds",?55,"Total",?70,"ADPL"
+10 WRITE !,$$REPEAT^XLFSTR("=",80)
+11 QUIT
+12 ;
PAD(D,L) ;EP -- SUBRTN to pad length of data
+1 ; -- D=data L=length
+2 QUIT $EXTRACT(D_$$REPEAT^XLFSTR(" ",L),1,L)
+3 ;
SP(N) ; -- SUBRTN to pad N number of spaces
+1 QUIT $$PAD(" ",N)
