PSALOC ;BIR/MNT,DB-Set Up/Edit a Pharmacy Location ;7/23/97
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**21**; 10/24/97
;
;References to ^PS(59, are covered under IA #212
;References to ^PS(59.4, are covered under IA #2505
;Due to merging facilities, this functionality is being
K PSALOC,PSALOCA,PSAMNU
S PSALOC=+$O(^PSD(58.8,"ADISP","P",0))
I 'PSALOC W !!?5,"No Drug Accountability location has been created yet." G ADD
D HDR
;
ORDER ;If more than one pharmacy location, collect them in alpha order.
S (PSACNT,PSALOC)=0 W !
F S PSALOC=+$O(^PSD(58.8,"ADISP","P",PSALOC)) Q:'PSALOC D
.Q:'$D(^PSD(58.8,PSALOC,0))!($P($G(^PSD(58.8,PSALOC,0)),"^")="")
.I +$G(^PSD(58.8,PSALOC,"I")),+^PSD(58.8,PSALOC,"I")'>DT Q
.D SITES^PSAUTL1
.K PSAISIT,PSAOSIT
.S PSACNT=PSACNT+1,PSAONE=+PSALOC
.S PSALOCA($P(^PSD(58.8,PSALOC,0),"^"),PSALOC)=$P(^(0),"^",3)_"^"_$P(^(0),"^",10) I $D(^PSD(58.8,PSALOC,7)) D
..;OP multiple has data
..S X2=0 F S X2=$O(^PSD(58.8,PSALOC,7,X2)) Q:X2'>0 I $P(^PSD(58.8,PSALOC,0),"^",10)'=X2,$P($G(^PSD(58.8,PSALOC,7,X2,0)),"^",2)="" S PSALOCA($P(^PSD(58.8,PSALOC,0),"^"),PSALOC)=PSALOCA($P(^PSD(58.8,PSALOC,0),"^"),PSALOC)_"^"_X2
S PSACHK=$O(PSALOCA("")) I PSACHK="" G ADD
I $G(PSACNT)=1 G DISP
G DISP
;
ONE ;only one
S PSALOC=PSAONE
I '$D(^PSD(58.8,PSALOC,0))!($P($G(^PSD(58.8,PSALOC,0)),"^")="") W !,"There are no Drug Accountability pharmacy locations with data." Q
S PSALOCN="",PSALOCN=$O(PSALOCA(PSALOCN)) Q:PSALOCN="" S PSALOC=0,PSALOC=+$O(PSALOCA(PSALOCN,PSALOC)) Q:'PSALOC
G EXIT
;
DISP ;Displays the available pharmacy locations.
S PSACNT=0,PSALOCN=""
F S PSALOCN=$O(PSALOCA(PSALOCN)) Q:PSALOCN="" D
.S PSALOC=0 F S PSALOC=+$O(PSALOCA(PSALOCN,PSALOC)) Q:'PSALOC D
..S PSACNT=PSACNT+1,PSAMNU(PSACNT,PSALOCN,PSALOC)=PSALOCA(PSALOCN,PSALOC)
..W !,$J(PSACNT,2),?5,PSALOCN S DATA=PSAMNU(PSACNT,PSALOCN,PSALOC) W:$P(DATA,"^",1)'="" ?25,$P($G(^PS(59.4,$P(DATA,"^",1),0)),"^") W:$P(DATA,"^",2)'="" ?50,$P($G(^PS(59,$P(DATA,"^",2),0)),"^")
..I $P(DATA,"^",3)'="" F X3=3:1 Q:$P(DATA,"^",X3)="" W:$P(DATA,"^",2)'="" "," W !,?50,$P($G(^PS(59,$P(DATA,"^",X3),0)),"^")
..;I $D(^PSD(58.8,PSALOC,"I")) W !,"***** INACTIVE *****"
;S PSACNT=$G(PSACNT)+1 W !,$J(PSACNT,2),?5,"New Pharmacy Location",! S PSANEW=PSACNT
;
SELECT S DIR(0)="L^1:"_PSACNT,DIR("A")="Select PHARMACY LOCATION",DIR("??")="^D HELP^PSAUTL3"
K PSALOC
S DIR("?")="Enter the number of the pharmacy location"
D ^DIR K DIR I 'Y S PSAOUT=1 G EXIT
S PSANUM=+Y
;I +Y=PSANEW G ADD
S PSALOCN=$O(PSAMNU(+Y,"")),PSALOC=+$O(PSAMNU(+Y,PSALOCN,0)),PSAITY=$S($E(PSALOCN)="C":3,$E(PSALOCN)="I":1,$E(PSALOCN)="O":2,1:"")
Q
;
EXIT ;Kills all variables except PSALOC array & PSAOUT
K AN,AN1,CNT,CNT1,CNT2,DA,DATA,DIC,DIE,DIR,PSA,PSAB,PSAC,PSACHK,PSACOMB,PSADEL,PSADRUG,PSADT,PSAERR,PSAI,PSAII,PSAINV,PSAIPS,PSAISIT,PSAISITN
K PSAIT,PSAITY,PSAIV,PSAIVCHG,PSAIVLOC,PSALEN,PSALOC,PSALOCA,PSALOCI,PSALOCN,PSAMNU,PSANEW,PSANLN,PSANLN1,PSANLN2,PSANOW,PSANUM,PSAO,PSAOC,PSAOK,PSAONE,PSAOP,PSAOSIT,PSAOSITN,PSAOU,PSAOUT,PSAPVMEN
K PSAQTY,PSASL,PSASTO,PSAT,PSATYP,PSAWARD,PSAY,X,X2,X3,XX,Y
Q
Q
;
ADD ;add locations
W !,"New location set-up"
S DIR(0)="S^1:INPATIENT;2:OUTPATIENT;3:COMBINED (IP/OP)",DIR("A")="Select Pharmacy type",DIR("?")="You can separate Inpatient and Outpatient or Combine into one location.",DIR("??")="PSA LOCATION EDIT"
D ^DIR I $G(DIRUT)=1!($G(DUOUT)=1) W !,"bye" G EXIT
S PSAITY=+Y,PSALOCN=Y(0) I $D(^PSD(58.8,"B",PSALOCN)) W !,"There is at least one entry setup with this name. Could we expand the name ?",!,"Something like "_PSALOCN_" (WEST WING) ?" D
NEWNM .;new Name
.R !!,"Please add text for a more descriptive name: ",AN1:DTIME I AN1["^"!('$T)!(AN1="") S PSAOUT=1 Q
.S AN=PSALOCN_" "_AN1
.I AN=PSALOCN W !,"Sorry that is what I have already" S PSAOUT=1 Q
.W !,"New name: "_AN
.I AN'=PSALOCN S PSALOCN=AN D
..W !,"Are you sure ? YES// " R AN:DTIME I AN["^" S PSAOUT=1 Q
..I AN="" S AN="Y"
..S AN=$E(AN,1) I "Nn"[AN S PSAOUT=1 Q
..I '$D(^PSD(58.8,"B",AN)) S PSANEW=1 Q
..I $D(^PSD(58.8,"B",AN)) W "sorry, this one exists" S PSAOUT=1 Q
I $G(PSAOUT)=1 G EXIT
I '$D(^PSD(58.8,"B",PSALOCN)) S PSANEW=1
I $G(PSANEW) S X=PSALOCN,DIC(0)="AEQMLZ",DLAYGO="58.8",DIC="^PSD(58.8," D FILE^DICN K DIC,DA S PSALOC=+Y,DIE="^PSD(58.8,",DA=+Y,DR="1////P" D ^DIE K DIE,DR,DA Q
Q
HDR W @IOF,?20,"<<<<< PHARMACY LOCATION SETUP SCREEN >>>>> ",!!,"LOCATION TYPES : INPATIENT, OUTPATIENT & COMBINED (IP/OP)",!!,"#",?5,"LOCATION ",?25,"INPATIENT SITE",?50,"OUTPATIENT SITE(s)",! F X=1:1:(IOM-4) W "="
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSALOC 4622 printed Sep 23, 2025@19:25:34 Page 2
PSALOC ;BIR/MNT,DB-Set Up/Edit a Pharmacy Location ;7/23/97
+1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**21**; 10/24/97
+2 ;
+3 ;References to ^PS(59, are covered under IA #212
+4 ;References to ^PS(59.4, are covered under IA #2505
+5 ;Due to merging facilities, this functionality is being
+6 KILL PSALOC,PSALOCA,PSAMNU
+7 SET PSALOC=+$ORDER(^PSD(58.8,"ADISP","P",0))
+8 IF 'PSALOC
WRITE !!?5,"No Drug Accountability location has been created yet."
GOTO ADD
+9 DO HDR
+10 ;
ORDER ;If more than one pharmacy location, collect them in alpha order.
+1 SET (PSACNT,PSALOC)=0
WRITE !
+2 FOR
SET PSALOC=+$ORDER(^PSD(58.8,"ADISP","P",PSALOC))
if 'PSALOC
QUIT
Begin DoDot:1
+3 if '$DATA(^PSD(58.8,PSALOC,0))!($PIECE($GET(^PSD(58.8,PSALOC,0)),"^")="")
QUIT
+4 IF +$GET(^PSD(58.8,PSALOC,"I"))
IF +^PSD(58.8,PSALOC,"I")'>DT
QUIT
+5 DO SITES^PSAUTL1
+6 KILL PSAISIT,PSAOSIT
+7 SET PSACNT=PSACNT+1
SET PSAONE=+PSALOC
+8 SET PSALOCA($PIECE(^PSD(58.8,PSALOC,0),"^"),PSALOC)=$PIECE(^(0),"^",3)_"^"_$PIECE(^(0),"^",10)
IF $DATA(^PSD(58.8,PSALOC,7))
Begin DoDot:2
+9 ;OP multiple has data
+10 SET X2=0
FOR
SET X2=$ORDER(^PSD(58.8,PSALOC,7,X2))
if X2'>0
QUIT
IF $PIECE(^PSD(58.8,PSALOC,0),"^",10)'=X2
IF $PIECE($GET(^PSD(58.8,PSALOC,7,X2,0)),"^",2)=""
SET PSALOCA($PIECE(^PSD(58.8,PSALOC,0),"^"),PSALOC)=PSALOCA($PIECE(^PSD(58.8,PSALOC,0),"^"),PSALOC)_"^"_X2
End DoDot:2
End DoDot:1
+11 SET PSACHK=$ORDER(PSALOCA(""))
IF PSACHK=""
GOTO ADD
+12 IF $GET(PSACNT)=1
GOTO DISP
+13 GOTO DISP
+14 ;
ONE ;only one
+1 SET PSALOC=PSAONE
+2 IF '$DATA(^PSD(58.8,PSALOC,0))!($PIECE($GET(^PSD(58.8,PSALOC,0)),"^")="")
WRITE !,"There are no Drug Accountability pharmacy locations with data."
QUIT
+3 SET PSALOCN=""
SET PSALOCN=$ORDER(PSALOCA(PSALOCN))
if PSALOCN=""
QUIT
SET PSALOC=0
SET PSALOC=+$ORDER(PSALOCA(PSALOCN,PSALOC))
if 'PSALOC
QUIT
+4 GOTO EXIT
+5 ;
DISP ;Displays the available pharmacy locations.
+1 SET PSACNT=0
SET PSALOCN=""
+2 FOR
SET PSALOCN=$ORDER(PSALOCA(PSALOCN))
if PSALOCN=""
QUIT
Begin DoDot:1
+3 SET PSALOC=0
FOR
SET PSALOC=+$ORDER(PSALOCA(PSALOCN,PSALOC))
if 'PSALOC
QUIT
Begin DoDot:2
+4 SET PSACNT=PSACNT+1
SET PSAMNU(PSACNT,PSALOCN,PSALOC)=PSALOCA(PSALOCN,PSALOC)
+5 WRITE !,$JUSTIFY(PSACNT,2),?5,PSALOCN
SET DATA=PSAMNU(PSACNT,PSALOCN,PSALOC)
if $PIECE(DATA,"^",1)'=""
WRITE ?25,$PIECE($GET(^PS(59.4,$PIECE(DATA,"^",1),0)),"^")
if $PIECE(DATA,"^",2)'=""
WRITE ?50,$PIECE($GET(^PS(59,$PIECE(DATA,"^",2),0)),"^")
+6 IF $PIECE(DATA,"^",3)'=""
FOR X3=3:1
if $PIECE(DATA,"^",X3)=""
QUIT
if $PIECE(DATA,"^",2)'=""
WRITE ","
WRITE !,?50,$PIECE($GET(^PS(59,$PIECE(DATA,"^",X3),0)),"^")
+7 ;I $D(^PSD(58.8,PSALOC,"I")) W !,"***** INACTIVE *****"
End DoDot:2
End DoDot:1
+8 ;S PSACNT=$G(PSACNT)+1 W !,$J(PSACNT,2),?5,"New Pharmacy Location",! S PSANEW=PSACNT
+9 ;
SELECT SET DIR(0)="L^1:"_PSACNT
SET DIR("A")="Select PHARMACY LOCATION"
SET DIR("??")="^D HELP^PSAUTL3"
+1 KILL PSALOC
+2 SET DIR("?")="Enter the number of the pharmacy location"
+3 DO ^DIR
KILL DIR
IF 'Y
SET PSAOUT=1
GOTO EXIT
+4 SET PSANUM=+Y
+5 ;I +Y=PSANEW G ADD
+6 SET PSALOCN=$ORDER(PSAMNU(+Y,""))
SET PSALOC=+$ORDER(PSAMNU(+Y,PSALOCN,0))
SET PSAITY=$SELECT($EXTRACT(PSALOCN)="C":3,$EXTRACT(PSALOCN)="I":1,$EXTRACT(PSALOCN)="O":2,1:"")
+7 QUIT
+8 ;
EXIT ;Kills all variables except PSALOC array & PSAOUT
+1 KILL AN,AN1,CNT,CNT1,CNT2,DA,DATA,DIC,DIE,DIR,PSA,PSAB,PSAC,PSACHK,PSACOMB,PSADEL,PSADRUG,PSADT,PSAERR,PSAI,PSAII,PSAINV,PSAIPS,PSAISIT,PSAISITN
+2 KILL PSAIT,PSAITY,PSAIV,PSAIVCHG,PSAIVLOC,PSALEN,PSALOC,PSALOCA,PSALOCI,PSALOCN,PSAMNU,PSANEW,PSANLN,PSANLN1,PSANLN2,PSANOW,PSANUM,PSAO,PSAOC,PSAOK,PSAONE,PSAOP,PSAOSIT,PSAOSITN,PSAOU,PSAOUT,PSAPVMEN
+3 KILL PSAQTY,PSASL,PSASTO,PSAT,PSATYP,PSAWARD,PSAY,X,X2,X3,XX,Y
+4 QUIT
+5 QUIT
+6 ;
ADD ;add locations
+1 WRITE !,"New location set-up"
+2 SET DIR(0)="S^1:INPATIENT;2:OUTPATIENT;3:COMBINED (IP/OP)"
SET DIR("A")="Select Pharmacy type"
SET DIR("?")="You can separate Inpatient and Outpatient or Combine into one location."
SET DIR("??")="PSA LOCATION EDIT"
+3 DO ^DIR
IF $GET(DIRUT)=1!($GET(DUOUT)=1)
WRITE !,"bye"
GOTO EXIT
+4 SET PSAITY=+Y
SET PSALOCN=Y(0)
IF $DATA(^PSD(58.8,"B",PSALOCN))
WRITE !,"There is at least one entry setup with this name. Could we expand the name ?",!,"Something like "_PSALOCN_" (WEST WING) ?"
Begin DoDot:1
NEWNM ;new Name
+1 READ !!,"Please add text for a more descriptive name: ",AN1:DTIME
IF AN1["^"!('$TEST)!(AN1="")
SET PSAOUT=1
QUIT
+2 SET AN=PSALOCN_" "_AN1
+3 IF AN=PSALOCN
WRITE !,"Sorry that is what I have already"
SET PSAOUT=1
QUIT
+4 WRITE !,"New name: "_AN
+5 IF AN'=PSALOCN
SET PSALOCN=AN
Begin DoDot:2
+6 WRITE !,"Are you sure ? YES// "
READ AN:DTIME
IF AN["^"
SET PSAOUT=1
QUIT
+7 IF AN=""
SET AN="Y"
+8 SET AN=$EXTRACT(AN,1)
IF "Nn"[AN
SET PSAOUT=1
QUIT
+9 IF '$DATA(^PSD(58.8,"B",AN))
SET PSANEW=1
QUIT
+10 IF $DATA(^PSD(58.8,"B",AN))
WRITE "sorry, this one exists"
SET PSAOUT=1
QUIT
End DoDot:2
End DoDot:1
+11 IF $GET(PSAOUT)=1
GOTO EXIT
+12 IF '$DATA(^PSD(58.8,"B",PSALOCN))
SET PSANEW=1
+13 IF $GET(PSANEW)
SET X=PSALOCN
SET DIC(0)="AEQMLZ"
SET DLAYGO="58.8"
SET DIC="^PSD(58.8,"
DO FILE^DICN
KILL DIC,DA
SET PSALOC=+Y
SET DIE="^PSD(58.8,"
SET DA=+Y
SET DR="1////P"
DO ^DIE
KILL DIE,DR,DA
QUIT
+14 QUIT
HDR WRITE @IOF,?20,"<<<<< PHARMACY LOCATION SETUP SCREEN >>>>> ",!!,"LOCATION TYPES : INPATIENT, OUTPATIENT & COMBINED (IP/OP)",!!,"#",?5,"LOCATION ",?25,"INPATIENT SITE",?50,"OUTPATIENT SITE(s)",!
FOR X=1:1:(IOM-4)
WRITE "="
+1 QUIT
