source: FOIAVistA/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUPR1.m@ 1071

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

initial load of FOIAVistA 6/30/08 version

File size: 3.8 KB
Line 
1PSUPR1 ;BIR/PDW - Data Gathering for PBMS PR file 442 ;12 AUG 1999
2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
3 ;DBIAs
4 ; Reference to file #442 supported by DBIA 1020
5 ; Reference to file #445.01 supported by DBIA 1021
6 ; Reference to file #420.5 supported by DBIA 1022
7 ; Reference to file #410 supported by DBIA 2345,2409
8 ; Reference to file #440 supported by DBIA 2606
9 ; Reference to file #4.3 supported by DBIA 10091
10 ; Reference to file #50 supported by DBIA 221
11 ;
12EN ;EP Entry Point
13 S PSUEDT=PSUEDT\1+.24
14 S PSUPRSDT=PSUSDT
15 S PSUPREDT=PSUEDT
16 ; setup ^XTMP node
17 S:'$D(PSUPRJOB) PSUPRJOB=$J
18 S:'$D(PSUPRSUB) PSUPRSUB="PSUPR_"_PSUPRJOB
19 I '$D(^XTMP(PSUPRSUB)) D
20 . S ^XTMP(PSUPRSUB,"RECORDS",0)=""
21 . S X1=DT,X2=6 D C^%DTC
22 . S ^XTMP(PSUPRSUB,0)=X_"^"_DT_"^ PBMS Procurement Extraction"
23START ;EP
24 N PSUDT,PSUDA
25 S PSURC=0 ; record counter
26 S PSUDT=PSUPRSDT
27 F S PSUDT=$O(^PRC(442,"AB",PSUDT)) Q:PSUDT'>0 Q:PSUDT>PSUPREDT D PODATE
28 Q
29 ;
30PODATE ;EP Process a PO DATE
31 N PSUPODA
32 ; File 442 can not be linked to division so div=sender
33 ; and indicator = "H"
34 S X=$P($G(^XMB(1,1,"XUS")),U,17)
35 S PSUDIV=PSUSNDR,PSUDIVI="H"
36 ; Loop POs within date
37 S PSUPODA=0
38 F S PSUPODA=$O(^PRC(442,"AB",PSUDT,PSUPODA)) Q:'PSUPODA D PO
39 Q
40 ;
41PO ;EP Process a PO
42 N PSUPO,PSUCC
43 S PSUCC=$$VALI^PSUTL(442,PSUPODA,2) ; cost center
44 I PSUCC'=822400,PSUCC'=828100 Q ; not pharmacy related
45 S PSUSS=$$VALI^PSUTL(442,PSUPODA,.5) ; supply status
46 I PSUSS>14,PSUSS<45
47 E Q ; not within status range
48 ; load po information
49 D GETS^PSUTL(442,PSUPODA,".01;.1;1;2;5","PSUPO","I")
50 D MOVEI^PSUTL("PSUPO")
51 ;
52 ; further process po information
53 S PSUPO(5)=$$VALI^PSUTL(440,PSUPO(5),.01) ; Vendor name
54 ;
55 ; load item information
56 K ^TMP($J,"PSUMIT")
57 D GETM^PSUTL(442,PSUPODA,"40*^1;1.5;3;3.1;5;9.3;10;11","^TMP($J,""PSUMIT"")","IN")
58 D MOVEMI^PSUTL("^TMP($J,""PSUMIT"")")
59 ;
60 ; loop items
61 S PSUITDA=0
62 F S PSUITDA=$O(^TMP($J,"PSUMIT",PSUITDA)) Q:PSUITDA'>0 D ITEM
63 Q
64 ;
65ITEM ;EP Process one item
66 N PSUIT,PSUDRDA
67 M PSUIT=^TMP($J,"PSUMIT",PSUITDA)
68 ;
69 ; Get Drug
70 S PSUIT(1.5)=+$G(PSUIT(1.5))
71 S PSUDRDA=$O(^PSDRUG("AB",PSUIT(1.5),0))
72 N PSUARSUB,PSUARJOB S PSUARSUB=PSUPRSUB,PSUARJOB=PSUPRJOB
73 I PSUDRDA D DRUG^PSUAR2(PSUDRDA) ; setup drug profile
74 ;
75 ; process dispense unit 445 & conversion factor 3.2.6.1.5
76 S X=+$G(PSUIT(10)),X=+$$VALI^PSUTL(410,X,4)
77 ; disp unit
78 S PSUIT("DU")=$$VALI^PSUTL(445.01,"X,PSUIT(1.5)",50)
79 ; disp unit conver factor
80 S PSUIT("DUCV")=$$VALI^PSUTL(445.01,"X,PSUIT(1.5)",51)
81 ; unit of purchase
82 S PSUIT("UOP")=$$VALI^PSUTL(420.5,+$G(PSUIT(3)),.01)
83 ;
84 ; further process fields
85 S:'$L($G(PSUIT(9.3))) PSUIT(9.3)="No NDC"
86 ;
87 ;
88REC ;EP Assemble record
89 K PSUR
90 S PSUG="^XTMP(PSUPRSUB,""PSUDRUG_DET"",PSUDRDA)" ; drug reference
91 S PSUR(2)=$G(PSUDIV)
92 S PSUR(3)=$G(PSUDIVI)
93 S PSUR(4)=$G(PSUPO(.1))
94 I PSUDRDA D
95 . S PSUR(5)=@PSUG@(21)
96 . S PSUR(7)=@PSUG@(.01)
97 . S PSUR(12)=@PSUG@(14.5)
98 . S PSUR(6)=@PSUG@(2)
99 I 'PSUDRDA D
100 . S PSUR(5)="Unknown VA Product Name"
101 . S PSUR(7)="Unknown Generic Name"
102 S PSUR(8)=$G(PSUIT(1,1))_$G(PSUIT(1,2)) S:'$L(PSUR(8)) PSUR(8)="No description listed"
103 F S X=$E(PSUR(8)) Q:X'=" " S PSUR(8)=$E(PSUR(8),2,999)
104 S PSUR(8)=$E(PSUR(8),1,50)
105 S PSUR(9)=$G(PSUIT(9.3))
106 S PSUR(12)=$G(PSUIT("DU"))
107 S PSUR(13)=$G(PSUIT("UOP"))
108 S PSUR(14)=$G(PSUIT(3.1))
109 S PSUR(15)=PSUIT("DU")
110 S PSUR(16)=PSUIT("DUCV")
111 S PSUR(17)=$G(PSUIT(11))
112 S PSUR(18)=$G(PSUIT(5))
113 S PSUR(19)=$G(PSUIT(11))*$G(PSUIT(5))
114 S PSUR(20)=PSUPO(5)
115 S PSUR(22)=PSUPO(1)
116 S PSUR=""
117 S I=0 F S I=$O(PSUR(I)) Q:I'>0 S PSUR(I)=$TR(PSUR(I),"^","'")
118 S I=0 F S I=$O(PSUR(I)) Q:I'>0 S $P(PSUR,"^",I)=PSUR(I)
119 S PSUR=PSUR_"^"
120 ; Store Records under PSUSNDR default division
121 S PSURC=PSURC+1,^XTMP(PSUPRSUB,"RECORDS",PSUSNDR,PSURC)=$E(PSUR,1,240) I $L(PSUR)>240 S ^(PSURC,1)=$E(PSUR,241,999)
122 Q
Note: See TracBrowser for help on using the repository browser.