PSOLSET.m

PSOLSET ;BHAM ISC/SAB - site parameter set up ;14-Nov-2012 13:55;PB

VERS ;;7.0;OUTPATIENT PHARMACY;**10,22,32,40,120,1009,247,1015**;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

 ; Modified - IHS/CIA/PLS - 12/30/03 - Line DIV3+11

 ;            IHS/MSC/PLS - 06/29/10 - Line LBL - Added check for APSPLAP

 ;            IHS/MSC/PB  - 11/14/12 - Line DIV3+4 to allow multi-divisional processing for CMOP

 ;

 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

 ;next line added to allow for multi-divisional processing

 I $G(PSOSITE)'="" S S3=$P($G(^PS(59,PSOSITE,0)),"^",6)

 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

 ; IHS/CIA/PLS - 12/30/03 - Call to setup IHS variables

 S X="APSPSITE" X ^%ZOSF("TEST") I $T D EP^APSPSITE

PLBL 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 S %ZIS="MNQ",%ZIS("A")="Select LABEL PRINTER: " S:$G(PSOCLBL)&($D(PSOLAP))!($G(SUSPT))!($D(APSPLAP)) %ZIS("B")=$S($G(SUSPT):PSLION,$L($G(APSPLAP)):APSPLAP,1:$S($G(PSOLAP):PSOLAP,1:""))

 D ^%ZIS K %ZIS,IO("Q"),IOP S:POP PSOQUIT=1 G:POP EXIT 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 EXIT

 K DIR S DIR("A")="OK to assume label alignment is correct",DIR("B")="YES",DIR(0)="Y",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)) EXIT

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."

 ; IHS/CIA/PLS - 12/30/03 - Call IHS test label routine

 ;W ! K DIR,DIRUT,DUOUT,DTOUT S DIR(0)="E" D ^DIR K DIR,DTOUT,DUOUT Q:$D(DIRUT)  D ^PSOLBLT D ^%ZISC

 W ! K DIR,DIRUT,DUOUT,DTOUT S DIR(0)="E" D ^DIR K DIR,DTOUT,DUOUT Q:$D(DIRUT)  D ^APSPLBLT D ^%ZISC

 K DIRUT,DIR S DIR("A")="Is this correct",DIR("B")="YES",DIR(0)="Y",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)) EXIT

 G P2

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

 S X="APSPXUT" X ^%ZOSF("TEST") I $T D ^APSPXUT   ; IHS/CIA/PLS - Clean up variables

 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

PSOLSET   ;BHAM ISC/SAB - site parameter set up ;14-Nov-2012 13:55;PB

