PSOLSET ;BHAM ISC/SAB - site parameter set up ;12/03/92
VERS ;;7.0;OUTPATIENT PHARMACY;**10,22,32,40,120,247,359,367**;DEC 1997;Build 62
;Reference to ^PS(59.7 supported by DBIA 694
;Reference to ^PSX(550 supported by DBIA 2230
;Reference to ^%ZIS(2 supported by DBIA 3435
;
I '$D(DUZ) W !,$C(7),"DUZ Number must be defined !!",! G LEAVE
W !,"Outpatient Pharmacy software - Version "_$P($T(VERS),";",3)
I $D(^XTMP("PSO_V7 INSTALL",0)) W !!,"Outpatient Pharmacy software is being installed. PLEASE TRY LATER!",! G LEAVE
S PSOBAR1="",PSOBARS=0 ;make sure we have one
S PSOCNT=0 F I=0:0 S I=$O(^PS(59,I)) Q:'I S PSOCNT=PSOCNT+1,Y=I
G DIV1:PSOCNT W !,$C(7) S DIR("A",1)="Site parameters must be specified for at least one site."
S DIR("A",2)="This is usually done by the package Co-ordinator.",DIR("A")="Do you want to continue: ",DIR("B")="YES",DIR(0)="SA^Y:YES;N:NO",DIR("?")="Enter Y to edit site parameters or N to exit." D ^DIR
G LEAVE:"Y"'[$E(X)
W ! D ^PSOSITED G PSOLSET
DIV1 G:PSOCNT=1 DIV3 S DIR(0)="Y",DIR("?")="Enter 'Y' to select Division or 'N' to EXIT"
DIV2 I PSOCNT>1 W ! S DIC("A")="Division: ",DIC=59,DIC(0)="AEMQ"
S:$G(PSOVEX)'=1 DIC("S")="I $S('$D(^PS(59,+Y,""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0)"
D ^DIC K DIC G:$D(DUOUT)!($D(DTOUT)) LEAVE
I +Y<0 W $C(7),! S DIR("A",1)="A 'DIVISION' must be selected!",DIR("A")="Do you want to try again",DIR("B")="YES" D ^DIR G:'Y LEAVE G DIV2
DIV3 K DIR S PSOSITE=+Y W:PSOCNT>1 !!?10,"You are logged on under the ",$P(^PS(59,PSOSITE,0),"^")," division.",! S PSOPAR=$G(^PS(59,PSOSITE,1)),PSOPAR7=$G(^PS(59,PSOSITE,"IB")),PSOSYS=$G(^PS(59.7,1,40.1)) D CUTDATE^PSOFUNC
S PSOPINST=$P($G(^PS(59,PSOSITE,"INI")),"^")
S (SITE,DA)=$P(^XMB(1,1,"XUS"),"^",17),DIC="4",DIQ(0)="IE",DR=".01;99",DIQ="PSXUTIL" D EN^DIQ1 S S3=$G(PSXUTIL(4,SITE,99,"I")),S2=$G(PSXUTIL(4,SITE,.01,"E")) K DA,DIC,DIQ(0),DR
S PSXSYS=+$O(^PSX(550,"C",""))_"^"_$G(S3)_"^"_$G(S2),PSOINST=S3
K S3,S2,S1,PSXUTIL
I $G(PSXSYS) D
.K:($P($G(^PSX(550,+PSXSYS,0)),"^",2)'="A") PSXSYS
.S Y=$$VERSION^XPDUTL("PSO") I Y>6.0 S PSXVER=1
E K PSXSYS
S PSODIV=$S(($P(PSOSYS,"^",2))&('$P(PSOSYS,"^",3)):0,1:1)
I $D(DUZ),$D(^VA(200,+DUZ,0)) S PSOCLC=DUZ
PLBL ; Profile Printer Selection
I $P(PSOPAR,"^",8) D
.S %ZIS="MNQ",%ZIS("A")="Select PROFILE PRINTER: " S:$G(PSOCLBL)&($D(PSOPROP)) %ZIS("B")=PSOPROP
.D ^%ZIS K %ZIS,IO("Q"),IOP Q:POP S PSOPROP=ION D ^%ZISC
LBL ; Label Printer Selection
S %ZIS="MNQ",%ZIS("A")="Select LABEL PRINTER: " S:$G(PSOCLBL)&($D(PSOLAP))!($G(SUSPT)) %ZIS("B")=$S($G(SUSPT):PSLION,1:PSOLAP)
D ^%ZIS K %ZIS,IO("Q"),IOP S:POP PSOQUIT=1 G:POP FDAPRT S @$S($G(SUSPT):"PSLION",1:"PSOLAP")=ION,PSOPIOST=$G(IOST(0))
N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST
S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",19),PSOIOS=IOS D ^%ZISC
LASK I $G(PSOPIOST),$D(^%ZIS(2,PSOPIOST,55,"B","LL")) G FDAPRT
K DIR S DIR("A")="OK to assume label alignment is correct",DIR("B")="YES",DIR(0)="Y"
S DIR("?")="Enter Y if labels are aligned, N if they need to be aligned."
D ^DIR S:$D(DIRUT) PSOQUIT=1 G:Y!($D(DIRUT)) FDAPRT
P2 S IOP=$G(PSOLAP) D ^%ZIS K IOP I POP W $C(7),!?5,"Printer is busy.",! G LASK
U IO(0) W !,"Align labels so that a perforation is at the top of the",!,"print head and the left side is at column zero."
W ! K DIR,DIRUT,DUOUT,DTOUT S DIR(0)="E" D ^DIR K DIR,DTOUT,DUOUT I $D(DIRUT) D ^%ZISC G FDAPRT
D ^PSOLBLT D ^%ZISC
K DIRUT,DIR S DIR("A")="Is this correct",DIR("B")="YES",DIR(0)="Y"
S DIR("?")="Enter Y if labels are aligned correctly, N if they need to be aligned."
D ^DIR S:$D(DIRUT) PSOQUIT=1 G:Y!($D(DIRUT)) FDAPRT
G P2
;
FDAPRT ; FDA Med Guide Printer Selection
I $G(PSOBFLAG) G EXIT
N FDAPRT
S FDAPRT=$$SELPRT^PSOFDAUT($P($G(PSOFDAPT),"^")) I FDAPRT="^" G EXIT
S PSOFDAPT=FDAPRT
G EXIT
;
LEAVE S XQUIT="" G FINAL
Q W !?10,$C(7),"Default printer for labels must be entered." G LBL
;
EXIT D ^%ZISC Q:$G(PSOCLBL)
D:'$G(PSOBFLAG) GROUP K I,IOP,X,Y,%ZIS,DIC,J,DIR,X,Y,DTOUT,DIROUT,DIRUT,DUOUT Q
;
FINAL ;exit action from main menu - kill and quit
K SITE,PSOCP,PSNP,PSL,PRCA,PSLION,PSOPINST
K GROUPCNT,DISGROUP,PSOCAP,PSOINST,PSOION,PSONULBL,PSOSITE7,PFIO,PSOIOS,X,Y,PSOSYS,PSODIV,PSOPAR,PSOPAR7,PSOLAP,PSOPROP,PSOCLC,PSOCNT
K PSODTCUT,PSOSITE,PSOPRPAS,PSOBAR1,PSOBAR0,PSOBARS,SIG,DIR,DIRUT,DTOUT,DIROUT,DUOUT,I,%ZIS,DIC,J,PSOREL,PSOFDAPT
Q
GROUP ;display group
S GROUPCNT=0,AGROUP="" I $D(^PS(59.3,0)) F S AGROUP=$O(^PS(59.3,"B",AGROUP)) Q:AGROUP="" D
.S GROUPCNT=GROUPCNT+1 I GROUPCNT=1 S AGROUP1=AGROUP
S:GROUPCNT=1 GRPNME=AGROUP1,II="" G:GROUPCNT>1 GROUP1
Q:'$D(GRPNME) F S II=$O(^PS(59.3,"B",GRPNME,II)) Q:II="" S DISGROUP=II
K AGROUP,AGROUP1,GRPNME,II
Q
GROUP1 W ! S DIC("A")="Bingo Board Display: ",DIC=59.3,DIC(0)="AEMQZ",DIR(0)="Y",DIR("?")="Enter 'Y' to select Bingo Board Display or 'N' to EXIT"
S:$P($G(^PS(59,PSOSITE,1)),"^",20) DIC("B")=$P($G(^PS(59,PSOSITE,1)),"^",20)
D ^DIC K DIC Q:$D(DTOUT)!($D(DUOUT))
I +Y<0 W $C(7) S DIR("A",1)="A 'BINGO BOARD DISPLAY' should be selected!",DIR("A")="Do you want to try again",DIR("B")="YES",DIR("?")="A display group must be defined in order to run Bingo Board." D ^DIR Q:"Y"'[$E(X) G GROUP
S DISGROUP=+Y
K DIR,DIC,AGROUP,AGROUP1,GRPNME,II
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOLSET 5285 printed Sep 23, 2025@20:07:23 Page 2
PSOLSET ;BHAM ISC/SAB - site parameter set up ;12/03/92
VERS ;;7.0;OUTPATIENT PHARMACY;**10,22,32,40,120,247,359,367**;DEC 1997;Build 62
+1 ;Reference to ^PS(59.7 supported by DBIA 694
+2 ;Reference to ^PSX(550 supported by DBIA 2230
+3 ;Reference to ^%ZIS(2 supported by DBIA 3435
+4 ;
+5 IF '$DATA(DUZ)
WRITE !,$CHAR(7),"DUZ Number must be defined !!",!
GOTO LEAVE
+6 WRITE !,"Outpatient Pharmacy software - Version "_$PIECE($TEXT(VERS),";",3)
+7 IF $DATA(^XTMP("PSO_V7 INSTALL",0))
WRITE !!,"Outpatient Pharmacy software is being installed. PLEASE TRY LATER!",!
GOTO LEAVE
+8 ;make sure we have one
SET PSOBAR1=""
SET PSOBARS=0
+9 SET PSOCNT=0
FOR I=0:0
SET I=$ORDER(^PS(59,I))
if 'I
QUIT
SET PSOCNT=PSOCNT+1
SET Y=I
+10 if PSOCNT
GOTO DIV1
WRITE !,$CHAR(7)
SET DIR("A",1)="Site parameters must be specified for at least one site."
+11 SET DIR("A",2)="This is usually done by the package Co-ordinator."
SET DIR("A")="Do you want to continue: "
SET DIR("B")="YES"
SET DIR(0)="SA^Y:YES;N:NO"
SET DIR("?")="Enter Y to edit site parameters or N to exit."
DO ^DIR
+12 if "Y"'[$EXTRACT(X)
GOTO LEAVE
+13 WRITE !
DO ^PSOSITED
GOTO PSOLSET
DIV1 if PSOCNT=1
GOTO DIV3
SET DIR(0)="Y"
SET DIR("?")="Enter 'Y' to select Division or 'N' to EXIT"
DIV2 IF PSOCNT>1
WRITE !
SET DIC("A")="Division: "
SET DIC=59
SET DIC(0)="AEMQ"
+1 if $GET(PSOVEX)'=1
SET DIC("S")="I $S('$D(^PS(59,+Y,""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0)"
+2 DO ^DIC
KILL DIC
if $DATA(DUOUT)!($DATA(DTOUT))
GOTO LEAVE
+3 IF +Y<0
WRITE $CHAR(7),!
SET DIR("A",1)="A 'DIVISION' must be selected!"
SET DIR("A")="Do you want to try again"
SET DIR("B")="YES"
DO ^DIR
if 'Y
GOTO LEAVE
GOTO DIV2
DIV3 KILL DIR
SET PSOSITE=+Y
if PSOCNT>1
WRITE !!?10,"You are logged on under the ",$PIECE(^PS(59,PSOSITE,0),"^")," division.",!
SET PSOPAR=$GET(^PS(59,PSOSITE,1))
SET PSOPAR7=$GET(^PS(59,PSOSITE,"IB"))
SET PSOSYS=$GET(^PS(59.7,1,40.1))
DO CUTDATE^PSOFUNC
+1 SET PSOPINST=$PIECE($GET(^PS(59,PSOSITE,"INI")),"^")
+2 SET (SITE,DA)=$PIECE(^XMB(1,1,"XUS"),"^",17)
SET DIC="4"
SET DIQ(0)="IE"
SET DR=".01;99"
SET DIQ="PSXUTIL"
DO EN^DIQ1
SET S3=$GET(PSXUTIL(4,SITE,99,"I"))
SET S2=$GET(PSXUTIL(4,SITE,.01,"E"))
KILL DA,DIC,DIQ(0),DR
+3 SET PSXSYS=+$ORDER(^PSX(550,"C",""))_"^"_$GET(S3)_"^"_$GET(S2)
SET PSOINST=S3
+4 KILL S3,S2,S1,PSXUTIL
+5 IF $GET(PSXSYS)
Begin DoDot:1
+6 if ($PIECE($GET(^PSX(550,+PSXSYS,0)),"^",2)'="A")
KILL PSXSYS
+7 SET Y=$$VERSION^XPDUTL("PSO")
IF Y>6.0
SET PSXVER=1
End DoDot:1
+8 IF '$TEST
KILL PSXSYS
+9 SET PSODIV=$SELECT(($PIECE(PSOSYS,"^",2))&('$PIECE(PSOSYS,"^",3)):0,1:1)
+10 IF $DATA(DUZ)
IF $DATA(^VA(200,+DUZ,0))
SET PSOCLC=DUZ
PLBL ; Profile Printer Selection
+1 IF $PIECE(PSOPAR,"^",8)
Begin DoDot:1
+2 SET %ZIS="MNQ"
SET %ZIS("A")="Select PROFILE PRINTER: "
if $GET(PSOCLBL)&($DATA(PSOPROP))
SET %ZIS("B")=PSOPROP
+3 DO ^%ZIS
KILL %ZIS,IO("Q"),IOP
if POP
QUIT
SET PSOPROP=ION
DO ^%ZISC
End DoDot:1
LBL ; Label Printer Selection
+1 SET %ZIS="MNQ"
SET %ZIS("A")="Select LABEL PRINTER: "
if $GET(PSOCLBL)&($DATA(PSOLAP))!($GET(SUSPT))
SET %ZIS("B")=$SELECT($GET(SUSPT):PSLION,1:PSOLAP)
+2 DO ^%ZIS
KILL %ZIS,IO("Q"),IOP
if POP
SET PSOQUIT=1
if POP
GOTO FDAPRT
SET @$SELECT($GET(SUSPT):"PSLION",1:"PSOLAP")=ION
SET PSOPIOST=$GET(IOST(0))
+3 NEW PSOIOS
SET PSOIOS=IOS
DO DEVBAR^PSOBMST
+4 SET PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$PIECE(PSOPAR,"^",19)
SET PSOIOS=IOS
DO ^%ZISC
LASK IF $GET(PSOPIOST)
IF $DATA(^%ZIS(2,PSOPIOST,55,"B","LL"))
GOTO FDAPRT
+1 KILL DIR
SET DIR("A")="OK to assume label alignment is correct"
SET DIR("B")="YES"
SET DIR(0)="Y"
+2 SET DIR("?")="Enter Y if labels are aligned, N if they need to be aligned."
+3 DO ^DIR
if $DATA(DIRUT)
SET PSOQUIT=1
if Y!($DATA(DIRUT))
GOTO FDAPRT
P2 SET IOP=$GET(PSOLAP)
DO ^%ZIS
KILL IOP
IF POP
WRITE $CHAR(7),!?5,"Printer is busy.",!
GOTO LASK
+1 USE IO(0)
WRITE !,"Align labels so that a perforation is at the top of the",!,"print head and the left side is at column zero."
+2 WRITE !
KILL DIR,DIRUT,DUOUT,DTOUT
SET DIR(0)="E"
DO ^DIR
KILL DIR,DTOUT,DUOUT
IF $DATA(DIRUT)
DO ^%ZISC
GOTO FDAPRT
+3 DO ^PSOLBLT
DO ^%ZISC
+4 KILL DIRUT,DIR
SET DIR("A")="Is this correct"
SET DIR("B")="YES"
SET DIR(0)="Y"
+5 SET DIR("?")="Enter Y if labels are aligned correctly, N if they need to be aligned."
+6 DO ^DIR
if $DATA(DIRUT)
SET PSOQUIT=1
if Y!($DATA(DIRUT))
GOTO FDAPRT
+7 GOTO P2
+8 ;
FDAPRT ; FDA Med Guide Printer Selection
+1 IF $GET(PSOBFLAG)
GOTO EXIT
+2 NEW FDAPRT
+3 SET FDAPRT=$$SELPRT^PSOFDAUT($PIECE($GET(PSOFDAPT),"^"))
IF FDAPRT="^"
GOTO EXIT
+4 SET PSOFDAPT=FDAPRT
+5 GOTO EXIT
+6 ;
LEAVE SET XQUIT=""
GOTO FINAL
Q WRITE !?10,$CHAR(7),"Default printer for labels must be entered."
GOTO LBL
+1 ;
EXIT DO ^%ZISC
if $GET(PSOCLBL)
QUIT
+1 if '$GET(PSOBFLAG)
DO GROUP
KILL I,IOP,X,Y,%ZIS,DIC,J,DIR,X,Y,DTOUT,DIROUT,DIRUT,DUOUT
QUIT
+2 ;
FINAL ;exit action from main menu - kill and quit
+1 KILL SITE,PSOCP,PSNP,PSL,PRCA,PSLION,PSOPINST
+2 KILL GROUPCNT,DISGROUP,PSOCAP,PSOINST,PSOION,PSONULBL,PSOSITE7,PFIO,PSOIOS,X,Y,PSOSYS,PSODIV,PSOPAR,PSOPAR7,PSOLAP,PSOPROP,PSOCLC,PSOCNT
+3 KILL PSODTCUT,PSOSITE,PSOPRPAS,PSOBAR1,PSOBAR0,PSOBARS,SIG,DIR,DIRUT,DTOUT,DIROUT,DUOUT,I,%ZIS,DIC,J,PSOREL,PSOFDAPT
+4 QUIT
GROUP ;display group
+1 SET GROUPCNT=0
SET AGROUP=""
IF $DATA(^PS(59.3,0))
FOR
SET AGROUP=$ORDER(^PS(59.3,"B",AGROUP))
if AGROUP=""
QUIT
Begin DoDot:1
+2 SET GROUPCNT=GROUPCNT+1
IF GROUPCNT=1
SET AGROUP1=AGROUP
End DoDot:1
+3 if GROUPCNT=1
SET GRPNME=AGROUP1
SET II=""
if GROUPCNT>1
GOTO GROUP1
+4 if '$DATA(GRPNME)
QUIT
FOR
SET II=$ORDER(^PS(59.3,"B",GRPNME,II))
if II=""
QUIT
SET DISGROUP=II
+5 KILL AGROUP,AGROUP1,GRPNME,II
+6 QUIT
GROUP1 WRITE !
SET DIC("A")="Bingo Board Display: "
SET DIC=59.3
SET DIC(0)="AEMQZ"
SET DIR(0)="Y"
SET DIR("?")="Enter 'Y' to select Bingo Board Display or 'N' to EXIT"
+1 if $PIECE($GET(^PS(59,PSOSITE,1)),"^",20)
SET DIC("B")=$PIECE($GET(^PS(59,PSOSITE,1)),"^",20)
+2 DO ^DIC
KILL DIC
if $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+3 IF +Y<0
WRITE $CHAR(7)
SET DIR("A",1)="A 'BINGO BOARD DISPLAY' should be selected!"
SET DIR("A")="Do you want to try again"
SET DIR("B")="YES"
SET DIR("?")="A display group must be defined in order to run Bingo Board."
DO ^DIR
if "Y"'[$EXTRACT(X)
QUIT
GOTO GROUP
+4 SET DISGROUP=+Y
+5 KILL DIR,DIC,AGROUP,AGROUP1,GRPNME,II
+6 QUIT
