Routine: ADGADSP3

ADGADSP3 ; IHS/ADC/PDW/ENM - A & D SHEET PRINT (SUMMARY) ; [ 03/25/1999  11:48 AM ]

 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999

 ;***> Summary version of ADMISSIONS & DISCHARGES SHEET

 ;***> initialize variables

 S X1=DGDATE,X2=-1 D C^%DTC S DGOLD=X  ;get prev date

 S DGZ=0 F I=1:1:7 S DGCT(I)=0  ;initialize counts

 S DGPAGE=0,DGSTOP="" D HEAD

 S DGLIN="",$P(DGLIN,"-",37)=""

 ;***> loop thru adt census-treating specialty file for census figures

A1 S DGZ=$O(^ADGTX(DGZ)) G A3:DGZ'?1N.N G:'$$AS A1

 W !,$P(^DIC(45.7,DGZ,0),U) ;print service name

 I '$D(^ADGTX(DGZ,1,DGOLD,0))!'$D(^(1)) G A1 ;skip if no data for prev

 S DGX=$P(^ADGTX(DGZ,1,DGOLD,0),U,2)+$P(^(1),U)

 S DGCT(1)=DGCT(1)+DGX W ?20,DGX ;old count

 I '$D(^ADGTX(DGZ,1,DGDATE,0))!'$D(^(1)) G A1 ;skip if no data for date

 S DGSTR=^ADGTX(DGZ,1,DGDATE,0),DGPSTR=^(1)  ;set adult & peds var

 S DGX=($P(DGSTR,U,3)+$P(DGPSTR,U,2)),DGCT(2)=DGCT(2)+DGX W ?30,DGX

 S DGX=($P(DGSTR,U,5)+$P(DGPSTR,U,4)),DGCT(3)=DGCT(3)+DGX W ?38,DGX

 S DGX=($P(DGSTR,U,7)+$P(DGPSTR,U,6)),DGCT(4)=DGCT(4)+DGX W ?47,DGX

 S DGX=($P(DGSTR,U,4)+$P(DGPSTR,U,3)),DGCT(5)=DGCT(5)+DGX W ?54,DGX

 S DGX=($P(DGSTR,U,6)+$P(DGPSTR,U,5)),DGCT(6)=DGCT(6)+DGX W ?61,DGX

 S DGX=($P(DGSTR,U,2)+$P(DGPSTR,U)),DGCT(7)=DGCT(7)+DGX W ?71,DGX

 I $Y>(IOSL-5) D NEWPG G END1:DGSTOP=U

 G A1

 ;***> print census totals

A3 W !?17,"----------------------------------------------------------"

 W !?5,"TOTALS:",?18,$J(DGCT(1),3),?28,$J(DGCT(2),3),?36,$J(DGCT(3),3)

 W ?45,$J(DGCT(4),3),?51,$J(DGCT(5),3),?59,$J(DGCT(6),3)

 W ?69,$J(DGCT(7),3)

NEXT G ^ADGADSP4  ;prints individual patient data

