PSALOCO ;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
;PSALOC = Internal entry number for location
;References to ^PSDRUG( are covered by IA #2095
;PSALOCN = Location Name
;PSALOCA(PSALOCN,PSALOC)=ip site ^ Op site ^ more op sites
;
K PSALOC
PSAOPT W @IOF,!!,?20,"<<<< PHARMACY LOCATION OPTION SCREEN >>>>",! F X=1:1:(IOM-2) W "="
W !!,"# OPTION NAME",!,"---------------",!,"1. CHANGE LOCATION TYPE",!,"2. CHANGE LOCATION NAME",!,"3. INPATIENT SITE SELECTION (not available for Outpatient locations)"
W !,"4. OUTPATIENT SITE SELECTION (not available for Inpatient locations)"
W !,"5. IV ROOM SETUP ",!,"6. WARD SETUP"
W !,"7. INACTIVATE PHARMACY LOCATION",!,"8. ADD/EDIT DRUGS",!,"9. SET MAINTAIN REORDER LEVELS FLAG"
W !,"10. REACTIVATE A PHARMACY LOCATION."
W !,"11. CREATE NEW PHARMACY LOCATION"
OPTASK W !!,"Select Option Number: " R AN:DTIME G Q:AN["^" G Q:AN="" G HLP:"?"[AN I AN<1!(AN>11) W !,"Please enter a number between 1 & 11." K AN G OPTASK
S PSAOPT=AN I AN="10" G 10
I PSAOPT="11" G ADD^PSALOC
I $G(PSALOC)="" D ^PSALOC G Q:$G(PSALOC)'>0 G @PSAOPT
1 S PSAHDR="CHANGE LOCATION TYPE" D HDR
D ^PSALOC2
G NXT
2 S PSAHDR="CHANGE LOCATION NAME" D HDR
W !,"The new location name must at least contain : " S PSACHKR=$S($E(PSALOCN)="C":"COMBINED (IP/OP)",$E(PSALOCN)="I":"INPATIENT",1:"OUTPATIENT") W PSACHKR
ASK2 R !,"Please enter the new name : ",AN:DTIME G NXT:AN["^" I AN="" W " ??? " G ASK2
S PSALOCN1=AN I $E(PSALOCN1,1,$L(PSACHKR))'=PSACHKR W !,"Sorry, the new name must start with "_PSACHKR G ASK2
I $D(^PSD(58.8,"B",PSALOCN1)) W !,"Sorry, this name is already setup." K PSALOCN1 G ASK2
S $P(^PSD(58.8,PSALOC,0),"^")=PSALOCN1
K ^PSD(58.8,"B",PSALOCN,PSALOC)
S ^PSD(58.8,"B",PSALOCN1,PSALOC)=""
S PSALOCA(PSALOCN1,PSALOC)=PSALOCA(PSALOCN,PSALOC)
S PSALOCA(PSALOCN1,PSALOC)=PSALOCA(PSALOCN,PSALOC)
S PSAMNU(PSANUM,PSALOCN1,PSALOC)=PSAMNU(PSANUM,PSALOCN,PSALOC) K PSAMNU(PSANUM,PSALOCN,PSALOC)
S PSALOCN=PSALOCN1 K PSALOCN1
G NXT
3 S PSAHDR="INPATIENT SITE SELECTION" D HDR
I $E(PSALOCN)="O" W !!,"Sorry, Inpatient Site association is not permitted for an Outpatient Location" G QUIT3
I $P($G(PSALOCA(PSALOCN,PSALOC)),"^")="" S (PSA(1),PSA(2))=0 G INP
S PSAISIT=$P($G(PSALOCA(PSALOCN,PSALOC)),"^")
S PSAISIT(1)=$P($G(^PS(59.4,PSAISIT,0)),"^") ;Inpatient Site Name
W !,"Inpatient Site : ",$P($G(^PS(59.4,$P($G(PSALOCA(PSALOCN,PSALOC)),"^"),0)),"^")
W !,"Change this site? NO// " R AN:DTIME I AN["^" G QUIT3
S:AN="" AN="N" S AN=$E(AN) I "NnyY"'[AN W !,"Answer 'Y' for yes to change which Inpatient Site is associated with this",!,"pharmacy location.",! D EOP G 3
I "nN"[AN G QUIT3
S PSAIVCHG=1
S (PSA(1),PSA(2))=0
INP S PSA(1)=$O(^PS(59.4,PSA(1))) G INPQ:PSA(1)'>0 I $P($G(^PS(59.4,PSA(1),0)),"^",26)=1 S PSA(2)=PSA(2)+1,PSAB=PSA(1)
G INP
INPQ ;End loop through inpatient file
I PSA(2)<1 W !,"An Inpatient Site has not been identified for AR/WS.",!,"AR/WS dispensing data cannot be gathered" G QUIT3
S:PSA(2)=1 PSAISIT=PSAB
I $G(PSAIVCHG)=1,PSA(2)=1 W !,"Sorry, but this is the only inpatient site in the Inpatient Site file ? ",! G QUIT3
D:PSA(2)>1 I Y<1 S PSAOU=1 G QUIT3
.W !!,"Because there is more than one Inpatient Site at this facility, I need you to",! S DIC="^PS(59.4,",DIC(0)="AEQMZ",DIC("A")="Select an AR/WS Inpatient Site Name : ",DIC("S")="I $P($G(^(0)),U,26)=1" D ^DIC S PSAISIT=+Y
.K DIC S:$D(DUOUT)!($D(DTOUT))!(X="") PSAERR=1 Q
.I PSAITY=3&(Y<1) S PSAOU=1 S PSAERR=1 Q
.S PSAISIT=+Y
I $G(PSAERR)=1 G QUIT3
S PSALOCI=0 F S PSALOCI=$O(^PSD(58.8,"ASITE",PSAISIT,"P",PSALOCI)) Q:'PSALOCI I '$P($G(^PSD(58.8,PSALOCI,"I")),"^") W !,"Already Assigned to : "_$P($G(^PSD(58.8,PSALOCI,0)),"^") S PSAERR=1
I $G(PSAERR)'>0,$G(PSAISIT)>0,$G(PSALOC)>0 S DIE="^PSD(58.8,",DA=PSALOC,DR="2////^S X=PSAISIT" D ^DIE S $P(PSALOCA(PSALOCN,PSALOC),"^")=PSAISIT
;
QUIT3 G NXT
4 S PSAHDR="OUTPATIENT SITE SELECTION" D HDR
I $E(PSALOCN)="I" W !!,"Sorry, Outpatient Site association is not permitted for an Inpatient Location.",! G QUIT4
I $G(PSAITY)=1 G QUIT4
S PSAOSIT=$P($G(PSALOCA(PSALOCN,PSALOC)),"^",2)
W !!,"Outpatient site selection affects the collection of dispensing data.",!,"When a prescription is released through Outpatient pharmacy, the data is stored "
W !,"then retrieved by the Drug Accountability back-ground job that runs each night.",!!
;
OPASK ;get Outpatient site(s)
I $G(PSAOSIT)'="" S PSAOSIT(1)=$P($G(^PS(59,PSAOSIT,0)),"^")
W !,"Primary Outpatient Site : ",$S($G(PSAOSIT)="":"Unknown",1:$G(PSAOSIT(1)))
D OPSITES I $O(PSAOSIT(1))'="" W !,"Secondary Site(s) : " F X=2:1 Q:$G(PSAOSIT(X))="" I PSAOSIT(X)'=PSAOSIT W ?34,$P($G(^PS(59,PSAOSIT(X),0)),"^"),!
K DIC,DA,DO,DR,DIR,DIE
S DIC(0)="AEQMZL",DA(1)=PSALOC,DIC="^PSD(58.8,PSALOC,7,",DIC("A")="Select Outpatient Site: " D ^DIC
I +Y'>0 G QUIT4
;Check for existence of op site in PSALOCA(PSALOCN,PSALOC)
S DA=+Y
S PSAOSIT=+Y,PSAOSIT(1)=Y(0,0),DIE="^PSD(58.8,PSALOC,7,",DR="1" D ^DIE
;
I $P($G(PSALOCA(PSALOCN,PSALOC)),"^",2)="" S $P(PSALOCA(PSALOCN,PSALOC),"^",2)=PSAOSIT G QUIT4
S NOMATCH=0,CNTR=1 F X=2:1 Q:$G(PSAOSIT(X))="" S CNTR=$G(CNTR)+1 I PSAOSIT(X)=+PSAOSIT S NOMATCH=1
I $G(NOMATCH)=0 S $P(PSALOCA(PSALOCN,PSALOC),"^",(CNTR+1))=+PSAOSIT
;
QUIT4 G NXT
5 S PSAHDR="IV ROOM SETUP" D HDR
D IV^PSAENTO
QUIT5 G NXT
6 S PSAHDR="WARD LOCATION SETUP" D HDR
I $G(PSAISIT)'>0,$P(PSALOCA(PSALOCN,PSALOC),"^")'="" S PSAISIT=$P(PSALOCA(PSALOCN,PSALOC),"^")
I $G(PSAISIT)'>0 W !!,"Sorry, I cannot find an Inpatient Site associated with this location.",! G WARDQ
I $O(^PSD(58.8,+PSALOC,3,0))="" W !,"No wards are currently assigned to this location."
S PSAWARD=0 I $O(^PSD(58.8,+PSALOC,3,0)) W !,PSALOCN," is set up to gather AR/WS dispensing data for : ",!!,$P($G(^PS(59.4,+PSAISIT,0)),U),"," D
.S PSA(3)=0 F S PSA(3)=$O(^PSD(58.8,+PSALOC,3,+PSA(3))) Q:'PSA(3) W:$X+10>IOM ! W $P($G(^DIC(42,+PSA(3),0)),U),$S($O(^PSD(58.8,+PSALOC,3,+PSA(3))):", ",1:".")
EDTWRD ;Edit Wards
R !!,"Do you want to add/edit the wards accociated with this location? NO // ",AN:DTIME G WARDQ:AN["^" I AN="" S AN="N"
S AN=$E(AN) I "yYnN"'[AN W !,"Answer Yes, and we'll loop through the ward file, and either add new wards,",!,"or delete wards already associated with this location. " G EDTWRD
I "Nn"[AN G WARDQ
S PSAWARD=0
WARDLP S PSAWARD=$O(^DIC(42,PSAWARD)) G WARDQ:PSAWARD'>0 W !,$P($G(^DIC(42,PSAWARD,0)),"^")
I '$D(^PSD(58.8,PSALOC,3,PSAWARD,0)) G WARD1
WARDASK R ?25,"Remove association with location? NO // ",AN:DTIME I AN["^" S PSAERR=1 G WARDQ
I AN="" G WARDLP
I "YyNn"'[AN W !
I "yY"[AN W ?(IOM-9),"removed" S DIK="^PSD(58.8,+PSALOC,3,",DIC(0)="AEMQ",DA(1)=PSALOC,DA=PSAWARD D ^DIK
G WARDLP
;
WARD1 ;not currently assigned
I $D(^PSD(58.8,"AB",PSAWARD)),$O(^PSD(58.8,"AB",PSAWARD,0))'=PSALOC W ?30,"This ward is already associated with : "_$P($G(^PSD(58.8,$O(^PSD(58.8,"AB",PSAWARD,0)),0)),"^") G WARDLP
R ?40,"Add to location ? NO // : ",AN:DTIME G WARDQ:AN["^" I AN="" G WARDLP
S AN=$E(AN) I "nNyY"'[AN W !,"Do you want to add this ward to this location?" K AN G WARD1
I "Nn"[AN G WARDLP
W ?(IOM-7),"Adding" S (DINUM,X)=PSAWARD,DIC="^PSD(58.8,+PSALOC,3,",DA(1)=PSALOC,DIC(0)="LNX" D FILE^DICN
G WARDLP
WARDQ ;
G NXT
7 S PSAHDR="EDIT INACTIVATION DATA" D HDR
S DIE="^PSD(58.8,",DA=PSALOC,DR="4" D ^DIE
G NXT
8 S PSAHDR="ADD/EDIT DRUGS FOR LOCATION" D HDR
I $O(^PSD(58.8,PSALOC,1,0))>0 G 83
81 R !,"Do you want to transfer drugs from another location? NO// ",AN:DTIME G Q:AN["^" S AN=$E(AN) I "nN"[AN G 83
I "YyNn"'[AN W !,"Answer 'Y'es to transfer all the drugs from another location to this location.",!,"Please note that the drugs will be inactivated in the old location." G 81
82 R !,"Transfer the drug's balance, stock level, etc., as well? YES // ",AN:DTIME G Q:AN["^" S AN=$E(AN) I "nN"'[AN S PSATFER=0
I "YyNn"'[AN W !!,"Answer 'Y'es to transfer all the current information about the drug to the new",!," location.",!! G 82
I "Yy"[AN S PSATFER=1
811 S PSALOCB=PSALOC K PSALOC D ^PSALOC G Q:$G(PSALOC)'>0 S PSALOC2=PSALOC,PSALOC=PSALOCB K PSALOCB I PSALOC2=PSALOC W !!,"Sorry, that is the current location." D EOP G 811
S X1=0 F S X1=$O(^PSD(58.8,PSALOC2,1,X1)) Q:X1'>0 W !,$P($G(^PSDRUG(X1,0)),"^") D
.S ^PSD(58.8,PSALOC,1,X1,0)=X1 I $G(PSATFER)=1 S ^PSD(58.8,PSALOC,1,X1,0)=^PSD(58.8,PSALOC2,1,X1,0)
.S ^PSD(58.8,PSALOC,1,"B",X1,X1)="" ;drug xref
D EOP G NXT
83 K DIC,DIR S PSAOPT="PSALOC" D GETDRUG^PSADRUGP K PSAOPT
G NXT
9 S PSAHDR="SET/DELETE MAINTAIN REORDER LEVELS FLAG"
S DIE="^PSD(58.8,",DA=PSALOC,DR=34 D ^DIE K DA,DIE
G NXT
10 S DIC(0)="AEQMZ",DIC="^PSD(58.8,",DIC("A")="Select Inactive Pharmacy Location: ",DIC("S")="I $D(^PSD(58.8,+Y,""I""))"
D ^DIC G Q:+Y'>0 S DIE="^PSD(58.8,",DA=+Y,DR="4" D ^DIE
I $P($G(^PSD(58.8,DA,"I")),"^")="" K ^PSD(58.8,DA,"I") W !,$P(^PSD(58.8,DA,0),"^")," Reactivated."
Q
PSA10 S PSAHDR="SETUP RECIPIENTS OF MAILMESSAGE" W @IOF,!,PSAHDR_" SCREEN",! F X=1:1:(IOM-1) W "="
D PSASETUP^PSALOC1,EOP Q
HLP W !!,"Display help for which item # ?" R AN:DTIME G PSALOCO:"^"[AN I AN<1!(AN>10) G OPTASK
S X="PSAHLP"_AN_"^PSALOC1" D @X G OPTASK
EOP F X=$Y:1:(IOSL-5) W !
R !,"Press RETURN/ENTER to continue: ",AN:DTIME
Q
Q G EXIT^PSALOC
HDR S PSAHDR=PSAHDR_" SCREEN" W @IOF,!,PSAHDR_" for : "_PSALOCN,! F X=1:1:(IOM-1) W "="
;
W ! Q
NXT D EOP G PSALOCO
OPSITES ;
F X=2:1 Q:'$D(PSAOSIT(X)) K PSAOSIT(X)
F X=2:1 Q:$P($G(PSALOCA(PSALOCN,PSALOC)),"^",X)="" S PSAOSIT(X)=$P($G(PSALOCA(PSALOCN,PSALOC)),"^",X)
Q
ADD S X6=$$MG^XMBGRP(PSAGROUP,0,DUZ,0,.XMY,,0)
W !,$S($G(X6)>0:"Ok, addition completed.",1:"error in adding users ? "),!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSALOCO 9940 printed Sep 23, 2025@19:25:37 Page 2
PSALOCO ;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 ;PSALOC = Internal entry number for location
+6 ;References to ^PSDRUG( are covered by IA #2095
+7 ;PSALOCN = Location Name
+8 ;PSALOCA(PSALOCN,PSALOC)=ip site ^ Op site ^ more op sites
+9 ;
+10 KILL PSALOC
PSAOPT WRITE @IOF,!!,?20,"<<<< PHARMACY LOCATION OPTION SCREEN >>>>",!
FOR X=1:1:(IOM-2)
WRITE "="
+1 WRITE !!,"# OPTION NAME",!,"---------------",!,"1. CHANGE LOCATION TYPE",!,"2. CHANGE LOCATION NAME",!,"3. INPATIENT SITE SELECTION (not available for Outpatient locations)"
+2 WRITE !,"4. OUTPATIENT SITE SELECTION (not available for Inpatient locations)"
+3 WRITE !,"5. IV ROOM SETUP ",!,"6. WARD SETUP"
+4 WRITE !,"7. INACTIVATE PHARMACY LOCATION",!,"8. ADD/EDIT DRUGS",!,"9. SET MAINTAIN REORDER LEVELS FLAG"
+5 WRITE !,"10. REACTIVATE A PHARMACY LOCATION."
+6 WRITE !,"11. CREATE NEW PHARMACY LOCATION"
OPTASK WRITE !!,"Select Option Number: "
READ AN:DTIME
if AN["^"
GOTO Q
if AN=""
GOTO Q
if "?"[AN
GOTO HLP
IF AN<1!(AN>11)
WRITE !,"Please enter a number between 1 & 11."
KILL AN
GOTO OPTASK
+1 SET PSAOPT=AN
IF AN="10"
GOTO 10
+2 IF PSAOPT="11"
GOTO ADD^PSALOC
+3 IF $GET(PSALOC)=""
DO ^PSALOC
if $GET(PSALOC)'>0
GOTO Q
GOTO @PSAOPT
1 SET PSAHDR="CHANGE LOCATION TYPE"
DO HDR
+1 DO ^PSALOC2
+2 GOTO NXT
2 SET PSAHDR="CHANGE LOCATION NAME"
DO HDR
+1 WRITE !,"The new location name must at least contain : "
SET PSACHKR=$SELECT($EXTRACT(PSALOCN)="C":"COMBINED (IP/OP)",$EXTRACT(PSALOCN)="I":"INPATIENT",1:"OUTPATIENT")
WRITE PSACHKR
ASK2 READ !,"Please enter the new name : ",AN:DTIME
if AN["^"
GOTO NXT
IF AN=""
WRITE " ??? "
GOTO ASK2
+1 SET PSALOCN1=AN
IF $EXTRACT(PSALOCN1,1,$LENGTH(PSACHKR))'=PSACHKR
WRITE !,"Sorry, the new name must start with "_PSACHKR
GOTO ASK2
+2 IF $DATA(^PSD(58.8,"B",PSALOCN1))
WRITE !,"Sorry, this name is already setup."
KILL PSALOCN1
GOTO ASK2
+3 SET $PIECE(^PSD(58.8,PSALOC,0),"^")=PSALOCN1
+4 KILL ^PSD(58.8,"B",PSALOCN,PSALOC)
+5 SET ^PSD(58.8,"B",PSALOCN1,PSALOC)=""
+6 SET PSALOCA(PSALOCN1,PSALOC)=PSALOCA(PSALOCN,PSALOC)
+7 SET PSALOCA(PSALOCN1,PSALOC)=PSALOCA(PSALOCN,PSALOC)
+8 SET PSAMNU(PSANUM,PSALOCN1,PSALOC)=PSAMNU(PSANUM,PSALOCN,PSALOC)
KILL PSAMNU(PSANUM,PSALOCN,PSALOC)
+9 SET PSALOCN=PSALOCN1
KILL PSALOCN1
+10 GOTO NXT
3 SET PSAHDR="INPATIENT SITE SELECTION"
DO HDR
+1 IF $EXTRACT(PSALOCN)="O"
WRITE !!,"Sorry, Inpatient Site association is not permitted for an Outpatient Location"
GOTO QUIT3
+2 IF $PIECE($GET(PSALOCA(PSALOCN,PSALOC)),"^")=""
SET (PSA(1),PSA(2))=0
GOTO INP
+3 SET PSAISIT=$PIECE($GET(PSALOCA(PSALOCN,PSALOC)),"^")
+4 ;Inpatient Site Name
SET PSAISIT(1)=$PIECE($GET(^PS(59.4,PSAISIT,0)),"^")
+5 WRITE !,"Inpatient Site : ",$PIECE($GET(^PS(59.4,$PIECE($GET(PSALOCA(PSALOCN,PSALOC)),"^"),0)),"^")
+6 WRITE !,"Change this site? NO// "
READ AN:DTIME
IF AN["^"
GOTO QUIT3
+7 if AN=""
SET AN="N"
SET AN=$EXTRACT(AN)
IF "NnyY"'[AN
WRITE !,"Answer 'Y' for yes to change which Inpatient Site is associated with this",!,"pharmacy location.",!
DO EOP
GOTO 3
+8 IF "nN"[AN
GOTO QUIT3
+9 SET PSAIVCHG=1
+10 SET (PSA(1),PSA(2))=0
INP SET PSA(1)=$ORDER(^PS(59.4,PSA(1)))
if PSA(1)'>0
GOTO INPQ
IF $PIECE($GET(^PS(59.4,PSA(1),0)),"^",26)=1
SET PSA(2)=PSA(2)+1
SET PSAB=PSA(1)
+1 GOTO INP
INPQ ;End loop through inpatient file
+1 IF PSA(2)<1
WRITE !,"An Inpatient Site has not been identified for AR/WS.",!,"AR/WS dispensing data cannot be gathered"
GOTO QUIT3
+2 if PSA(2)=1
SET PSAISIT=PSAB
+3 IF $GET(PSAIVCHG)=1
IF PSA(2)=1
WRITE !,"Sorry, but this is the only inpatient site in the Inpatient Site file ? ",!
GOTO QUIT3
+4 if PSA(2)>1
Begin DoDot:1
+5 WRITE !!,"Because there is more than one Inpatient Site at this facility, I need you to",!
SET DIC="^PS(59.4,"
SET DIC(0)="AEQMZ"
SET DIC("A")="Select an AR/WS Inpatient Site Name : "
SET DIC("S")="I $P($G(^(0)),U,26)=1"
DO ^DIC
SET PSAISIT=+Y
+6 KILL DIC
if $DATA(DUOUT)!($DATA(DTOUT))!(X="")
SET PSAERR=1
QUIT
+7 IF PSAITY=3&(Y<1)
SET PSAOU=1
SET PSAERR=1
QUIT
+8 SET PSAISIT=+Y
End DoDot:1
IF Y<1
SET PSAOU=1
GOTO QUIT3
+9 IF $GET(PSAERR)=1
GOTO QUIT3
+10 SET PSALOCI=0
FOR
SET PSALOCI=$ORDER(^PSD(58.8,"ASITE",PSAISIT,"P",PSALOCI))
if 'PSALOCI
QUIT
IF '$PIECE($GET(^PSD(58.8,PSALOCI,"I")),"^")
WRITE !,"Already Assigned to : "_$PIECE($GET(^PSD(58.8,PSALOCI,0)),"^")
SET PSAERR=1
+11 IF $GET(PSAERR)'>0
IF $GET(PSAISIT)>0
IF $GET(PSALOC)>0
SET DIE="^PSD(58.8,"
SET DA=PSALOC
SET DR="2////^S X=PSAISIT"
DO ^DIE
SET $PIECE(PSALOCA(PSALOCN,PSALOC),"^")=PSAISIT
+12 ;
QUIT3 GOTO NXT
4 SET PSAHDR="OUTPATIENT SITE SELECTION"
DO HDR
+1 IF $EXTRACT(PSALOCN)="I"
WRITE !!,"Sorry, Outpatient Site association is not permitted for an Inpatient Location.",!
GOTO QUIT4
+2 IF $GET(PSAITY)=1
GOTO QUIT4
+3 SET PSAOSIT=$PIECE($GET(PSALOCA(PSALOCN,PSALOC)),"^",2)
+4 WRITE !!,"Outpatient site selection affects the collection of dispensing data.",!,"When a prescription is released through Outpatient pharmacy, the data is stored "
+5 WRITE !,"then retrieved by the Drug Accountability back-ground job that runs each night.",!!
+6 ;
OPASK ;get Outpatient site(s)
+1 IF $GET(PSAOSIT)'=""
SET PSAOSIT(1)=$PIECE($GET(^PS(59,PSAOSIT,0)),"^")
+2 WRITE !,"Primary Outpatient Site : ",$SELECT($GET(PSAOSIT)="":"Unknown",1:$GET(PSAOSIT(1)))
+3 DO OPSITES
IF $ORDER(PSAOSIT(1))'=""
WRITE !,"Secondary Site(s) : "
FOR X=2:1
if $GET(PSAOSIT(X))=""
QUIT
IF PSAOSIT(X)'=PSAOSIT
WRITE ?34,$PIECE($GET(^PS(59,PSAOSIT(X),0)),"^"),!
+4 KILL DIC,DA,DO,DR,DIR,DIE
+5 SET DIC(0)="AEQMZL"
SET DA(1)=PSALOC
SET DIC="^PSD(58.8,PSALOC,7,"
SET DIC("A")="Select Outpatient Site: "
DO ^DIC
+6 IF +Y'>0
GOTO QUIT4
+7 ;Check for existence of op site in PSALOCA(PSALOCN,PSALOC)
+8 SET DA=+Y
+9 SET PSAOSIT=+Y
SET PSAOSIT(1)=Y(0,0)
SET DIE="^PSD(58.8,PSALOC,7,"
SET DR="1"
DO ^DIE
+10 ;
+11 IF $PIECE($GET(PSALOCA(PSALOCN,PSALOC)),"^",2)=""
SET $PIECE(PSALOCA(PSALOCN,PSALOC),"^",2)=PSAOSIT
GOTO QUIT4
+12 SET NOMATCH=0
SET CNTR=1
FOR X=2:1
if $GET(PSAOSIT(X))=""
QUIT
SET CNTR=$GET(CNTR)+1
IF PSAOSIT(X)=+PSAOSIT
SET NOMATCH=1
+13 IF $GET(NOMATCH)=0
SET $PIECE(PSALOCA(PSALOCN,PSALOC),"^",(CNTR+1))=+PSAOSIT
+14 ;
QUIT4 GOTO NXT
5 SET PSAHDR="IV ROOM SETUP"
DO HDR
+1 DO IV^PSAENTO
QUIT5 GOTO NXT
6 SET PSAHDR="WARD LOCATION SETUP"
DO HDR
+1 IF $GET(PSAISIT)'>0
IF $PIECE(PSALOCA(PSALOCN,PSALOC),"^")'=""
SET PSAISIT=$PIECE(PSALOCA(PSALOCN,PSALOC),"^")
+2 IF $GET(PSAISIT)'>0
WRITE !!,"Sorry, I cannot find an Inpatient Site associated with this location.",!
GOTO WARDQ
+3 IF $ORDER(^PSD(58.8,+PSALOC,3,0))=""
WRITE !,"No wards are currently assigned to this location."
+4 SET PSAWARD=0
IF $ORDER(^PSD(58.8,+PSALOC,3,0))
WRITE !,PSALOCN," is set up to gather AR/WS dispensing data for : ",!!,$PIECE($GET(^PS(59.4,+PSAISIT,0)),U),","
Begin DoDot:1
+5 SET PSA(3)=0
FOR
SET PSA(3)=$ORDER(^PSD(58.8,+PSALOC,3,+PSA(3)))
if 'PSA(3)
QUIT
if $X+10>IOM
WRITE !
WRITE $PIECE($GET(^DIC(42,+PSA(3),0)),U),$SELECT($ORDER(^PSD(58.8,+PSALOC,3,+PSA(3))):", ",1:".")
End DoDot:1
EDTWRD ;Edit Wards
+1 READ !!,"Do you want to add/edit the wards accociated with this location? NO // ",AN:DTIME
if AN["^"
GOTO WARDQ
IF AN=""
SET AN="N"
+2 SET AN=$EXTRACT(AN)
IF "yYnN"'[AN
WRITE !,"Answer Yes, and we'll loop through the ward file, and either add new wards,",!,"or delete wards already associated with this location. "
GOTO EDTWRD
+3 IF "Nn"[AN
GOTO WARDQ
+4 SET PSAWARD=0
WARDLP SET PSAWARD=$ORDER(^DIC(42,PSAWARD))
if PSAWARD'>0
GOTO WARDQ
WRITE !,$PIECE($GET(^DIC(42,PSAWARD,0)),"^")
+1 IF '$DATA(^PSD(58.8,PSALOC,3,PSAWARD,0))
GOTO WARD1
WARDASK READ ?25,"Remove association with location? NO // ",AN:DTIME
IF AN["^"
SET PSAERR=1
GOTO WARDQ
+1 IF AN=""
GOTO WARDLP
+2 IF "YyNn"'[AN
WRITE !
+3 IF "yY"[AN
WRITE ?(IOM-9),"removed"
SET DIK="^PSD(58.8,+PSALOC,3,"
SET DIC(0)="AEMQ"
SET DA(1)=PSALOC
SET DA=PSAWARD
DO ^DIK
+4 GOTO WARDLP
+5 ;
WARD1 ;not currently assigned
+1 IF $DATA(^PSD(58.8,"AB",PSAWARD))
IF $ORDER(^PSD(58.8,"AB",PSAWARD,0))'=PSALOC
WRITE ?30,"This ward is already associated with : "_$PIECE($GET(^PSD(58.8,$ORDER(^PSD(58.8,"AB",PSAWARD,0)),0)),"^")
GOTO WARDLP
+2 READ ?40,"Add to location ? NO // : ",AN:DTIME
if AN["^"
GOTO WARDQ
IF AN=""
GOTO WARDLP
+3 SET AN=$EXTRACT(AN)
IF "nNyY"'[AN
WRITE !,"Do you want to add this ward to this location?"
KILL AN
GOTO WARD1
+4 IF "Nn"[AN
GOTO WARDLP
+5 WRITE ?(IOM-7),"Adding"
SET (DINUM,X)=PSAWARD
SET DIC="^PSD(58.8,+PSALOC,3,"
SET DA(1)=PSALOC
SET DIC(0)="LNX"
DO FILE^DICN
+6 GOTO WARDLP
WARDQ ;
+1 GOTO NXT
7 SET PSAHDR="EDIT INACTIVATION DATA"
DO HDR
+1 SET DIE="^PSD(58.8,"
SET DA=PSALOC
SET DR="4"
DO ^DIE
+2 GOTO NXT
8 SET PSAHDR="ADD/EDIT DRUGS FOR LOCATION"
DO HDR
+1 IF $ORDER(^PSD(58.8,PSALOC,1,0))>0
GOTO 83
81 READ !,"Do you want to transfer drugs from another location? NO// ",AN:DTIME
if AN["^"
GOTO Q
SET AN=$EXTRACT(AN)
IF "nN"[AN
GOTO 83
+1 IF "YyNn"'[AN
WRITE !,"Answer 'Y'es to transfer all the drugs from another location to this location.",!,"Please note that the drugs will be inactivated in the old location."
GOTO 81
82 READ !,"Transfer the drug's balance, stock level, etc., as well? YES // ",AN:DTIME
if AN["^"
GOTO Q
SET AN=$EXTRACT(AN)
IF "nN"'[AN
SET PSATFER=0
+1 IF "YyNn"'[AN
WRITE !!,"Answer 'Y'es to transfer all the current information about the drug to the new",!," location.",!!
GOTO 82
+2 IF "Yy"[AN
SET PSATFER=1
811 SET PSALOCB=PSALOC
KILL PSALOC
DO ^PSALOC
if $GET(PSALOC)'>0
GOTO Q
SET PSALOC2=PSALOC
SET PSALOC=PSALOCB
KILL PSALOCB
IF PSALOC2=PSALOC
WRITE !!,"Sorry, that is the current location."
DO EOP
GOTO 811
+1 SET X1=0
FOR
SET X1=$ORDER(^PSD(58.8,PSALOC2,1,X1))
if X1'>0
QUIT
WRITE !,$PIECE($GET(^PSDRUG(X1,0)),"^")
Begin DoDot:1
+2 SET ^PSD(58.8,PSALOC,1,X1,0)=X1
IF $GET(PSATFER)=1
SET ^PSD(58.8,PSALOC,1,X1,0)=^PSD(58.8,PSALOC2,1,X1,0)
+3 ;drug xref
SET ^PSD(58.8,PSALOC,1,"B",X1,X1)=""
End DoDot:1
+4 DO EOP
GOTO NXT
83 KILL DIC,DIR
SET PSAOPT="PSALOC"
DO GETDRUG^PSADRUGP
KILL PSAOPT
+1 GOTO NXT
9 SET PSAHDR="SET/DELETE MAINTAIN REORDER LEVELS FLAG"
+1 SET DIE="^PSD(58.8,"
SET DA=PSALOC
SET DR=34
DO ^DIE
KILL DA,DIE
+2 GOTO NXT
10 SET DIC(0)="AEQMZ"
SET DIC="^PSD(58.8,"
SET DIC("A")="Select Inactive Pharmacy Location: "
SET DIC("S")="I $D(^PSD(58.8,+Y,""I""))"
+1 DO ^DIC
if +Y'>0
GOTO Q
SET DIE="^PSD(58.8,"
SET DA=+Y
SET DR="4"
DO ^DIE
+2 IF $PIECE($GET(^PSD(58.8,DA,"I")),"^")=""
KILL ^PSD(58.8,DA,"I")
WRITE !,$PIECE(^PSD(58.8,DA,0),"^")," Reactivated."
+3 QUIT
PSA10 SET PSAHDR="SETUP RECIPIENTS OF MAILMESSAGE"
WRITE @IOF,!,PSAHDR_" SCREEN",!
FOR X=1:1:(IOM-1)
WRITE "="
+1 DO PSASETUP^PSALOC1
DO EOP
QUIT
HLP WRITE !!,"Display help for which item # ?"
READ AN:DTIME
if "^"[AN
GOTO PSALOCO
IF AN<1!(AN>10)
GOTO OPTASK
+1 SET X="PSAHLP"_AN_"^PSALOC1"
DO @X
GOTO OPTASK
EOP FOR X=$Y:1:(IOSL-5)
WRITE !
+1 READ !,"Press RETURN/ENTER to continue: ",AN:DTIME
+2 QUIT
Q GOTO EXIT^PSALOC
HDR SET PSAHDR=PSAHDR_" SCREEN"
WRITE @IOF,!,PSAHDR_" for : "_PSALOCN,!
FOR X=1:1:(IOM-1)
WRITE "="
+1 ;
+2 WRITE !
QUIT
NXT DO EOP
GOTO PSALOCO
OPSITES ;
+1 FOR X=2:1
if '$DATA(PSAOSIT(X))
QUIT
KILL PSAOSIT(X)
+2 FOR X=2:1
if $PIECE($GET(PSALOCA(PSALOCN,PSALOC)),"^",X)=""
QUIT
SET PSAOSIT(X)=$PIECE($GET(PSALOCA(PSALOCN,PSALOC)),"^",X)
+3 QUIT
ADD SET X6=$$MG^XMBGRP(PSAGROUP,0,DUZ,0,.XMY,,0)
+1 WRITE !,$SELECT($GET(X6)>0:"Ok, addition completed.",1:"error in adding users ? "),!
+2 QUIT
