Routine: PSODIV

PSODIV ;BHAM ISC/SAB - DIVISION LOOKUP AND CHECKS ; 08/20/92 9:11

 ;;7.0;OUTPATIENT PHARMACY;;DEC 1997

START W ! S PSOCNT=0 F I=0:0 S I=$O(^PS(59,I)) Q:'I  S PSOCNT=PSOCNT+1

 I 'PSOCNT W !,$C(7)," NO SITES HAVE BEEN DEFINED!" Q

 I PSOCNT=1 W !!,$C(7),"  Only one site is defined. 'INTERDIVISIONAL' processing is not applicable." Q

 S PSOSYS=^PS(59.7,1,40.1),DIR("A",1)="Currently 'INTERDIVISIONAL' processing 'is"_$S('+$P(PSOSYS,"^",2):" not",1:"")_"' allowed.",DIR("A")="    Do you want to change this? : ",DIR("B")="N",DIR(0)="SA^1:YES;0:NO"

 S DIR("?")="^D SYN^PSODIV" D ^DIR G:$D(DTOUT)!($D(DUOUT))!($D(DIROUT))!($D(DIRUT)) END

 I +$P(PSOSYS,"^",2),'Y G ANS2

 I '+$P(PSOSYS,"^",2),Y S $P(PSOSYS,"^",2)=1 W !,"'INTERDIVISIONAL PROCESSING' is initialized.",!

 E  S $P(PSOSYS,"^",2)="",$P(PSOSYS,"^",3)="",$P(PSOSYS,"^",4)="",^PS(59.7,1,40.1)=PSOSYS G END

ANS2 K DIR W ! S DIR("A",1)=" This question involves the following prompt:",DIR("A",2)=" ",DIR("A",3)="'RX is from another division.  Continue? (Y/N)'"

 S DIR("A",4)=" ",DIR("A",5)="Do you want this prompt to appear"

 S DIR("A")="whenever an action is attempted on the prescription: ",DIR("B")=$S($P($G(PSOSYS),"^",3):"Y",1:"N"),DIR(0)="SA^1:YES;0:NO"

 S DIR("?")="^D SYN^PSODIV" D ^DIR G:$D(DTOUT)!($D(DUOUT))!($D(DIROUT))!($D(DIRUT)) END

 S $P(PSOSYS,"^",3)=Y,^PS(59.7,1,40.1)=PSOSYS

 W !! K DIR S DIR("A",1)="Do you want all refill request forms to be processed",DIR("A")="at a particular division?: "

 S DIR("B")=$S($P(PSOSYS,"^",4):"Y",1:"N"),DIR(0)="SA^1:YES;0:NO"

 S DIR("?")="^D SYN^PSODIV" D ^DIR G:$D(DTOUT)!($D(DUOUT))!($D(DIROUT))!($D(DIRUT)) END I 'Y S $P(^PS(59.7,1,40.1),"^",4)="" G END

DIV W ! S DIC("B")=$S($P($G(^PS(59.7,1,40.1)),"^",4):$P(^PS(59,$P(^PS(59.7,1,40.1),"^",4),0),"^"),1:""),DIC=59,DIC(0)="AEMQ",DIC("A")="Choose REFILL division: " D ^DIC K DIC G:"^"[X NS I Y<0 W !!,$C(7),"You must choose a division" G DIV

 S $P(PSOSYS,"^",4)=+Y,$P(^PS(59.7,1,40.1),"^",4)=+Y G END

NS W !!,"Default Division not "_$S('$P(PSOSYS,"^",4):"Added",1:"Changed")_".",!

END W !!,$C(7),"Initialization of 'INTERDIVISIONAL PROCESSING' is complete." K DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,I,X,Y,PSOCNT Q

SYN W !,$C(7),"  ...Please answer 'Yes' or 'No'!!",!

PSODIV    ;BHAM ISC/SAB - DIVISION LOOKUP AND CHECKS ; 08/20/92 9:11

 +1       ;;7.0;OUTPATIENT PHARMACY;;DEC 1997

START      WRITE !

           SET PSOCNT=0

           FOR I=0:0

               SET I=$ORDER(^PS(59,I))

               IF 'I

                   QUIT

               SET PSOCNT=PSOCNT+1

 +1        IF 'PSOCNT

               WRITE !,$CHAR(7)," NO SITES HAVE BEEN DEFINED!"

               QUIT

 +2        IF PSOCNT=1

               WRITE !!,$CHAR(7),"  Only one site is defined. 'INTERDIVISIONAL' processing is not applicable."

               QUIT

 +3        SET PSOSYS=^PS(59.7,1,40.1)

           SET DIR("A",1)="Currently 'INTERDIVISIONAL' processing 'is"_$SELECT('+$PIECE(PSOSYS,"^",2):" not",1:"")_"' allowed."

           SET DIR("A")="    Do you want to change this? : "

           SET DIR("B")="N"

           SET DIR(0)="SA^1:YES;0:NO"

 +4        SET DIR("?")="^D SYN^PSODIV"

           DO ^DIR

           IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIROUT))!($DATA(DIRUT))

               GOTO END

 +5        IF +$PIECE(PSOSYS,"^",2)

               IF 'Y

                   GOTO ANS2

 +6        IF '+$PIECE(PSOSYS,"^",2)

               IF Y

                   SET $PIECE(PSOSYS,"^",2)=1

                   WRITE !,"'INTERDIVISIONAL PROCESSING' is initialized.",!

 +7       IF '$TEST

               SET $PIECE(PSOSYS,"^",2)=""

               SET $PIECE(PSOSYS,"^",3)=""

               SET $PIECE(PSOSYS,"^",4)=""

               SET ^PS(59.7,1,40.1)=PSOSYS

               GOTO END

ANS2       KILL DIR

           WRITE !

           SET DIR("A",1)=" This question involves the following prompt:"

           SET DIR("A",2)=" "

           SET DIR("A",3)="'RX is from another division.  Continue? (Y/N)'"

 +1        SET DIR("A",4)=" "

           SET DIR("A",5)="Do you want this prompt to appear"

 +2        SET DIR("A")="whenever an action is attempted on the prescription: "

           SET DIR("B")=$SELECT($PIECE($GET(PSOSYS),"^",3):"Y",1:"N")

           SET DIR(0)="SA^1:YES;0:NO"

 +3        SET DIR("?")="^D SYN^PSODIV"

           DO ^DIR

           IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIROUT))!($DATA(DIRUT))

               GOTO END

 +4        SET $PIECE(PSOSYS,"^",3)=Y

           SET ^PS(59.7,1,40.1)=PSOSYS

 +5        WRITE !!

           KILL DIR

           SET DIR("A",1)="Do you want all refill request forms to be processed"

           SET DIR("A")="at a particular division?: "

 +6        SET DIR("B")=$SELECT($PIECE(PSOSYS,"^",4):"Y",1:"N")

           SET DIR(0)="SA^1:YES;0:NO"

 +7        SET DIR("?")="^D SYN^PSODIV"

           DO ^DIR

           IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIROUT))!($DATA(DIRUT))

               GOTO END

           IF 'Y

               SET $PIECE(^PS(59.7,1,40.1),"^",4)=""

               GOTO END

DIV        WRITE !

           SET DIC("B")=$SELECT($PIECE($GET(^PS(59.7,1,40.1)),"^",4):$PIECE(^PS(59,$PIECE(^PS(59.7,1,40.1),"^",4),0),"^"),1:"")

           SET DIC=59

           SET DIC(0)="AEMQ"

           SET DIC("A")="Choose REFILL division: "

           DO ^DIC

           KILL DIC

           IF "^"[X

               GOTO NS

           IF Y<0

               WRITE !!,$CHAR(7),"You must choose a division"

               GOTO DIV

 +1        SET $PIECE(PSOSYS,"^",4)=+Y

           SET $PIECE(^PS(59.7,1,40.1),"^",4)=+Y

           GOTO END

NS         WRITE !!,"Default Division not "_$SELECT('$PIECE(PSOSYS,"^",4):"Added",1:"Changed")_".",!

END        WRITE !!,$CHAR(7),"Initialization of 'INTERDIVISIONAL PROCESSING' is complete."

           KILL DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,I,X,Y,PSOCNT

           QUIT

SYN        WRITE !,$CHAR(7),"  ...Please answer 'Yes' or 'No'!!",!

 +1        QUIT

PSODIV.m