- BDGCEN0 ; IHS/ANMC/LJF - CENSUS AID-BY WARD CONT ;
- ;;5.3;PIMS;;APR 26, 2002
- ;
- NEW DGTOT,DGCNT,DGDT,DGSTR
- S (DGTOT,DGCNT)=0
- ;
- ; -- loop thru adt census-ward file by date
- S DGDT=BDGBD-.0001
- F S DGDT=$O(^BDGCWD(BDGWD,1,DGDT)) Q:'DGDT Q:(DGDT>BDGED) D
- . ;
- . I '$D(^BDGCWD(BDGWD,1,DGDT,0)) D Q
- .. W !!,"NO CENSUS DATA FOR THIS WARD FOR ",$$FMTE^XLFDT(DGDT,2),!!
- . ;
- . S DGSTR=^BDGCWD(BDGWD,1,DGDT,0)
- . W !,$E(DGDT,4,5)_"/"_$E(DGDT,6,7)_"/"_$E(DGDT,2,3) ;date
- . W ?12,$P(DGSTR,U,3) ;admits
- . W ?22,$P(DGSTR,U,5) ;trans in
- . W ?32,$P(DGSTR,U,6) ;trans out
- . W ?42,$P(DGSTR,U,4) ;disch
- . W ?51,$P(DGSTR,U,7) ;deaths
- . W ?61,$P(DGSTR,U,2) ;# remaining
- . W ?71,$J($$BENCHMRK,3,0)
- . S DGCNT=DGCNT+1,DGTOT=DGTOT+$$BENCHMRK
- ;
- W !?60,"Average:",?71,$J($S(DGTOT=0:0,1:DGTOT/DGCNT),3,0)
- Q
- ;
- HEAD ;EP; -- subrtn to print heading
- ; DGPAGE set by calling routine
- NEW DGSITE,DGDUZ,DGTL,DGLIN
- S DGSITE=$$GET1^DIQ(4,DUZ(2),.01),DGDUZ=$$GET1^DIQ(200,DUZ,2)
- S DGTL=$$GET1^DIQ(42,BDGWD,.01)_" WARD",DGLIN=$$REPEAT^XLFSTR("=",80)
- ;
- W:DGPAGE>0 @IOF S DGPAGE=DGPAGE+1
- W !,DGDUZ,?80-$L(DGSITE)/2,DGSITE ;user initials & site
- W !,$$TIME^BDGF($$NOW^XLFDT) W ?28,"ADT WARD CENSUS DATA FOR"
- W !,$$FMTE^XLFDT(DT),?80-$L(DGTL)/2,DGTL,?70,"Page: ",DGPAGE
- W !,DGLIN
- W !,"Date",?10,"Admits",?19,"Trans In",?29,"Trans Out"
- W ?40,"Disch",?49,"Deaths",?57,"Remaining",?69,"Unit Score"
- W !,DGLIN,!
- Q
- ;
- ;
- BENCHMRK() ;bed control movements divided by # remaining
- NEW X,I,Y
- F I=3,4,5,6,7 S X=$G(X)+$P(DGSTR,U,I)
- S Y=$P(DGSTR,U,2) I +Y=0 S Y=1
- Q $G(X)/Y*100
- BDGCEN0 ; IHS/ANMC/LJF - CENSUS AID-BY WARD CONT ;
- +1 ;;5.3;PIMS;;APR 26, 2002
- +2 ;
- +3 NEW DGTOT,DGCNT,DGDT,DGSTR
- +4 SET (DGTOT,DGCNT)=0
- +5 ;
- +6 ; -- loop thru adt census-ward file by date
- +7 SET DGDT=BDGBD-.0001
- +8 FOR
- SET DGDT=$ORDER(^BDGCWD(BDGWD,1,DGDT))
- IF 'DGDT
- QUIT
- IF (DGDT>BDGED)
- QUIT
- Begin DoDot:1
- +9 ;
- +10 IF '$DATA(^BDGCWD(BDGWD,1,DGDT,0))
- Begin DoDot:2
- +11 WRITE !!,"NO CENSUS DATA FOR THIS WARD FOR ",$$FMTE^XLFDT(DGDT,2),!!
- End DoDot:2
- QUIT
- +12 ;
- +13 SET DGSTR=^BDGCWD(BDGWD,1,DGDT,0)
- +14 ;date
- WRITE !,$EXTRACT(DGDT,4,5)_"/"_$EXTRACT(DGDT,6,7)_"/"_$EXTRACT(DGDT,2,3)
- +15 ;admits
- WRITE ?12,$PIECE(DGSTR,U,3)
- +16 ;trans in
- WRITE ?22,$PIECE(DGSTR,U,5)
- +17 ;trans out
- WRITE ?32,$PIECE(DGSTR,U,6)
- +18 ;disch
- WRITE ?42,$PIECE(DGSTR,U,4)
- +19 ;deaths
- WRITE ?51,$PIECE(DGSTR,U,7)
- +20 ;# remaining
- WRITE ?61,$PIECE(DGSTR,U,2)
- +21 WRITE ?71,$JUSTIFY($$BENCHMRK,3,0)
- +22 SET DGCNT=DGCNT+1
- SET DGTOT=DGTOT+$$BENCHMRK
- End DoDot:1
- +23 ;
- +24 WRITE !?60,"Average:",?71,$JUSTIFY($SELECT(DGTOT=0:0,1:DGTOT/DGCNT),3,0)
- +25 QUIT
- +26 ;
- HEAD ;EP; -- subrtn to print heading
- +1 ; DGPAGE set by calling routine
- +2 NEW DGSITE,DGDUZ,DGTL,DGLIN
- +3 SET DGSITE=$$GET1^DIQ(4,DUZ(2),.01)
- SET DGDUZ=$$GET1^DIQ(200,DUZ,2)
- +4 SET DGTL=$$GET1^DIQ(42,BDGWD,.01)_" WARD"
- SET DGLIN=$$REPEAT^XLFSTR("=",80)
- +5 ;
- +6 IF DGPAGE>0
- WRITE @IOF
- SET DGPAGE=DGPAGE+1
- +7 ;user initials & site
- WRITE !,DGDUZ,?80-$LENGTH(DGSITE)/2,DGSITE
- +8 WRITE !,$$TIME^BDGF($$NOW^XLFDT)
- WRITE ?28,"ADT WARD CENSUS DATA FOR"
- +9 WRITE !,$$FMTE^XLFDT(DT),?80-$LENGTH(DGTL)/2,DGTL,?70,"Page: ",DGPAGE
- +10 WRITE !,DGLIN
- +11 WRITE !,"Date",?10,"Admits",?19,"Trans In",?29,"Trans Out"
- +12 WRITE ?40,"Disch",?49,"Deaths",?57,"Remaining",?69,"Unit Score"
- +13 WRITE !,DGLIN,!
- +14 QUIT
- +15 ;
- +16 ;
- BENCHMRK() ;bed control movements divided by # remaining
- +1 NEW X,I,Y
- +2 FOR I=3,4,5,6,7
- SET X=$GET(X)+$PIECE(DGSTR,U,I)
- +3 SET Y=$PIECE(DGSTR,U,2)
- IF +Y=0
- SET Y=1
- +4 QUIT $GET(X)/Y*100
