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'!!",!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODIV 2242 printed Sep 23, 2025@20:03:28 Page 2
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
