ADGCEN20 ; IHS/ADC/PDW/ENM - CENSUS AID-LIST BY TX (PRINT) ; [ 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(45.7,DGSRV,0),U)_" SERVICE"
S DGTYP=$S(DGAGE=0:"ADULT",1:"PEDIATRIC")
;
;***> loop thru census file by service and print data
D HEAD S DGDT=DGBDT-.0001
A1 S DGDT=$O(^ADGTX(DGSRV,1,DGDT)) G END:DGDT="",END:DGDT>DGEDT
;
I '$D(^ADGTX(DGSRV,1,DGDT,DGAGE)) D G END
.W !!,"NO CENSUS DATA FOR THIS SERVICE FOR "
.W $E(DGDT,4,5)_"/"_$E(DGDT,6,7)_"/"_$E(DGDT,2,3),!! Q
;
S DGSTR=^ADGTX(DGSRV,1,DGDT,DGAGE)
W !,$E(DGDT,4,5)_"/"_$E(DGDT,6,7)_"/"_$E(DGDT,2,3)
W ?17,$P(DGSTR,U,3-DGAGE),?27,$P(DGSTR,U,5-DGAGE)
W ?37,$P(DGSTR,U,6-DGAGE),?48,$P(DGSTR,U,4-DGAGE)
W ?58,$P(DGSTR,U,7-DGAGE),?69,$P(DGSTR,U,2-DGAGE)
I $Y>(IOSL-6) D NEWPG G END1:DGSTOP=U
G A1
;
END I IOST["C-" K DIR S DIR(0)="E" D ^DIR
END1 I $D(ZTQUEUED) Q
K DGBDT,DGEDT,DGDT,DGSRV,DGAGE,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 S DGX="ADT "_DGTYP_" CENSUS DATA FOR" W ?80-$L(DGX)/2,DGX
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
ADGCEN20 ; IHS/ADC/PDW/ENM - CENSUS AID-LIST BY TX (PRINT) ; [ 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(45.7,DGSRV,0),U)_" SERVICE"
+6 SET DGTYP=$SELECT(DGAGE=0:"ADULT",1:"PEDIATRIC")
+7 ;
+8 ;***> loop thru census file by service and print data
+9 DO HEAD
SET DGDT=DGBDT-.0001
A1 SET DGDT=$ORDER(^ADGTX(DGSRV,1,DGDT))
IF DGDT=""
GOTO END
IF DGDT>DGEDT
GOTO END
+1 ;
+2 IF '$DATA(^ADGTX(DGSRV,1,DGDT,DGAGE))
Begin DoDot:1
+3 WRITE !!,"NO CENSUS DATA FOR THIS SERVICE 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=^ADGTX(DGSRV,1,DGDT,DGAGE)
+7 WRITE !,$EXTRACT(DGDT,4,5)_"/"_$EXTRACT(DGDT,6,7)_"/"_$EXTRACT(DGDT,2,3)
+8 WRITE ?17,$PIECE(DGSTR,U,3-DGAGE),?27,$PIECE(DGSTR,U,5-DGAGE)
+9 WRITE ?37,$PIECE(DGSTR,U,6-DGAGE),?48,$PIECE(DGSTR,U,4-DGAGE)
+10 WRITE ?58,$PIECE(DGSTR,U,7-DGAGE),?69,$PIECE(DGSTR,U,2-DGAGE)
+11 IF $Y>(IOSL-6)
DO NEWPG
IF DGSTOP=U
GOTO END1
+12 GOTO A1
+13 ;
END IF IOST["C-"
KILL DIR
SET DIR(0)="E"
DO ^DIR
END1 IF $DATA(ZTQUEUED)
QUIT
+1 KILL DGBDT,DGEDT,DGDT,DGSRV,DGAGE,DGPAGE,DGSITE,DGLIN,DGX
+2 KILL DGDUZ,DGTL,DGSTR,DGSTOP,DGTYP,X,Y,DIR
+3 DO ^%ZISC
QUIT
+4 ;
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
SET DGX="ADT "_DGTYP_" CENSUS DATA FOR"
WRITE ?80-$LENGTH(DGX)/2,DGX
+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
