ADGCEN3.m

ADGCEN3 ; IHS/ADC/PDW/ENM - CENSUS AID-PATIENT LISTS ; [ 03/25/1999  11:48 AM ]

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

 ;

 ;This rtn lists patient admissions, transfers, and discharges

 ;for the day specified to check against manual lists

 ;

 W @IOF W !!?30,"WARD CENSUS LISTING",!!

WARD ;select all wards or just one

 K DIR S DIR("A")="Print ALL Wards",DIR(0)="YO",DIR("B")="NO"

 D ^DIR G END:$D(DIRUT)

 I Y=1 S DGWD="A" G BDATE  ;yes-all wards

 ;if no-which ward

WD1 K DIR S DIR(0)="PO^42:EQMZ" D ^DIR G WARD:$D(DIRUT),WD1:Y=-1

 I $D(^DIC(42,+Y,"I")),$P(^("I"),U)="I" W *7,?40,"** INACTIVE WARD **" G WARD

 S DGWD=+Y

 ;

BDATE D NOW^%DTC S DGNOW=%

 S %DT="AEQRP",%DT("A")="Select beginning date and time: ",X="" D ^%DT

 G END:Y=-1 S DGBDT=Y

 I DGBDT>DGNOW W !!?10,"Date/Time CANNOT be in the future!",!! G BDATE

EDATE S %DT="AEQRP",%DT("A")="Select ending date and time: ",X="" D ^%DT

 G END:Y=-1 S DGEDT=Y

 I DGEDT'>DGBDT W !!?10,"Ending date/time must be AFTER beginning date/time!",!! G BDATE

 I DGEDT>DGNOW W !!?10,"Date/Time CANNOT be in the future!",!! G EDATE

 ;

 S %ZIS="Q" D ^%ZIS G END:POP,QUE:$D(IO("Q")) U IO G ^ADGCEN30

QUE K IO("Q") S ZTRTN="^ADGCEN30",ZTDESC="CENSUS AID 3"

 F DGI="DGBDT","DGEDT","DGWD" S ZTSAVE(DGI)=""

 D ^%ZTLOAD D ^%ZISC K ZTSK

END K Y,DGBDT,DGEDT,DGWD,DGNOW,DIR,DGI D HOME^%ZIS Q

ADGCEN3   ; IHS/ADC/PDW/ENM - CENSUS AID-PATIENT LISTS ; [ 03/25/1999  11:48 AM ]

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

 +2       ;

 +3       ;This rtn lists patient admissions, transfers, and discharges

 +4       ;for the day specified to check against manual lists

 +5       ;

 +6        WRITE @IOF

           WRITE !!?30,"WARD CENSUS LISTING",!!

WARD      ;select all wards or just one

 +1        KILL DIR

           SET DIR("A")="Print ALL Wards"

           SET DIR(0)="YO"

           SET DIR("B")="NO"

 +2        DO ^DIR

           IF $DATA(DIRUT)

               GOTO END

 +3       ;yes-all wards

           IF Y=1

               SET DGWD="A"

               GOTO BDATE

 +4       ;if no-which ward

WD1        KILL DIR

           SET DIR(0)="PO^42:EQMZ"

           DO ^DIR

           IF $DATA(DIRUT)

               GOTO WARD

           IF Y=-1

               GOTO WD1

 +1        IF $DATA(^DIC(42,+Y,"I"))

               IF $PIECE(^("I"),U)="I"

                   WRITE *7,?40,"** INACTIVE WARD **"

                   GOTO WARD

 +2        SET DGWD=+Y

 +3       ;

BDATE      DO NOW^%DTC

           SET DGNOW=%

 +1        SET %DT="AEQRP"

           SET %DT("A")="Select beginning date and time: "

           SET X=""

           DO ^%DT

 +2        IF Y=-1

               GOTO END

           SET DGBDT=Y

 +3        IF DGBDT>DGNOW

               WRITE !!?10,"Date/Time CANNOT be in the future!",!!

               GOTO BDATE

EDATE      SET %DT="AEQRP"

           SET %DT("A")="Select ending date and time: "

           SET X=""

           DO ^%DT

 +1        IF Y=-1

               GOTO END

           SET DGEDT=Y

 +2        IF DGEDT'>DGBDT

               WRITE !!?10,"Ending date/time must be AFTER beginning date/time!",!!

               GOTO BDATE

 +3        IF DGEDT>DGNOW

               WRITE !!?10,"Date/Time CANNOT be in the future!",!!

               GOTO EDATE

 +4       ;

 +5        SET %ZIS="Q"

           DO ^%ZIS

           IF POP

               GOTO END

           IF $DATA(IO("Q"))

               GOTO QUE

           USE IO

           GOTO ^ADGCEN30

QUE        KILL IO("Q")

           SET ZTRTN="^ADGCEN30"

           SET ZTDESC="CENSUS AID 3"

 +1        FOR DGI="DGBDT","DGEDT","DGWD"

               SET ZTSAVE(DGI)=""

 +2        DO ^%ZTLOAD

           DO ^%ZISC

           KILL ZTSK

END        KILL Y,DGBDT,DGEDT,DGWD,DGNOW,DIR,DGI

           DO HOME^%ZIS

           QUIT