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
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSACON1 1842 printed Mar 13, 2025@20:53:40 Page 2
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
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
