BDGCEN10.m

BDGCEN10 ; IHS/ANMC/LJF - CENSUS AID-LIST BY WARD&SRV ;  [ 08/20/2004  11:41 AM ]

 ;;5.3;PIMS;**1001**;APR 26, 2002

 ;

 NEW DGDT,DGSTR,ADJ

 ;

 ; adjustment for piece in node (peds items are 10 pieces higher)

 S ADJ=$S(BDGAGE="A":0,1:10)

 ;

 ; -- loop thru census files by ward & service

 S DGDT=BDGBD-.0001

 F  S DGDT=$O(^BDGCWD(BDGWD,1,DGDT)) Q:'DGDT  Q:(DGDT>BDGED)  D

 . ;

 . I '$D(^BDGCWD(BDGWD,1,DGDT,1,BDGTX,0)) D  Q

 .. W !!,"NO CENSUS DATA FOR THIS SERVICE FOR ",$$FMTE^XLFDT(DGDT),!!

 . ;

 . S DGSTR=^BDGCWD(BDGWD,1,DGDT,1,BDGTX,0)

 . W !,$E(DGDT,4,5)_"/"_$E(DGDT,6,7)_"/"_$E(DGDT,2,3)

 . W ?17,$P(DGSTR,U,3+ADJ),?27,$P(DGSTR,U,5+ADJ)

 . W ?37,$P(DGSTR,U,6+ADJ),?48,$P(DGSTR,U,4+ADJ)

 . W ?58,$P(DGSTR,U,7+ADJ),?69,$P(DGSTR,U,2+ADJ)

 Q

 ;

 ;

HEAD ;EP; -- subrtn to print heading

 ; DGPAGE is set in calling routine

 NEW SITE,WARD,SERV,TITLE,X,LINE

 S SITE=$$GET1^DIQ(4,DUZ(2),.01),LINE=$$REPEAT^XLFSTR("=",80)

 S WARD=$$GET1^DIQ(42,BDGWD,.01),SERV=$$GET1^DIQ(45.7,BDGTX,.01)

 S TITLE=SERV_" SERVICE IN WARD "_WARD

 ;

 W:DGPAGE>0 @IOF S DGPAGE=DGPAGE+1

 W !,$$GET1^DIQ(200,DUZ,2),?80-$L(SITE)/2,SITE    ;user initials & site

 W !,$$TIME^BDGF($$NOW^XLFDT)

 ;S X="ADT "_$S(BDGAGE="A":"ADULT",1:"PEDIATRIC")_" CENSUS DATA FOR"

 S X="ADT "_$S('$D(BDGAGE):"",BDGAGE="A":"ADULT",1:"PEDIATRIC")_" CENSUS DATA FOR"  ;IHS/ITSC/LJF 7/8/2004 PATCH #1001

 W ?80-$L(X)/2,X

 W !,$$FMTE^XLFDT(DT),?80-$L(TITLE)/2,TITLE,?70,"Page: ",DGPAGE

 W !,LINE,!,"Date",?15,"Admits",?25,"Trans In",?35,"Trans Out"

 W ?46,"Disch",?55,"Deaths",?65,"Remaining",!,LINE,!

 Q

BDGCEN10  ; IHS/ANMC/LJF - CENSUS AID-LIST BY WARD&SRV ;  [ 08/20/2004  11:41 AM ]

 +1       ;;5.3;PIMS;**1001**;APR 26, 2002

 +2       ;

 +3        NEW DGDT,DGSTR,ADJ

 +4       ;

 +5       ; adjustment for piece in node (peds items are 10 pieces higher)

 +6        SET ADJ=$SELECT(BDGAGE="A":0,1:10)

 +7       ;

 +8       ; -- loop thru census files by ward & service

 +9        SET DGDT=BDGBD-.0001

 +10       FOR 

               SET DGDT=$ORDER(^BDGCWD(BDGWD,1,DGDT))

               IF 'DGDT

                   QUIT 

               IF (DGDT>BDGED)

                   QUIT 

               Begin DoDot:1

 +11      ;

 +12               IF '$DATA(^BDGCWD(BDGWD,1,DGDT,1,BDGTX,0))

                       Begin DoDot:2

 +13                       WRITE !!,"NO CENSUS DATA FOR THIS SERVICE FOR ",$$FMTE^XLFDT(DGDT),!!

                       End DoDot:2

                       QUIT 

 +14      ;

 +15               SET DGSTR=^BDGCWD(BDGWD,1,DGDT,1,BDGTX,0)

 +16               WRITE !,$EXTRACT(DGDT,4,5)_"/"_$EXTRACT(DGDT,6,7)_"/"_$EXTRACT(DGDT,2,3)

 +17               WRITE ?17,$PIECE(DGSTR,U,3+ADJ),?27,$PIECE(DGSTR,U,5+ADJ)

 +18               WRITE ?37,$PIECE(DGSTR,U,6+ADJ),?48,$PIECE(DGSTR,U,4+ADJ)

 +19               WRITE ?58,$PIECE(DGSTR,U,7+ADJ),?69,$PIECE(DGSTR,U,2+ADJ)

               End DoDot:1

 +20       QUIT 

 +21      ;

 +22      ;

HEAD      ;EP; -- subrtn to print heading

 +1       ; DGPAGE is set in calling routine

 +2        NEW SITE,WARD,SERV,TITLE,X,LINE

 +3        SET SITE=$$GET1^DIQ(4,DUZ(2),.01)

           SET LINE=$$REPEAT^XLFSTR("=",80)

 +4        SET WARD=$$GET1^DIQ(42,BDGWD,.01)

           SET SERV=$$GET1^DIQ(45.7,BDGTX,.01)

 +5        SET TITLE=SERV_" SERVICE IN WARD "_WARD

 +6       ;

 +7        IF DGPAGE>0

               WRITE @IOF

           SET DGPAGE=DGPAGE+1

 +8       ;user initials & site

           WRITE !,$$GET1^DIQ(200,DUZ,2),?80-$LENGTH(SITE)/2,SITE

 +9        WRITE !,$$TIME^BDGF($$NOW^XLFDT)

 +10      ;S X="ADT "_$S(BDGAGE="A":"ADULT",1:"PEDIATRIC")_" CENSUS DATA FOR"

 +11      ;IHS/ITSC/LJF 7/8/2004 PATCH #1001

           SET X="ADT "_$SELECT('$DATA(BDGAGE):"",BDGAGE="A":"ADULT",1:"PEDIATRIC")_" CENSUS DATA FOR"

 +12       WRITE ?80-$LENGTH(X)/2,X

 +13       WRITE !,$$FMTE^XLFDT(DT),?80-$LENGTH(TITLE)/2,TITLE,?70,"Page: ",DGPAGE

 +14       WRITE !,LINE,!,"Date",?15,"Admits",?25,"Trans In",?35,"Trans Out"

 +15       WRITE ?46,"Disch",?55,"Deaths",?65,"Remaining",!,LINE,!

 +16       QUIT