source: FOIAVistA/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUOP2.m@ 1671

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

initial load of FOIAVistA 6/30/08 version
File size: 6.8 KB
Line 
1PSUOP2 ;BIR/CFL - PSU PBM Outpatient Pharmacy Data Collection for Version 7.0 ; 7/11/06 4:21pm
2 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**6,8,9**;MARCH, 2005;Build 6
3 ;
4 ;DBIAs
5 ; Reference to ^PSRX( file # 52 supported by DBIAs 465, 2512
6 ; Reference to EN^PSOORDER supported by DBIA 1878
7 ;
8 ;
9EN ;Entry to data collection
10 D ALLOOP,AMLOOP
11 K ^TMP("PSOR",$J)
12 Q
13ALLOOP ;Loop through the AL cross refererence
14 N PSUDOC1,PSUCAN,PSUCL,PSUCMP,PSUFP,PSUORDT,PSUCO
15 S PSUFDT=PSUSDT,PSUEDTM=PSUEDT_".24"
16 F S PSUFDT=$O(^PSRX("AL",PSUFDT)) Q:PSUFDT=""!(PSUFDT>PSUEDTM) D
17 .S PSURXIEN=""
18 .F S PSURXIEN=$O(^PSRX("AL",PSUFDT,PSURXIEN)) Q:PSURXIEN="" D
19 ..Q:$D(^XTMP(PSUOPSUB,"RXIEN",PSURXIEN)) ; already been processed
20 ..Q:'$D(^PSRX(PSURXIEN,0)) ; watch out for dangling pointers
21 ..S PSUCAN=$$GET1^DIQ(52,PSURXIEN,26.1,"I") ;Cancel date
22 ..D GETS^PSUTL(52,PSURXIEN,"2;21;27","PSUOP","I")
23 ..D MOVEI^PSUTL("PSUOP")
24 ..S DFN=PSUOP(2)
25 ..;
26 ..Q:$$TESTPAT^PSUTL1(DFN)
27 ..D PID^VADPT
28 ..S PSUSSN=$TR(VA("PID"),"^-","")
29 ..N PSUPSO S PSUPSO=1 ;flag to avoid a PSO error when SIG is too long
30 ..D EN^PSOORDER(DFN,PSURXIEN)
31 ..Q:'$D(^TMP("PSOR",$J))
32 ..D EN^PSUOPAM ;Gather AMIS data
33 ..D CMOPA ; set array of CMOP recs
34 ..D NEW ; check ^TMP to see if New Rx is in time frame, if so create record.
35 ..D REF ; check ^TMP to see if refills are in time frame, if so create records
36 ..D PAR ; check ^TMP to see if partials are in time frame, if so create records
37 Q
38 ;
39AMLOOP ; loop through "AM", partials, cross reference to see if any were missed
40 S X1=PSUSDT,X2=-1
41 D C^%DTC K %,%H,%T
42 S PSUFDT=PSUSDT,PSUEDTM=PSUEDT_".24"
43 F S PSUFDT=$O(^PSRX("AM",PSUFDT)) Q:PSUFDT=""!(PSUFDT>PSUEDTM) D
44 .S PSURXIEN=""
45 .F S PSURXIEN=$O(^PSRX("AM",PSUFDT,PSURXIEN)) Q:PSURXIEN="" D
46 ..Q:$D(^XTMP(PSUOPSUB,"RXIEN",PSURXIEN)) ; already been processed
47 ..Q:'$D(^PSRX(PSURXIEN,0)) ; watch out for dangling pointers
48 ..D GETS^PSUTL(52,PSURXIEN,"2;27","PSUOP","I")
49 ..D MOVEI^PSUTL("PSUOP")
50 ..S DFN=PSUOP(2)
51 ..; SCREEN OUT TEST PATIENTS
52 ..Q:$$TESTPAT^PSUTL1(DFN)
53 ..D PID^VADPT
54 ..S PSUSSN=$TR(VA("PID"),"^-","")
55 ..D EN^PSOORDER(DFN,PSURXIEN)
56 ..D EN^PSUOPAM ;Gather AMIS data PSU*4*5 fix
57 ..D PAR ; check ^TMP to see if partials are in time frame, if so create records
58 Q
59 ;
60NEW ; New Rx
61 S PSUFD=$P(^TMP("PSOR",$J,PSURXIEN,0),U,2)
62 D COMVAR
63 S PSUTYP="N"
64 S PSUCMOP=$S($D(PSUCMA(0)):"Y",1:"N")
65 S PSUR0=^TMP("PSOR",$J,PSURXIEN,0)
66 S PSUORDT=$P(PSUR0,U,17) ;AMIS Original Login Date
67 S PSUQTY=+$P(PSUR0,U,6)
68 ;
69 ;
70 S PSUDS=$P(PSUR0,U,7)
71 S PSUDRCT=$P(PSUR0,U,10)
72 S PSURELDT=$P($P(PSUR0,U,13),".",1)
73 Q:((PSURELDT<PSUSDT)!(PSURELDT>PSUEDTM))
74 S PSUWPC=$E($P(PSUR0,U,15))
75NEWX1 ;I PSUCMOP="Y" Q:((PSURELDT="")!(PSURELDT<PSUSDT)!(PSURELDT>PSUEDTM))
76NEWX2 ;I PSUCMOP="N",((PSUFD<PSUSDT)!(PSUFD\1>PSUEDT)) Q
77 S PSUR1=^TMP("PSOR",$J,PSURXIEN,1)
78 ; MOVE NEXT 2 LINES TO COMMON VARIABLE AREA
79 ;S PSUCLN=$P($P(PSUR1,U,4),";",2) ;AMIS data clinic
80 ;S PSUFP=$P($P(PSUR1,U,9),";",1) ;AMIS finishing person
81 S PSUPRID=$P($P(PSUR1,U,1),";",1)
82 S PSURXP=$P($P(PSUR1,U,5),";",1)
83 S PSUMW=$P($P(PSUR1,U,6),";",1)
84 S PSUDIVP=$P(PSUR1,U,7)
85 ;
86 S PSUNDC=""
87 I PSUCMOP="Y" S PSUNDC=PSUCMA(0)
88 I PSUNDC="" S PSUNDC=$S($L(PSUOP(27)):PSUOP(27),$L(PSUDRUG(31)):PSUDRUG(31),1:"No NDC")
89 D PROVDR^PSUOP3
90 D SETREC^PSUOP3
91NEWQ Q
92 ;
93REF ; Refills
94 Q:'$D(^TMP("PSOR",$J,PSURXIEN,"REF"))
95 D COMVAR
96 S PSUFLN=""
97 F S PSUFLN=$O(^TMP("PSOR",$J,PSURXIEN,"REF",PSUFLN)) Q:PSUFLN="" D
98 .S PSUTYP="R"
99 .S PSUCMOP=$S($D(PSUCMA(PSUFLN)):"Y",1:"N")
100 .S PSUR0=^TMP("PSOR",$J,PSURXIEN,"REF",PSUFLN,0)
101 .N PSUCLN,PSUR1
102 .S PSUR1=^TMP("PSOR",$J,PSURXIEN,1)
103 .S PSUCLN=$P($P(PSUR1,U,4),";",2)
104 .S PSUWPC="N"
105 .S PSUFD=$P(PSUR0,U,1)
106 .S PSUPRID=$P($P(PSUR0,U,2),";",1)
107 .S PSUQTY=+$P(PSUR0,U,4)
108 .S PSUDS=$P(PSUR0,U,5)
109 .S PSUDRCT=$P(PSUR0,U,6)
110 .S PSURELDT=$P(PSUR0,U,8)
111 .Q:((PSURELDT<PSUSDT)!(PSURELDT>PSUEDTM))
112 .S PSUMW=$P($P(PSUR0,U,10),";",1)
113 .S PSUDIVP=$P(PSUR0,U,11)
114 .S PSUREDT=$P(PSUR0,U,12) ;AMIS Refill Login Date
115 .I PSURELDT'="" S PSURELDT=PSURELDT\1
116 .;I PSUCMOP="Y" Q:((PSURELDT="")!(PSURELDT<PSUSDT)!(PSURELDT>PSUEDTM))
117 .;I PSUCMOP="N",((PSUFD<PSUSDT)!(PSUFD\1>PSUEDT)) Q
118 .S PSUNDC=""
119 .I PSUCMOP="Y" S PSUNDC=PSUCMA(PSUFLN)
120 .I PSUNDC="" S PSUNDC=$$VALI^PSUTL(52.1,PSURXIEN,11)
121 .I PSUNDC="" S PSUNDC=$S(PSUDRUG(31)'="":PSUDRUG(31),1:"No NDC")
122 .;
123 .D PROVDR^PSUOP3
124 .D SETREC^PSUOP3
125REFQ Q
126 ;
127PAR ; Partials
128 Q:'$D(^TMP("PSOR",$J,PSURXIEN,"RPAR"))
129 D COMVAR
130 S PSUFLN=""
131 F S PSUFLN=$O(^TMP("PSOR",$J,PSURXIEN,"RPAR",PSUFLN)) Q:PSUFLN="" D
132 .S PSUR0=^TMP("PSOR",$J,PSURXIEN,"RPAR",PSUFLN,0)
133 .N PSUCLN,PSUR1
134 .S PSUR1=^TMP("PSOR",$J,PSURXIEN,1)
135 .S PSUCLN=$P($P(PSUR1,U,4),";",2)
136 .S PSUTYP="P"
137 .S PSUCMOP="N"
138 .S PSUWPC="N"
139 .S PSUFD=$P(PSUR0,U,1)
140 .;I (PSUFD<PSUSDT)!(PSUFD\1>PSUEDT) Q
141 .S PSUPRID=$P($P(PSUR0,U,2),";",1)
142 .S PSUQTY=+$P(PSUR0,U,4)
143 .S PSUDS=$P(PSUR0,U,5)
144 .S PSUDRCT=$P(PSUR0,U,6)
145 .S PSURELDT=$P(PSUR0,U,8)
146 .S PSUMW=$P($P(PSUR0,U,10),";",1)
147 .S PSUDIVP=$P(PSUR0,U,11)
148 .S PSUPDT=$P(PSUR0,U,12) ;AMIS Partial Login Date
149 .I PSURELDT'="" S PSURELDT=PSURELDT\1
150 .Q:((PSURELDT<PSUSDT)!(PSURELDT>PSUEDTM))
151 .S PSUNDC=$$VALI^PSUTL(52.2,PSURXIEN,1)
152 .I PSUNDC="" S PSUNDC=$S(PSUDRUG(31)'="":PSUDRUG(31),1:"No NDC")
153 .;
154 .D PROVDR^PSUOP3
155 .D SETREC^PSUOP3
156PARQ Q
157 ;
158COMVAR ; set variables that are common between all record types
159 S PSUDR=$P($P(^TMP("PSOR",$J,PSURXIEN,"DRUG",0),U,1),";",1)
160 ;S CMOPID=$P($G(^PSDRUG(PSUDR,"ND")),U,10) ;AMIS CMOP ID
161 S PSUSIG=$P($G(^TMP("PSOR",$J,PSURXIEN,"SIG",1,0)),U,1)
162 S PSURXP=$P($P(^TMP("PSOR",$J,PSURXIEN,1),U,5),";",1)
163 S PSURXN=$P(^TMP("PSOR",$J,PSURXIEN,0),U,5)
164 ; PSU*4*9 - INSERT NEXT 2 LINES
165 S PSUCLN=$P($P(^TMP("PSOR",$J,PSURXIEN,1),U,4),";",2) ;AMIS CLINIC
166 S PSUFP=$P($P(^TMP("PSOR",$J,PSURXIEN,1),U,9),";",1) ;FINISHING PERSON
167 D GETDRUG^PSUOP3 ; loads data from file #50 using PSUDR as ien
168COMVARQ Q
169 ;
170CMOPA ; set array of CMOP recs
171 K PSUCMA
172 N PSUR1,PSUX,PSUST,PSUFIL,PSUNDC
173 S PSUX=""
174 F S PSUX=$O(^TMP("PSOR",$J,PSURXIEN,"CMOP",PSUX)) Q:PSUX="" D
175 .S PSUR1=^TMP("PSOR",$J,PSURXIEN,"CMOP",PSUX,0)
176 .F X="PSUFIL^3","PSUST^4","PSUNDC^6" D PIECE(X,PSUR1,U)
177 .S:+PSUST=1 PSUCMA(PSUFIL)=PSUNDC
178 .K:+PSUST=3 PSUCMA(PSUFIL)
179 .D:$D(PSUCMA(PSUFIL)) RTSTOCK
180CMOPAQ Q
181 ;
182RTSTOCK ; test for "AR" if none then unmark CMOP
183 ; needs PSURXIEN, PSUFIL, from CMOPA
184 N PSURELDT,PSUR0,PSURTSDT
185 I PSUFIL D Q
186 . S PSUR0=$G(^TMP("PSOR",$J,PSURXIEN,"REF",PSUFIL,0))
187 . F X="PSURELDT^8","PSURTSDT^9" D PIECE(X,PSUR0,U)
188 . I PSURELDT,$D(^PSRX("AR",PSURELDT,PSURXIEN,PSUFIL)) Q
189 . K PSUCMA(PSUFIL)
190 ;
191 S PSUR0=^TMP("PSOR",$J,PSURXIEN,0)
192 F X="PSURELDT^13","PSURTSDT^14" D PIECE(X,PSUR0,U)
193 I PSURELDT,$D(^PSRX("AR",PSURELDT,PSURXIEN,PSUFIL)) Q
194 I $D(PSUCMA(PSUFIL)) K PSUCMA(PSUFIL)
195 Q
196PIECE(%,REC,DLM) ;Piece % from record REC using delimiter DLM
197 ; %="VARNAME^PIECE",REC=SOURCE,DLM=DELIMITER in REC
198 N Y,I S Y=$P(%,U,1),I=$P(%,U,2) S @Y=$P(REC,DLM,I)
199 Q
200 ;
Note: See TracBrowser for help on using the repository browser.