ADGCEN0 ; IHS/ADC/PDW/ENM - CENSUS AID-LIST BY WARD ; [ 03/25/1999 11:48 AM ]
;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
;
;***> initialize variables
S DGPAGE=0,DGSITE=$P(^DIC(4,DUZ(2),0),U),DGDUZ=$P(^VA(200,DUZ,0),U,2)
S DGTL=$P(^DIC(42,DGWD,0),U)_" WARD"
D HEAD
;
;***> loop thru adt census-ward file by date
S DGDT=DGBDT-.0001
DT1 S DGDT=$O(^ADGWD(DGWD,1,DGDT)) G END:DGDT="",END:DGDT>DGEDT
;
I '$D(^ADGWD(DGWD,1,DGDT,0)) D G END
.W !!,"NO CENSUS DATA FOR THIS WARD FOR "
.W $E(DGDT,4,5)_"/"_$E(DGDT,6,7)_"/"_$E(DGDT,2,3),!! Q
;
S DGSTR=^ADGWD(DGWD,1,DGDT,0)
W !,$E(DGDT,4,5)_"/"_$E(DGDT,6,7)_"/"_$E(DGDT,2,3) ;date
;W ?17,$P(DGSTR,U,3),?27,$P(DGSTR,U,5) ;admits & transfers in
;W ?37,$P(DGSTR,U,6),?48,$P(DGSTR,U,4) ;transfers out & discharges
;W ?58,$P(DGSTR,U,7),?69,$P(DGSTR,U,2) ;deaths and # remaining
W ?17,$P(DGSTR,U,3)+$P(DGSTR,U,13),?27,$P(DGSTR,U,5)+$P(DGSTR,U,15)
W ?37,$P(DGSTR,U,6)+$P(DGSTR,U,16),?48,$P(DGSTR,U,4)+$P(DGSTR,U,14)
W ?58,$P(DGSTR,U,7)+$P(DGSTR,U,17),?69,$P(DGSTR,U,2)+$P(DGSTR,U,12)
I $Y>(IOSL-6) D NEWPG G END1:DGSTOP=U
G DT1
;
END I IOST["C-" K DIR S DIR(0)="E" D ^DIR
END1 W @IOF K DGBDT,DGEDT,DGDT,DGWD,DGPAGE,DGSITE,DGLIN,DGX
K DGDUZ,DGTL,DGSTR,DGSTOP,DGTYP,X,Y,DIR D ^%ZISC Q
;
NEWPG ;***> subrtn for end of page control
I IOST'?1"C-".E D HEAD S DGSTOP="" Q
K DIR S DIR(0)="E" D ^DIR S DGSTOP=X
I DGSTOP'=U D HEAD
Q
;
HEAD ;***> subrtn to print heading
I (IOST["C-")!(DGPAGE>0) W @IOF
S DGPAGE=DGPAGE+1 W !,DGDUZ,?80-$L(DGSITE)/2,DGSITE
W ! D TIME^ADGUTIL W ?28,"ADT WARD CENSUS DATA FOR"
S Y=DT X ^DD("DD") W !,Y
W ?80-$L(DGTL)/2,DGTL,?70,"Page: ",DGPAGE
S DGLIN="",$P(DGLIN,"=",80)="" W !,DGLIN
W !,"Date",?15,"Admits",?25,"Trans In",?35,"Trans Out"
W ?46,"Disch",?55,"Deaths",?65,"Remaining"
S DGLIN="",$P(DGLIN,"-",80)="" W !,DGLIN,!
Q
ADGCEN0 ; IHS/ADC/PDW/ENM - CENSUS AID-LIST BY WARD ; [ 03/25/1999 11:48 AM ]
+1 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999
+2 ;
+3 ;***> initialize variables
+4 SET DGPAGE=0
SET DGSITE=$PIECE(^DIC(4,DUZ(2),0),U)
SET DGDUZ=$PIECE(^VA(200,DUZ,0),U,2)
+5 SET DGTL=$PIECE(^DIC(42,DGWD,0),U)_" WARD"
+6 DO HEAD
+7 ;
+8 ;***> loop thru adt census-ward file by date
+9 SET DGDT=DGBDT-.0001
DT1 SET DGDT=$ORDER(^ADGWD(DGWD,1,DGDT))
IF DGDT=""
GOTO END
IF DGDT>DGEDT
GOTO END
+1 ;
+2 IF '$DATA(^ADGWD(DGWD,1,DGDT,0))
Begin DoDot:1
+3 WRITE !!,"NO CENSUS DATA FOR THIS WARD FOR "
+4 WRITE $EXTRACT(DGDT,4,5)_"/"_$EXTRACT(DGDT,6,7)_"/"_$EXTRACT(DGDT,2,3),!!
QUIT
End DoDot:1
GOTO END
+5 ;
+6 SET DGSTR=^ADGWD(DGWD,1,DGDT,0)
+7 ;date
WRITE !,$EXTRACT(DGDT,4,5)_"/"_$EXTRACT(DGDT,6,7)_"/"_$EXTRACT(DGDT,2,3)
+8 ;W ?17,$P(DGSTR,U,3),?27,$P(DGSTR,U,5) ;admits & transfers in
+9 ;W ?37,$P(DGSTR,U,6),?48,$P(DGSTR,U,4) ;transfers out & discharges
+10 ;W ?58,$P(DGSTR,U,7),?69,$P(DGSTR,U,2) ;deaths and # remaining
+11 WRITE ?17,$PIECE(DGSTR,U,3)+$PIECE(DGSTR,U,13),?27,$PIECE(DGSTR,U,5)+$PIECE(DGSTR,U,15)
+12 WRITE ?37,$PIECE(DGSTR,U,6)+$PIECE(DGSTR,U,16),?48,$PIECE(DGSTR,U,4)+$PIECE(DGSTR,U,14)
+13 WRITE ?58,$PIECE(DGSTR,U,7)+$PIECE(DGSTR,U,17),?69,$PIECE(DGSTR,U,2)+$PIECE(DGSTR,U,12)
+14 IF $Y>(IOSL-6)
DO NEWPG
IF DGSTOP=U
GOTO END1
+15 GOTO DT1
+16 ;
END IF IOST["C-"
KILL DIR
SET DIR(0)="E"
DO ^DIR
END1 WRITE @IOF
KILL DGBDT,DGEDT,DGDT,DGWD,DGPAGE,DGSITE,DGLIN,DGX
+1 KILL DGDUZ,DGTL,DGSTR,DGSTOP,DGTYP,X,Y,DIR
DO ^%ZISC
QUIT
+2 ;
NEWPG ;***> subrtn for end of page control
+1 IF IOST'?1"C-".E
DO HEAD
SET DGSTOP=""
QUIT
+2 KILL DIR
SET DIR(0)="E"
DO ^DIR
SET DGSTOP=X
+3 IF DGSTOP'=U
DO HEAD
+4 QUIT
+5 ;
HEAD ;***> subrtn to print heading
+1 IF (IOST["C-")!(DGPAGE>0)
WRITE @IOF
+2 SET DGPAGE=DGPAGE+1
WRITE !,DGDUZ,?80-$LENGTH(DGSITE)/2,DGSITE
+3 WRITE !
DO TIME^ADGUTIL
WRITE ?28,"ADT WARD CENSUS DATA FOR"
+4 SET Y=DT
XECUTE ^DD("DD")
WRITE !,Y
+5 WRITE ?80-$LENGTH(DGTL)/2,DGTL,?70,"Page: ",DGPAGE
+6 SET DGLIN=""
SET $PIECE(DGLIN,"=",80)=""
WRITE !,DGLIN
+7 WRITE !,"Date",?15,"Admits",?25,"Trans In",?35,"Trans Out"
+8 WRITE ?46,"Disch",?55,"Deaths",?65,"Remaining"
+9 SET DGLIN=""
SET $PIECE(DGLIN,"-",80)=""
WRITE !,DGLIN,!
+10 QUIT
