- 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/PSUPR2.m
r613 r623 1 PSUPR2 ;BIR/PDW - Procurement extract from file 58.811 ; 4/1/08 4:09pm 2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**13**;MARCH, 2005;Build 3 3 ;DBIAs 4 ; Reference to file #58.811 supported by DBIA 2521 5 ; Reference to file #51.5 supported by DBIA 1931 6 ; Reference to file #50 supported by DBIA 221 7 ; Reference to file #58.8 supported by DBIA 2519 8 ; Reference to file #42 supported by DBIA 2440 9 ; Reference to file #40.8 supported by DBIA 2438 10 ; Reference to file #59.5 supported by DBIA 2499 11 ; Reference to file #59 supported by DBIA 2510 12 ; 13 EN ; 14 S PSUEND=PSUEDT 15 S PSUEDT=PSUEDT\1+.24 16 S:'$D(PSUPRJOB) PSUPRJOB=$J 17 S:'$D(PSUPRSUB) PSUPRSUB="PSUPR_"_$J 18 I '$D(^XTMP(PSUPRSUB)) D 19 . S ^XTMP(PSUPRSUB,"RECORDS",0)="" 20 . S X1=DT,X2=6 D C^%DTC 21 . S ^XTMP(PSUPRSUB,0)=X_"^"_DT_"^ PBMS Procurement Extraction" 22 ; 23 S PSUARJOB=PSUPRJOB,PSUARSUB="PSUAR_"_PSUARJOB 24 D MAP 25 ; 26 ; check for Drug Accountability 27 S X=$$VERSION^XPDUTL("DRUG ACCOUNTABILITY") 28 I 'X Q ; not installed 29 ; 30 S X1=PSUSDT,X2=-45 ;backup by 45 days per revision 31 D C^%DTC 32 S PSUDT=X 33 ; loop thru invoice date field xref 34 F S PSUDT=$O(^PSD(58.811,"ADATE",PSUDT)) Q:PSUDT>PSUEDT Q:PSUDT'>0 D 35 . S PSUORDA=0 F S PSUORDA=$O(^PSD(58.811,"ADATE",PSUDT,PSUORDA)) Q:PSUORDA'>0 D 36 .. S PSUINVDA=0 F S PSUINVDA=$O(^PSD(58.811,"ADATE",PSUDT,PSUORDA,PSUINVDA)) Q:PSUINVDA'>0 D INVOICE 37 Q 38 ; 39 INVOICE ;EP process an invoice within an order 40 N PSUSTAT 41 S PSUSTAT=$$VALI^PSUTL(58.8112,"PSUORDA,PSUINVDA",2) 42 I PSUSTAT'="C" Q ; 3.2.6.1 43 N PSUORD 44 D GETS^PSUTL(58.811,PSUORDA,".01;1","PSUORD") 45 ; 46 S PSUINV="" 47 N PSURDT,PSUIVNUM 48 D GETS^PSUTL(58.8112,"PSUORDA,PSUINVDA",".01;1;2;3;4;7;8;13","PSUINV","I") 49 D MOVEI^PSUTL("PSUINV") 50 S PSURDT=PSUINV(8) 51 S PSUIVNUM=PSUINV(.01) 52 ; 53 I $G(PSUINV(4)) D DIV 54 I $L(PSUDIV) S PSUDIVI="" 55 E S PSUDIV=PSUSNDR,PSUDIVI="H" 56 ; 57 ; 58 K ^TMP($J,"PSUMIT") ; array for multiple items 59 D GETM^PSUTL(58.8112,"PSUORDA,PSUINVDA","5*^1;2;3;4;7;13;14;15","^TMP($J,""PSUMIT"")","I") 60 I '$D(^TMP($J,"PSUMIT")) Q ; 61 D MOVEMI^PSUTL("^TMP($J,""PSUMIT"")") 62 ; 63 S PSUITDA=0 F S PSUITDA=$O(^TMP($J,"PSUMIT",PSUITDA)) Q:PSUITDA'>0 D ITEM 64 Q 65 ITEM ;EP process one item within the invoice 66 N PSUIT ; array for one item 67 M PSUIT=^TMP($J,"PSUMIT",PSUITDA) 68 ; 69 I (PSUIT(7)<PSUSDT) Q 70 I (PSUIT(7)>PSUEDT) Q 71 ; pull adjustments 3.2.6.2.8 72 N PSUMADJ 73 D GETM^PSUTL(58.81125,"PSUORDA,PSUINVDA,PSUITDA","9*^.01;5","PSUMADJ","I") 74 I $D(PSUMADJ) D MOVEMI^PSUTL("PSUMADJ") 75 ; 76 ; 77 ; Review/Process Adjustments 78 I $D(PSUMADJ) S PSUADJDA=0 F S PSUADJDA=$O(PSUMADJ(PSUADJDA)) Q:PSUADJDA'>0 D 79 . N PSUADJ 80 . M PSUADJ=PSUMADJ(PSUADJDA) 81 . ; 82 . I PSUADJ(.01)="D" S PSUIT(1)=PSUADJ(5) ; 3.2.6.2.8 Drug or Supply 83 . I PSUADJ(.01)="O" S PSUIT(3)=PSUADJ(5) ; 3.2.6.2.11 OrderUnits 84 . I PSUADJ(.01)="P" S PSUIT(4)=PSUADJ(5) ; 3.2.6.2.12 Price 85 . I PSUADJ(.01)="Q" S PSUIT(2)=PSUIT(2)+PSUADJ(5) ; 3.2.6.2.10 Quantity 86 . Q 87 ; 88 I 'PSUIT(2) Q ; per Lina 10/7/98 if qty = 0 don't send record 89 ; work on the order unit PSUIT(3) 90 I '$D(PSUADJ),+PSUIT(3)=0 S PSUIT(3)="" ; per Lina 91 I PSUIT(3) S PSUIT(3)=$$VAL^PSUTL(51.5,PSUIT(3),.01) ; 3.2.6.2.11 92 ; 93 ; further process item fields 3.2.6.2.9 + 94 ; 95 ; look for/ construct Dispense Units per Order Unit 96 ; Store in PSUIT(9999) 3.2.6.2.13 97 ; Get Related Drug Fields 3.2.6.2.9 98 ; 99 N PSUDRUG 100 S PSUDRDA=0 101 ; if PSUIT(1) is a supply item the following will not be computed 102 I PSUIT(1)=+PSUIT(1) D 103 . S PSUDRDA=PSUIT(1) 104 . ;S PSUARJOB=PSUPRJOB,PSUARSUB="PSUAR_"_PSUARJOB 105 . D GETS^PSUTL(50,PSUDRDA,".01;2;13;25;14.5;21;31","PSUDRUG","I") 106 . D MOVEI^PSUTL("PSUDRUG") 107 . S PSUIT(1)=PSUDRUG(.01) ; Generic Name 108 . S:PSUDRUG(21)="" PSUDRUG(21)="Unknown VA Product Name" 109 . S:PSUDRUG(31)="" PSUDRUG(31)="No NDC" 110 ; further process fields 111 ; fill in drug fields for supply items 112 I 'PSUDRDA D 113 . S PSUDRUG(.01)="Unknown Generic Name" 114 . S PSUDRUG(21)="Unknown VA Product Name" 115 . S PSUDRUG(31)="No NDC" 116 ; 117 ; NDC 118 I PSUIT(13)="" S PSUIT(13)=$G(PSUDRUG(31)) S:PSUIT(13)="" PSUIT(13)="No NDC" 119 ; 120 ; dispense units per order unit 3.2.6.2.13 121 ; 122 S PSUIT(9999)=0 123 I $L(PSUIT(13)),$G(PSUDRDA) D 124 . S X=$O(^PSDRUG("C",PSUIT(13),PSUDRDA,"")) 125 . I X S PSUIT(9999)=$$VALI^PSUTL(50.1,"PSUDRDA,X","403") 126 ; 127 I '$D(PSUADJ),'PSUIT(9999) S PSUIT(9999)="" ; per Lina 128 ; 129 ;PSU*4*13 Comment out To prevent XINDEX from complaining about 130 ; ^PSUPR7 (CoreFLS remnance) 131 ;Create "RECORDS" global for CoreFLS data 132 ;I $D(PSUFLSFG) S PSUA="" D 133 ;.F S PSUA=$O(^XTMP(PSUPRSUB,"PSUFLS",PSUA)) Q:PSUA="" D SIMPL^PSUPR7 134 ; 135 ; Construct record and store into ^XTMP(PSUPRSUB,"RECORDS",PSUDIV,LC) 136 S PSUR=$$RECORD() 137 ; Store Records by Division 138 S PSULC=+$O(^XTMP(PSUPRSUB,"RECORDS",PSUDIV,""),-1) 139 S PSULC=PSULC+1 140 S ^XTMP(PSUPRSUB,"RECORDS",PSUDIV,PSULC)=PSUR 141 Q 142 ; 143 RECORD() ;EP Assemble record 144 N PSUR 145 S PSUR(2)=$G(PSUDIV) 146 S PSUR(3)=$G(PSUDIVI) 147 S PSUR(4)=PSUIT(7)\1 ; 3.2.6.2.2 148 S PSUR(5)=$G(PSUDRUG(21)) ; 3.2.6.2.9 149 S PSUR(6)=$G(PSUDRUG(2)) ; "" 150 S PSUR(7)=PSUIT(1) ; 3.2.6.2.8 151 S PSUR(9)=PSUIT(13) ; 3.2.6.2.9 152 S PSUR(10)=PSUIT(14) ; "" 153 S PSUR(11)=PSUIT(15) ; "" 154 S PSUR(12)=$G(PSUDRUG(14.5)) ; "" 155 S PSUR(13)=PSUIT(3) ; 3.2.6.2.11 156 S PSUR(16)=PSUIT(9999) ; 3.2.6.2.13 157 S PSUR(17)=PSUIT(2) ; 3.2.6.2.10 158 S PSUR(18)=PSUIT(4) ; 3.2.6.2.12 159 S PSUR(19)=PSUR(17)*PSUR(18) ; 3.2.6.2.14 160 S PSUR(20)=PSUORD(1) ; 3.2.6.2.5 161 S PSUR(21)=PSUINV(.01) ; 3.2.6.2.6 162 S PSUR(22)="" 163 S PSUR="" 164 S I=0 F S I=$O(PSUR(I)) Q:I'>0 S PSUR(I)=$TR(PSUR(I),"^","'") 165 S I=0 F S I=$O(PSUR(I)) Q:I'>0 S $P(PSUR,U,I)=PSUR(I) 166 S PSUR=PSUR_U 167 Q PSUR 168 ; 169 DIV ;Find division or outpatient site 170 ; 171 S PSUDIV="" 172 N MAPLOCI 173 D GETM^PSUTL(59.7,1,"90.03*^.01;.02;.03","MAPLOCI","I") 174 D MOVEMI^PSUTL("MAPLOCI") 175 ; 176 I $G(MAPLOCI(PSUINV(4),.01)) D 177 .S X=$G(MAPLOCI(PSUINV(4),.02)) I X S PSUDIV=$$VALI^PSUTL(40.8,X,1) 178 .S X=$G(MAPLOCI(PSUINV(4),.03)) I X S PSUDIV=$$VALI^PSUTL(59,X,.06) 179 I '$G(MAPLOCI(PSUINV(4),.01)) D 180 .S PSUDIV=PSUSNDR 181 .S PSUDIVI="H" 182 Q 183 ; 184 ; 185 MAP ;Find out whether a Narcotics Area of Use (NAOU) or a DA Pharmacy 186 ;Location is mapped to a division or outpatient site. If it is not 187 ;mapped, store the NAME and INACTIVATION DAT (if applicable) in a 188 ;global to be mailed to the user. 189 ; 190 K NAOU,DAPH 191 K MAPLOCI,MAPLOC 192 S PSUNAM=0 ;This is the name of the NAOU or DA PHARMACY 193 ; 194 F S PSUNAM=$O(^PSD(58.8,"B",PSUNAM)) Q:PSUNAM="" D 195 .S IEN=0 196 .F S IEN=$O(^PSD(58.8,"B",PSUNAM,IEN)) Q:IEN="" D 197 ..D GETS^PSUTL(58.8,IEN,".01;1;4","NAOU(IEN)") 198 ..I NAOU(IEN,1)="PRIMARY" M DAPH(IEN)=NAOU(IEN) K NAOU(IEN) 199 ..D MAP1 200 ; 201 Q 202 ; 203 MAP1 ;MAP continued. This subroutine takes the IEN from file 58.8 and looks 204 ;to see if it is in file 59.7, field 90.02 or 90.03. 205 ; 206 ;If it is in 90.02, and field 4 from 58.8 is NOT "P", and there is 207 ;no value in subfield .02 or .03, then an NAOU has not been mapped. 208 ; 209 ;If it is in 90.03, and field 4 from 58.8 IS a "P", and there is 210 ;no value in subfield .02 or .03, then a DA PHARMACY location has not 211 ;been mapped. 212 ; 213 ;Keep only the entries that are NOT mapped 214 ; 215 N PSUDA 216 ; 217 ;Look for unmapped NAOU's 218 ;I $G(NAOU(IEN),1) D 219 I $G(^PS(59.7,1,90.02,IEN,0)) D 220 .D GETM^PSUTL(59.7,1,"90.02*^.01;.02;.03","MAPLOCI") 221 .S PSUDA=0 222 .F S PSUDA=$O(MAPLOCI(PSUDA)) Q:PSUDA="" D 223 ..I MAPLOCI(PSUDA,.02)'="" K NAOU(PSUDA) 224 ..I MAPLOCI(PSUDA,.03)'="" K NAOU(PSUDA) 225 M ^XTMP(PSUARSUB,"NAOU")=NAOU ;only unmapped NAOU locations. 226 ; 227 ; 228 ;Look for unmapped DA PHARM 229 I $G(^PS(59.7,1,90.03,IEN,0)) D 230 .D GETM^PSUTL(59.7,1,"90.03*^.01;.02;.03","MAPLOC") 231 .S PSUDA=0 232 .F S PSUDA=$O(MAPLOC(PSUDA)) Q:PSUDA="" D 233 ..;PSU*4*13 Correct Problm DA Pharm Report 234 ..I $G(MAPLOC(PSUDA,.02))'="" K DAPH(PSUDA) 235 ..I $G(MAPLOC(PSUDA,.03))'="" K DAPH(PSUDA) 236 M ^XTMP(PSUARSUB,"DAPH")=DAPH ;only unmapped DA PHARM locations. 237 Q 238 ; 239 WRD() ;EP Process for ward; 240 N PSUWD,PSUWDDA,PSUDIV 241 S PSUDIV="" 242 D GETM^PSUTL(58.8,PSULOC,"21*^.01","PSUWD","I") 243 D MOVEMI^PSUTL("PSUWD") 244 ; loop ward pointers 245 S PSUWDDA=0 246 F S PSUWDDA=$O(PSUWD(PSUWDDA)) Q:PSUWDDA'>0 D Q:$L(PSUDIV) 247 . S X=$$VALI^PSUTL(42,PSUWDDA,.015) 248 . Q:'X 249 . S X=$$VALI^PSUTL(40.8,X,1) 250 . I $L(X) S PSUDIV=X 251 ; return value of PSUDIV "" or = facility number 252 Q PSUDIV 253 ; 254 INP() ;EP Process for Inpatient 255 ; within package call to AR/WS that pulls/builds Inpatient AOU Site 256 ; uses IEN Value to AOU STATs file 58.5 257 N PSUARSUB,PSUARJOB 258 S PSULOCA=$$VALI^PSUTL(58.8,PSULOC,2) 259 N PSULOC 260 S PSUARSUB=PSUPRSUB,PSUARJOB=PSUPRJOB 261 S X=$$DIV^PSUAR1(PSULOCA,PSUDT) ;returns "NULL" if none found 262 S:X="NULL" X="" 263 Q X 264 ; 265 IV() ;EP Process,PSUIVDA for IV 266 ; PSULOC IEN pharmacy location in file 58.8 (DRUG ACCOUNTABILITY) 267 N PSUIV,PSUDIV 268 S PSUDIV="" 269 D GETM^PSUTL(58.8,PSULOC,"31*^.01","PSUIV","I") 270 D MOVEMI^PSUTL("PSUIV") 271 S PSUIVDA=0 272 F S PSUIVDA=$O(PSUIV(PSUIVDA)) Q:PSUIVDA'>0 D Q:$L(PSUDIV) 273 . S X=$$VALI^PSUTL(59.5,PSUIVDA,.02) 274 . I X S X=$$VALI^PSUTL(40.8,X,1) 275 . I $L(X) S PSUDIV=X 276 ; 277 Q PSUDIV 278 ; 279 OUT() ;EP Process for Outpatient 280 S X=$$VALI^PSUTL(58.8,PSULOC,20) 281 I X S X=$$VALI^PSUTL(59,X,.06) 282 Q X 283 ; 1 PSUPR2 ;BIR/PDW - Procurement extract from file 58.811 ;20 AUG 1999 2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005 3 ;DBIAs 4 ; Reference to file #58.811 supported by DBIA 2521 5 ; Reference to file #51.5 supported by DBIA 1931 6 ; Reference to file #50 supported by DBIA 221 7 ; Reference to file #58.8 supported by DBIA 2519 8 ; Reference to file #42 supported by DBIA 2440 9 ; Reference to file #40.8 supported by DBIA 2438 10 ; Reference to file #59.5 supported by DBIA 2499 11 ; Reference to file #59 supported by DBIA 2510 12 ; 13 EN ; 14 S PSUEND=PSUEDT 15 S PSUEDT=PSUEDT\1+.24 16 S:'$D(PSUPRJOB) PSUPRJOB=$J 17 S:'$D(PSUPRSUB) PSUPRSUB="PSUPR_"_$J 18 I '$D(^XTMP(PSUPRSUB)) D 19 . S ^XTMP(PSUPRSUB,"RECORDS",0)="" 20 . S X1=DT,X2=6 D C^%DTC 21 . S ^XTMP(PSUPRSUB,0)=X_"^"_DT_"^ PBMS Procurement Extraction" 22 ; 23 S PSUARJOB=PSUPRJOB,PSUARSUB="PSUAR_"_PSUARJOB 24 D MAP 25 ; 26 ; check for Drug Accountability 27 S X=$$VERSION^XPDUTL("DRUG ACCOUNTABILITY") 28 I 'X Q ; not installed 29 ; 30 S X1=PSUSDT,X2=-45 ;backup by 45 days per revision 31 D C^%DTC 32 S PSUDT=X 33 ; loop thru invoice date field xref 34 F S PSUDT=$O(^PSD(58.811,"ADATE",PSUDT)) Q:PSUDT>PSUEDT Q:PSUDT'>0 D 35 . S PSUORDA=0 F S PSUORDA=$O(^PSD(58.811,"ADATE",PSUDT,PSUORDA)) Q:PSUORDA'>0 D 36 .. S PSUINVDA=0 F S PSUINVDA=$O(^PSD(58.811,"ADATE",PSUDT,PSUORDA,PSUINVDA)) Q:PSUINVDA'>0 D INVOICE 37 Q 38 ; 39 INVOICE ;EP process an invoice within an order 40 N PSUSTAT 41 S PSUSTAT=$$VALI^PSUTL(58.8112,"PSUORDA,PSUINVDA",2) 42 I PSUSTAT'="C" Q ; 3.2.6.1 43 N PSUORD 44 D GETS^PSUTL(58.811,PSUORDA,".01;1","PSUORD") 45 ; 46 S PSUINV="" 47 N PSURDT,PSUIVNUM 48 D GETS^PSUTL(58.8112,"PSUORDA,PSUINVDA",".01;1;2;3;4;7;8;13","PSUINV","I") 49 D MOVEI^PSUTL("PSUINV") 50 S PSURDT=PSUINV(8) 51 S PSUIVNUM=PSUINV(.01) 52 ; 53 I $G(PSUINV(4)) D DIV 54 I $L(PSUDIV) S PSUDIVI="" 55 E S PSUDIV=PSUSNDR,PSUDIVI="H" 56 ; 57 ; 58 K ^TMP($J,"PSUMIT") ; array for multiple items 59 D GETM^PSUTL(58.8112,"PSUORDA,PSUINVDA","5*^1;2;3;4;7;13;14;15","^TMP($J,""PSUMIT"")","I") 60 I '$D(^TMP($J,"PSUMIT")) Q ; 61 D MOVEMI^PSUTL("^TMP($J,""PSUMIT"")") 62 ; 63 S PSUITDA=0 F S PSUITDA=$O(^TMP($J,"PSUMIT",PSUITDA)) Q:PSUITDA'>0 D ITEM 64 Q 65 ITEM ;EP process one item within the invoice 66 N PSUIT ; array for one item 67 M PSUIT=^TMP($J,"PSUMIT",PSUITDA) 68 ; 69 I (PSUIT(7)<PSUSDT) Q 70 I (PSUIT(7)>PSUEDT) Q 71 ; pull adjustments 3.2.6.2.8 72 N PSUMADJ 73 D GETM^PSUTL(58.81125,"PSUORDA,PSUINVDA,PSUITDA","9*^.01;5","PSUMADJ","I") 74 I $D(PSUMADJ) D MOVEMI^PSUTL("PSUMADJ") 75 ; 76 ; 77 ; Review/Process Adjustments 78 I $D(PSUMADJ) S PSUADJDA=0 F S PSUADJDA=$O(PSUMADJ(PSUADJDA)) Q:PSUADJDA'>0 D 79 . N PSUADJ 80 . M PSUADJ=PSUMADJ(PSUADJDA) 81 . ; 82 . I PSUADJ(.01)="D" S PSUIT(1)=PSUADJ(5) ; 3.2.6.2.8 Drug or Supply 83 . I PSUADJ(.01)="O" S PSUIT(3)=PSUADJ(5) ; 3.2.6.2.11 OrderUnits 84 . I PSUADJ(.01)="P" S PSUIT(4)=PSUADJ(5) ; 3.2.6.2.12 Price 85 . I PSUADJ(.01)="Q" S PSUIT(2)=PSUIT(2)+PSUADJ(5) ; 3.2.6.2.10 Quantity 86 . Q 87 ; 88 I 'PSUIT(2) Q ; per Lina 10/7/98 if qty = 0 don't send record 89 ; work on the order unit PSUIT(3) 90 I '$D(PSUADJ),+PSUIT(3)=0 S PSUIT(3)="" ; per Lina 91 I PSUIT(3) S PSUIT(3)=$$VAL^PSUTL(51.5,PSUIT(3),.01) ; 3.2.6.2.11 92 ; 93 ; further process item fields 3.2.6.2.9 + 94 ; 95 ; look for/ construct Dispense Units per Order Unit 96 ; Store in PSUIT(9999) 3.2.6.2.13 97 ; Get Related Drug Fields 3.2.6.2.9 98 ; 99 N PSUDRUG 100 S PSUDRDA=0 101 ; if PSUIT(1) is a supply item the following will not be computed 102 I PSUIT(1)=+PSUIT(1) D 103 . S PSUDRDA=PSUIT(1) 104 . ;S PSUARJOB=PSUPRJOB,PSUARSUB="PSUAR_"_PSUARJOB 105 . D GETS^PSUTL(50,PSUDRDA,".01;2;13;25;14.5;21;31","PSUDRUG","I") 106 . D MOVEI^PSUTL("PSUDRUG") 107 . S PSUIT(1)=PSUDRUG(.01) ; Generic Name 108 . S:PSUDRUG(21)="" PSUDRUG(21)="Unknown VA Product Name" 109 . S:PSUDRUG(31)="" PSUDRUG(31)="No NDC" 110 ; further process fields 111 ; fill in drug fields for supply items 112 I 'PSUDRDA D 113 . S PSUDRUG(.01)="Unknown Generic Name" 114 . S PSUDRUG(21)="Unknown VA Product Name" 115 . S PSUDRUG(31)="No NDC" 116 ; 117 ; NDC 118 I PSUIT(13)="" S PSUIT(13)=$G(PSUDRUG(31)) S:PSUIT(13)="" PSUIT(13)="No NDC" 119 ; 120 ; dispense units per order unit 3.2.6.2.13 121 ; 122 S PSUIT(9999)=0 123 I $L(PSUIT(13)),$G(PSUDRDA) D 124 . S X=$O(^PSDRUG("C",PSUIT(13),PSUDRDA,"")) 125 . I X S PSUIT(9999)=$$VALI^PSUTL(50.1,"PSUDRDA,X","403") 126 ; 127 I '$D(PSUADJ),'PSUIT(9999) S PSUIT(9999)="" ; per Lina 128 ; 129 ;Create "RECORDS" global for CoreFLS data 130 I $D(PSUFLSFG) S PSUA="" D 131 .F S PSUA=$O(^XTMP(PSUPRSUB,"PSUFLS",PSUA)) Q:PSUA="" D SIMPL^PSUPR7 132 ; 133 ; Construct record and store into ^XTMP(PSUPRSUB,"RECORDS",PSUDIV,LC) 134 S PSUR=$$RECORD() 135 ; Store Records by Division 136 S PSULC=+$O(^XTMP(PSUPRSUB,"RECORDS",PSUDIV,""),-1) 137 S PSULC=PSULC+1 138 S ^XTMP(PSUPRSUB,"RECORDS",PSUDIV,PSULC)=PSUR 139 Q 140 ; 141 RECORD() ;EP Assemble record 142 N PSUR 143 S PSUR(2)=$G(PSUDIV) 144 S PSUR(3)=$G(PSUDIVI) 145 S PSUR(4)=PSUIT(7)\1 ; 3.2.6.2.2 146 S PSUR(5)=$G(PSUDRUG(21)) ; 3.2.6.2.9 147 S PSUR(6)=$G(PSUDRUG(2)) ; "" 148 S PSUR(7)=PSUIT(1) ; 3.2.6.2.8 149 S PSUR(9)=PSUIT(13) ; 3.2.6.2.9 150 S PSUR(10)=PSUIT(14) ; "" 151 S PSUR(11)=PSUIT(15) ; "" 152 S PSUR(12)=$G(PSUDRUG(14.5)) ; "" 153 S PSUR(13)=PSUIT(3) ; 3.2.6.2.11 154 S PSUR(16)=PSUIT(9999) ; 3.2.6.2.13 155 S PSUR(17)=PSUIT(2) ; 3.2.6.2.10 156 S PSUR(18)=PSUIT(4) ; 3.2.6.2.12 157 S PSUR(19)=PSUR(17)*PSUR(18) ; 3.2.6.2.14 158 S PSUR(20)=PSUORD(1) ; 3.2.6.2.5 159 S PSUR(21)=PSUINV(.01) ; 3.2.6.2.6 160 S PSUR(22)="" 161 S PSUR="" 162 S I=0 F S I=$O(PSUR(I)) Q:I'>0 S PSUR(I)=$TR(PSUR(I),"^","'") 163 S I=0 F S I=$O(PSUR(I)) Q:I'>0 S $P(PSUR,U,I)=PSUR(I) 164 S PSUR=PSUR_U 165 Q PSUR 166 ; 167 DIV ;Find division or outpatient site 168 ; 169 S PSUDIV="" 170 N MAPLOCI 171 D GETM^PSUTL(59.7,1,"90.03*^.01;.02;.03","MAPLOCI","I") 172 D MOVEMI^PSUTL("MAPLOCI") 173 ; 174 I $G(MAPLOCI(PSUINV(4),.01)) D 175 .S X=$G(MAPLOCI(PSUINV(4),.02)) I X S PSUDIV=$$VALI^PSUTL(40.8,X,1) 176 .S X=$G(MAPLOCI(PSUINV(4),.03)) I X S PSUDIV=$$VALI^PSUTL(59,X,.06) 177 I '$G(MAPLOCI(PSUINV(4),.01)) D 178 .S PSUDIV=PSUSNDR 179 .S PSUDIVI="H" 180 Q 181 ; 182 ; 183 MAP ;Find out whether a Narcotics Area of Use (NAOU) or a DA Pharmacy 184 ;Location is mapped to a division or outpatient site. If it is not 185 ;mapped, store the NAME and INACTIVATION DAT (if applicable) in a 186 ;global to be mailed to the user. 187 ; 188 K NAOU,DAPH 189 K MAPLOCI,MAPLOC 190 S PSUNAM=0 ;This is the name of the NAOU or DA PHARMACY 191 ; 192 F S PSUNAM=$O(^PSD(58.8,"B",PSUNAM)) Q:PSUNAM="" D 193 .S IEN=0 194 .F S IEN=$O(^PSD(58.8,"B",PSUNAM,IEN)) Q:IEN="" D 195 ..D GETS^PSUTL(58.8,IEN,".01;1;4","NAOU(IEN)") 196 ..I NAOU(IEN,1)="PRIMARY" M DAPH(IEN)=NAOU(IEN) K NAOU(IEN) 197 ..D MAP1 198 ; 199 Q 200 ; 201 MAP1 ;MAP continued. This subroutine takes the IEN from file 58.8 and looks 202 ;to see if it is in file 59.7, field 90.02 or 90.03. 203 ; 204 ;If it is in 90.02, and field 4 from 58.8 is NOT "P", and there is 205 ;no value in subfield .02 or .03, then an NAOU has not been mapped. 206 ; 207 ;If it is in 90.03, and field 4 from 58.8 IS a "P", and there is 208 ;no value in subfield .02 or .03, then a DA PHARMACY location has not 209 ;been mapped. 210 ; 211 ;Keep only the entries that are NOT mapped 212 ; 213 N PSUDA 214 ; 215 ;Look for unmapped NAOU's 216 ;I $G(NAOU(IEN),1) D 217 I $G(^PS(59.7,1,90.02,IEN,0)) D 218 .D GETM^PSUTL(59.7,1,"90.02*^.01;.02;.03","MAPLOCI") 219 .S PSUDA=0 220 .F S PSUDA=$O(MAPLOCI(PSUDA)) Q:PSUDA="" D 221 ..I MAPLOCI(PSUDA,.02)'="" K NAOU(PSUDA) 222 ..I MAPLOCI(PSUDA,.03)'="" K NAOU(PSUDA) 223 M ^XTMP(PSUARSUB,"NAOU")=NAOU ;only unmapped NAOU locations. 224 ; 225 ; 226 ;Look for unmapped DA PHARM 227 I $G(^PS(59.7,1,90.03,IEN,0)) D 228 .D GETM^PSUTL(59.7,1,"90.03*^.01;.02;.03","MAPLOC") 229 .S PSUDA=0 230 .F S PSUDA=$O(MAPLOC(PSUDA)) Q:PSUDA="" D 231 ..I $G(MAPLOC(PSUDA,.02))'="" K NAOU(PSUDA) 232 ..I $G(MAPLOC(PSUDA,.03))'="" K NAOU(PSUDA) 233 M ^XTMP(PSUARSUB,"DAPH")=DAPH ;only unmapped DA PHARM locations. 234 Q 235 ; 236 WRD() ;EP Process for ward; 237 N PSUWD,PSUWDDA,PSUDIV 238 S PSUDIV="" 239 D GETM^PSUTL(58.8,PSULOC,"21*^.01","PSUWD","I") 240 D MOVEMI^PSUTL("PSUWD") 241 ; loop ward pointers 242 S PSUWDDA=0 243 F S PSUWDDA=$O(PSUWD(PSUWDDA)) Q:PSUWDDA'>0 D Q:$L(PSUDIV) 244 . S X=$$VALI^PSUTL(42,PSUWDDA,.015) 245 . Q:'X 246 . S X=$$VALI^PSUTL(40.8,X,1) 247 . I $L(X) S PSUDIV=X 248 ; return value of PSUDIV "" or = facility number 249 Q PSUDIV 250 ; 251 INP() ;EP Process for Inpatient 252 ; within package call to AR/WS that pulls/builds Inpatient AOU Site 253 ; uses IEN Value to AOU STATs file 58.5 254 N PSUARSUB,PSUARJOB 255 S PSULOCA=$$VALI^PSUTL(58.8,PSULOC,2) 256 N PSULOC 257 S PSUARSUB=PSUPRSUB,PSUARJOB=PSUPRJOB 258 S X=$$DIV^PSUAR1(PSULOCA,PSUDT) ;returns "NULL" if none found 259 S:X="NULL" X="" 260 Q X 261 ; 262 IV() ;EP Process,PSUIVDA for IV 263 ; PSULOC IEN pharmacy location in file 58.8 (DRUG ACCOUNTABILITY) 264 N PSUIV,PSUDIV 265 S PSUDIV="" 266 D GETM^PSUTL(58.8,PSULOC,"31*^.01","PSUIV","I") 267 D MOVEMI^PSUTL("PSUIV") 268 S PSUIVDA=0 269 F S PSUIVDA=$O(PSUIV(PSUIVDA)) Q:PSUIVDA'>0 D Q:$L(PSUDIV) 270 . S X=$$VALI^PSUTL(59.5,PSUIVDA,.02) 271 . I X S X=$$VALI^PSUTL(40.8,X,1) 272 . I $L(X) S PSUDIV=X 273 ; 274 Q PSUDIV 275 ; 276 OUT() ;EP Process for Outpatient 277 S X=$$VALI^PSUTL(58.8,PSULOC,20) 278 I X S X=$$VALI^PSUTL(59,X,.06) 279 Q X 280 ;
Note:
See TracChangeset
for help on using the changeset viewer.