END I IOST["C-" K DIR S DIR("A")="Press RETURN to continue",DIR(0)="E" D ^DIR

END1 ;EP;***> ending point for summary A&D Sheets

 W @IOF D KILL^ADGUTIL

 D ^%ZISC K ^TMP("DGZADS",$J)

NEWPG ;EP;***> end of page control

 I IOST["C-" K DIR S DIR(0)="E" D ^DIR S DGSTOP=X Q:X=U

 W @IOF

 W !?11,"*****Confidential Patient Data Covered by Privacy Act*****",!

HEAD ;***> print heading

 S DGY=^AUTTLOC(DUZ(2),0),DGFAC=$P(^DIC(4,DUZ(2),0),U)

 I (IOST["C-")!(DGPAGE>0) W @IOF

 W ?11,"*****Confidential Patient Data Covered by Privacy Act*****"

 W !?(80-$L(DGFAC)/2),DGFAC  ;facility name

 S DGCITY=$P(DGY,U,13),DGSTAT=$P(DGY,U,14),DGSTAT=$P(^DIC(5,DGSTAT,0),U)

 W !?(80-$L(DGCITY_DGSTAT)/2),DGCITY_","_DGSTAT  ;city and state

 W !!!,"DAILY CENSUS REPORT"

 S X=DGDATE D DW^%DTC W !,X  ;print day of the week

 W ?10,$E(DGDATE,4,5)_"-"_$E(DGDATE,6,7)_"-"_$E(DGDATE,2,3),! ;date

 S DGLIN="",$P(DGLIN,"-",80)="" W DGLIN

 W !!!,"SERVICE",?17,"REMAINING",?28,"ADMITS",?35,"TRANSFERS"

 W ?45,"DEATHS",?52,"OTHER",?58,"TRANSFERS",?68,"REMAINING"

 W !,"Responsible",?17,"from the",?38,"IN",?53,"DIS-",?61,"OUT",?72,"At"

 W !,"for Patient",?17,"Preceding",?51,"CHARGES",?69,"11:59 pm"

 W !?20,"Day",!!

 W DGLIN,!! Q

AS() ;--admitting service (yes=1,no=0)

 Q $S($P($G(^DIC(45.7,+DGZ,9999999)),U,3)="Y":1,1:0)

ADGADSP3  ; IHS/ADC/PDW/ENM - A & D SHEET PRINT (SUMMARY) ; [ 03/25/1999  11:48 AM ]

 +1       ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999

 +2       ;

 +3       ;***> Summary version of ADMISSIONS & DISCHARGES SHEET

 +4       ;

 +5       ;***> initialize variables

 +6       ;get prev date

           SET X1=DGDATE

           SET X2=-1

           DO C^%DTC

           SET DGOLD=X

 +7       ;initialize counts

           SET DGZ=0

           FOR I=1:1:7

               SET DGCT(I)=0

 +8        SET DGPAGE=0

           SET DGSTOP=""

           DO HEAD

 +9        SET DGLIN=""

           SET $PIECE(DGLIN,"-",37)=""

 +10      ;

 +11      ;***> loop thru adt census-treating specialty file for census figures

A1         SET DGZ=$ORDER(^ADGTX(DGZ))

           IF DGZ'?1N.N

               GOTO A3

           IF '$$AS

               GOTO A1

 +1       ;print service name

           WRITE !,$PIECE(^DIC(45.7,DGZ,0),U)

 +2       ;skip if no data for prev

           IF '$DATA(^ADGTX(DGZ,1,DGOLD,0))!'$DATA(^(1))

               GOTO A1

 +3        SET DGX=$PIECE(^ADGTX(DGZ,1,DGOLD,0),U,2)+$PIECE(^(1),U)

 +4       ;old count

           SET DGCT(1)=DGCT(1)+DGX

           WRITE ?20,DGX

 +5       ;skip if no data for date

           IF '$DATA(^ADGTX(DGZ,1,DGDATE,0))!'$DATA(^(1))

               GOTO A1

 +6       ;set adult & peds var

           SET DGSTR=^ADGTX(DGZ,1,DGDATE,0)

           SET DGPSTR=^(1)

 +7        SET DGX=($PIECE(DGSTR,U,3)+$PIECE(DGPSTR,U,2))

           SET DGCT(2)=DGCT(2)+DGX

           WRITE ?30,DGX

 +8        SET DGX=($PIECE(DGSTR,U,5)+$PIECE(DGPSTR,U,4))

           SET DGCT(3)=DGCT(3)+DGX

           WRITE ?38,DGX

 +9        SET DGX=($PIECE(DGSTR,U,7)+$PIECE(DGPSTR,U,6))

           SET DGCT(4)=DGCT(4)+DGX

           WRITE ?47,DGX

 +10       SET DGX=($PIECE(DGSTR,U,4)+$PIECE(DGPSTR,U,3))

           SET DGCT(5)=DGCT(5)+DGX

           WRITE ?54,DGX

 +11       SET DGX=($PIECE(DGSTR,U,6)+$PIECE(DGPSTR,U,5))

           SET DGCT(6)=DGCT(6)+DGX

           WRITE ?61,DGX

 +12       SET DGX=($PIECE(DGSTR,U,2)+$PIECE(DGPSTR,U))

           SET DGCT(7)=DGCT(7)+DGX

           WRITE ?71,DGX

 +13       IF $Y>(IOSL-5)

               DO NEWPG

               IF DGSTOP=U

                   GOTO END1

 +14       GOTO A1

 +15      ;

 +16      ;***> print census totals

A3         WRITE !?17,"----------------------------------------------------------"

 +1        WRITE !?5,"TOTALS:",?18,$JUSTIFY(DGCT(1),3),?28,$JUSTIFY(DGCT(2),3),?36,$JUSTIFY(DGCT(3),3)

 +2        WRITE ?45,$JUSTIFY(DGCT(4),3),?51,$JUSTIFY(DGCT(5),3),?59,$JUSTIFY(DGCT(6),3)

 +3        WRITE ?69,$JUSTIFY(DGCT(7),3)

 +4       ;

NEXT      ;prints individual patient data

           GOTO ^ADGADSP4

 +1       ;

END        IF IOST["C-"

               KILL DIR

               SET DIR("A")="Press RETURN to continue"

               SET DIR(0)="E"

               DO ^DIR

END1      ;EP;***> ending point for summary A&D Sheets

 +1        WRITE @IOF

           DO KILL^ADGUTIL

 +2        DO ^%ZISC

           KILL ^TMP("DGZADS",$JOB)

 +3        QUIT

 +4       ;

 +5       ;

NEWPG     ;EP;***> end of page control

 +1        IF IOST["C-"

               KILL DIR

               SET DIR(0)="E"

               DO ^DIR

               SET DGSTOP=X

               IF X=U

                   QUIT

 +2        WRITE @IOF

 +3        WRITE !?11,"*****Confidential Patient Data Covered by Privacy Act*****",!

 +4        QUIT

 +5       ;

HEAD      ;***> print heading

 +1        SET DGY=^AUTTLOC(DUZ(2),0)

           SET DGFAC=$PIECE(^DIC(4,DUZ(2),0),U)

 +2        IF (IOST["C-")!(DGPAGE>0)

               WRITE @IOF

 +3        WRITE ?11,"*****Confidential Patient Data Covered by Privacy Act*****"

 +4       ;facility name

           WRITE !?(80-$LENGTH(DGFAC)/2),DGFAC

 +5        SET DGCITY=$PIECE(DGY,U,13)

           SET DGSTAT=$PIECE(DGY,U,14)

           SET DGSTAT=$PIECE(^DIC(5,DGSTAT,0),U)

 +6       ;city and state

           WRITE !?(80-$LENGTH(DGCITY_DGSTAT)/2),DGCITY_","_DGSTAT

 +7        WRITE !!!,"DAILY CENSUS REPORT"

 +8       ;print day of the week

           SET X=DGDATE

           DO DW^%DTC

           WRITE !,X

 +9       ;date

           WRITE ?10,$EXTRACT(DGDATE,4,5)_"-"_$EXTRACT(DGDATE,6,7)_"-"_$EXTRACT(DGDATE,2,3),!

 +10       SET DGLIN=""

           SET $PIECE(DGLIN,"-",80)=""

           WRITE DGLIN

 +11       WRITE !!!,"SERVICE",?17,"REMAINING",?28,"ADMITS",?35,"TRANSFERS"

 +12       WRITE ?45,"DEATHS",?52,"OTHER",?58,"TRANSFERS",?68,"REMAINING"

 +13       WRITE !,"Responsible",?17,"from the",?38,"IN",?53,"DIS-",?61,"OUT",?72,"At"

 +14       WRITE !,"for Patient",?17,"Preceding",?51,"CHARGES",?69,"11:59 pm"

 +15       WRITE !?20,"Day",!!

 +16       WRITE DGLIN,!!

           QUIT

 +17      ;

AS()      ;--admitting service (yes=1,no=0)

 +1        QUIT $SELECT($PIECE($GET(^DIC(45.7,+DGZ,9999999)),U,3)="Y":1,1:0)

ADGADSP3.m