ADGADPL ; IHS/ADC/PDW/ENM - AVERAGE DAILY PATIENT LOAD BY WARD ; [ 03/25/1999 11:48 AM ]
;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
;
;***> setup for print
W @IOF,!!!?18,"AVERAGE DAILY PATIENT LOAD BY WARD OR SERVICE",!!
;
SELECT ; -- have user select report by ward or by service
W !! K DIR S DIR(0)="SO^1:By WARD;2:By SERVICE"
S DIR("A")="Select report format (by number)" D ^DIR
G END:Y<1,END:Y>2 S DGFORM=Y
;
BDATE ; -- ask users for beginning date
W ! S %DT="AEQ",%DT("A")="Select beginning date: ",X="" D ^%DT
G SELECT:Y=-1 S DGBDT=Y
EDATE ; -- ask user for ending date
S %DT="AEQ",%DT("A")="Select ending date: ",X="" D ^%DT
G BDATE:Y=-1 S DGEDT=Y
;
DEV ; -- ask user for printing device
S %ZIS="PQ" D ^%ZIS G END:POP,QUE:$D(IO("Q")) U IO G CALC
QUE K IO("Q") S ZTRTN="CALC^ADGADPL",ZTDESC="AVERAGE DAILY PATIENT LOAD"
F I="DGBDT","DGEDT","DGFORM" S ZTSAVE(I)=""
D ^%ZTLOAD D ^%ZISC K ZTSK
END K Y,DGBDT,DGEDT,DGFORM D HOME^%ZIS Q
;
;
CALC ;EP; -- calculate of ADPL
I DGFORM=1 D D PRINT Q
. S DGW=0 ;step thru ADT Census-Ward file for date range
. F S DGW=$O(^ADGWD(DGW)) Q:DGW'=+DGW D
.. S DGWN=$P(^DIC(42,DGW,0),U)
.. I $G(^DIC(42,DGW,"I"))="I" S DGWN=DGWN_" **INACTIVE**"
.. S DGD=DGBDT-.001
.. F S DGD=$O(^ADGWD(DGW,1,DGD)) Q:DGD>DGEDT Q:DGD="" D
... S X=$P($G(^ADGWD(DGW,1,DGD,0)),U,2)+$P($G(^(0)),U,12)
... S DGA(DGWN)=$G(DGA(DGWN))+X
;
S DGW=0 ;step thru ADT Census-Treating Specialty file by date
F S DGW=$O(^ADGTX(DGW)) Q:DGW'=+DGW D
. S DGWN=$P(^DIC(45.7,DGW,0),U)
. I $P(^DIC(45.7,DGW,9999999),U,3)="" S DGWN=DGWN_" **INACTIVE**"
. S DGD=DGBDT-.001
. F S DGD=$O(^ADGTX(DGW,1,DGD)) Q:DGD>DGEDT Q:DGD="" D
.. S X=$P($G(^ADGTX(DGW,1,DGD,0)),U,2),Y=$P($G(^ADGTX(DGW,1,DGD,1)),U)
.. S DGA(DGWN)=$G(DGA(DGWN))+X+Y
;
PRINT ;***> Print report
;
;initialize variables
S DGPAGE=0,DGDUZ=$P(^VA(200,DUZ,0),U,2) ;page#/user initials
S DGFAC=$P(^DIC(4,DUZ(2),0),U),DGSTOP="" ;facility
S (DGLIN,DGLIN1)="",$P(DGLIN,"=",80)="",$P(DGLIN1,"-",80)="" ;line
S DGDTLIN="from "_$E(DGBDT,4,5)_"/"_$E(DGBDT,6,7)_"/"_$E(DGBDT,2,3)_" to "_$E(DGEDT,4,5)_"/"_$E(DGEDT,6,7)_"/"_$E(DGEDT,2,3) ;date range
;
S X1=DGEDT,X2=DGBDT D ^%DTC S DGL=X+1
D HEAD S (DGW,DGT,DGAT)=0
F S DGW=$O(DGA(DGW)) Q:DGW="" Q:DGSTOP=U D
. I $Y>(IOSL-5) D NEWPG Q:DGSTOP=U
. I DGW["INACTIVE",DGA(DGW)=0 Q ;don't prnt inact wards w/no activity
. W !!?5,DGW ;print ward or service name
. S DGAV=DGA(DGW)/DGL,DGAV=DGAV_".00" ;calculate adpl
. S DGT=DGT+DGA(DGW),DGAT=DGAT+DGAV
. W ?45,$J(DGA(DGW),3),?60,$J(DGAV,5,2),!
G END2:DGSTOP=U
W !,DGLIN1,!?10,"TOTAL:",?45,$J(DGT,3),?60,$J(DGAT,5,2),!
;
;***> eoj
END1 I IOST["C-" D PRTOPT^ADGVAR
END2 D KILL^ADGUTIL W @IOF D ^%ZISC Q
;
;
NEWPG ;***> end of page control
I IOST'?1"C-".E D HEAD S DGSTOP="" Q
I DGPAGE>0 K DIR S DIR(0)="E" D ^DIR S DGSTOP=X
I DGSTOP'=U D HEAD
Q
;
HEAD ;***> print heading
I (IOST["C-")!(DGPAGE>0) W @IOF
W DGDUZ,?80-$L(DGFAC)\2,DGFAC
S DGPAGE=DGPAGE+1 W ?70,"Page ",DGPAGE
W ! D TIME
S X="AVERAGE DAILY PATIENT LOAD by "_$S(DGFORM=1:"WARD",1:"SERVICE")
W ?80-$L(X)/2,X
W !,$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3),?25,DGDTLIN,!!
W ?5,$S(DGFORM=1:"WARD",1:"SERVICE"),?40,"INPATIENT DAYS",?60,"ADPL"
W !!,DGLIN Q
;
TIME ; -- SUBRTN to print time
N X S X=$E($$HTFM^XLFDT($H),1,12)
W $P($$FMTE^XLFDT(X,"2P")," ",2,3)
Q
ADGADPL ; IHS/ADC/PDW/ENM - AVERAGE DAILY PATIENT LOAD BY WARD ; [ 03/25/1999 11:48 AM ]
+1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
+2 ;
+3 ;***> setup for print
+4 WRITE @IOF,!!!?18,"AVERAGE DAILY PATIENT LOAD BY WARD OR SERVICE",!!
+5 ;
SELECT ; -- have user select report by ward or by service
+1 WRITE !!
KILL DIR
SET DIR(0)="SO^1:By WARD;2:By SERVICE"
+2 SET DIR("A")="Select report format (by number)"
DO ^DIR
+3 IF Y<1
GOTO END
IF Y>2
GOTO END
SET DGFORM=Y
+4 ;
BDATE ; -- ask users for beginning date
+1 WRITE !
SET %DT="AEQ"
SET %DT("A")="Select beginning date: "
SET X=""
DO ^%DT
+2 IF Y=-1
GOTO SELECT
SET DGBDT=Y
EDATE ; -- ask user for ending date
+1 SET %DT="AEQ"
SET %DT("A")="Select ending date: "
SET X=""
DO ^%DT
+2 IF Y=-1
GOTO BDATE
SET DGEDT=Y
+3 ;
DEV ; -- ask user for printing device
+1 SET %ZIS="PQ"
DO ^%ZIS
IF POP
GOTO END
IF $DATA(IO("Q"))
GOTO QUE
USE IO
GOTO CALC
QUE KILL IO("Q")
SET ZTRTN="CALC^ADGADPL"
SET ZTDESC="AVERAGE DAILY PATIENT LOAD"
+1 FOR I="DGBDT","DGEDT","DGFORM"
SET ZTSAVE(I)=""
+2 DO ^%ZTLOAD
DO ^%ZISC
KILL ZTSK
END KILL Y,DGBDT,DGEDT,DGFORM
DO HOME^%ZIS
QUIT
+1 ;
+2 ;
CALC ;EP; -- calculate of ADPL
+1 IF DGFORM=1
Begin DoDot:1
+2 ;step thru ADT Census-Ward file for date range
SET DGW=0
+3 FOR
SET DGW=$ORDER(^ADGWD(DGW))
IF DGW'=+DGW
QUIT
Begin DoDot:2
+4 SET DGWN=$PIECE(^DIC(42,DGW,0),U)
+5 IF $GET(^DIC(42,DGW,"I"))="I"
SET DGWN=DGWN_" **INACTIVE**"
+6 SET DGD=DGBDT-.001
+7 FOR
SET DGD=$ORDER(^ADGWD(DGW,1,DGD))
IF DGD>DGEDT
QUIT
IF DGD=""
QUIT
Begin DoDot:3
+8 SET X=$PIECE($GET(^ADGWD(DGW,1,DGD,0)),U,2)+$PIECE($GET(^(0)),U,12)
+9 SET DGA(DGWN)=$GET(DGA(DGWN))+X
End DoDot:3
End DoDot:2
End DoDot:1
DO PRINT
QUIT
+10 ;
+11 ;step thru ADT Census-Treating Specialty file by date
SET DGW=0
+12 FOR
SET DGW=$ORDER(^ADGTX(DGW))
IF DGW'=+DGW
QUIT
Begin DoDot:1
+13 SET DGWN=$PIECE(^DIC(45.7,DGW,0),U)
+14 IF $PIECE(^DIC(45.7,DGW,9999999),U,3)=""
SET DGWN=DGWN_" **INACTIVE**"
+15 SET DGD=DGBDT-.001
+16 FOR
SET DGD=$ORDER(^ADGTX(DGW,1,DGD))
IF DGD>DGEDT
QUIT
IF DGD=""
QUIT
Begin DoDot:2
+17 SET X=$PIECE($GET(^ADGTX(DGW,1,DGD,0)),U,2)
SET Y=$PIECE($GET(^ADGTX(DGW,1,DGD,1)),U)
+18 SET DGA(DGWN)=$GET(DGA(DGWN))+X+Y
End DoDot:2
End DoDot:1
+19 ;
PRINT ;***> Print report
+1 ;
+2 ;initialize variables
+3 ;page#/user initials
SET DGPAGE=0
SET DGDUZ=$PIECE(^VA(200,DUZ,0),U,2)
+4 ;facility
SET DGFAC=$PIECE(^DIC(4,DUZ(2),0),U)
SET DGSTOP=""
+5 ;line
SET (DGLIN,DGLIN1)=""
SET $PIECE(DGLIN,"=",80)=""
SET $PIECE(DGLIN1,"-",80)=""
+6 ;date range
SET DGDTLIN="from "_$EXTRACT(DGBDT,4,5)_"/"_$EXTRACT(DGBDT,6,7)_"/"_$EXTRACT(DGBDT,2,3)_" to "_$EXTRACT(DGEDT,4,5)_"/"_$EXTRACT(DGEDT,6,7)_"/"_$EXTRACT(DGEDT,2,3)
+7 ;
+8 SET X1=DGEDT
SET X2=DGBDT
DO ^%DTC
SET DGL=X+1
+9 DO HEAD
SET (DGW,DGT,DGAT)=0
+10 FOR
SET DGW=$ORDER(DGA(DGW))
IF DGW=""
QUIT
IF DGSTOP=U
QUIT
Begin DoDot:1
+11 IF $Y>(IOSL-5)
DO NEWPG
IF DGSTOP=U
QUIT
+12 ;don't prnt inact wards w/no activity
IF DGW["INACTIVE"
IF DGA(DGW)=0
QUIT
+13 ;print ward or service name
WRITE !!?5,DGW
+14 ;calculate adpl
SET DGAV=DGA(DGW)/DGL
SET DGAV=DGAV_".00"
+15 SET DGT=DGT+DGA(DGW)
SET DGAT=DGAT+DGAV
+16 WRITE ?45,$JUSTIFY(DGA(DGW),3),?60,$JUSTIFY(DGAV,5,2),!
End DoDot:1
+17 IF DGSTOP=U
GOTO END2
+18 WRITE !,DGLIN1,!?10,"TOTAL:",?45,$JUSTIFY(DGT,3),?60,$JUSTIFY(DGAT,5,2),!
+19 ;
+20 ;***> eoj
END1 IF IOST["C-"
DO PRTOPT^ADGVAR
END2 DO KILL^ADGUTIL
WRITE @IOF
DO ^%ZISC
QUIT
+1 ;
+2 ;
NEWPG ;***> end of page control
+1 IF IOST'?1"C-".E
DO HEAD
SET DGSTOP=""
QUIT
+2 IF DGPAGE>0
KILL DIR
SET DIR(0)="E"
DO ^DIR
SET DGSTOP=X
+3 IF DGSTOP'=U
DO HEAD
+4 QUIT
+5 ;
HEAD ;***> print heading
+1 IF (IOST["C-")!(DGPAGE>0)
WRITE @IOF
+2 WRITE DGDUZ,?80-$LENGTH(DGFAC)\2,DGFAC
+3 SET DGPAGE=DGPAGE+1
WRITE ?70,"Page ",DGPAGE
+4 WRITE !
DO TIME
+5 SET X="AVERAGE DAILY PATIENT LOAD by "_$SELECT(DGFORM=1:"WARD",1:"SERVICE")
+6 WRITE ?80-$LENGTH(X)/2,X
+7 WRITE !,$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3),?25,DGDTLIN,!!
+8 WRITE ?5,$SELECT(DGFORM=1:"WARD",1:"SERVICE"),?40,"INPATIENT DAYS",?60,"ADPL"
+9 WRITE !!,DGLIN
QUIT
+10 ;
TIME ; -- SUBRTN to print time
+1 NEW X
SET X=$EXTRACT($$HTFM^XLFDT($HOROLOG),1,12)
+2 WRITE $PIECE($$FMTE^XLFDT(X,"2P")," ",2,3)
+3 QUIT
