PSAWARD.m

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 ---PSAWARD   3788     printed  Mar 13, 2025@20:55:55                                                                                                                                                                                                     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