PSGWEXR1.m

PSGWEXR1 ;BHAM ISC/CML-Print Drug Expiration Date Report by Selected Date Range/AOU ; 23 Mar 93 / 12:51 PM

 ;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94

PRINT ;ENTRY POINT WHEN QUEUED

 S PG=0,$P(LN,"-",80)="",(AOU,AOUNM,QFLG)=""

 I CNT<2 S AOU=$O(AOULP(AOU)),AOUNM=$P(^PSI(58.1,AOU,0),"^")

PRT S TAB=$S(CNT<2:(80-(32+$L(AOUNM)))*.5,1:26) D HDR

 I '$D(^TMP("PSGWEXR",$J)) W !!,"NO DATA FOUND FOR THIS REPORT" G DONE

 F EXDT=0:0 S EXDT=$O(^TMP("PSGWEXR",$J,EXDT)) Q:'EXDT!(QFLG)  D W1 Q:QFLG  S P1="" F JJ=0:0 S P1=$O(^TMP("PSGWEXR",$J,EXDT,P1)) Q:P1=""  D W2 Q:QFLG  I CNT>1 S P2="" D W3 Q:QFLG

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

 I $E(IOST)="C" D:'QFLG SS^PSGWUTL1

QUIT K %,%H,%I,%Z,AOU,ANS,QFLG,AOULP,AOUNM,BDT,DRG,DRGNM,EDT,EXDT,HDT,HH,JJ,LN,PG,X,Y,SEL,IGDA,CNT,SORT,P1,P2,G,TAB,ZTSK,IO("Q"),^TMP("PSGWEXR",$J) D ^%ZISC

 S:$D(ZTQUEUED) ZTREQ="@" Q

W1 ;

 D:$Y+5>IOSL PRTCHK Q:QFLG  S Y=EXDT X ^DD("DD") W !!,"=> ",Y Q

W2 ;

 D:$Y+5>IOSL PRTCHK Q:QFLG  W:CNT>1 ! W !?12,P1 Q

W3 ;

 F HH=0:0 S P2=$O(^TMP("PSGWEXR",$J,EXDT,P1,P2)) Q:P2=""  D:$Y+5>IOSL PRTCHK Q:QFLG  W !,?25,P2

 Q

HDR ;PRINT REPORT MAIN HEADER

 S PG=PG+1 S HDT=$$PSGWDT^PSGWUTL1 W:$Y @IOF W !?TAB,"DRUG EXPIRATION DATE REPORT" I CNT<2 W " for ",AOUNM

 W ?70,"PAGE ",PG,!?22,"FOR PERIOD " S Y=BDT X ^DD("DD") W Y," TO " S Y=EDT X ^DD("DD") W Y,!?27,"PRINTED ",HDT,!!

 I $D(SEL),SEL="I",$D(IGDA) W "FOR INVENTORY GROUP - ",$P(^PSI(58.2,IGDA,0),"^"),!

 W "=> DATE",!?12

 I CNT<2 W "ITEM",!,LN Q

 I SORT=1 W "ITEM",!?25,"AOU",!,LN Q

 W "AOU",!?25,"ITEM",!,LN Q

PRTCHK ;

 I $E(IOST)="C" W !!,"Press <RETURN> to Continue or ""^"" to Exit: " R ANS:DTIME S:'$T ANS="^" D:ANS?1."?" HELP^PSGWUTL1 I ANS="^" S QFLG=1 Q

 D HDR Q

PSGWEXR1  ;BHAM ISC/CML-Print Drug Expiration Date Report by Selected Date Range/AOU ; 23 Mar 93 / 12:51 PM

 +1       ;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94

PRINT     ;ENTRY POINT WHEN QUEUED

 +1        SET PG=0

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

           SET (AOU,AOUNM,QFLG)=""

 +2        IF CNT<2

               SET AOU=$ORDER(AOULP(AOU))

               SET AOUNM=$PIECE(^PSI(58.1,AOU,0),"^")

