PSDEXP1.m

PSDEXP1 ;BIR/JPW-CS Drug Expiration Date Report (cont'd) ; 2 Aug 94

 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97

 U IO

PRINT ;print cs exp date report

 S (PG,PSDOUT)=0

 K LN S $P(LN,"-",80)="" D NOW^%DTC S Y=+$E(%,1,12) X ^DD("DD") S RPDT=Y

 D HDR

 I '$D(^TMP("PSDEXP",$J)) W !!,?15,"****  NO DRUG EXPIRATION DATA FOR THIS REPORT  ****" G END

 F PSD=0:0 S PSD=$O(^TMP("PSDEXP",$J,PSD)) Q:'PSD!(PSDOUT)  D:$Y+5>IOSL HDR Q:PSDOUT  S Y=PSD X ^DD("DD") W !!,"=> ",Y D

 .S PSD1="" F  S PSD1=$O(^TMP("PSDEXP",$J,PSD,PSD1)) Q:PSD1=""!(PSDOUT)  D:$Y+5>IOSL HDR Q:PSDOUT  W !,?12,PSD1 D

 ..S PSD2="" F  S PSD2=$O(^TMP("PSDEXP",$J,PSD,PSD1,PSD2)) Q:PSD2=""!(PSDOUT)  S PSD3="" F  S PSD3=$O(^TMP("PSDEXP",$J,PSD,PSD1,PSD2,PSD3)) Q:PSD3=""!(PSDOUT)  D:$Y+5>IOSL HDR Q:PSDOUT  W !,?14,$S(PSD3'="N/A":PSD3,1:""),?25,PSD2

DONE I $E(IOST)'="C" W @IOF

 I $E(IOST,1,2)="C-",'PSDOUT W ! K DIR,DIRUT S DIR(0)="EA",DIR("A")="END OF REPORT!  Press <RET> to return to the menu" D ^DIR K DIR

END ;

 K %,%DT,%H,%I,%ZIS,ANS,CNT,DA,DIC,DIR,DIROUT,DIRUT,DTOUT,DRUG,DRUGN,DUOUT,JJ,LN,NAOU,NAOUN,NODE,OK,ORD

 K PG,POP,PSD,PSDT,PSD1,PSD2,PSD3,PSDATE,PSDED,PSDIO,PSDOUT,PSDSD,RPDT,TYPE,X,Y,ZTDESC,ZTDTH,ZTRTN,ZTSAVE,ZTSK

 K ^TMP("PSDEXP",$J) D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"

 Q

HDR ;header for log

 I $E(IOST,1,2)="C-",PG W ! K DA,DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSDOUT=1 Q

 S PG=PG+1 W:$Y @IOF W !,?27,"CS DRUG EXPIRATION DATE REPORT",?70,"Page: ",PG

 W !,?22,"FOR PERIOD ",$P(PSDATE,"^")," TO ",$P(PSDATE,"^",2)

 W !,?27,"PRINTED ",RPDT,!!,"=> DATE",!,?12

 I ANS="D" W "DRUG",!,?14,"DISP #",?25,"NAOU",!,LN Q

 W "NAOU",!,?14,"DISP #",?25,"ITEM",!,LN

 Q

PSDEXP1   ;BIR/JPW-CS Drug Expiration Date Report (cont'd) ; 2 Aug 94

 +1       ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97

 +2        USE IO

PRINT     ;print cs exp date report

 +1        SET (PG,PSDOUT)=0

 +2        KILL LN

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

           DO NOW^%DTC

           SET Y=+$EXTRACT(%,1,12)

           XECUTE ^DD("DD")

           SET RPDT=Y

 +3        DO HDR

 +4        IF '$DATA(^TMP("PSDEXP",$JOB))

               WRITE !!,?15,"****  NO DRUG EXPIRATION DATA FOR THIS REPORT  ****"

               GOTO END

 +5        FOR PSD=0:0

               SET PSD=$ORDER(^TMP("PSDEXP",$JOB,PSD))

               IF 'PSD!(PSDOUT)

                   QUIT 

               IF $Y+5>IOSL

                   DO HDR

               IF PSDOUT

                   QUIT 

               SET Y=PSD

               XECUTE ^DD("DD")

               WRITE !!,"=> ",Y

               Begin DoDot:1

 +6                SET PSD1=""

                   FOR 

                       SET PSD1=$ORDER(^TMP("PSDEXP",$JOB,PSD,PSD1))

                       IF PSD1=""!(PSDOUT)

                           QUIT 

                       IF $Y+5>IOSL

                           DO HDR

                       IF PSDOUT

                           QUIT 

                       WRITE !,?12,PSD1

                       Begin DoDot:2

 +7                        SET PSD2=""

                           FOR 

                               SET PSD2=$ORDER(^TMP("PSDEXP",$JOB,PSD,PSD1,PSD2))

                               IF PSD2=""!(PSDOUT)

                                   QUIT 

                               SET PSD3=""

                               FOR 

                                   SET PSD3=$ORDER(^TMP("PSDEXP",$JOB,PSD,PSD1,PSD2,PSD3))

                                   IF PSD3=""!(PSDOUT)

                                       QUIT 

                                   IF $Y+5>IOSL

                                       DO HDR

                                   IF PSDOUT

                                       QUIT 

                                   WRITE !,?14,$SELECT(PSD3'="N/A":PSD3,1:""),?25,PSD2

                       End DoDot:2

               End DoDot:1

DONE       IF $EXTRACT(IOST)'="C"

               WRITE @IOF

 +1        IF $EXTRACT(IOST,1,2)="C-"

               IF 'PSDOUT

                   WRITE !

                   KILL DIR,DIRUT

                   SET DIR(0)="EA"

                   SET DIR("A")="END OF REPORT!  Press <RET> to return to the menu"

                   DO ^DIR

                   KILL DIR

END       ;

 +1        KILL %,%DT,%H,%I,%ZIS,ANS,CNT,DA,DIC,DIR,DIROUT,DIRUT,DTOUT,DRUG,DRUGN,DUOUT,JJ,LN,NAOU,NAOUN,NODE,OK,ORD

 +2        KILL PG,POP,PSD,PSDT,PSD1,PSD2,PSD3,PSDATE,PSDED,PSDIO,PSDOUT,PSDSD,RPDT,TYPE,X,Y,ZTDESC,ZTDTH,ZTRTN,ZTSAVE,ZTSK

 +3        KILL ^TMP("PSDEXP",$JOB)

           DO ^%ZISC

           IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +4        QUIT 

HDR       ;header for log

 +1        IF $EXTRACT(IOST,1,2)="C-"

               IF PG

                   WRITE !

                   KILL DA,DIR

                   SET DIR(0)="E"

                   DO ^DIR

                   KILL DIR

                   IF 'Y

                       SET PSDOUT=1

                       QUIT 

 +2        SET PG=PG+1

           IF $Y

               WRITE @IOF

           WRITE !,?27,"CS DRUG EXPIRATION DATE REPORT",?70,"Page: ",PG

 +3        WRITE !,?22,"FOR PERIOD ",$PIECE(PSDATE,"^")," TO ",$PIECE(PSDATE,"^",2)

 +4        WRITE !,?27,"PRINTED ",RPDT,!!,"=> DATE",!,?12

 +5        IF ANS="D"

               WRITE "DRUG",!,?14,"DISP #",?25,"NAOU",!,LN

               QUIT 

 +6        WRITE "NAOU",!,?14,"DISP #",?25,"ITEM",!,LN

 +7        QUIT