PSACON ;BIR/LTL-Display Connected Drug and Procurement History ;7/23/97
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**15**; 10/24/97
;References to $$DESCR^PRCPUX1 are covered by IA #259
;References to ^DIC(51.5 are covered by IA #1931
;References to $$NSN^PRCPUX1 are covered by IA #259
;References to $$UNITCODE^PRCPUX1 are covered by IA #259
;References to $$UNITVAL^PRCPUX1 are covered by IA #259
;References to $$VENNAME^PRCPUX1 are covered by IA #259
;References to ^PSDRUG( are covered by IA #2095
;References to ^PRC( are covered by IA #214
;References to ^PRCP( are covered by IA #214
;
N DA,DIC,DTOUT,DUOUT,PSA,PSACON,PSAW,X,Y
D DT^DICRW
F S DIC="^PSDRUG(",DIC(0)="AEMQZ",DIC("S")="I $S('$D(^(""I"")):1,+^(""I"")>DT:1,1:0)",DIC("W")="W:'$O(^(441,0)) ?65,""NOT CONNECTED""" W ! D ^DIC K DA,DIC G:Y<0 END S PSA=+Y D G:Y<0 END G:$G(PSAW) ^PSACONW D:$G(PSACON) ^PSACON1 D ^PSACON2
.W @IOF,!!,$P($G(^PSDRUG(+PSA,0)),U),!!,?25,"** FROM THE DRUG FILE **",!!
.W "FSN: ",$P($G(^PSDRUG(+PSA,0)),U,6),?40,"NDC: ",$P($G(^PSDRUG(+PSA,2)),U,4),!!
.S PSA(5)=$S($P($G(^PSDRUG(+PSA,660)),U,5):$P($G(^(660)),U,5),1:1)
.S PSA(6)=$P($G(^DIC(51.5,+$P($G(^PSDRUG(+PSA,660)),U,2),0)),U)
.W "PACKAGING: ",PSA(5),"/",PSA(6)
.S PSA(8)=$P($G(^PSDRUG(+PSA,660)),U,8)
.W ?20,"PRICE: $",$P($G(^PSDRUG(+PSA,660)),U,3),"/",PSA(6)
.W ?40,"PRICE/DISPENSE UNIT: $",$P($G(^PSDRUG(+PSA,660)),U,6),"/",PSA(8)
.S PSA(15)=$O(^PSDRUG(+PSA,441,0)),PSA(1)=$G(^(+PSA(15),0))
.;more than one item linked
.D:$O(^PSDRUG(+PSA,441,PSA(15))) Q:Y<0 K DIC,DA
..W !!,"There is more than one item linked to this drug.",!
..S DIC="^PSDRUG(+PSA,441,",DIC(0)="AEQ",DA(1)=+PSA
..S DIC("W")="W ?10,$$DESCR^PRCPUX1(0,$G(^(0)))"
..D ^DIC Q:Y<0 S PSA(1)=$G(^PSDRUG(+PSA,441,+Y,0)) K DIC,DA
.I 'PSA(1) S Y=-1 Q
.D:PSA(1) Q:$D(DTOUT)!($D(DUOUT))
..W !!?25,"<< FROM THE ITEM MASTER FILE >>",!!
..S PSA(11)=$G(^PRC(441,+PSA(1),0))
..W "ITEM #: ",PSA(1),?15,$$DESCR^PRCPUX1(0,PSA(1)),!!
..W "NSN: ",$$NSN^PRCPUX1(PSA(1))
..I $P($G(^PRC(440,+$P(PSA(11),U,8),0)),U,11)="S" S PSAW=$O(^PRCP(445,"AC","W","")) Q
..S PSA(3)=$O(^PRC(441,+PSA(1),2,0))
..I PSA(3)&('$O(^PRC(441,+PSA(1),2,+PSA(3)))) D Q
...W ?40,"ONLY VENDOR: ",$E($$VENNAME^PRCPUX1(+PSA(3)_"PRC(440"),1,28),!!
...S PSA(33)=$G(^PRC(441,+PSA(1),2,+PSA(3),0))
...W "VENDOR STOCK #: ",$P(PSA(33),U,4)
...W ?40,"NDC: ",$P(PSA(33),U,5),!!
...W "PACKAGING: ",$$UNITVAL^PRCPUX1($P(PSA(33),U,8),$P(PSA(33),U,7))
...W ?20,"PRICE: $",$P(PSA(33),U,2),"/",$$UNITCODE^PRCPUX1($P(PSA(33),U,7))
...W ?40,"PRICE/DISPENSE UNIT: $",$P(PSA(33),U,2)/PSA(5)
...W !!,"MINIMUM ORDER: ",$P(PSA(33),U,12)
...S Y=$P(PSA(33),U,6) X ^DD("DD")
...S Y=$E(Y,1,4)_$S($L(Y)=10:$E(Y,7,10),$L(Y)=11:$E(Y,8,11),1:"")
...W ?20,"PRICE DATE: ",Y
...W ?40,"REQUIRED ORDER MULTIPLE: ",$P(PSA(33),U,11),!!
..W !!,"LAST VENDOR ORDERED: ",$$VENNAME^PRCPUX1($P(PSA(11),U,4)_"PRC(440"),!!
..W "MANDATORY SOURCE: ",$$VENNAME^PRCPUX1($P(PSA(11),U,8)_"PRC(440"),!
..K IO("Q") N %ZIS,IOP,POP S %ZIS="Q",%ZIS("A")="For Vendor listing, please select DEVICE: " D ^%ZIS I POP S DTOUT=1,Y=-1 W !,"NO DEVICE SELECTED OR OUTPUT PRINTED!" Q
..I $D(IO("Q")) N ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTDTH,ZTSK S ZTRTN="^PSACON1",ZTDESC="DRUG VENDORS",ZTSAVE("PSA*")="" D ^%ZTLOAD,HOME^%ZIS S Y=1 Q
..S (DTOUT,PSACON)=1 Q
END K PSAOUT Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSACON 3385 printed Oct 16, 2024@17:49:50 Page 2
PSACON ;BIR/LTL-Display Connected Drug and Procurement History ;7/23/97
+1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**15**; 10/24/97
+2 ;References to $$DESCR^PRCPUX1 are covered by IA #259
+3 ;References to ^DIC(51.5 are covered by IA #1931
+4 ;References to $$NSN^PRCPUX1 are covered by IA #259
+5 ;References to $$UNITCODE^PRCPUX1 are covered by IA #259
+6 ;References to $$UNITVAL^PRCPUX1 are covered by IA #259
+7 ;References to $$VENNAME^PRCPUX1 are covered by IA #259
+8 ;References to ^PSDRUG( are covered by IA #2095
+9 ;References to ^PRC( are covered by IA #214
+10 ;References to ^PRCP( are covered by IA #214
+11 ;
+12 NEW DA,DIC,DTOUT,DUOUT,PSA,PSACON,PSAW,X,Y
+13 DO DT^DICRW
+14 FOR
SET DIC="^PSDRUG("
SET DIC(0)="AEMQZ"
SET DIC("S")="I $S('$D(^(""I"")):1,+^(""I"")>DT:1,1:0)"
SET DIC("W")="W:'$O(^(441,0)) ?65,""NOT CONNECTED"""
WRITE !
DO ^DIC
KILL DA,DIC
if Y<0
GOTO END
SET PSA=+Y
Begin DoDot:1
+15 WRITE @IOF,!!,$PIECE($GET(^PSDRUG(+PSA,0)),U),!!,?25,"** FROM THE DRUG FILE **",!!
+16 WRITE "FSN: ",$PIECE($GET(^PSDRUG(+PSA,0)),U,6),?40,"NDC: ",$PIECE($GET(^PSDRUG(+PSA,2)),U,4),!!
+17 SET PSA(5)=$SELECT($PIECE($GET(^PSDRUG(+PSA,660)),U,5):$PIECE($GET(^(660)),U,5),1:1)
+18 SET PSA(6)=$PIECE($GET(^DIC(51.5,+$PIECE($GET(^PSDRUG(+PSA,660)),U,2),0)),U)
+19 WRITE "PACKAGING: ",PSA(5),"/",PSA(6)
+20 SET PSA(8)=$PIECE($GET(^PSDRUG(+PSA,660)),U,8)
+21 WRITE ?20,"PRICE: $",$PIECE($GET(^PSDRUG(+PSA,660)),U,3),"/",PSA(6)
+22 WRITE ?40,"PRICE/DISPENSE UNIT: $",$PIECE($GET(^PSDRUG(+PSA,660)),U,6),"/",PSA(8)
+23 SET PSA(15)=$ORDER(^PSDRUG(+PSA,441,0))
SET PSA(1)=$GET(^(+PSA(15),0))
+24 ;more than one item linked
+25 if $ORDER(^PSDRUG(+PSA,441,PSA(15)))
Begin DoDot:2
+26 WRITE !!,"There is more than one item linked to this drug.",!
+27 SET DIC="^PSDRUG(+PSA,441,"
SET DIC(0)="AEQ"
SET DA(1)=+PSA
+28 SET DIC("W")="W ?10,$$DESCR^PRCPUX1(0,$G(^(0)))"
+29 DO ^DIC
if Y<0
QUIT
SET PSA(1)=$GET(^PSDRUG(+PSA,441,+Y,0))
KILL DIC,DA
End DoDot:2
if Y<0
QUIT
KILL DIC,DA
+30 IF 'PSA(1)
SET Y=-1
QUIT
+31 if PSA(1)
Begin DoDot:2
+32 WRITE !!?25,"<< FROM THE ITEM MASTER FILE >>",!!
+33 SET PSA(11)=$GET(^PRC(441,+PSA(1),0))
+34 WRITE "ITEM #: ",PSA(1),?15,$$DESCR^PRCPUX1(0,PSA(1)),!!
+35 WRITE "NSN: ",$$NSN^PRCPUX1(PSA(1))
+36 IF $PIECE($GET(^PRC(440,+$PIECE(PSA(11),U,8),0)),U,11)="S"
SET PSAW=$ORDER(^PRCP(445,"AC","W",""))
QUIT
+37 SET PSA(3)=$ORDER(^PRC(441,+PSA(1),2,0))
+38 IF PSA(3)&('$ORDER(^PRC(441,+PSA(1),2,+PSA(3))))
Begin DoDot:3
+39 WRITE ?40,"ONLY VENDOR: ",$EXTRACT($$VENNAME^PRCPUX1(+PSA(3)_"PRC(440"),1,28),!!
+40 SET PSA(33)=$GET(^PRC(441,+PSA(1),2,+PSA(3),0))
+41 WRITE "VENDOR STOCK #: ",$PIECE(PSA(33),U,4)
+42 WRITE ?40,"NDC: ",$PIECE(PSA(33),U,5),!!
+43 WRITE "PACKAGING: ",$$UNITVAL^PRCPUX1($PIECE(PSA(33),U,8),$PIECE(PSA(33),U,7))
+44 WRITE ?20,"PRICE: $",$PIECE(PSA(33),U,2),"/",$$UNITCODE^PRCPUX1($PIECE(PSA(33),U,7))
+45 WRITE ?40,"PRICE/DISPENSE UNIT: $",$PIECE(PSA(33),U,2)/PSA(5)
+46 WRITE !!,"MINIMUM ORDER: ",$PIECE(PSA(33),U,12)
+47 SET Y=$PIECE(PSA(33),U,6)
XECUTE ^DD("DD")
+48 SET Y=$EXTRACT(Y,1,4)_$SELECT($LENGTH(Y)=10:$EXTRACT(Y,7,10),$LENGTH(Y)=11:$EXTRACT(Y,8,11),1:"")
+49 WRITE ?20,"PRICE DATE: ",Y
+50 WRITE ?40,"REQUIRED ORDER MULTIPLE: ",$PIECE(PSA(33),U,11),!!
End DoDot:3
QUIT
+51 WRITE !!,"LAST VENDOR ORDERED: ",$$VENNAME^PRCPUX1($PIECE(PSA(11),U,4)_"PRC(440"),!!
+52 WRITE "MANDATORY SOURCE: ",$$VENNAME^PRCPUX1($PIECE(PSA(11),U,8)_"PRC(440"),!
+53 KILL IO("Q")
NEW %ZIS,IOP,POP
SET %ZIS="Q"
SET %ZIS("A")="For Vendor listing, please select DEVICE: "
DO ^%ZIS
IF POP
SET DTOUT=1
SET Y=-1
WRITE !,"NO DEVICE SELECTED OR OUTPUT PRINTED!"
QUIT
+54 IF $DATA(IO("Q"))
NEW ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTDTH,ZTSK
SET ZTRTN="^PSACON1"
SET ZTDESC="DRUG VENDORS"
SET ZTSAVE("PSA*")=""
DO ^%ZTLOAD
DO HOME^%ZIS
SET Y=1
QUIT
+55 SET (DTOUT,PSACON)=1
QUIT
End DoDot:2
if $DATA(DTOUT)!($DATA(DUOUT))
QUIT
End DoDot:1
if Y<0
GOTO END
if $GET(PSAW)
GOTO ^PSACONW
if $GET(PSACON)
DO ^PSACON1
DO ^PSACON2
END KILL PSAOUT
QUIT
