[623] | 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 | ;
|
---|