source: WorldVistAEHR/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUMAP0.m@ 619

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

initial load of WorldVistAEHR
File size: 5.7 KB
Line 
1PSUMAP0 ;BHM/PDW-MAP OAU,NAOU,DA LOCATION TO DIVISION/OUTPATIENT SITES ; 4/12/07 2:12pm
2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**12**;MARCH, 2005;Build 19
3 ;
4 ;DBIA's
5 ;Reference to file (#59.7) supported by DBIA 2854
6 ;
7EN ; select Editing or Report of Mapping
8 W @IOF,!,?10,"MAPPING PHARMACY LOCATIONS FOR PBM EXTRACTS",!!
9 ;
10MODP ; module selection prompt
11 W !!,?5,"This option allows the mapping of dispensing/procurement locations"
12 W !,?5,"from the AR/WS, Controlled Substances, and Drug Accountability"
13 W !,?5,"applications to either a Medical Center Division or an Outpatient Site."
14 W !,?5,"Any dispensing/procurement data associated with an AR/WS AOU, CS NAOU"
15 W !,?5,"or DA Pharmacy Location that has not been mapped will be attributed to"
16 W !,?5,"to the facility at which the database resides. Any unmapped locations"
17 W !,?5,"will be displayed upon entering the option.",!
18 ;
19 D EN1^PSUMAPR ;scan and report unmapped locations
20 W @IOF
21 ;
22MODULE ;
23 W !!,"Select the dispensing/procurement location to map:",!
24 S PSUA(1)="1. AR/WS Area of Use (AOU)"
25 S PSUA(2)="2. Controlled Substances (CS) Narcotic Area of Use (NAOU)"
26 S PSUA(3)="3. Drug Accountability (DA) Pharmacy location"
27 S PSUA(4)="4. Print Report of Mapped/Unmapped Locations"
28 F I=1:1:4 W !,?10,PSUA(I)
29 W !!,?2,"You may select all by entering 'A' for ALL or by using '1:4'.",!
30 W !,?2,"Select the dispensing/procurement location: "
31 R X:DTIME E W !!,"Nothing Selected - Exiting",! H 3 G EXIT
32 I X["^" G EXIT:X="^"
33 I X="" W " <??>",$C(7) S X="?"
34 ;
35 S:"Aa"[$E(X) X="1:4"
36MODHLP I X["?" D G MODULE
37 .W !!,"Enter: A single number to edit (or print) that selection."
38 .W !,?8,"A range of code numbers. Example: 1:3"
39 .W !,?8,"Multiple code numbers separated by commas. Example: 1,3"
40 .W !,?8,"The letter A to select ALL items."
41 .W !,?8,"A single up-arrow ( ^ ) to exit now without any action."
42 S X=$TR(X,"-;_><.A","::::::")
43 K PSUMOD
44 F PII=1:1:$L(X,",") D
45 .S X1=$P(X,",",PII)
46 .Q:X1=""
47 .I X1[":" D Q
48 ..S XBEG=$P(X1,":",1),XEND=$P(X1,":",2)
49 ..I (XBEG="")!(XEND="") Q
50 ..F PJJ=XBEG:1:XEND S PSUMOD(PJJ)=""
51 ..K PJJ,XBEG,XEND
52 .S PSUMOD(X1)=""
53 ; modified to fix <UNDEFINED> PSU*3*12 BAJ
54 S X="",ERC=0 F S X=$O(PSUMOD(X)) Q:X="" I '$D(PSUA(X)) S ERC=1 Q
55 I ERC W !!,"<INVALID CHOICE - ",X,", TRY AGAIN>",$C(7) G MODP
56 I '$D(PSUMOD) W !!,"No choices were made." K DIR S DIR(0)="E",DIR("A")="EXITING" D ^DIR G EXIT
57 ;
58 ;
59 W !!,"You have selected: "
60 S X="",PSUOPTS="" F S X=$O(PSUMOD(X)) Q:X="" W !,?10,PSUA(X)
61 W ! K DIR S DIR(0)="E" D ^DIR G:'Y EXIT
62 I $D(PSUMOD(4)) D REPORT K PSUA(4)
63 I $D(PSUMOD(1)) D E9001
64 I $D(PSUMOD(2)) D E9002
65 I $D(PSUMOD(3)) D E9003
66 Q
67E9001 ;EDIT 90.01 AR/WS AOU MAPPING
68 W @IOF,!!,?20,"EDITING Mapping of AR/WS AOUs",!!
69 K DIC,DA,DIE
70 K Z,ZZ,IENS
71 S DA(1)=1
72 S DIC="^PS(59.7,1,90.01,",DA(1)=1,DIC(0)="ACEQML"
73 S DIC("W")="X XX1,XX2"
74 S XX1="S IENS=+Y_"",""_DA(1) S Z=$$GET1^DIQ(59.79001,IENS,.02),ZZ=$$GET1^DIQ(59.79001,IENS,.03) W:$L(Z) ?35,""Div: "",Z W:$L(ZZ) ?35,""OP: "",ZZ"
75 S XX2="S ZZ=$$GET1^DIQ(58.1,+Y,3,""I"") W:ZZ ?65,""**INACTIVE**"""
76 D ^DIC
77 Q:Y'>0
78 S DA=+Y,DIE=DIC
79 S ZZ=^PS(59.7,1,90.01,DA,0),XX=$P(ZZ,U,2),YY=$P(ZZ,U,3)
80 I YY S DR=".01;.03;S:X'="""" Y=0;.02" I 1
81 E S DR=".01;.02;S:X'="""" Y=0;.03"
82 D ^DIE W !
83 G E9001
84 ;
85CHK1 ;check that AOUs are mapped
86 K IENS
87 S DA=0,DA(1)=1 F S DA=$O(^PS(59.7,1,90.01,DA)) Q:DA'>0 D
88 . S Z=^PS(59.7,1,90.01,DA,0),X=$P(Z,U,2),Y=$P(Z,U,3)
89 . I Y,'X Q
90 . I 'Y,X Q
91 . S IENS=DA_",1" W !,?3,"AR/WS AOU",?15,$$GET1^DIQ(59.79001,IENS,.01),?25," is not mapped."
92 I $G(STOP),$G(IENS) K DIR S DIR(0)="E" D ^DIR I X="^" S PSUSTOP=1 I 1
93 Q
94 ;
95E9002 ;EDIT 90.02 CS NAOU MAPPING
96 W @IOF,!!,?20,"EDITING Mapping of CS NAOUs",!!
97 K DIC,DA,DIE
98 K Z,ZZ,IENS
99 S DA(1)=1
100 S DIC="^PS(59.7,DA(1),90.02,",DIC(0)="AEQMLCZ"
101 S DIC("W")="X XX1,XX2"
102 S XX1="S IENS=+Y_"",""_DA(1) S Z=$$GET1^DIQ(59.79002,IENS,.02),ZZ=$$GET1^DIQ(59.79002,IENS,.03) W:$L(Z) ?35,""Div: "",Z W:$L(ZZ) ?35,""OP: "",ZZ"
103 S XX2="S ZZ=$$GET1^DIQ(58.8,+Y,4,""I"") W:ZZ ?65,""**INACTIVE** """
104 D ^DIC
105 Q:Y'>0
106 S DA=+Y,DIE=DIC
107 S ZZ=^PS(59.7,1,90.02,DA,0),XX=$P(ZZ,U,2),YY=$P(ZZ,U,3)
108 I YY S DR=".01;.03;S:X'="""" Y=0;.02" I 1
109 E S DR=".01;.02;S:X'="""" Y=0;.03"
110 D ^DIE W !
111 G E9002
112 ;
113CHK2 ;check that NAOUs are mapped
114 K IENS
115 S DA=0,DA(1)=1 F S DA=$O(^PS(59.7,1,90.02,DA)) Q:DA'>0 D
116 . S Z=^PS(59.7,1,90.02,DA,0),X=$P(Z,U,2),Y=$P(Z,U,3)
117 . I Y,'X Q
118 . I 'Y,X Q
119 . S IENS=DA_",1" W !,?3,"CS NAOU",?15,$$GET1^DIQ(59.79002,IENS,.01),?25," is not mapped."
120 Q
121E9003 ;EDIT 90.03 DRUG ACCOUNTABILITY LOCATION MAPPING
122 W @IOF,!!,?20,"EDITING Mapping of DA Pharmacy Locations",!!
123 K DIC,DA,DIE
124 K Z,ZZ,IENS
125 S DA(1)=1
126 S DIC="^PS(59.7,DA(1),90.03,",DIC(0)="AEQMLZ"
127 S DIC("W")="X XX1,XX2"
128 S XX1="S IENS=+Y_"",""_DA(1) S Z=$$GET1^DIQ(59.79003,IENS,.02),ZZ=$$GET1^DIQ(59.79003,IENS,.03) W:$L(Z) ?35,"" Div: "",Z W:$L(ZZ) ?35,""OP: "",ZZ"
129 S XX2="S ZZ=$$GET1^DIQ(58.8,+Y,4,""I"") W:ZZ ?65,""**INACTIVE** """
130 D ^DIC
131 Q:Y'>0
132 S DA=+Y,DIE=DIC
133 S ZZ=^PS(59.7,1,90.03,DA,0),XX=$P(ZZ,U,2),YY=$P(ZZ,U,3)
134 I YY S DR=".01;.03;S:X'="""" Y=0;.02" I 1
135 E S DR=".01;.02;S:X'="""" Y=0;.03"
136 D ^DIE W !
137 G E9003
138 ;
139CHK3 ;check that DRUG ACCOUNTABILITY LOCATIONs are mapped
140 K IENS
141 S DA=0,DA(1)=1 F S DA=$O(^PS(59.7,1,90.03,DA)) Q:DA'>0 D
142 . S Z=^PS(59.7,1,90.03,DA,0),X=$P(Z,U,2),Y=$P(Z,U,3)
143 . I Y,'X Q
144 . I 'Y,X Q
145 . S IENS=DA_",1" W !,?3,"DA Phar Loc",?15,$$GET1^DIQ(59.79003,IENS,.01),?25," is not mapped."
146 I $G(STOP),$G(IENS) K DIR S DIR(0)="E" D ^DIR I X="^" S PSUSTOP=1 I 1
147 Q
148REPORT ;Print Mapping Report
149 W @IOF,!,"Print Pharmacy Location PBM Extract Mapping Report",!
150 S %ZIS="Q" D ^%ZIS
151 Q:POP
152 I $D(IO("Q")) D QUEUE Q
153 D EN^PSUMAPR
154 Q
155QUEUE S ZTRTN="EN^PSUMAPR",ZTDESC="PRINT REPORT OF PBM EXTRACT MAPPING"
156 S ZTREQ="@" D ^%ZTLOAD
157 W !,"TASKED with ",$G(ZTSK) I '$G(ZTSK) W ">> DID NOT Task !!",! H 3
158 Q
159EXIT ;
160 Q
Note: See TracBrowser for help on using the repository browser.