- 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
