PSAWARD ;BIR/LTL,JMB-Set Up/Edit a Pharmacy Location ;7/23/97
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;; 10/24/97
;This routine links wards to the pharmacy location.
;
N DIC,DIE,D0,D1,DLAYGO,DR,DIR,DIRUT,DTOUT,DUOUT,DA,PSAW,PSADR,X,Y,PSAOUT
W @IOF,!?5,"For the purpose of collecting Unit Dose and IV dispensing data,",!,"any ward at which such dispensing might ever occur should be added."
W !,"The ONLY reason to NOT add a ward would be if the dispensing at that ward",!,"should NOT update ",$G(PSALOCN),"."
W !!,"There is NO harm in adding inactive wards."
I '$D(^PSD(58.8,+PSALOC,3,0)) S ^(0)="^58.842P^^"
ALL I $G(PSA(2))=1 S PSA(3)=0,DIC="^PSD(58.8,+PSALOC,3,",DA(1)=PSALOC,DIC(0)="LNX" W !!,PSALOCN," is linked to " F S (DA,DINUM,X,PSA(3))=$O(^DIC(42,PSA(3))) Q:'PSA(3) K DD,DO D:'$G(^PSD(58.8,+PSALOC,3,+PSA(3),0)) FILE^DICN D
.W $P($G(^DIC(42,+PSA(3),0)),U) W:$O(^DIC(42,PSA(3))) ", "
.I '$O(^DIC(42,PSA(3))) W ".",!
.W:$X+10>IOM !!
K DINUM
G:$G(PSA(2))=1 QUIT
MUL I $O(^PSD(58.8,+PSALOC,3,0)) D G:$G(PSAOUT) QUIT
.S PSA(3)=0
.W !!,"The following wards are currently connected to ",PSALOCN,":",!!
.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:".")
.S DIR(0)="Y",DIR("A")="Do you wish to change this",DIR("B")="No",DIR("?")="Any dispensing to these wards by the UD or IV modules will update this location"
.W ! D ^DIR K DIR I Y'=1 S PSAOUT=1 Q
.S DIR(0)="SBOA^A:ADD;D:DELETE",DIR("A")="Do you wish to ADD or DELETE WARDS? (A/D): "
.S DIR("?",1)="Enter 'A' to ADD a Ward, 'D' to DELETE a Ward"
.S DIR("?")="or '^' to quit" D ^DIR K DIR S PSAOUT(1)=Y I $D(DIRUT) S PSAOUT=1 Q
.I Y="D" S DIC="^PSD(58.8,+PSALOC,3,",DIC(0)="AEMQ",DA(1)=PSALOC,DIC("A")="Select "_$G(PSALOCN)_" WARD: " F D ^DIC Q:Y<0!(Y="") S PSAW=+Y,PSAW(1)=$P($G(^DIC(42,+PSAW,0)),U) D I $D(DIRUT) S PSAOUT=1 Q
..S DIR(0)="Y",DIR("A")="OK to delete "_$G(PSAW(1))
..S DIR("B")="No",DIR("?")="If yes, I'll remove it from "_$G(PSALOCN)
..D ^DIR I Y'=1 S PSAOUT=1 Q
..S DIK=DIC,DA(1)=PSALOC,DA=PSAW D ^DIK W !,$G(PSAW(1))," deleted."
.K DIC,DIK,DA,PSAW S:PSAOUT(1)'="A" PSAOUT=1
S DIR(0)="SBOA^A:ALL;R:RANGE",DIR("A")="Do you wish to add ALL wards or select a RANGE of wards? (A/R): "
S DIR("?",1)="Enter 'A' to add ALL wards, 'R' to select a range"
S DIR("?")="or '^' to quit" D ^DIR K DIR I $D(DIRUT) S PSAOUT=1 Q
I Y="A" S PSA(2)=1 G ALL
S PSAW=0,(PSA,PSA(3))=1,PSA(2)=20
LOOP F PSA=PSA:1:PSA(2) S PSAW=$O(^DIC(42,PSAW)) Q:'PSAW S PSA=PSA-1 I '$O(^PSD(58.8,"AB",+PSAW,0)) S PSA=PSA+1 W !,PSA,?10,$P($G(^DIC(42,PSAW,0)),U) S PSADR(PSA)=PSAW W:$D(^DIC(42,+PSAW,"I")) ?40,"***INACTIVE***"
I PSA=1 W !!,"Sorry, you've already added all the wards that you can." G QUIT
S:$O(PSADR(PSA)) PSA=$O(PSADR(PSA))
I $G(PSAW) F PSAW(1)=PSAW:0 S PSAW(1)=$O(^DIC(42,PSAW(1))) Q:'PSAW(1)!($G(PSAW(2))>19) I '$O(^PSD(58.8,"AB",+PSAW(1),0)) S PSAW(2)=$G(PSAW(2))+1
I $G(PSA)'>$G(PSA(3)) G QUIT
S PSA(2)=$G(PSA(2))+$G(PSAW(2))
S DIR("?")="You can only select wards that are not yet linked to a location"
S DIR(0)="LA^"_PSA(3)_":"_$S($O(PSADR((PSA-1))):PSA,1:PSA-1),DIR("A",1)="Select the ward(s) or range of wards from which you want "_PSALOCN,DIR("A")="to collect dispensing data: " D ^DIR K DIR G:$D(DIRUT) QUIT S PSAC=Y
S DIC="^PSD(58.8,"_+PSALOC_",3,",DIC(0)="LNX",DA(1)=PSALOC
F PSAB=1:1:PSA I $P($G(PSAC),",",PSAB) K DD,DO S (DA,DINUM,X)=$G(PSADR($P(PSAC,",",PSAB))) D FILE^DICN W "." K DINUM,PSA(1) Q:$G(PSAOUT)
K PSAB I $G(PSAW(2)) W @IOF S (PSA,PSA(3))=$G(PSA)+1 G LOOP
K DIC,PSA,PSADR G MUL
QUIT I '$D(DIRUT) W ! S DIE="^PS(59.7,",DA=$O(^PS(59.7,0)),DR="72Inpatient Dispensing Update?" D ^DIE K DIE,DA S:$D(Y) PSAOUT=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSAWARD 3788 printed Dec 13, 2024@01:51:17 Page 2
PSAWARD ;BIR/LTL,JMB-Set Up/Edit a Pharmacy Location ;7/23/97
+1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;; 10/24/97
+2 ;This routine links wards to the pharmacy location.
+3 ;
+4 NEW DIC,DIE,D0,D1,DLAYGO,DR,DIR,DIRUT,DTOUT,DUOUT,DA,PSAW,PSADR,X,Y,PSAOUT
+5 WRITE @IOF,!?5,"For the purpose of collecting Unit Dose and IV dispensing data,",!,"any ward at which such dispensing might ever occur should be added."
+6 WRITE !,"The ONLY reason to NOT add a ward would be if the dispensing at that ward",!,"should NOT update ",$GET(PSALOCN),"."
+7 WRITE !!,"There is NO harm in adding inactive wards."
+8 IF '$DATA(^PSD(58.8,+PSALOC,3,0))
SET ^(0)="^58.842P^^"
ALL IF $GET(PSA(2))=1
SET PSA(3)=0
SET DIC="^PSD(58.8,+PSALOC,3,"
SET DA(1)=PSALOC
SET DIC(0)="LNX"
WRITE !!,PSALOCN," is linked to "
FOR
SET (DA,DINUM,X,PSA(3))=$ORDER(^DIC(42,PSA(3)))
if 'PSA(3)
QUIT
KILL DD,DO
if '$GET(^PSD(58.8,+PSALOC,3,+PSA(3),0))
DO FILE^DICN
Begin DoDot:1
+1 WRITE $PIECE($GET(^DIC(42,+PSA(3),0)),U)
if $ORDER(^DIC(42,PSA(3)))
WRITE ", "
+2 IF '$ORDER(^DIC(42,PSA(3)))
WRITE ".",!
+3 if $X+10>IOM
WRITE !!
End DoDot:1
+4 KILL DINUM
+5 if $GET(PSA(2))=1
GOTO QUIT
MUL IF $ORDER(^PSD(58.8,+PSALOC,3,0))
Begin DoDot:1
+1 SET PSA(3)=0
+2 WRITE !!,"The following wards are currently connected to ",PSALOCN,":",!!
+3 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:".")
+4 SET DIR(0)="Y"
SET DIR("A")="Do you wish to change this"
SET DIR("B")="No"
SET DIR("?")="Any dispensing to these wards by the UD or IV modules will update this location"
+5 WRITE !
DO ^DIR
KILL DIR
IF Y'=1
SET PSAOUT=1
QUIT
+6 SET DIR(0)="SBOA^A:ADD;D:DELETE"
SET DIR("A")="Do you wish to ADD or DELETE WARDS? (A/D): "
+7 SET DIR("?",1)="Enter 'A' to ADD a Ward, 'D' to DELETE a Ward"
+8 SET DIR("?")="or '^' to quit"
DO ^DIR
KILL DIR
SET PSAOUT(1)=Y
IF $DATA(DIRUT)
SET PSAOUT=1
QUIT
+9 IF Y="D"
SET DIC="^PSD(58.8,+PSALOC,3,"
SET DIC(0)="AEMQ"
SET DA(1)=PSALOC
SET DIC("A")="Select "_$GET(PSALOCN)_" WARD: "
FOR
DO ^DIC
if Y<0!(Y="")
QUIT
SET PSAW=+Y
SET PSAW(1)=$PIECE($GET(^DIC(42,+PSAW,0)),U)
Begin DoDot:2
+10 SET DIR(0)="Y"
SET DIR("A")="OK to delete "_$GET(PSAW(1))
+11 SET DIR("B")="No"
SET DIR("?")="If yes, I'll remove it from "_$GET(PSALOCN)
+12 DO ^DIR
IF Y'=1
SET PSAOUT=1
QUIT
+13 SET DIK=DIC
SET DA(1)=PSALOC
SET DA=PSAW
DO ^DIK
WRITE !,$GET(PSAW(1))," deleted."
End DoDot:2
IF $DATA(DIRUT)
SET PSAOUT=1
QUIT
+14 KILL DIC,DIK,DA,PSAW
if PSAOUT(1)'="A"
SET PSAOUT=1
End DoDot:1
if $GET(PSAOUT)
GOTO QUIT
+15 SET DIR(0)="SBOA^A:ALL;R:RANGE"
SET DIR("A")="Do you wish to add ALL wards or select a RANGE of wards? (A/R): "
+16 SET DIR("?",1)="Enter 'A' to add ALL wards, 'R' to select a range"
+17 SET DIR("?")="or '^' to quit"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET PSAOUT=1
QUIT
+18 IF Y="A"
SET PSA(2)=1
GOTO ALL
+19 SET PSAW=0
SET (PSA,PSA(3))=1
SET PSA(2)=20
LOOP FOR PSA=PSA:1:PSA(2)
SET PSAW=$ORDER(^DIC(42,PSAW))
if 'PSAW
QUIT
SET PSA=PSA-1
IF '$ORDER(^PSD(58.8,"AB",+PSAW,0))
SET PSA=PSA+1
WRITE !,PSA,?10,$PIECE($GET(^DIC(42,PSAW,0)),U)
SET PSADR(PSA)=PSAW
if $DATA(^DIC(42,+PSAW,"I"))
WRITE ?40,"***INACTIVE***"
+1 IF PSA=1
WRITE !!,"Sorry, you've already added all the wards that you can."
GOTO QUIT
+2 if $ORDER(PSADR(PSA))
SET PSA=$ORDER(PSADR(PSA))
+3 IF $GET(PSAW)
FOR PSAW(1)=PSAW:0
SET PSAW(1)=$ORDER(^DIC(42,PSAW(1)))
if 'PSAW(1)!($GET(PSAW(2))>19)
QUIT
IF '$ORDER(^PSD(58.8,"AB",+PSAW(1),0))
SET PSAW(2)=$GET(PSAW(2))+1
+4 IF $GET(PSA)'>$GET(PSA(3))
GOTO QUIT
+5 SET PSA(2)=$GET(PSA(2))+$GET(PSAW(2))
+6 SET DIR("?")="You can only select wards that are not yet linked to a location"
+7 SET DIR(0)="LA^"_PSA(3)_":"_$SELECT($ORDER(PSADR((PSA-1))):PSA,1:PSA-1)
SET DIR("A",1)="Select the ward(s) or range of wards from which you want "_PSALOCN
SET DIR("A")="to collect dispensing data: "
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO QUIT
SET PSAC=Y
+8 SET DIC="^PSD(58.8,"_+PSALOC_",3,"
SET DIC(0)="LNX"
SET DA(1)=PSALOC
+9 FOR PSAB=1:1:PSA
IF $PIECE($GET(PSAC),",",PSAB)
KILL DD,DO
SET (DA,DINUM,X)=$GET(PSADR($PIECE(PSAC,",",PSAB)))
DO FILE^DICN
WRITE "."
KILL DINUM,PSA(1)
if $GET(PSAOUT)
QUIT
+10 KILL PSAB
IF $GET(PSAW(2))
WRITE @IOF
SET (PSA,PSA(3))=$GET(PSA)+1
GOTO LOOP
+11 KILL DIC,PSA,PSADR
GOTO MUL
QUIT IF '$DATA(DIRUT)
WRITE !
SET DIE="^PS(59.7,"
SET DA=$ORDER(^PS(59.7,0))
SET DR="72Inpatient Dispensing Update?"
DO ^DIE
KILL DIE,DA
if $DATA(Y)
SET PSAOUT=1
+1 QUIT
