PSDADJW.m

PSDADJW ;BIR/LTL-Review Adjustment Transactions for a Drug; 2 Nov 94 [ 11/02/94  12:19 PM ]

 ;;3.0; CONTROLLED SUBSTANCES ;**32**;13 Feb 97

 ;

 ; Reference to ^PSD(58.81 supported by DBIA # 2808

 ;

START ;compiles and prints output

 N LN,JJ,KK,NN,PSDR,PG S (PG,PSDOUT)=0 D HEADER

LOOP F  S PSDT=$O(^PSD(58.81,"ACT",PSDT)) Q:'PSDT!(PSDT>PSDTB(1))  F JJ=0:0 S JJ=$O(^PSD(58.81,"ACT",PSDT,JJ)) Q:'JJ  D:JJ=PSDLOC  G:PSDOUT END

 .F KK=0:0 S KK=$O(^PSD(58.81,"ACT",PSDT,JJ,KK)) Q:'KK  F NN=0:0 S NN=$O(^PSD(58.81,"ACT",PSDT,JJ,KK,9,NN)) Q:'NN  D

 ..S PSDR=KK

 ..Q:'$D(PSDA(+PSDR))

 ..S PSDR(1)=NN

 ..S PSDR(2)=$G(^PSD(58.81,NN,0))

 ..D:$Y+7>IOSL HEADER Q:PSDOUT

 ..W !,$$FMTE^XLFDT($E($P(PSDR(2),U,4),1,12),"2P"),?18,PSDA(PSDR)

 ..W ?61,$J($P(PSDR(2),U,6),6),?69,$P(PSDR(2),U,16),?116

 ..W $E($P($G(^VA(200,+$P(PSDR(2),U,7),0)),U),1,16),!

END W:$E(IOST)'="C" @IOF

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

 D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" K IO("Q")

 Q

HEADER ;prints header info

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

 I $$S^%ZTLOAD W !!,"Task #",$G(ZTSK),", ",$G(ZTDESC)," was stopped by ",$P($G(^VA(200,+$G(DUZ),0)),U),"." S PSDOUT=1

 W:$Y @IOF S $P(LN,"-",80)="",PG=PG+1 W !,"Adjustments from ",PSDTB(2)," to ",PSDTB(3),?70,"PAGE: ",PG,!,LN,!?2,"Date",?18,"Drug",?64,"QTY",?69,"Reason",?116,"Pharmacist",!,LN,!

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PSDADJW   1435     printed  Apr 09, 2024@20:53:40                                                                                                                                                                                                     Page 2

PSDADJW   ;BIR/LTL-Review Adjustment Transactions for a Drug; 2 Nov 94 [ 11/02/94  12:19 PM ]

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

 +2       ;

 +3       ; Reference to ^PSD(58.81 supported by DBIA # 2808

 +4       ;

START     ;compiles and prints output

 +1        NEW LN,JJ,KK,NN,PSDR,PG

           SET (PG,PSDOUT)=0

           DO HEADER

LOOP       FOR 

               SET PSDT=$ORDER(^PSD(58.81,"ACT",PSDT))

               if 'PSDT!(PSDT>PSDTB(1))

                   QUIT 

               FOR JJ=0:0

                   SET JJ=$ORDER(^PSD(58.81,"ACT",PSDT,JJ))

                   if 'JJ

                       QUIT 

                   if JJ=PSDLOC

                       Begin DoDot:1

 +1                        FOR KK=0:0

                               SET KK=$ORDER(^PSD(58.81,"ACT",PSDT,JJ,KK))

                               if 'KK

                                   QUIT 

                               FOR NN=0:0

                                   SET NN=$ORDER(^PSD(58.81,"ACT",PSDT,JJ,KK,9,NN))

                                   if 'NN

                                       QUIT 

                                   Begin DoDot:2

 +2                                    SET PSDR=KK

 +3                                    if '$DATA(PSDA(+PSDR))

                                           QUIT 

 +4                                    SET PSDR(1)=NN

 +5                                    SET PSDR(2)=$GET(^PSD(58.81,NN,0))

 +6                                    if $Y+7>IOSL

                                           DO HEADER

                                       if PSDOUT

                                           QUIT 

 +7                                    WRITE !,$$FMTE^XLFDT($EXTRACT($PIECE(PSDR(2),U,4),1,12),"2P"),?18,PSDA(PSDR)

 +8                                    WRITE ?61,$JUSTIFY($PIECE(PSDR(2),U,6),6),?69,$PIECE(PSDR(2),U,16),?116

 +9                                    WRITE $EXTRACT($PIECE($GET(^VA(200,+$PIECE(PSDR(2),U,7),0)),U),1,16),!

                                   End DoDot:2

                       End DoDot:1

                   if PSDOUT

                       GOTO END

END        if $EXTRACT(IOST)'="C"

               WRITE @IOF

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

               IF 'PSDOUT

                   SET DIR(0)="EA"

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

                   DO ^DIR

 +2        DO ^%ZISC

           if $DATA(ZTQUEUED)

               SET ZTREQ="@"

           KILL IO("Q")

 +3        QUIT 

HEADER    ;prints header info

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

               IF PG

                   SET DIR(0)="E"

                   DO ^DIR

                   KILL DIR

                   IF 'Y

                       SET PSDOUT=1

                       QUIT 

 +2        IF $$S^%ZTLOAD

               WRITE !!,"Task #",$GET(ZTSK),", ",$GET(ZTDESC)," was stopped by ",$PIECE($GET(^VA(200,+$GET(DUZ),0)),U),"."

               SET PSDOUT=1

 +3        if $Y

               WRITE @IOF

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

           SET PG=PG+1

           WRITE !,"Adjustments from ",PSDTB(2)," to ",PSDTB(3),?70,"PAGE: ",PG,!,LN,!?2,"Date",?18,"Drug",?64,"QTY",?69,"Reason",?116,"Pharmacist",!,LN,!

 +4        QUIT