Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSACON1

PSACON1.m

Go to the documentation of this file.
  1. PSACON1 ;BIR/LTL-Display Connected Drug and Procurement History - CONT'D ;7/23/97
  1. ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;; 10/24/97
  1. ;This routine is call by PSACON.
  1. ;
  1. VEN N PSALN,PSAPG,PSARPDT S (PSA(7),PSAPG,PSAOUT)=0
  1. S Y=DT X ^DD("DD") S PSARPDT=Y D HEADER
  1. 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))
  1. S (PSA(7),PSA(77))=0
  1. 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
  1. .S PSA(66)=$G(^TMP("PSA",$J,+PSA(7),+PSA(77)))
  1. .S PSA(4)=$$UNITCODE^PRCPUX1($P($G(PSA(66)),U,7))
  1. .W !!,$E($$VENNAME^PRCPUX1(PSA(77)_"PRC(440"),1,20)
  1. .W ?22,$P($G(PSA(66)),U,8),"/",PSA(4)
  1. .W ?32,"$",$J($P($G(PSA(66)),U,2),7,2),"/",PSA(4)
  1. .W ?45,"$",$J($P($G(PSA(66)),U,2)/PSA(5),7,3),"/",PSA(8)
  1. .S Y=$P($G(PSA(66)),U,6) X ^DD("DD")
  1. .W ?60,Y
  1. .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
  1. .W:$G(PSA(44)) ?73,"YES" K PSA(44)
  1. I $E(IOST)'="C" W @IOF
  1. 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
  1. D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" K IO("Q") D HOME^%ZIS
  1. K ^TMP("PSA",$J) Q
  1. I $$S^%ZTLOAD W !!,"Task #",$G(ZTSK),", ",$G(ZTDESC)," was stopped by ",$P($G(^VA(200,+$G(DUZ),0)),U),"." S PSAOUT=1 Q
  1. W:$Y @IOF S $P(PSALN,"-",81)="",PSAPG=PSAPG+1
  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
  1. Q