source: FOIAVistA/trunk/r/DRUG_ACCOUNTABILITY-PSA/PSALOCO.m@ 1397

Last change on this file since 1397 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 9.5 KB
Line 
1PSALOCO ;BIR/MNT,DB-Set Up/Edit a Pharmacy Location ;7/23/97
2 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**21**; 10/24/97
3 ;
4 ;References to ^PS(59, are covered under IA #212
5 ;References to ^PS(59.4, are covered under IA #2505
6 ;PSALOC = Internal entry number for location
7 ;References to ^PSDRUG( are covered by IA #2095
8 ;PSALOCN = Location Name
9 ;PSALOCA(PSALOCN,PSALOC)=ip site ^ Op site ^ more op sites
10 ;
11 K PSALOC
12PSAOPT W @IOF,!!,?20,"<<<< PHARMACY LOCATION OPTION SCREEN >>>>",! F X=1:1:(IOM-2) W "="
13 W !!,"# OPTION NAME",!,"---------------",!,"1. CHANGE LOCATION TYPE",!,"2. CHANGE LOCATION NAME",!,"3. INPATIENT SITE SELECTION (not available for Outpatient locations)"
14 W !,"4. OUTPATIENT SITE SELECTION (not available for Inpatient locations)"
15 W !,"5. IV ROOM SETUP ",!,"6. WARD SETUP"
16 W !,"7. INACTIVATE PHARMACY LOCATION",!,"8. ADD/EDIT DRUGS",!,"9. SET MAINTAIN REORDER LEVELS FLAG"
17 W !,"10. REACTIVATE A PHARMACY LOCATION."
18 W !,"11. CREATE NEW PHARMACY LOCATION"
19OPTASK W !!,"Select Option Number: " R AN:DTIME G Q:AN["^" G Q:AN="" G HLP:"?"[AN I AN<1!(AN>11) W !,"Please enter a number between 1 & 11." K AN G OPTASK
20 S PSAOPT=AN I AN="10" G 10
21 I PSAOPT="11" G ADD^PSALOC
22 I $G(PSALOC)="" D ^PSALOC G Q:$G(PSALOC)'>0 G @PSAOPT
231 S PSAHDR="CHANGE LOCATION TYPE" D HDR
24 D ^PSALOC2
25 G NXT
262 S PSAHDR="CHANGE LOCATION NAME" D HDR
27 W !,"The new location name must at least contain : " S PSACHKR=$S($E(PSALOCN)="C":"COMBINED (IP/OP)",$E(PSALOCN)="I":"INPATIENT",1:"OUTPATIENT") W PSACHKR
28ASK2 R !,"Please enter the new name : ",AN:DTIME G NXT:AN["^" I AN="" W " ??? " G ASK2
29 S PSALOCN1=AN I $E(PSALOCN1,1,$L(PSACHKR))'=PSACHKR W !,"Sorry, the new name must start with "_PSACHKR G ASK2
30 I $D(^PSD(58.8,"B",PSALOCN1)) W !,"Sorry, this name is already setup." K PSALOCN1 G ASK2
31 S $P(^PSD(58.8,PSALOC,0),"^")=PSALOCN1
32 K ^PSD(58.8,"B",PSALOCN,PSALOC)
33 S ^PSD(58.8,"B",PSALOCN1,PSALOC)=""
34 S PSALOCA(PSALOCN1,PSALOC)=PSALOCA(PSALOCN,PSALOC)
35 S PSALOCA(PSALOCN1,PSALOC)=PSALOCA(PSALOCN,PSALOC)
36 S PSAMNU(PSANUM,PSALOCN1,PSALOC)=PSAMNU(PSANUM,PSALOCN,PSALOC) K PSAMNU(PSANUM,PSALOCN,PSALOC)
37 S PSALOCN=PSALOCN1 K PSALOCN1
38 G NXT
393 S PSAHDR="INPATIENT SITE SELECTION" D HDR
40 I $E(PSALOCN)="O" W !!,"Sorry, Inpatient Site association is not permitted for an Outpatient Location" G QUIT3
41 I $P($G(PSALOCA(PSALOCN,PSALOC)),"^")="" S (PSA(1),PSA(2))=0 G INP
42 S PSAISIT=$P($G(PSALOCA(PSALOCN,PSALOC)),"^")
43 S PSAISIT(1)=$P($G(^PS(59.4,PSAISIT,0)),"^") ;Inpatient Site Name
44 W !,"Inpatient Site : ",$P($G(^PS(59.4,$P($G(PSALOCA(PSALOCN,PSALOC)),"^"),0)),"^")
45 W !,"Change this site? NO// " R AN:DTIME I AN["^" G QUIT3
46 S:AN="" AN="N" S AN=$E(AN) I "NnyY"'[AN W !,"Answer 'Y' for yes to change which Inpatient Site is associated with this",!,"pharmacy location.",! D EOP G 3
47 I "nN"[AN G QUIT3
48 S PSAIVCHG=1
49 S (PSA(1),PSA(2))=0
50INP S PSA(1)=$O(^PS(59.4,PSA(1))) G INPQ:PSA(1)'>0 I $P($G(^PS(59.4,PSA(1),0)),"^",26)=1 S PSA(2)=PSA(2)+1,PSAB=PSA(1)
51 G INP
52INPQ ;End loop through inpatient file
53 I PSA(2)<1 W !,"An Inpatient Site has not been identified for AR/WS.",!,"AR/WS dispensing data cannot be gathered" G QUIT3
54 S:PSA(2)=1 PSAISIT=PSAB
55 I $G(PSAIVCHG)=1,PSA(2)=1 W !,"Sorry, but this is the only inpatient site in the Inpatient Site file ? ",! G QUIT3
56 D:PSA(2)>1 I Y<1 S PSAOU=1 G QUIT3
57 .W !!,"Because there is more than one Inpatient Site at this facility, I need you to",! S DIC="^PS(59.4,",DIC(0)="AEQMZ",DIC("A")="Select an AR/WS Inpatient Site Name : ",DIC("S")="I $P($G(^(0)),U,26)=1" D ^DIC S PSAISIT=+Y
58 .K DIC S:$D(DUOUT)!($D(DTOUT))!(X="") PSAERR=1 Q
59 .I PSAITY=3&(Y<1) S PSAOU=1 S PSAERR=1 Q
60 .S PSAISIT=+Y
61 I $G(PSAERR)=1 G QUIT3
62 S PSALOCI=0 F S PSALOCI=$O(^PSD(58.8,"ASITE",PSAISIT,"P",PSALOCI)) Q:'PSALOCI I '$P($G(^PSD(58.8,PSALOCI,"I")),"^") W !,"Already Assigned to : "_$P($G(^PSD(58.8,PSALOCI,0)),"^") S PSAERR=1
63 I $G(PSAERR)'>0,$G(PSAISIT)>0,$G(PSALOC)>0 S DIE="^PSD(58.8,",DA=PSALOC,DR="2////^S X=PSAISIT" D ^DIE S $P(PSALOCA(PSALOCN,PSALOC),"^")=PSAISIT
64 ;
65QUIT3 G NXT
664 S PSAHDR="OUTPATIENT SITE SELECTION" D HDR
67 I $E(PSALOCN)="I" W !!,"Sorry, Outpatient Site association is not permitted for an Inpatient Location.",! G QUIT4
68 I $G(PSAITY)=1 G QUIT4
69 S PSAOSIT=$P($G(PSALOCA(PSALOCN,PSALOC)),"^",2)
70 W !!,"Outpatient site selection affects the collection of dispensing data.",!,"When a prescription is released through Outpatient pharmacy, the data is stored "
71 W !,"then retrieved by the Drug Accountability back-ground job that runs each night.",!!
72 ;
73OPASK ;get Outpatient site(s)
74 I $G(PSAOSIT)'="" S PSAOSIT(1)=$P($G(^PS(59,PSAOSIT,0)),"^")
75 W !,"Primary Outpatient Site : ",$S($G(PSAOSIT)="":"Unknown",1:$G(PSAOSIT(1)))
76 D OPSITES I $O(PSAOSIT(1))'="" W !,"Secondary Site(s) : " F X=2:1 Q:$G(PSAOSIT(X))="" I PSAOSIT(X)'=PSAOSIT W ?34,$P($G(^PS(59,PSAOSIT(X),0)),"^"),!
77 K DIC,DA,DO,DR,DIR,DIE
78 S DIC(0)="AEQMZL",DA(1)=PSALOC,DIC="^PSD(58.8,PSALOC,7,",DIC("A")="Select Outpatient Site: " D ^DIC
79 I +Y'>0 G QUIT4
80 ;Check for existence of op site in PSALOCA(PSALOCN,PSALOC)
81 S DA=+Y
82 S PSAOSIT=+Y,PSAOSIT(1)=Y(0,0),DIE="^PSD(58.8,PSALOC,7,",DR="1" D ^DIE
83 ;
84 I $P($G(PSALOCA(PSALOCN,PSALOC)),"^",2)="" S $P(PSALOCA(PSALOCN,PSALOC),"^",2)=PSAOSIT G QUIT4
85 S NOMATCH=0,CNTR=1 F X=2:1 Q:$G(PSAOSIT(X))="" S CNTR=$G(CNTR)+1 I PSAOSIT(X)=+PSAOSIT S NOMATCH=1
86 I $G(NOMATCH)=0 S $P(PSALOCA(PSALOCN,PSALOC),"^",(CNTR+1))=+PSAOSIT
87 ;
88QUIT4 G NXT
895 S PSAHDR="IV ROOM SETUP" D HDR
90 D IV^PSAENTO
91QUIT5 G NXT
926 S PSAHDR="WARD LOCATION SETUP" D HDR
93 I $G(PSAISIT)'>0,$P(PSALOCA(PSALOCN,PSALOC),"^")'="" S PSAISIT=$P(PSALOCA(PSALOCN,PSALOC),"^")
94 I $G(PSAISIT)'>0 W !!,"Sorry, I cannot find an Inpatient Site associated with this location.",! G WARDQ
95 I $O(^PSD(58.8,+PSALOC,3,0))="" W !,"No wards are currently assigned to this location."
96 S PSAWARD=0 I $O(^PSD(58.8,+PSALOC,3,0)) W !,PSALOCN," is set up to gather AR/WS dispensing data for : ",!!,$P($G(^PS(59.4,+PSAISIT,0)),U),"," D
97 .S PSA(3)=0 F S PSA(3)=$O(^PSD(58.8,+PSALOC,3,+PSA(3))) Q:'PSA(3) W:$X+10>IOM ! W $P($G(^DIC(42,+PSA(3),0)),U),$S($O(^PSD(58.8,+PSALOC,3,+PSA(3))):", ",1:".")
98EDTWRD ;Edit Wards
99 R !!,"Do you want to add/edit the wards accociated with this location? NO // ",AN:DTIME G WARDQ:AN["^" I AN="" S AN="N"
100 S AN=$E(AN) I "yYnN"'[AN W !,"Answer Yes, and we'll loop through the ward file, and either add new wards,",!,"or delete wards already associated with this location. " G EDTWRD
101 I "Nn"[AN G WARDQ
102 S PSAWARD=0
103WARDLP S PSAWARD=$O(^DIC(42,PSAWARD)) G WARDQ:PSAWARD'>0 W !,$P($G(^DIC(42,PSAWARD,0)),"^")
104 I '$D(^PSD(58.8,PSALOC,3,PSAWARD,0)) G WARD1
105WARDASK R ?25,"Remove association with location? NO // ",AN:DTIME I AN["^" S PSAERR=1 G WARDQ
106 I AN="" G WARDLP
107 I "YyNn"'[AN W !
108 I "yY"[AN W ?(IOM-9),"removed" S DIK="^PSD(58.8,+PSALOC,3,",DIC(0)="AEMQ",DA(1)=PSALOC,DA=PSAWARD D ^DIK
109 G WARDLP
110 ;
111WARD1 ;not currently assigned
112 I $D(^PSD(58.8,"AB",PSAWARD)),$O(^PSD(58.8,"AB",PSAWARD,0))'=PSALOC W ?30,"This ward is already associated with : "_$P($G(^PSD(58.8,$O(^PSD(58.8,"AB",PSAWARD,0)),0)),"^") G WARDLP
113 R ?40,"Add to location ? NO // : ",AN:DTIME G WARDQ:AN["^" I AN="" G WARDLP
114 S AN=$E(AN) I "nNyY"'[AN W !,"Do you want to add this ward to this location?" K AN G WARD1
115 I "Nn"[AN G WARDLP
116 W ?(IOM-7),"Adding" S (DINUM,X)=PSAWARD,DIC="^PSD(58.8,+PSALOC,3,",DA(1)=PSALOC,DIC(0)="LNX" D FILE^DICN
117 G WARDLP
118WARDQ ;
119 G NXT
1207 S PSAHDR="EDIT INACTIVATION DATA" D HDR
121 S DIE="^PSD(58.8,",DA=PSALOC,DR="4" D ^DIE
122 G NXT
1238 S PSAHDR="ADD/EDIT DRUGS FOR LOCATION" D HDR
124 I $O(^PSD(58.8,PSALOC,1,0))>0 G 83
12581 R !,"Do you want to transfer drugs from another location? NO// ",AN:DTIME G Q:AN["^" S AN=$E(AN) I "nN"[AN G 83
126 I "YyNn"'[AN W !,"Answer 'Y'es to transfer all the drugs from another location to this location.",!,"Please note that the drugs will be inactivated in the old location." G 81
12782 R !,"Transfer the drug's balance, stock level, etc., as well? YES // ",AN:DTIME G Q:AN["^" S AN=$E(AN) I "nN"'[AN S PSATFER=0
128 I "YyNn"'[AN W !!,"Answer 'Y'es to transfer all the current information about the drug to the new",!," location.",!! G 82
129 I "Yy"[AN S PSATFER=1
130811 S PSALOCB=PSALOC K PSALOC D ^PSALOC G Q:$G(PSALOC)'>0 S PSALOC2=PSALOC,PSALOC=PSALOCB K PSALOCB I PSALOC2=PSALOC W !!,"Sorry, that is the current location." D EOP G 811
131 S X1=0 F S X1=$O(^PSD(58.8,PSALOC2,1,X1)) Q:X1'>0 W !,$P($G(^PSDRUG(X1,0)),"^") D
132 .S ^PSD(58.8,PSALOC,1,X1,0)=X1 I $G(PSATFER)=1 S ^PSD(58.8,PSALOC,1,X1,0)=^PSD(58.8,PSALOC2,1,X1,0)
133 .S ^PSD(58.8,PSALOC,1,"B",X1,X1)="" ;drug xref
134 D EOP G NXT
13583 K DIC,DIR S PSAOPT="PSALOC" D GETDRUG^PSADRUGP K PSAOPT
136 G NXT
1379 S PSAHDR="SET/DELETE MAINTAIN REORDER LEVELS FLAG"
138 S DIE="^PSD(58.8,",DA=PSALOC,DR=34 D ^DIE K DA,DIE
139 G NXT
14010 S DIC(0)="AEQMZ",DIC="^PSD(58.8,",DIC("A")="Select Inactive Pharmacy Location: ",DIC("S")="I $D(^PSD(58.8,+Y,""I""))"
141 D ^DIC G Q:+Y'>0 S DIE="^PSD(58.8,",DA=+Y,DR="4" D ^DIE
142 I $P($G(^PSD(58.8,DA,"I")),"^")="" K ^PSD(58.8,DA,"I") W !,$P(^PSD(58.8,DA,0),"^")," Reactivated."
143 Q
144PSA10 S PSAHDR="SETUP RECIPIENTS OF MAILMESSAGE" W @IOF,!,PSAHDR_" SCREEN",! F X=1:1:(IOM-1) W "="
145 D PSASETUP^PSALOC1,EOP Q
146HLP W !!,"Display help for which item # ?" R AN:DTIME G PSALOCO:"^"[AN I AN<1!(AN>10) G OPTASK
147 S X="PSAHLP"_AN_"^PSALOC1" D @X G OPTASK
148EOP F X=$Y:1:(IOSL-5) W !
149 R !,"Press RETURN/ENTER to continue: ",AN:DTIME
150 Q
151Q G EXIT^PSALOC
152HDR S PSAHDR=PSAHDR_" SCREEN" W @IOF,!,PSAHDR_" for : "_PSALOCN,! F X=1:1:(IOM-1) W "="
153 ;
154 W ! Q
155NXT D EOP G PSALOCO
156OPSITES ;
157 F X=2:1 Q:'$D(PSAOSIT(X)) K PSAOSIT(X)
158 F X=2:1 Q:$P($G(PSALOCA(PSALOCN,PSALOC)),"^",X)="" S PSAOSIT(X)=$P($G(PSALOCA(PSALOCN,PSALOC)),"^",X)
159 Q
160ADD S X6=$$MG^XMBGRP(PSAGROUP,0,DUZ,0,.XMY,,0)
161 W !,$S($G(X6)>0:"Ok, addition completed.",1:"error in adding users ? "),!
162 Q
Note: See TracBrowser for help on using the repository browser.