source: FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBRPCMO.m@ 707

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

initial load of FOIAVistA 6/30/08 version
File size: 9.5 KB
Line 
1PSBRPCMO ;BIRMINGHAM/EFC-MED ORDER BUTTON FUNCTIONS ;Mar 2004
2 ;;3.0;BAR CODE MED ADMIN;**6,32**;Mar 2004;Build 32
3 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
4 ; Reference/IA
5 ; ^XUSEC("PROVIDER")/10076
6 ; ^%DTC/10000
7 ; ^XPAR/2263
8 ; File 50/221
9 ; File 50.7/2880
10 ; File 200/10060
11 ; File 52.6/436
12 ; File 52.7/437
13 ; $$EN^ORBCMA2/3616
14 ; C^PSN50P65/4543
15OILST(RESULTS,PSBSCAN,PSBOTYP) ;
16 I PSBOTYP="VAC" D VACLKU Q
17 I $L(PSBSCAN?.N)>31 S PSBSCAN=$E(PSBSCAN,1,31)
18 S PSBSCAN=$TR(PSBSCAN,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
19 D NOW^%DTC S PSBDT=%
20 I $$GET^XPAR("DIV","PSB ROBOT RX"),PSBSCAN?1"3"15N!(PSBSCAN?1"3"17N),123[$E(PSBSCAN,12) S PSBSCAN=$E(PSBSCAN,2,11)
21 S PSBCNT=0
22 I PSBSCAN?.N I PSBOTYP'="OIT" D ;is a scanned bar code
23 .I '$D(^PSDRUG(PSBSCAN)) S PSBSCAN=$$FIND1^DIC(50,"","AX",PSBSCAN,"B^C") I PSBSCAN<1 Q ; not in the drug file
24 .Q:PSBOTYP="UD"&($P($G(^PSDRUG(PSBSCAN,2)),U,3)'["U")
25 .Q:PSBOTYP="UD"&($G(^PSDRUG(PSBSCAN,"I"))&(+$G(^("I"))'>PSBDT))
26 .S PSBOIEN=$$GET1^DIQ(50,PSBSCAN,"PHARMACY ORDERABLE ITEM","I") Q:PSBOIEN="" ;orderable item ien
27 .D CPRS
28 .Q:PSBCPRS]""&(PSBCPRS'>PSBDT)
29 .;cprs orderable inact dt?
30 .I $P(A,U,4)="" Q
31 .I +$P(A,U,4)=0 Q ;not inpat pharm item
32 .S PSBPOI=$$GET1^DIQ(50.7,PSBOIEN,.01)
33 .S PSBDD=$$GET1^DIQ(50,PSBSCAN,.01)
34 .I PSBOTYP="UD" D Q
35 ..S PSBDRUG="DD"_U_PSBSCAN_U_PSBDD_U_PSBOIEN_U_PSBPOI_U_PSBORIEN_U_PSBORNM
36 ..S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=PSBDRUG,RESULTS(0)=PSBCNT
37 .I PSBOTYP="IV" D Q
38 ..S PSBCNT=0
39 ..I $P(A,U,4)=2 D
40 ...I $D(^PSDRUG("A527",PSBSCAN)) D SOLN
41 ...I $D(^PSDRUG("A526",PSBSCAN)) D ADD
42 .S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)="-1^Medication does not match ordertype",RESULTS(0)=PSBCNT Q
43 I PSBSCAN?.N I PSBOTYP="OIT" D ;scanned?
44 .I '$D(^PS(50.7,PSBSCAN)) S PSBSCAN=$$FIND1^DIC(50.7,"","AX",PSBSCAN,"B^C") I PSBSCAN<1 Q ; not in the OItem file
45 .S PSBOIEN=PSBSCAN Q:PSBOIEN="" ;ord item ien
46 .D CPRS
47 .Q:PSBCPRS]""&(PSBCPRS'>PSBDT)
48 .;cprs orderable inact dt?
49 .I $P(A,U,4)="" Q
50 .I +$P(A,U,4)=0 Q ;not inpat pharm item
51 .S PSBPOI=$$GET1^DIQ(50.7,PSBOIEN,.01)
52 .S PSBDIEN=$$GETDRN^PSBOMT(PSBPOI)
53 .S PSBDD=$$GET1^DIQ(50,PSBDIEN,.01)
54 .S PSBDRUG="OIT"_U_PSBSCAN_U_PSBPOI_U_PSBDIEN_U_PSBDD_U_PSBORIEN_U_PSBORNM
55 .S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=PSBDRUG,RESULTS(0)=PSBCNT
56 .;
57 I PSBSCAN'?.N D
58 .I PSBOTYP="OIT" D OITMB
59 .I PSBOTYP'="OIT" K PSBMSG D LIST^DIC(50,"","2.1I;2.1","P","","",PSBSCAN,"B","","","^TMP(""PSBLST"",$J)","PSBMSG")
60 .;alpha-numerc look up "B" index drug file
61 .S X=0 F S X=$O(^TMP("PSBLST",$J,"DILIST",X)) Q:X="" D
62 ..Q:$P(^TMP("PSBLST",$J,"DILIST",X,0),U,3)=""
63 ..Q:$P(^TMP("PSBLST",$J,"DILIST",X,0),U,4)=""
64 ..I PSBOTYP'="OIT" D
65 ...I $P(^TMP("PSBLST",$J,"DILIST",X,0),U,3)'?.N S $P(^TMP("PSBLST",$J,"DILIST",X,0),U,3,99)=$P(^TMP("PSBLST",$J,"DILIST",X,0),U,4,99) Q
66 ...S ^TMP("PSB",$J,$P(^TMP("PSBLST",$J,"DILIST",X,0),U))=^TMP("PSBLST",$J,"DILIST",X,0)
67 ..I PSBOTYP="OIT" S ^TMP("PSB",$J,$P(^TMP("PSBLST",$J,"DILIST",X,0),U))=^TMP("PSBLST",$J,"DILIST",X,0)
68 .I PSBOTYP="OIT" D OITMC
69 .I PSBOTYP'="OIT" K ^TMP("PSBLST",$J,"DILIST"),PSBMSG D LIST^DIC(50,"","2.1I;2.1","P","","",PSBSCAN,"C","","","^TMP(""PSBLST"",$J)","PSBMSG")
70 .;alpha-numerc look up "C" index drug file
71 .S X=0 F S X=$O(^TMP("PSBLST",$J,"DILIST",X)) Q:X="" D
72 ..Q:$P(^TMP("PSBLST",$J,"DILIST",X,0),U,3)=""
73 ..Q:$P(^TMP("PSBLST",$J,"DILIST",X,0),U,4)=""
74 ..I PSBOTYP'="OIT" D
75 ...I $P(^TMP("PSBLST",$J,"DILIST",X,0),U,3)'?.N S $P(^TMP("PSBLST",$J,"DILIST",X,0),U,3,99)=$P(^TMP("PSBLST",$J,"DILIST",X,0),U,4,99) Q
76 ...S ^TMP("PSB",$J,$P(^TMP("PSBLST",$J,"DILIST",X,0),U))=$P(^TMP("PSBLST",$J,"DILIST",X,0),U)_U_$P($G(^PSDRUG($P(^TMP("PSBLST",$J,"DILIST",X,0),U),0)),U)_U_$P(^TMP("PSBLST",$J,"DILIST",X,0),U,3,99)
77 ..I PSBOTYP="OIT" S ^TMP("PSB",$J,$P(^TMP("PSBLST",$J,"DILIST",X,0),U))=$P(^TMP("PSBLST",$J,"DILIST",X,0),U)_U_$P($G(^PSDRUG($P(^TMP("PSBLST",$J,"DILIST",X,0),U),0)),U)_U_$P(^TMP("PSBLST",$J,"DILIST",X,0),U,3,99)
78 .S PSBCNT=0,RESULTS(0)=0,PSBTLNG=0
79 .S X="" K PSBGOT F S X=$O(^TMP("PSB",$J,X)) Q:((+X=0)!(PSBTLNG=1)) D
80 ..I PSBOTYP'="OIT" D
81 ...I $P(^TMP("PSB",$J,X),U,3)'?.N S $P(^TMP("PSB",$J,X),U,3,99)=$P(^TMP("PSB",$J,X),U,4,99)
82 ...S PSBOIEN=$P(^TMP("PSB",$J,X),U,3)
83 ...S PSBSCIEN=$P(^TMP("PSB",$J,X),U,1)
84 ..I PSBOTYP'="OIT" Q:PSBOTYP="UD"&($P($G(^PSDRUG(PSBSCIEN,2)),U,3)'["U")
85 ..I PSBOTYP'="OIT" Q:PSBOTYP="UD"&($G(^PSDRUG(PSBSCIEN,"I"))&(+$G(^("I"))'>PSBDT))
86 ..I PSBOTYP="OIT" D
87 ...S PSBOIEN=$P(^TMP("PSB",$J,X),U)
88 ..D CPRS
89 ..Q:PSBCPRS]""&(PSBCPRS'>PSBDT)
90 ..;cprs orderable inact dt?
91 ..I $P(A,U,4)="" Q
92 ..I +$P(A,U,4)=0 Q ;not inpat pharm item
93 ..I PSBOTYP="OIT" D Q
94 ...I $D(PSBGOT($P(^TMP("PSB",$J,X),U,4))) S $P(RESULTS(PSBCNT),U,2)=$P(RESULTS(PSBCNT),U,2)_","_$P(^TMP("PSB",$J,X),U) Q
95 ...S PSBDRUG="OIT"_U_$P(^TMP("PSB",$J,X),U)_U_$P(^TMP("PSB",$J,X),U,3,4)_U_PSBORIEN_U_PSBORNM,PSBGOT($P(^TMP("PSB",$J,X),U,4))=""
96 ...S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=PSBDRUG,RESULTS(0)=PSBCNT
97 ..I PSBOTYP="UD" D Q
98 ...S PSBDRUG="DD"_U_$P(^TMP("PSB",$J,X),U,1,2)_U_$P(^TMP("PSB",$J,X),U,3,4)_U_PSBORIEN_U_PSBORNM
99 ...S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=PSBDRUG,RESULTS(0)=PSBCNT
100 ..I PSBOTYP="IV" D Q
101 ...I $P(A,U,4)=2 D
102 ....I $D(^PSDRUG("A527",PSBSCIEN)) D SOLNAL
103 ....I $D(^PSDRUG("A526",PSBSCIEN)) D ADDAL
104 ..I RESULTS(0)>100 K RESULTS S RESULTS(0)=1,RESULTS(1)=-2,PSBTLNG=1 Q
105 I $G(RESULTS(1))="" S RESULTS(0)=1,RESULTS(1)="-1^Invalid Medication Lookup"
106 K PSBDD,PSBDRUG,PSBDT,PSBDTYP,PSBSCIEN,PSBOIEN,PSBORNM,PSBORIEN,PSBPOI,PSBSCAN,PSBTLNG,PSBID,PSBCPRS,^TMP("PSB",$J),^TMP("PSBLST",$J)
107 Q
108CPRS ;
109 S PSBID=PSBOIEN_";99PSP"
110 S A=$$EN^ORBCMA2(PSBID)
111 S PSBORNM=$P(A,U,2)
112 S PSBORIEN=$P(A,U,1)
113 S PSBCPRS=$P(A,U,3)
114 Q
115SOLN ;
116 S X="" F S X=$O(^PSDRUG("A527",PSBSCAN,X)) Q:X="" D
117 .S PSBINACT=$$GET1^DIQ(52.7,X,8,"I") I PSBINACT]"",PSBINACT'>PSBDT Q
118 .S PSBDRUG="SOL"_U_PSBSCAN_U_PSBDD_U_PSBOIEN_U_PSBPOI_U_PSBORIEN_U_PSBORNM
119 .S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=PSBDRUG_U_X_U_$$GET1^DIQ(52.7,X_",",.01)_U_$$GET1^DIQ(52.7,X_",",2),RESULTS(0)=PSBCNT
120 Q
121ADD ;
122 S X="" F S X=$O(^PSDRUG("A526",PSBSCAN,X)) Q:X="" D
123 .S PSBINACT=$$GET1^DIQ(52.6,X,12,"I") I PSBINACT]"",PSBINACT'>PSBDT Q
124 .S PSBDRUG="ADD"_U_PSBSCAN_U_PSBDD_U_PSBOIEN_U_PSBPOI_U_PSBORIEN_U_PSBORNM
125 .S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=PSBDRUG_U_X_U_$$GET1^DIQ(52.6,X_",",.01),RESULTS(0)=PSBCNT
126 Q
127OITMB ;
128 K PSBMSG D LIST^DIC(50.7,"",".01I;.01","P","","",PSBSCAN,"B","","","^TMP(""PSBLST"",$J)","PSBMSG")
129 Q
130OITMC ;
131 K PSBMSG D LIST^DIC(50.7,"",".01I;.01","P","","",PSBSCAN,"C","","","^TMP(""PSBLST"",$J)","PSBMSG")
132 Q
133SOLNAL ;
134 S Y="" F S Y=$O(^PSDRUG("A527",PSBSCIEN,Y)) Q:Y="" D
135 .S PSBINACT=$$GET1^DIQ(52.7,Y,8,"I") I PSBINACT]"",PSBINACT'>PSBDT Q
136 .S PSBDRUG="SOL"_U_$P(^TMP("PSB",$J,X),U,1,2)_U_$P(^TMP("PSB",$J,X),U,3,4)_U_PSBORIEN_U_PSBORNM
137 .S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=PSBDRUG_U_Y_U_$$GET1^DIQ(52.7,Y_",",.01)_U_$$GET1^DIQ(52.7,Y_",",2),RESULTS(0)=PSBCNT
138 Q
139ADDAL ;
140 S Y="" F S Y=$O(^PSDRUG("A526",PSBSCIEN,Y)) Q:Y="" D
141 .S PSBINACT=$$GET1^DIQ(52.6,Y,12,"I") I PSBINACT]"",PSBINACT'>PSBDT Q
142 .S PSBDRUG="ADD"_U_$P(^TMP("PSB",$J,X),U,1,2)_U_$P(^TMP("PSB",$J,X),U,3,4)_U_PSBORIEN_U_PSBORNM
143 .S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=PSBDRUG_U_Y_U_$$GET1^DIQ(52.6,Y_",",.01),RESULTS(0)=PSBCNT
144 Q
145PROVLST(RESULTS,PSBIN) ;
146 K ^TMP("PSB",$J) D NOW^%DTC
147 S PSBIN=$TR(PSBIN,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
148 S RESULTS(0)=1,RESULTS(1)="-1^No provider matching input.",PSBTLNG=0
149 D LIST^DIC(200,"","","P","","",PSBIN,"B","","","^TMP(""PSB"",$J)","PSBMSG")
150 S X=0 F S X=$O(^TMP("PSB",$J,"DILIST",X)) Q:((X="")!(PSBTLNG=1)) D
151 .S PSBIEN=$P(^TMP("PSB",$J,"DILIST",X,0),U,1)
152 .I '$D(^XUSEC("PROVIDER",PSBIEN)) Q
153 .S PSBIACT=$$GET1^DIQ(200,PSBIEN_",",53.4,"I")
154 .Q:PSBIACT'=""&(+PSBIACT'>%) ;if Inactive date and date is less than now Q
155 .S PSBTERM=$$GET1^DIQ(200,PSBIEN_",",9.2,"I")
156 .Q:PSBTERM'=""&(+PSBTERM'>%) ;if termination date and date is less than now Q
157 .S PSBAUTH=$$GET1^DIQ(200,PSBIEN_",",53.1,"I") I PSBAUTH'=1 Q ;is AUTHORIZED TO WRITE MED ORDERS
158 .I RESULTS(1)["-1" S RESULTS(0)=0
159 .S RESULTS(0)=RESULTS(0)+1,RESULTS(RESULTS(0))=$P(^TMP("PSB",$J,"DILIST",X,0),U,1,2)
160 .I RESULTS(0)>100 K RESULTS S RESULTS(0)=1,RESULTS(1)=-2,PSBTLNG=1
161 K ^TMP("PSB",$J),PSBIN,PSBTLNG,PSBIACT,PSBIEN,PSBTERM,PSBAUTH
162 Q
163ORDER(RESULTS,PSBHDR,PSBREC) ;
164 S RESULTS(0)=1,RESULTS(1)="-1^Data not filed"
165 S PSBDFN=$P(PSBHDR,U,1),PSBMON=$P(PSBHDR,U,2),PSBSCH=$P(PSBHDR,U,3)
166 S ^TMP("PSBMO",$J,PSBDFN,PSBMON,0)=PSBDFN_U_PSBMON_U_PSBREC(0)_U_PSBREC(1)_U_PSBREC(2)_U_PSBSCH
167 S ^TMP("PSBMO",$J,PSBDFN,PSBMON,700,0)=0,^TMP("PSBMO",$J,PSBDFN,PSBMON,800,0)=0,^TMP("PSBMO",$J,PSBDFN,PSBMON,900,0)=0
168 I PSBREC(3)>0 D
169 .S ^TMP("PSBMO",$J,PSBDFN,PSBMON,700,0)=PSBREC(3)
170 .F I=1:1:PSBREC(3) D
171 ..S ^TMP("PSBMO",$J,PSBDFN,PSBMON,700,I,0)=$P(PSBREC(4),U,1)_U_$P(PSBREC(4),U,2)
172 ..S PSBREC(4)=$P(PSBREC(4),U,3,99)
173 I PSBREC(5)>0 D
174 .S ^TMP("PSBMO",$J,PSBDFN,PSBMON,800,0)=PSBREC(5)
175 .F I=1:1:PSBREC(5) S ^TMP("PSBMO",$J,PSBDFN,PSBMON,800,I,0)=$P(PSBREC(6),U,I)
176 I PSBREC(7)>0 D
177 .S ^TMP("PSBMO",$J,PSBDFN,PSBMON,900,0)=PSBREC(7)
178 .F I=1:1:PSBREC(7) S ^TMP("PSBMO",$J,PSBDFN,PSBMON,900,I,0)=$P(PSBREC(8),U,I)
179 S ^TMP("PSBMO",$J,PSBDFN,PSBMON,"PSB")=DUZ_U_DUZ(2)_U_PSBREC(9)_U_$G(PSBREC(10))
180 S RESULTS(0)=1,RESULTS(1)="1^Data successfully filed"
181 Q
182VACLKU ;
183 D C^PSN50P65(,PSBSCAN,"PSBLST")
184 S PSBCNT=0,RESULTS(0)=0,PSBTLNG=0
185 S X=0 F S X=$O(^TMP($J,"PSBLST",X)) Q:((+X=0)!(PSBTLNG=1)) D
186 .S PSBVAC="VAC"_U_X_U_^TMP($J,"PSBLST",X,1)_U_^TMP($J,"PSBLST",X,.01)
187 .S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=PSBVAC,RESULTS(0)=PSBCNT
188 .I RESULTS(0)>100 K RESULTS S RESULTS(0)=1,RESULTS(1)=-2,PSBTLNG=1 Q
189 I $G(RESULTS(1))="" S RESULTS(0)=1,RESULTS(1)="-1^Invalid Medication Lookup"
190 K ^TMP($J,"PSBLST"),PSBVAC
191 Q
Note: See TracBrowser for help on using the repository browser.