PSADRUGP ;BIR/LTL,JMB-Enter/Edit a Drug ;7/23/97
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,21,60,64**; 10/24/97;Build 4
;
;References to ^PSDRUG( are covered by IA #2095
;References to ^PS(52.6, are covered by IA #270
;References to ^DIC(51.5 are covered by IA #1931
;References to ^PS(52.7 are covered by IA #770
LOC G:+$G(PSAOUT)&($G(PSACNT)=1) EXIT
S (PSADD,PSACNT,PSAOUT)=0,PSASLN="",$P(PSASLN,"-",80)=""
D ^PSAUTL3 G:PSAOUT EXIT S PSACHK=$O(PSALOC(""))
I PSACHK="",'PSALOC W !,"There are no active pharmacy locations." G EXIT
I $O(PSALOC(PSACHK))="" W !,PSALOCN
;
GETDRUG S PSAQTY=0
S:'$D(^PSD(58.8,PSALOC,1,0)) ^(0)="^58.8001IP^^"
S DA(1)=PSALOC,DIC="^PSD(58.8,"_PSALOC_",1,",DIC(0)="AEMQL",DIC("W")="I $S($P($G(^(0)),U,14):$P($G(^(0)),U,14)'>DT,1:0) W $C(7),"" *** INACTIVE ***""",DLAYGO=58.8 W ! D ^DIC K DIC,DLAYGO
I Y<0!($G(DTOUT))!($G(DUOUT)) S PSAOUT=1 Q:$G(PSAOPT)="PSALOC" G LOC
S PSADRG=+Y,PSADRGN=$P($G(^PSDRUG(PSADRG,0)),"^")
I $D(^PSD(58.8,PSALOC,1,PSADRG,0)),+$P(^(0),"^",14),$P(^(0),"^",14)'>DT W !,$C(7)," *** INACTIVE ***" G DISP ;PSA*3*21 (Allow re-activation)
S PSA660=$G(^PSDRUG(PSADRG,660))
I '$D(^PSD(58.8,PSALOC,1,PSADRG,0)) G NOINV
I $D(^PSD(58.8,PSALOC,1,PSADRG,0)),$P(^(0),"^",4)="" G DRUG
G DISP
;
NOINV I '$D(^PSD(58.8,PSALOC,1,PSADRG,0)) D
.S:'$D(^PSD(58.8,PSALOC,1,0)) ^(0)="^58.8001IP^^"
.K DA,DD,DO S DIC="^PSD(58.8,"_PSALOC_",1,",DIC(0)="LM",DA(1)=PSALOC,(X,DINUM)=PSADRG,DLAYGO=58.8 D ^DIC K DIC,DINUM,DLAYGO
DRUG S DIE="^PSD(58.8,"_PSALOC_",1,",DA(1)=PSALOC,DA=PSADRG,DR="3Enter total "_$P(PSA660,"^",8)_" currently on hand: "
W @IOF,!,$G(PSALOCN),!,"DRUG: "_PSADRGN
D:+$P(PSA660,"^",2)
.W !!?30,"DRUG FILE info:",!
.W ?20,"Order unit: "_$P(^DIC(51.5,$P(PSA660,"^",2),0),"^",1),!?20,"Dispense units per order unit: "_$P(PSA660,"^",5),!?20,"Dispense unit: "_$P(PSA660,"^",8)
.W !!,"Current Inventory from the DRUG file = "_$P($G(^PSDRUG(PSADRG,660.1)),"^")
I '$P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",4) D
.W !!,"Once an initial quantity is entered, it can only be updated by receiving,",!,"dispensing, adjusting, or transferring."
.W:+$P(PSA660,"^",2) " The Current Inventory from the",!,"DRUG file is only offered as an initial balance and and is NOT updated."
F L +^PSD(58.8,PSALOC,1,PSADRG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
W ! D ^DIE L -^PSD(58.8,PSALOC,1,PSADRG,0) K DA,DIE G:$D(Y) LOC
S PSAQTY=X
I +$P($G(^PSD(58.8,PSALOC,0)),"^",14) D
.S DIE="^PSD(58.8,"_PSALOC_",1,",DA(1)=PSALOC,DA=PSADRG,DR="2Stock Level: ;4Reorder Level: "
.F L +^PSD(58.8,PSALOC,1,PSADRG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
.D ^DIE L -^PSD(58.8,PSALOC,1,PSADRG,0) K DA,DIE
DISP ;
S:'$D(PSA660) PSA660=$G(^PSDRUG(PSADRG,660)) ;*60
W !!,"Current balance: "_+$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",4)," ",$P(PSA660,"^",8)
;PSA*3*21 (Give option of inactivation - Dave B)
S DIE="^PSD(58.8,"_PSALOC_",1,",DA(1)=PSALOC,DA=PSADRG,DR="13;14" D ^DIE K DIE,DR
S PSAIT=PSADRG,PSAIT(2)=PSADRGN,PSAIT(4)=$G(^PSDRUG(PSAIT,660)) D:$O(^PS(52.6,"AC",PSADRG,0))!($O(^PS(52.7,"AC",PSADRG,0))) ^PSAPSI4
G:'$G(PSAQTY) GETDRUG
D NOW^%DTC S PSADT=+$E(%,1,12)
MON S:'$D(^PSD(58.8,PSALOC,1,PSADRG,5,0)) ^PSD(58.8,PSALOC,1,PSADRG,5,0)="^58.801A^^"
I '$D(^PSD(58.8,PSALOC,1,PSADRG,5,+($E(DT,1,5)*100),0)) S DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRG_",5,",DIC(0)="LM",(X,DINUM)=($E(DT,1,5)*100),DA(2)=PSALOC,DA(1)=PSADRG,DLAYGO=58.8 D ^DIC K DA,DIC,DLAYGO
S DIE="^PSD(58.8,"_PSALOC_",1,"_PSADRG_",5,",DA(2)=PSALOC,DA(1)=PSADRG,DA=($E(DT,1,5)*100),DR="1////^S X=PSAQTY;7////^S X=PSAQTY" D ^DIE K DA,DIE
W !!,"Updating beginning balance and transaction history."
F L +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
FIND S PSAT=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSAT)) S $P(^PSD(58.81,0),"^",3)=$P(^PSD(58.81,0),"^",3)+1 G FIND
S DIC="^PSD(58.81,",DIC(0)="L",DLAYGO=58.81,(DINUM,X)=PSAT D ^DIC
L -^PSD(58.81,0) K DIC,DLAYGO
S DIE="^PSD(58.81,",DA=PSAT,DR="1////11;2////^S X=PSALOC;3////^S X=PSADT;4////^S X=PSADRG;5////^S X=PSAQTY;6////^S X=DUZ;9////0" D ^DIE K DIE,DA
S:'$D(^PSD(58.8,PSALOC,1,PSADRG,4,0)) ^PSD(58.8,PSALOC,1,PSADRG,4,0)="^58.800119PA^^"
S DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRG_",4,",DIC(0)="LM",(X,DINUM)=PSAT
S DA(2)=PSALOC,DA(1)=PSADRG,DLAYGO=58.8 D ^DIC K DA,DIC,DLAYGO
G GETDRUG
EXIT K %,DA,DIC,DIE,DINUM,DR,DTOUT,DUOUT,PSA660,PSACHK,PSACNT,PSADD,PSADRG,PSADRGN,PSADT,PSALOC,PSALOCA,PSALOCN,PSAOUT,PSAQTY,PSASLN,PSAT,X,Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSADRUGP 4486 printed Sep 23, 2025@19:25:17 Page 2
PSADRUGP ;BIR/LTL,JMB-Enter/Edit a Drug ;7/23/97
+1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,21,60,64**; 10/24/97;Build 4
+2 ;
+3 ;References to ^PSDRUG( are covered by IA #2095
+4 ;References to ^PS(52.6, are covered by IA #270
+5 ;References to ^DIC(51.5 are covered by IA #1931
+6 ;References to ^PS(52.7 are covered by IA #770
LOC if +$GET(PSAOUT)&($GET(PSACNT)=1)
GOTO EXIT
+1 SET (PSADD,PSACNT,PSAOUT)=0
SET PSASLN=""
SET $PIECE(PSASLN,"-",80)=""
+2 DO ^PSAUTL3
if PSAOUT
GOTO EXIT
SET PSACHK=$ORDER(PSALOC(""))
+3 IF PSACHK=""
IF 'PSALOC
WRITE !,"There are no active pharmacy locations."
GOTO EXIT
+4 IF $ORDER(PSALOC(PSACHK))=""
WRITE !,PSALOCN
+5 ;
GETDRUG SET PSAQTY=0
+1 if '$DATA(^PSD(58.8,PSALOC,1,0))
SET ^(0)="^58.8001IP^^"
+2 SET DA(1)=PSALOC
SET DIC="^PSD(58.8,"_PSALOC_",1,"
SET DIC(0)="AEMQL"
SET DIC("W")="I $S($P($G(^(0)),U,14):$P($G(^(0)),U,14)'>DT,1:0) W $C(7),"" *** INACTIVE ***"""
SET DLAYGO=58.8
WRITE !
DO ^DIC
KILL DIC,DLAYGO
+3 IF Y<0!($GET(DTOUT))!($GET(DUOUT))
SET PSAOUT=1
if $GET(PSAOPT)="PSALOC"
QUIT
GOTO LOC
+4 SET PSADRG=+Y
SET PSADRGN=$PIECE($GET(^PSDRUG(PSADRG,0)),"^")
+5 ;PSA*3*21 (Allow re-activation)
IF $DATA(^PSD(58.8,PSALOC,1,PSADRG,0))
IF +$PIECE(^(0),"^",14)
IF $PIECE(^(0),"^",14)'>DT
WRITE !,$CHAR(7)," *** INACTIVE ***"
GOTO DISP
+6 SET PSA660=$GET(^PSDRUG(PSADRG,660))
+7 IF '$DATA(^PSD(58.8,PSALOC,1,PSADRG,0))
GOTO NOINV
+8 IF $DATA(^PSD(58.8,PSALOC,1,PSADRG,0))
IF $PIECE(^(0),"^",4)=""
GOTO DRUG
+9 GOTO DISP
+10 ;
NOINV IF '$DATA(^PSD(58.8,PSALOC,1,PSADRG,0))
Begin DoDot:1
+1 if '$DATA(^PSD(58.8,PSALOC,1,0))
SET ^(0)="^58.8001IP^^"
+2 KILL DA,DD,DO
SET DIC="^PSD(58.8,"_PSALOC_",1,"
SET DIC(0)="LM"
SET DA(1)=PSALOC
SET (X,DINUM)=PSADRG
SET DLAYGO=58.8
DO ^DIC
KILL DIC,DINUM,DLAYGO
End DoDot:1
DRUG SET DIE="^PSD(58.8,"_PSALOC_",1,"
SET DA(1)=PSALOC
SET DA=PSADRG
SET DR="3Enter total "_$PIECE(PSA660,"^",8)_" currently on hand: "
+1 WRITE @IOF,!,$GET(PSALOCN),!,"DRUG: "_PSADRGN
+2 if +$PIECE(PSA660,"^",2)
Begin DoDot:1
+3 WRITE !!?30,"DRUG FILE info:",!
+4 WRITE ?20,"Order unit: "_$PIECE(^DIC(51.5,$PIECE(PSA660,"^",2),0),"^",1),!?20,"Dispense units per order unit: "_$PIECE(PSA660,"^",5),!?20,"Dispense unit: "_$PIECE(PSA660,"^",8)
+5 WRITE !!,"Current Inventory from the DRUG file = "_$PIECE($GET(^PSDRUG(PSADRG,660.1)),"^")
End DoDot:1
+6 IF '$PIECE(^PSD(58.8,PSALOC,1,PSADRG,0),"^",4)
Begin DoDot:1
+7 WRITE !!,"Once an initial quantity is entered, it can only be updated by receiving,",!,"dispensing, adjusting, or transferring."
+8 if +$PIECE(PSA660,"^",2)
WRITE " The Current Inventory from the",!,"DRUG file is only offered as an initial balance and and is NOT updated."
End DoDot:1
+9 FOR
LOCK +^PSD(58.8,PSALOC,1,PSADRG,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+10 WRITE !
DO ^DIE
LOCK -^PSD(58.8,PSALOC,1,PSADRG,0)
KILL DA,DIE
if $DATA(Y)
GOTO LOC
+11 SET PSAQTY=X
+12 IF +$PIECE($GET(^PSD(58.8,PSALOC,0)),"^",14)
Begin DoDot:1
+13 SET DIE="^PSD(58.8,"_PSALOC_",1,"
SET DA(1)=PSALOC
SET DA=PSADRG
SET DR="2Stock Level: ;4Reorder Level: "
+14 FOR
LOCK +^PSD(58.8,PSALOC,1,PSADRG,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+15 DO ^DIE
LOCK -^PSD(58.8,PSALOC,1,PSADRG,0)
KILL DA,DIE
End DoDot:1
DISP ;
+1 ;*60
if '$DATA(PSA660)
SET PSA660=$GET(^PSDRUG(PSADRG,660))
+2 WRITE !!,"Current balance: "_+$PIECE($GET(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",4)," ",$PIECE(PSA660,"^",8)
+3 ;PSA*3*21 (Give option of inactivation - Dave B)
+4 SET DIE="^PSD(58.8,"_PSALOC_",1,"
SET DA(1)=PSALOC
SET DA=PSADRG
SET DR="13;14"
DO ^DIE
KILL DIE,DR
+5 SET PSAIT=PSADRG
SET PSAIT(2)=PSADRGN
SET PSAIT(4)=$GET(^PSDRUG(PSAIT,660))
if $ORDER(^PS(52.6,"AC",PSADRG,0))!($ORDER(^PS(52.7,"AC",PSADRG,0)))
DO ^PSAPSI4
+6 if '$GET(PSAQTY)
GOTO GETDRUG
+7 DO NOW^%DTC
SET PSADT=+$EXTRACT(%,1,12)
MON if '$DATA(^PSD(58.8,PSALOC,1,PSADRG,5,0))
SET ^PSD(58.8,PSALOC,1,PSADRG,5,0)="^58.801A^^"
+1 IF '$DATA(^PSD(58.8,PSALOC,1,PSADRG,5,+($EXTRACT(DT,1,5)*100),0))
SET DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRG_",5,"
SET DIC(0)="LM"
SET (X,DINUM)=($EXTRACT(DT,1,5)*100)
SET DA(2)=PSALOC
SET DA(1)=PSADRG
SET DLAYGO=58.8
DO ^DIC
KILL DA,DIC,DLAYGO
+2 SET DIE="^PSD(58.8,"_PSALOC_",1,"_PSADRG_",5,"
SET DA(2)=PSALOC
SET DA(1)=PSADRG
SET DA=($EXTRACT(DT,1,5)*100)
SET DR="1////^S X=PSAQTY;7////^S X=PSAQTY"
DO ^DIE
KILL DA,DIE
+3 WRITE !!,"Updating beginning balance and transaction history."
+4 FOR
LOCK +^PSD(58.81,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
FIND SET PSAT=$PIECE(^PSD(58.81,0),"^",3)+1
IF $DATA(^PSD(58.81,PSAT))
SET $PIECE(^PSD(58.81,0),"^",3)=$PIECE(^PSD(58.81,0),"^",3)+1
GOTO FIND
+1 SET DIC="^PSD(58.81,"
SET DIC(0)="L"
SET DLAYGO=58.81
SET (DINUM,X)=PSAT
DO ^DIC
+2 LOCK -^PSD(58.81,0)
KILL DIC,DLAYGO
+3 SET DIE="^PSD(58.81,"
SET DA=PSAT
SET DR="1////11;2////^S X=PSALOC;3////^S X=PSADT;4////^S X=PSADRG;5////^S X=PSAQTY;6////^S X=DUZ;9////0"
DO ^DIE
KILL DIE,DA
+4 if '$DATA(^PSD(58.8,PSALOC,1,PSADRG,4,0))
SET ^PSD(58.8,PSALOC,1,PSADRG,4,0)="^58.800119PA^^"
+5 SET DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRG_",4,"
SET DIC(0)="LM"
SET (X,DINUM)=PSAT
+6 SET DA(2)=PSALOC
SET DA(1)=PSADRG
SET DLAYGO=58.8
DO ^DIC
KILL DA,DIC,DLAYGO
+7 GOTO GETDRUG
EXIT KILL %,DA,DIC,DIE,DINUM,DR,DTOUT,DUOUT,PSA660,PSACHK,PSACNT,PSADD,PSADRG,PSADRGN,PSADT,PSALOC,PSALOCA,PSALOCN,PSAOUT,PSAQTY,PSASLN,PSAT,X,Y
+1 QUIT
