PSDADJB.m

PSDADJB ;BIR/LTL-Review Adjustment Transactions for a Drug; 2 Nov 94 [ 05/01/95  3:11 PM ]

 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97

START ;compiles and prints output

 S PSDTI="Adjustments from "_PSDTB(2)_" to "_PSDTB(3)

 N PSDR,PG S PSDT=PSDTB,CNT=0 S $P(LN,"-",81)=""

LOOP F  S PSDT=$O(^PSD(58.81,"ACT",PSDT)) Q:'PSDT!(PSDT>PSDTB(1))  I $O(^PSD(58.81,"ACT",PSDT,0))=PSDLOC S PSDT(1)=$O(^PSD(58.81,"ACT",PSDT,PSDLOC,0)) I $D(PSDA(+PSDT(1))),$O(^PSD(58.81,"ACT",PSDT,PSDLOC,+PSDT(1),9,0)) D

 .S PSDR(2)=$G(^PSD(58.81,+$O(^PSD(58.81,"ACT",PSDT,PSDLOC,+PSDT(1),9,0)),0))

 .S CNT=$G(CNT)+1,^TMP("PSD",$J,CNT)=LN

 .S CNT=$G(CNT)+1,^TMP("PSD",$J,CNT)=PSDA(+PSDT(1))

 .S Y=$E($P(PSDR(2),U,4),1,12),CNT=$G(CNT)+1 X ^DD("DD") S ^TMP("PSD",$J,CNT)=Y_"  "_" -> "_$P(PSDR(2),U,6)_" adjusted by "_$P($G(^VA(200,+$P(PSDR(2),U,7),0)),U)

 .S CNT=$G(CNT)+1,^TMP("PSD",$J,CNT)="Reason:  "_$P(PSDR(2),U,16)

 D BROWSE^DDBR("^TMP(""PSD"",$J)","NR",PSDTI)

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")

 K ^TMP("PSD",$J) Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PSDADJB   1148     printed  Apr 09, 2024@20:54:08                                                                                                                                                                                                     Page 2

PSDADJB   ;BIR/LTL-Review Adjustment Transactions for a Drug; 2 Nov 94 [ 05/01/95  3:11 PM ]

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

START     ;compiles and prints output

 +1        SET PSDTI="Adjustments from "_PSDTB(2)_" to "_PSDTB(3)

 +2        NEW PSDR,PG

           SET PSDT=PSDTB

           SET CNT=0

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

LOOP       FOR 

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

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

                   QUIT 

               IF $ORDER(^PSD(58.81,"ACT",PSDT,0))=PSDLOC

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

                   IF $DATA(PSDA(+PSDT(1)))

                       IF $ORDER(^PSD(58.81,"ACT",PSDT,PSDLOC,+PSDT(1),9,0))

                           Begin DoDot:1

 +1                            SET PSDR(2)=$GET(^PSD(58.81,+$ORDER(^PSD(58.81,"ACT",PSDT,PSDLOC,+PSDT(1),9,0)),0))

 +2                            SET CNT=$GET(CNT)+1

                               SET ^TMP("PSD",$JOB,CNT)=LN

 +3                            SET CNT=$GET(CNT)+1

                               SET ^TMP("PSD",$JOB,CNT)=PSDA(+PSDT(1))

 +4                            SET Y=$EXTRACT($PIECE(PSDR(2),U,4),1,12)

                               SET CNT=$GET(CNT)+1

                               XECUTE ^DD("DD")

                               SET ^TMP("PSD",$JOB,CNT)=Y_"  "_" -> "_$PIECE(PSDR(2),U,6)_" adjusted by "_$PIECE($GET(^VA(200,+$PIECE(PSDR(2),U,7),0)),U)

 +5                            SET CNT=$GET(CNT)+1

                               SET ^TMP("PSD",$JOB,CNT)="Reason:  "_$PIECE(PSDR(2),U,16)

                           End DoDot:1

 +6        DO BROWSE^DDBR("^TMP(""PSD"",$J)","NR",PSDTI)

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        KILL ^TMP("PSD",$JOB)

           QUIT