- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUMAP0.m
r613 r623 1 PSUMAP0 ;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 ; 7 EN ; select Editing or Report of Mapping 8 W @IOF,!,?10,"MAPPING PHARMACY LOCATIONS FOR PBM EXTRACTS",!! 9 ; 10 MODP ; 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 ; 22 MODULE ; 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" 36 MODHLP 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 67 E9001 ;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 ; 85 CHK1 ;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 ; 95 E9002 ;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 ; 113 CHK2 ;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 121 E9003 ;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 ; 139 CHK3 ;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 148 REPORT ;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 155 QUEUE 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 159 EXIT ; 160 Q 1 PSUMAP0 ;BHM/PDW-MAP OAU,NAOU,DA LOCATION TO DIVISION/OUTPATIENT SITES ; 9SEP2003 2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005 3 ; 4 ;DBIA's 5 ;Reference to file (#59.7) supported by DBIA 2854 6 ; 7 EN ; select Editing or Report of Mapping 8 W @IOF,!,?10,"MAPPING PHARMACY LOCATIONS FOR PBM EXTRACTS",!! 9 ; 10 MODP ; 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 ; 22 MODULE ; 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" 36 MODHLP 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 S (X,ERC)=0 F S X=$O(PSUMOD(X)) Q:X="" I '$D(PSUA(X)) S ERC=1 Q 54 I ERC W !!,"<INVALID CHOICE - ",X,", TRY AGAIN>",$C(7) G MODP 55 I '$D(PSUMOD) W !!,"No choices were made." K DIR S DIR(0)="E",DIR("A")="EXITING" D ^DIR G EXIT 56 ; 57 ; 58 W !!,"You have selected: " 59 S X="",PSUOPTS="" F S X=$O(PSUMOD(X)) Q:X="" W !,?10,PSUA(X) 60 W ! K DIR S DIR(0)="E" D ^DIR G:'Y EXIT 61 I $D(PSUMOD(4)) D REPORT K PSUA(4) 62 I $D(PSUMOD(1)) D E9001 63 I $D(PSUMOD(2)) D E9002 64 I $D(PSUMOD(3)) D E9003 65 Q 66 E9001 ;EDIT 90.01 AR/WS AOU MAPPING 67 W @IOF,!!,?20,"EDITING Mapping of AR/WS AOUs",!! 68 K DIC,DA,DIE 69 K Z,ZZ,IENS 70 S DA(1)=1 71 S DIC="^PS(59.7,1,90.01,",DA(1)=1,DIC(0)="ACEQML" 72 S DIC("W")="X XX1,XX2" 73 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" 74 S XX2="S ZZ=$$GET1^DIQ(58.1,+Y,3,""I"") W:ZZ ?65,""**INACTIVE**""" 75 D ^DIC 76 Q:Y'>0 77 S DA=+Y,DIE=DIC 78 S ZZ=^PS(59.7,1,90.01,DA,0),XX=$P(ZZ,U,2),YY=$P(ZZ,U,3) 79 I YY S DR=".01;.03;S:X'="""" Y=0;.02" I 1 80 E S DR=".01;.02;S:X'="""" Y=0;.03" 81 D ^DIE W ! 82 G E9001 83 ; 84 CHK1 ;check that AOUs are mapped 85 K IENS 86 S DA=0,DA(1)=1 F S DA=$O(^PS(59.7,1,90.01,DA)) Q:DA'>0 D 87 . S Z=^PS(59.7,1,90.01,DA,0),X=$P(Z,U,2),Y=$P(Z,U,3) 88 . I Y,'X Q 89 . I 'Y,X Q 90 . S IENS=DA_",1" W !,?3,"AR/WS AOU",?15,$$GET1^DIQ(59.79001,IENS,.01),?25," is not mapped." 91 I $G(STOP),$G(IENS) K DIR S DIR(0)="E" D ^DIR I X="^" S PSUSTOP=1 I 1 92 Q 93 ; 94 E9002 ;EDIT 90.02 CS NAOU MAPPING 95 W @IOF,!!,?20,"EDITING Mapping of CS NAOUs",!! 96 K DIC,DA,DIE 97 K Z,ZZ,IENS 98 S DA(1)=1 99 S DIC="^PS(59.7,DA(1),90.02,",DIC(0)="AEQMLCZ" 100 S DIC("W")="X XX1,XX2" 101 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" 102 S XX2="S ZZ=$$GET1^DIQ(58.8,+Y,4,""I"") W:ZZ ?65,""**INACTIVE** """ 103 D ^DIC 104 Q:Y'>0 105 S DA=+Y,DIE=DIC 106 S ZZ=^PS(59.7,1,90.02,DA,0),XX=$P(ZZ,U,2),YY=$P(ZZ,U,3) 107 I YY S DR=".01;.03;S:X'="""" Y=0;.02" I 1 108 E S DR=".01;.02;S:X'="""" Y=0;.03" 109 D ^DIE W ! 110 G E9002 111 ; 112 CHK2 ;check that NAOUs are mapped 113 K IENS 114 S DA=0,DA(1)=1 F S DA=$O(^PS(59.7,1,90.02,DA)) Q:DA'>0 D 115 . S Z=^PS(59.7,1,90.02,DA,0),X=$P(Z,U,2),Y=$P(Z,U,3) 116 . I Y,'X Q 117 . I 'Y,X Q 118 . S IENS=DA_",1" W !,?3,"CS NAOU",?15,$$GET1^DIQ(59.79002,IENS,.01),?25," is not mapped." 119 Q 120 E9003 ;EDIT 90.03 DRUG ACCOUNTABILITY LOCATION MAPPING 121 W @IOF,!!,?20,"EDITING Mapping of DA Pharmacy Locations",!! 122 K DIC,DA,DIE 123 K Z,ZZ,IENS 124 S DA(1)=1 125 S DIC="^PS(59.7,DA(1),90.03,",DIC(0)="AEQMLZ" 126 S DIC("W")="X XX1,XX2" 127 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" 128 S XX2="S ZZ=$$GET1^DIQ(58.8,+Y,4,""I"") W:ZZ ?65,""**INACTIVE** """ 129 D ^DIC 130 Q:Y'>0 131 S DA=+Y,DIE=DIC 132 S ZZ=^PS(59.7,1,90.03,DA,0),XX=$P(ZZ,U,2),YY=$P(ZZ,U,3) 133 I YY S DR=".01;.03;S:X'="""" Y=0;.02" I 1 134 E S DR=".01;.02;S:X'="""" Y=0;.03" 135 D ^DIE W ! 136 G E9003 137 ; 138 CHK3 ;check that DRUG ACCOUNTABILITY LOCATIONs are mapped 139 K IENS 140 S DA=0,DA(1)=1 F S DA=$O(^PS(59.7,1,90.03,DA)) Q:DA'>0 D 141 . S Z=^PS(59.7,1,90.03,DA,0),X=$P(Z,U,2),Y=$P(Z,U,3) 142 . I Y,'X Q 143 . I 'Y,X Q 144 . S IENS=DA_",1" W !,?3,"DA Phar Loc",?15,$$GET1^DIQ(59.79003,IENS,.01),?25," is not mapped." 145 I $G(STOP),$G(IENS) K DIR S DIR(0)="E" D ^DIR I X="^" S PSUSTOP=1 I 1 146 Q 147 REPORT ;Print Mapping Report 148 W @IOF,!,"Print Pharmacy Location PBM Extract Mapping Report",! 149 S %ZIS="Q" D ^%ZIS 150 Q:POP 151 I $D(IO("Q")) D QUEUE Q 152 D EN^PSUMAPR 153 Q 154 QUEUE S ZTRTN="EN^PSUMAPR",ZTDESC="PRINT REPORT OF PBM EXTRACT MAPPING" 155 S ZTREQ="@" D ^%ZTLOAD 156 W !,"TASKED with ",$G(ZTSK) I '$G(ZTSK) W ">> DID NOT Task !!",! H 3 157 Q 158 EXIT ; 159 Q
Note:
See TracChangeset
for help on using the changeset viewer.
