- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLSET.m
r613 r623 1 PSOLSET 2 VERS ;;7.0;OUTPATIENT PHARMACY;**10,22,32,40,120,247,208**;DEC 1997;Build 413 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 DIV1 33 DIV2 34 35 36 37 DIV3 38 39 40 41 42 43 44 45 46 47 48 PLBL 49 50 51 52 53 LBL 54 55 56 57 LASK 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 P2 78 79 80 81 82 LEAVE 83 Q 84 85 EXIT 86 87 88 FINAL 89 90 91 92 93 GROUP 94 95 96 97 98 99 100 GROUP1 101 102 103 104 105 106 1 PSOLSET ;BHAM ISC/SAB - site parameter set up ;3/13/07 19:50 2 VERS ;;7.0;OUTPATIENT PHARMACY;**10,22,32,40,120,247,208**;DEC 1997;Build 39 3 ; Modified from FOIA VistA 4 ; Copyright (C) 2007 WorldVistA 5 ; 6 ; This program is free software; you can redistribute it and/or modify 7 ; it under the terms of the GNU General Public License as published by 8 ; the Free Software Foundation; either version 2 of the License, or 9 ; (at your option) any later version. 10 ; 11 ; This program is distributed in the hope that it will be useful, 12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of 13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 ; GNU General Public License for more details. 15 ; 16 ; You should have received a copy of the GNU General Public License 17 ; along with this program; if not, write to the Free Software 18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA 19 ;Reference to ^PS(59.7 supported by DBIA 694 20 ;Reference to ^PSX(550 supported by DBIA 2230 21 ;Reference to ^%ZIS(2 supported by DBIA 3435 22 ; 23 I '$D(DUZ) W !,$C(7),"DUZ Number must be defined !!",! G LEAVE 24 W !,"Outpatient Pharmacy software - Version "_$P($T(VERS),";",3) 25 I $D(^XTMP("PSO_V7 INSTALL",0)) W !!,"Outpatient Pharmacy software is being installed. PLEASE TRY LATER!",! G LEAVE 26 S PSOBAR1="",PSOBARS=0 ;make sure we have one 27 S PSOCNT=0 F I=0:0 S I=$O(^PS(59,I)) Q:'I S PSOCNT=PSOCNT+1,Y=I 28 G DIV1:PSOCNT W !,$C(7) S DIR("A",1)="Site parameters must be specified for at least one site." 29 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 30 G LEAVE:"Y"'[$E(X) 31 W ! D ^PSOSITED G PSOLSET 32 DIV1 G:PSOCNT=1 DIV3 S DIR(0)="Y",DIR("?")="Enter 'Y' to select Division or 'N' to EXIT" 33 DIV2 I PSOCNT>1 W ! S DIC("A")="Division: ",DIC=59,DIC(0)="AEMQ" 34 S:$G(PSOVEX)'=1 DIC("S")="I $S('$D(^PS(59,+Y,""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0)" 35 D ^DIC K DIC G:$D(DUOUT)!($D(DTOUT)) LEAVE 36 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 37 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 38 S PSOPINST=$P($G(^PS(59,PSOSITE,"INI")),"^") 39 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 40 S PSXSYS=+$O(^PSX(550,"C",""))_"^"_$G(S3)_"^"_$G(S2),PSOINST=S3 41 K S3,S2,S1,PSXUTIL 42 I $G(PSXSYS) D 43 .K:($P($G(^PSX(550,+PSXSYS,0)),"^",2)'="A") PSXSYS 44 .S Y=$$VERSION^XPDUTL("PSO") I Y>6.0 S PSXVER=1 45 E K PSXSYS 46 S PSODIV=$S(($P(PSOSYS,"^",2))&('$P(PSOSYS,"^",3)):0,1:1) 47 I $D(DUZ),$D(^VA(200,+DUZ,0)) S PSOCLC=DUZ 48 PLBL I $P(PSOPAR,"^",8) D 49 .S %ZIS="MNQ",%ZIS("A")="Select PROFILE PRINTER: " S:$G(PSOCLBL)&($D(PSOPROP)) %ZIS("B")=PSOPROP 50 .D ^%ZIS K %ZIS,IO("Q"),IOP Q:POP S PSOPROP=ION D ^%ZISC 51 S PSOAFIN=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",1) ;vfah 52 S PSOAFPFX=$S(PSOAFIN="Y":"Select LABEL PRINTER or FAX DEVICE: ",1:"Select LABEL PRINT: ") ;vfah 53 LBL S %ZIS="MNQ",%ZIS("A")=PSOAFPFX S:$G(PSOCLBL)&($D(PSOLAP))!($G(SUSPT)) %ZIS("B")=$S($G(SUSPT):PSLION,1:PSOLAP) ;vfah 54 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)) 55 N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST 56 S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",19),PSOIOS=IOS D ^%ZISC 57 LASK I $G(PSOPIOST),$D(^%ZIS(2,PSOPIOST,55,"B","LL")) G EXIT 58 ; 59 ;vfah AutoFinish fax additions begin here 60 K PSOAFFXP,PSOAFFXL 61 I PSOLAP["FAX" D 62 .S PSOAFFXP="",PSOAFFXL="",PSOAFFXR="" 63 .S PSOLAP="AFFAX" D 64 ..S PSOION="" S PSOION=$O(^%ZIS(1,"B",PSOLAP,PSOION)) 65 ..I $D(^DIZ(22900)) D 66 ...S DIC="^DIZ(22900,",DIC(0)="AEQMZ",DIC("A")="SEND FAX TO: " 67 ...D ^DIC K DIC 68 ...I Y=-1 W !,"Invalid selection" G LBL 69 ...S PSOAFFXL=$P(Y,"^",2) 70 ...S PSOAFFXP=$P($G(^DIZ(22900,+Y,3)),"^",3) 71 ...S PSOAFFXR=PSOAFFXP 72 ...I PSOAFFXL=""!(PSOAFFXP="") G LBL 73 I $G(PSOAFFXP)&(PSOLAP="AFFAX")'="" G EXIT 74 ;vfah Autofinish fax additions end here 75 ; 76 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 77 P2 S IOP=$G(PSOLAP) D ^%ZIS K IOP I POP W $C(7),!?5,"Printer is busy.",! G LASK 78 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." 79 W ! K DIR,DIRUT,DUOUT,DTOUT S DIR(0)="E" D ^DIR K DIR,DTOUT,DUOUT Q:$D(DIRUT) D ^PSOLBLT D ^%ZISC 80 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 81 G P2 82 LEAVE S XQUIT="" G FINAL 83 Q W !?10,$C(7),"Default printer for labels must be entered." G LBL 84 ; 85 EXIT D ^%ZISC Q:$G(PSOCLBL) 86 D:'$G(PSOBFLAG) GROUP K I,IOP,X,Y,%ZIS,DIC,J,DIR,X,Y,DTOUT,DIROUT,DIRUT,DUOUT Q 87 ; 88 FINAL ;exit action from main menu - kill and quit 89 K SITE,PSOCP,PSNP,PSL,PRCA,PSLION,PSOPINST 90 K GROUPCNT,DISGROUP,PSOCAP,PSOINST,PSOION,PSONULBL,PSOSITE7,PFIO,PSOIOS,X,Y,PSOSYS,PSODIV,PSOPAR,PSOPAR7,PSOLAP,PSOPROP,PSOCLC,PSOCNT 91 K PSODTCUT,PSOSITE,PSOPRPAS,PSOBAR1,PSOBAR0,PSOBARS,SIG,DIR,DIRUT,DTOUT,DIROUT,DUOUT,I,%ZIS,DIC,J,PSOREL 92 Q 93 GROUP ;display group 94 S GROUPCNT=0,AGROUP="" I $D(^PS(59.3,0)) F S AGROUP=$O(^PS(59.3,"B",AGROUP)) Q:AGROUP="" D 95 .S GROUPCNT=GROUPCNT+1 I GROUPCNT=1 S AGROUP1=AGROUP 96 S:GROUPCNT=1 GRPNME=AGROUP1,II="" G:GROUPCNT>1 GROUP1 97 Q:'$D(GRPNME) F S II=$O(^PS(59.3,"B",GRPNME,II)) Q:II="" S DISGROUP=II 98 K AGROUP,AGROUP1,GRPNME,II 99 Q 100 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" 101 S:$P($G(^PS(59,PSOSITE,1)),"^",20) DIC("B")=$P($G(^PS(59,PSOSITE,1)),"^",20) 102 D ^DIC K DIC Q:$D(DTOUT)!($D(DUOUT)) 103 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 104 S DISGROUP=+Y 105 K DIR,DIC,AGROUP,AGROUP1,GRPNME,II 106 Q
Note:
See TracChangeset
for help on using the changeset viewer.