VERS      ;;7.0;OUTPATIENT PHARMACY;**10,22,32,40,120,1009,247,1015**;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       ; Modified - IHS/CIA/PLS - 12/30/03 - Line DIV3+11

 +5       ;            IHS/MSC/PLS - 06/29/10 - Line LBL - Added check for APSPLAP

 +6       ;            IHS/MSC/PB  - 11/14/12 - Line DIV3+4 to allow multi-divisional processing for CMOP

 +7       ;

 +8        IF '$DATA(DUZ)

               WRITE !,$CHAR(7),"DUZ Number must be defined !!",!

               GOTO LEAVE

 +9        WRITE !,"Outpatient Pharmacy software - Version "_$PIECE($TEXT(VERS),";",3)

 +10       IF $DATA(^XTMP("PSO_V7 INSTALL",0))

               WRITE !!,"Outpatient Pharmacy software is being installed.  PLEASE TRY LATER!",!

               GOTO LEAVE

 +11      ;make sure we have one

           SET PSOBAR1=""

           SET PSOBARS=0

 +12       SET PSOCNT=0

           FOR I=0:0

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

               IF 'I

                   QUIT 

               SET PSOCNT=PSOCNT+1

               SET Y=I

 +13       IF PSOCNT

               GOTO DIV1

           WRITE !,$CHAR(7)

           SET DIR("A",1)="Site parameters must be specified for at least one site."

 +14       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

 +15       IF "Y"'[$EXTRACT(X)

               GOTO LEAVE

 +16       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       ;next line added to allow for multi-divisional processing

 +4        IF $GET(PSOSITE)'=""

               SET S3=$PIECE($GET(^PS(59,PSOSITE,0)),"^",6)

 +5        SET PSXSYS=+$ORDER(^PSX(550,"C",""))_"^"_$GET(S3)_"^"_$GET(S2)

           SET PSOINST=S3

 +6        KILL S3,S2,S1,PSXUTIL

 +7        IF $GET(PSXSYS)

               Begin DoDot:1

 +8                IF ($PIECE($GET(^PSX(550,+PSXSYS,0)),"^",2)'="A")

                       KILL PSXSYS

 +9                SET Y=$$VERSION^XPDUTL("PSO")

                   IF Y>6.0

                       SET PSXVER=1

               End DoDot:1

 +10      IF '$TEST

               KILL PSXSYS

 +11       SET PSODIV=$SELECT(($PIECE(PSOSYS,"^",2))&('$PIECE(PSOSYS,"^",3)):0,1:1)

 +12       IF $DATA(DUZ)

               IF $DATA(^VA(200,+DUZ,0))

                   SET PSOCLC=DUZ

 +13      ; IHS/CIA/PLS - 12/30/03 - Call to setup IHS variables

 +14       SET X="APSPSITE"

           XECUTE ^%ZOSF("TEST")

           IF $TEST

               DO EP^APSPSITE

PLBL       IF $PIECE(PSOPAR,"^",8)

               Begin DoDot:1

 +1                SET %ZIS="MNQ"

                   SET %ZIS("A")="Select PROFILE PRINTER: "

                   IF $GET(PSOCLBL)&($DATA(PSOPROP))

                       SET %ZIS("B")=PSOPROP

 +2                DO ^%ZIS

                   KILL %ZIS,IO("Q"),IOP

                   IF POP

                       QUIT 

                   SET PSOPROP=ION

                   DO ^%ZISC

               End DoDot:1

LBL        SET %ZIS="MNQ"

           SET %ZIS("A")="Select LABEL PRINTER: "

           IF $GET(PSOCLBL)&($DATA(PSOLAP))!($GET(SUSPT))!($DATA(APSPLAP))

               SET %ZIS("B")=$SELECT($GET(SUSPT):PSLION,$LENGTH($GET(APSPLAP)):APSPLAP,1:$SELECT($GET(PSOLAP):PSOLAP,1:""))

 +1        DO ^%ZIS

           KILL %ZIS,IO("Q"),IOP

           IF POP

               SET PSOQUIT=1

           IF POP

               GOTO EXIT

           SET @$SELECT($GET(SUSPT):"PSLION",1:"PSOLAP")=ION

           SET PSOPIOST=$GET(IOST(0))

 +2        NEW PSOIOS

           SET PSOIOS=IOS

           DO DEVBAR^PSOBMST

 +3        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 EXIT

 +1        KILL DIR

           SET DIR("A")="OK to assume label alignment is correct"

           SET DIR("B")="YES"

           SET DIR(0)="Y"

           SET DIR("?")="Enter Y if labels are aligned, N if they need to be aligned."

           DO ^DIR

           IF $DATA(DIRUT)

               SET PSOQUIT=1

           IF Y!($DATA(DIRUT))

               GOTO EXIT

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       ; IHS/CIA/PLS - 12/30/03 - Call IHS test label routine

 +3       ;W ! K DIR,DIRUT,DUOUT,DTOUT S DIR(0)="E" D ^DIR K DIR,DTOUT,DUOUT Q:$D(DIRUT)  D ^PSOLBLT D ^%ZISC

 +4        WRITE !

           KILL DIR,DIRUT,DUOUT,DTOUT

           SET DIR(0)="E"

           DO ^DIR

           KILL DIR,DTOUT,DUOUT

           IF $DATA(DIRUT)

               QUIT 

           DO ^APSPLBLT

           DO ^%ZISC

 +5        KILL DIRUT,DIR

           SET DIR("A")="Is this correct"

           SET DIR("B")="YES"

           SET DIR(0)="Y"

           SET DIR("?")="Enter Y if labels are aligned correctly, N if they need to be aligned."

           DO ^DIR

           IF $DATA(DIRUT)

               SET PSOQUIT=1

           IF Y!($DATA(DIRUT))

               GOTO EXIT

 +6        GOTO P2

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

 +4       ; IHS/CIA/PLS - Clean up variables

           SET X="APSPXUT"

           XECUTE ^%ZOSF("TEST")

           IF $TEST

               DO ^APSPXUT

 +5        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