PSACON1.m

PSACON1 ;BIR/LTL-Display Connected Drug and Procurement History - CONT'D ;7/23/97

 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;; 10/24/97

 ;This routine is call by PSACON.

 ;

VEN N PSALN,PSAPG,PSARPDT S (PSA(7),PSAPG,PSAOUT)=0

 S Y=DT X ^DD("DD") S PSARPDT=Y D HEADER

 F  S PSA(7)=$O(^PRC(441,+PSA(1),2,PSA(7))) Q:'PSA(7)  S ^TMP("PSA",$J,(9999999-$P($G(^PRC(441,+PSA(1),2,+PSA(7),0)),U,6)),PSA(7))=$G(^PRC(441,+PSA(1),2,+PSA(7),0))

 S (PSA(7),PSA(77))=0

 F  S PSA(7)=$O(^TMP("PSA",$J,PSA(7))) Q:PSAOUT!('PSA(7))  D:$Y+4>IOSL HEADER Q:PSAOUT  F  S PSA(77)=$O(^TMP("PSA",$J,+PSA(7),PSA(77))) Q:PSAOUT!('PSA(77))  D

 .S PSA(66)=$G(^TMP("PSA",$J,+PSA(7),+PSA(77)))

 .S PSA(4)=$$UNITCODE^PRCPUX1($P($G(PSA(66)),U,7))

 .W !!,$E($$VENNAME^PRCPUX1(PSA(77)_"PRC(440"),1,20)

 .W ?22,$P($G(PSA(66)),U,8),"/",PSA(4)

 .W ?32,"$",$J($P($G(PSA(66)),U,2),7,2),"/",PSA(4)

 .W ?45,"$",$J($P($G(PSA(66)),U,2)/PSA(5),7,3),"/",PSA(8)

 .S Y=$P($G(PSA(66)),U,6) X ^DD("DD")

 .W ?60,Y

 .I $O(^PRC(440,+PSA(77),4,0)) S PSA(55)=0 F  S PSA(55)=$O(^PRC(440,+PSA(77),4,PSA(55))) Q:'PSA(55)  S:$P($G(^PRC(440,+PSA(77),4,+PSA(55),0)),U,2)'<DT PSA(44)=1

 .W:$G(PSA(44)) ?73,"YES" K PSA(44)

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

 I $E(IOST,1,2)="C-",'PSAOUT S DIR(0)="EA",DIR("A")="END OF LIST!  Press <RET> to return to the option." W ! D ^DIR K DIR S:Y<1 PSAOUT=1

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

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

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

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

 W:$Y @IOF S $P(PSALN,"-",81)="",PSAPG=PSAPG+1

 W !,$E($$DESCR^PRCPUX1(0,PSA(1)),1,45),?50,PSARPDT,?70,"PAGE: ",PSAPG,!,PSALN,!,"VENDOR",?23,"PKG",?32,"COST/PKG",?45,"COST/UNIT",?60,"PRICE DATE  CONTRACT",!,PSALN

 Q

PSACON1   ;BIR/LTL-Display Connected Drug and Procurement History - CONT'D ;7/23/97

 +1       ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;; 10/24/97

 +2       ;This routine is call by PSACON.

 +3       ;

VEN        NEW PSALN,PSAPG,PSARPDT

           SET (PSA(7),PSAPG,PSAOUT)=0

 +1        SET Y=DT

           XECUTE ^DD("DD")

           SET PSARPDT=Y

           DO HEADER

 +2        FOR 

               SET PSA(7)=$ORDER(^PRC(441,+PSA(1),2,PSA(7)))

               IF 'PSA(7)

                   QUIT 

               SET ^TMP("PSA",$JOB,(9999999-$PIECE($GET(^PRC(441,+PSA(1),2,+PSA(7),0)),U,6)),PSA(7))=$GET(^PRC(441,+PSA(1),2,+PSA(7),0))

 +3        SET (PSA(7),PSA(77))=0

 +4        FOR 

               SET PSA(7)=$ORDER(^TMP("PSA",$JOB,PSA(7)))

               IF PSAOUT!('PSA(7))

                   QUIT 

               IF $Y+4>IOSL

                   DO HEADER

               IF PSAOUT

                   QUIT 

               FOR 

                   SET PSA(77)=$ORDER(^TMP("PSA",$JOB,+PSA(7),PSA(77)))

                   IF PSAOUT!('PSA(77))

                       QUIT 

                   Begin DoDot:1

 +5                    SET PSA(66)=$GET(^TMP("PSA",$JOB,+PSA(7),+PSA(77)))

 +6                    SET PSA(4)=$$UNITCODE^PRCPUX1($PIECE($GET(PSA(66)),U,7))

 +7                    WRITE !!,$EXTRACT($$VENNAME^PRCPUX1(PSA(77)_"PRC(440"),1,20)

 +8                    WRITE ?22,$PIECE($GET(PSA(66)),U,8),"/",PSA(4)

 +9                    WRITE ?32,"$",$JUSTIFY($PIECE($GET(PSA(66)),U,2),7,2),"/",PSA(4)

 +10                   WRITE ?45,"$",$JUSTIFY($PIECE($GET(PSA(66)),U,2)/PSA(5),7,3),"/",PSA(8)

 +11                   SET Y=$PIECE($GET(PSA(66)),U,6)

                       XECUTE ^DD("DD")

 +12                   WRITE ?60,Y

 +13                   IF $ORDER(^PRC(440,+PSA(77),4,0))

                           SET PSA(55)=0

                           FOR 

                               SET PSA(55)=$ORDER(^PRC(440,+PSA(77),4,PSA(55)))

                               IF 'PSA(55)

                                   QUIT 

                               IF $PIECE($GET(^PRC(440,+PSA(77),4,+PSA(55),0)),U,2)'<DT

                                   SET PSA(44)=1

 +14                   IF $GET(PSA(44))

                           WRITE ?73,"YES"

                       KILL PSA(44)

                   End DoDot:1

 +15       IF $EXTRACT(IOST)'="C"

               WRITE @IOF

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

               IF 'PSAOUT

                   SET DIR(0)="EA"

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

                   WRITE !

                   DO ^DIR

                   KILL DIR

                   IF Y<1

                       SET PSAOUT=1

 +17       DO ^%ZISC

           IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

           KILL IO("Q")

           DO HOME^%ZIS

 +18       KILL ^TMP("PSA",$JOB)

           QUIT 

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

               IF PSAPG

                   SET DIR(0)="E"

                   DO ^DIR

                   KILL DIR

                   IF 'Y

                       SET PSAOUT=1

                       QUIT 

 +1        IF $$S^%ZTLOAD

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

               SET PSAOUT=1

               QUIT 

 +2        IF $Y

               WRITE @IOF

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

           SET PSAPG=PSAPG+1

 +3        WRITE !,$EXTRACT($$DESCR^PRCPUX1(0,PSA(1)),1,45),?50,PSARPDT,?70,"PAGE: ",PSAPG,!,PSALN,!,"VENDOR",?23,"PKG",?32,"COST/PKG",?45,"COST/UNIT",?60,"PRICE DATE  CONTRACT",!,PSALN

 +4        QUIT