- 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
