- 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