PRT        SET TAB=$SELECT(CNT<2:(80-(32+$LENGTH(AOUNM)))*.5,1:26)

           DO HDR

 +1        IF '$DATA(^TMP("PSGWEXR",$JOB))

               WRITE !!,"NO DATA FOUND FOR THIS REPORT"

               GOTO DONE

 +2        FOR EXDT=0:0

               SET EXDT=$ORDER(^TMP("PSGWEXR",$JOB,EXDT))

               IF 'EXDT!(QFLG)

                   QUIT 

               DO W1

               IF QFLG

                   QUIT 

               SET P1=""

               FOR JJ=0:0

                   SET P1=$ORDER(^TMP("PSGWEXR",$JOB,EXDT,P1))

                   IF P1=""

                       QUIT 

                   DO W2

                   IF QFLG

                       QUIT 

                   IF CNT>1

                       SET P2=""

                       DO W3

                       IF QFLG

                           QUIT 

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

               WRITE @IOF

 +1        IF $EXTRACT(IOST)="C"

               IF 'QFLG

                   DO SS^PSGWUTL1

QUIT       KILL %,%H,%I,%Z,AOU,ANS,QFLG,AOULP,AOUNM,BDT,DRG,DRGNM,EDT,EXDT,HDT,HH,JJ,LN,PG,X,Y,SEL,IGDA,CNT,SORT,P1,P2,G,TAB,ZTSK,IO("Q"),^TMP("PSGWEXR",$JOB)

           DO ^%ZISC

 +1        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

           QUIT 

W1        ;

 +1        IF $Y+5>IOSL

               DO PRTCHK

           IF QFLG

               QUIT 

           SET Y=EXDT

           XECUTE ^DD("DD")

           WRITE !!,"=> ",Y

           QUIT 

W2        ;

 +1        IF $Y+5>IOSL

               DO PRTCHK

           IF QFLG

               QUIT 

           IF CNT>1

               WRITE !

           WRITE !?12,P1

           QUIT 

W3        ;

 +1        FOR HH=0:0

               SET P2=$ORDER(^TMP("PSGWEXR",$JOB,EXDT,P1,P2))

               IF P2=""

                   QUIT 

               IF $Y+5>IOSL

                   DO PRTCHK

               IF QFLG

                   QUIT 

               WRITE !,?25,P2

 +2        QUIT 

HDR       ;PRINT REPORT MAIN HEADER

 +1        SET PG=PG+1

           SET HDT=$$PSGWDT^PSGWUTL1

           IF $Y

               WRITE @IOF

           WRITE !?TAB,"DRUG EXPIRATION DATE REPORT"

           IF CNT<2

               WRITE " for ",AOUNM

 +2        WRITE ?70,"PAGE ",PG,!?22,"FOR PERIOD "

           SET Y=BDT

           XECUTE ^DD("DD")

           WRITE Y," TO "

           SET Y=EDT

           XECUTE ^DD("DD")

           WRITE Y,!?27,"PRINTED ",HDT,!!

 +3        IF $DATA(SEL)

               IF SEL="I"

                   IF $DATA(IGDA)

                       WRITE "FOR INVENTORY GROUP - ",$PIECE(^PSI(58.2,IGDA,0),"^"),!

 +4        WRITE "=> DATE",!?12

 +5        IF CNT<2

               WRITE "ITEM",!,LN

               QUIT 

 +6        IF SORT=1

               WRITE "ITEM",!?25,"AOU",!,LN

               QUIT 

 +7        WRITE "AOU",!?25,"ITEM",!,LN

           QUIT 

PRTCHK    ;

 +1        IF $EXTRACT(IOST)="C"

               WRITE !!,"Press <RETURN> to Continue or ""^"" to Exit: "

               READ ANS:DTIME

               IF '$TEST

                   SET ANS="^"

               IF ANS?1."?"

                   DO HELP^PSGWUTL1

               IF ANS="^"

                   SET QFLG=1

                   QUIT 

 +2        DO HDR

           QUIT