PSAENT ;BIR/LTL,JMB-Set Up/Edit a Pharmacy Location ;7/23/97
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**21**; 10/24/97
;
;References to ^PS(59.4, are covered under IA #2505
START D DT^DICRW
N D0,D1,DA,DIE,DIC,DIR,DIRUT,DLAYGO,DR,DTOUT,DUOUT,PSA,PSAB,PSAC,PSADRUG,PSAII,PSAIT,PSAIPS,PSAINV,PSAISIT,PSAIVLOC,PSALOC,PSAOC,PSALOCN,PSAOSIT,PSASTO,PSAITY,PSANOW,PSAOP,PSAO,PSAI,PSAOU,X,Y
;pick type
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 K DIR Q:'Y S PSAITY=+Y,PSALOCN=Y(0)
;new IP or combined
D:'$O(^PSD(58.8,"ADISP","P",0))
.W !!,"Creating ",PSALOCN H 1
.S DIC="^PSD(58.8,",DIC(0)="L",DLAYGO=58.8,X=PSALOCN,DIC("DR")="1////P",DIC("S")="I $S($P($G(^(0)),U,2)]"""":$P($G(^(0)),U,2)=""P"",1:1)" D ^DIC K DIC S PSALOC=+Y
D:PSAITY'=2
.;check for more than one IP site
.S (PSA(1),PSA(2))=0 F S PSA(1)=$O(^PS(59.4,PSA(1))) Q:'PSA(1) S:$P($G(^(PSA(1),0)),U,26)=1 PSA(2)=PSA(2)+1,PSAB=PSA(1)
.I PSA(2)<1 W !!,"An Inpatient Site has not been identified for AR/WS.",!!,"AR/WS dispensing data may not be gathered.",!! S:PSAITY=3 PSAO=1 S:PSAITY=1 PSAOU=1 Q
.S:PSA(2)=1 PSAISIT=PSAB
.D:PSA(2)>1 I Y<1 S PSAOU=1 Q
..W !!,"Because there is more than one Inpatient Site at this facility, I need you to"
..S DIC="^PS(59.4,",DIC(0)="AEMQZ",DIC("A")="select an AR/WS Inpatient Site Name: ",DIC("S")="I $P($G(^(0)),U,26)=1" D ^DIC K DIC S:$D(DUOUT)!($D(DTOUT))!(X="") PSAOU=1 S:PSAITY=3&(Y<1) PSAO=1 Q:Y<1 S PSAISIT=+Y
.I $D(PSALOC) D Q
..S DIE="^PSD(58.8,",DA=PSALOC,DR="2////^S X=PSAISIT" D ^DIE K DIE S Y=0
.S PSALOC=""
.F S PSALOC=$O(^PSD(58.8,"ASITE",PSAISIT,"P",PSALOC)) Q:'PSALOC I $S('$G(^PSD(58.8,+PSALOC,"I")):1,+^("I")>DT:1,1:0) Q
.D:'PSALOC
..K DD,DO S DIC="^PSD(58.8,",DIC(0)="LZ",X=PSALOCN,DIC("DR")="1////P;2////^S X=PSAISIT" D FILE^DICN K DIC S PSALOC=+Y,PSALOCN=Y(0,0)
.I PSALOC S PSALOCN=$P($G(^PSD(58.8,+PSALOC,0)),U) D Q:'Y
..W !!,PSALOCN," is set up to gather AR/WS dispensing data for ",$P($G(^PS(59.4,PSAISIT,0)),U)
..;PSA*3*21 (Dave B 0 Allow selection of linking/unlinking rooms)
..S DIR(0)="Y",DIR("A")="Do you wish to change this",DIR("B")="No" D ^DIR K DIR S:'Y PSAO=1 S:$D(DIRUT) PSAOU=1 Q:'Y
..S DIR(0)="Y",DIR("A")="Do you want to change "_PSALOCN_" to "_$S($E(PSALOCN)="I":"COMBINED (IP/OP)",$E(PSALOCN)="C":"INPATIENT",1:""),DIR("B")="No" D ^DIR K DIR S:'Y PSAO=1 S:$D(DIRUT) PSAOU=1 Q:'Y D
...S DIE="^PSD(58.8,",DA=PSALOC,DR=$S($E(PSALOCN)="I":".01////COMBINED (IP/OP)",$E(PSALOCN)="C":".01////INPATIENT;20////@",1:"") D ^DIE K DIE,DA S Y=1 I $E(PSALOCN)="I" S PSAO=1,PSAOC=1
...S PSALOCN=$P($G(^PSD(58.8,+PSALOC,0)),U)
D:PSAITY'=2&('$G(PSAOU)) ^PSAWARD S:PSAITY=2 PSAO=1 Q:$D(PSAOU)
I $D(PSAO) D OP^PSAENTO G QUIT
D:'$G(PSAPVMEN) ED^PSAENTO D:$G(PSAPVMEN) DRUGS^PSAENTO
QUIT Q:'$D(PSALOC)
W ! S DIE="^PSD(58.8,",DA=PSALOC,DR=$S(+$G(PSAPVMEN):"34Maintain reorder levels;35Days to keep invoice data;4Inactive Date",1:"4Inactive Date") D ^DIE K DIE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSAENT 3122 printed Sep 23, 2025@19:25:18 Page 2
PSAENT ;BIR/LTL,JMB-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.4, are covered under IA #2505
START DO DT^DICRW
+1 NEW D0,D1,DA,DIE,DIC,DIR,DIRUT,DLAYGO,DR,DTOUT,DUOUT,PSA,PSAB,PSAC,PSADRUG,PSAII,PSAIT,PSAIPS,PSAINV,PSAISIT,PSAIVLOC,PSALOC,PSAOC,PSALOCN,PSAOSIT,PSASTO,PSAITY,PSANOW,PSAOP,PSAO,PSAI,PSAOU,X,Y
+2 ;pick type
+3 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"
+4 DO ^DIR
KILL DIR
if 'Y
QUIT
SET PSAITY=+Y
SET PSALOCN=Y(0)
+5 ;new IP or combined
+6 if '$ORDER(^PSD(58.8,"ADISP","P",0))
Begin DoDot:1
+7 WRITE !!,"Creating ",PSALOCN
HANG 1
+8 SET DIC="^PSD(58.8,"
SET DIC(0)="L"
SET DLAYGO=58.8
SET X=PSALOCN
SET DIC("DR")="1////P"
SET DIC("S")="I $S($P($G(^(0)),U,2)]"""":$P($G(^(0)),U,2)=""P"",1:1)"
DO ^DIC
KILL DIC
SET PSALOC=+Y
End DoDot:1
+9 if PSAITY'=2
Begin DoDot:1
+10 ;check for more than one IP site
+11 SET (PSA(1),PSA(2))=0
FOR
SET PSA(1)=$ORDER(^PS(59.4,PSA(1)))
if 'PSA(1)
QUIT
if $PIECE($GET(^(PSA(1),0)),U,26)=1
SET PSA(2)=PSA(2)+1
SET PSAB=PSA(1)
+12 IF PSA(2)<1
WRITE !!,"An Inpatient Site has not been identified for AR/WS.",!!,"AR/WS dispensing data may not be gathered.",!!
if PSAITY=3
SET PSAO=1
if PSAITY=1
SET PSAOU=1
QUIT
+13 if PSA(2)=1
SET PSAISIT=PSAB
+14 if PSA(2)>1
Begin DoDot:2
+15 WRITE !!,"Because there is more than one Inpatient Site at this facility, I need you to"
+16 SET DIC="^PS(59.4,"
SET DIC(0)="AEMQZ"
SET DIC("A")="select an AR/WS Inpatient Site Name: "
SET DIC("S")="I $P($G(^(0)),U,26)=1"
DO ^DIC
KILL DIC
if $DATA(DUOUT)!($DATA(DTOUT))!(X="")
SET PSAOU=1
if PSAITY=3&(Y<1)
SET PSAO=1
if Y<1
QUIT
SET PSAISIT=+Y
End DoDot:2
IF Y<1
SET PSAOU=1
QUIT
+17 IF $DATA(PSALOC)
Begin DoDot:2
+18 SET DIE="^PSD(58.8,"
SET DA=PSALOC
SET DR="2////^S X=PSAISIT"
DO ^DIE
KILL DIE
SET Y=0
End DoDot:2
QUIT
+19 SET PSALOC=""
+20 FOR
SET PSALOC=$ORDER(^PSD(58.8,"ASITE",PSAISIT,"P",PSALOC))
if 'PSALOC
QUIT
IF $SELECT('$GET(^PSD(58.8,+PSALOC,"I")):1,+^("I")>DT:1,1:0)
QUIT
+21 if 'PSALOC
Begin DoDot:2
+22 KILL DD,DO
SET DIC="^PSD(58.8,"
SET DIC(0)="LZ"
SET X=PSALOCN
SET DIC("DR")="1////P;2////^S X=PSAISIT"
DO FILE^DICN
KILL DIC
SET PSALOC=+Y
SET PSALOCN=Y(0,0)
End DoDot:2
+23 IF PSALOC
SET PSALOCN=$PIECE($GET(^PSD(58.8,+PSALOC,0)),U)
Begin DoDot:2
+24 WRITE !!,PSALOCN," is set up to gather AR/WS dispensing data for ",$PIECE($GET(^PS(59.4,PSAISIT,0)),U)
+25 ;PSA*3*21 (Dave B 0 Allow selection of linking/unlinking rooms)
+26 SET DIR(0)="Y"
SET DIR("A")="Do you wish to change this"
SET DIR("B")="No"
DO ^DIR
KILL DIR
if 'Y
SET PSAO=1
if $DATA(DIRUT)
SET PSAOU=1
if 'Y
QUIT
+27 SET DIR(0)="Y"
SET DIR("A")="Do you want to change "_PSALOCN_" to "_$SELECT($EXTRACT(PSALOCN)="I":"COMBINED (IP/OP)",$EXTRACT(PSALOCN)="C":"INPATIENT",1:"")
SET DIR("B")="No"
DO ^DIR
KILL DIR
if 'Y
SET PSAO=1
if $DATA(DIRUT)
SET PSAOU=1
if 'Y
QUIT
Begin DoDot:3
+28 SET DIE="^PSD(58.8,"
SET DA=PSALOC
SET DR=$SELECT($EXTRACT(PSALOCN)="I":".01////COMBINED (IP/OP)",$EXTRACT(PSALOCN)="C":".01////INPATIENT;20////@",1:"")
DO ^DIE
KILL DIE,DA
SET Y=1
IF $EXTRACT(PSALOCN)="I"
SET PSAO=1
SET PSAOC=1
+29 SET PSALOCN=$PIECE($GET(^PSD(58.8,+PSALOC,0)),U)
End DoDot:3
End DoDot:2
if 'Y
QUIT
End DoDot:1
+30 if PSAITY'=2&('$GET(PSAOU))
DO ^PSAWARD
if PSAITY=2
SET PSAO=1
if $DATA(PSAOU)
QUIT
+31 IF $DATA(PSAO)
DO OP^PSAENTO
GOTO QUIT
+32 if '$GET(PSAPVMEN)
DO ED^PSAENTO
if $GET(PSAPVMEN)
DO DRUGS^PSAENTO
QUIT if '$DATA(PSALOC)
QUIT
+1 WRITE !
SET DIE="^PSD(58.8,"
SET DA=PSALOC
SET DR=$SELECT(+$GET(PSAPVMEN):"34Maintain reorder levels;35Days to keep invoice data;4Inactive Date",1:"4Inactive Date")
DO ^DIE
KILL DIE
+2 QUIT
