source: FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBMLLKU.m@ 808

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

initial load of FOIAVistA 6/30/08 version
File size: 9.5 KB
Line 
1PSBMLLKU ;BIRMINGHAM/TEJ-BCMA RPC LOOKUP UTLILITIES ;Mar 2004
2 ;;3.0;BAR CODE MED ADMIN;**3,9,11,20,13,38,32**;Mar 2004;Build 32
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ; Reference/IA
6 ; EN^PSJBCMA1/2829
7 ; $$DOB^DPTLK1/3266
8 ; $$SSN^DPTLK1/3267
9 ; ^DPT/10035
10 ; ^XUSEC/10076
11 ; File 52.6/436
12 ; File 52.7/437
13 ; File 50/221
14 ; File 211.4/1409
15 ;
16RPC(RESULTS,PSBREC) ; Remote Procedure Call Entry Point.
17 ;
18 S RESULTS="" D @(PSBREC(0)_"(.RESULTS,.PSBREC)") Q
19 Q
20 ;
21ADMLKUP(RESULTS,PSBREC) ;
22 ; Lookup ADMinistrations per DFN and search DATE
23 ; input - PSBREC(1) DFN
24 ; PSBREC(2) Search DATE
25 ;
26 ; outpt - RESULTS (array)
27 ; (Administrations returned will be dated = to Search Date
28 ;
29 ;
30 K RESULTS
31 S DFN=PSBREC(1),PSBSRCH=$G(PSBREC(2)) I $G(PSBSRCH)']"" D NOW^%DTC S PSBSRCH=$P(%,".")
32 S PSBDT=PSBSRCH,PSBCNT=0 S:PSBSRCH'["." PSBSRCH=PSBSRCH+.9
33 S RESULTS(0)=1,RESULTS(1)="-1^No Meds Found!"
34 F S PSBSRCH=$O(^PSB(53.79,"AADT",DFN,PSBSRCH),-1) Q:'PSBSRCH!(PSBSRCH<PSBDT) D
35 .S PSBIEN=""
36 .F S PSBIEN=$O(^PSB(53.79,"AADT",DFN,PSBSRCH,PSBIEN),-1) Q:'PSBIEN D:'$D(^PSB(53.79,PSBIEN)) KILLAADT Q:'$D(^PSB(53.79,PSBIEN)) D:$$CHKKEY(PSBIEN)
37 ..L +^PSB(53.79,PSBIEN):1
38 ..I L -^PSB(53.79,PSBIEN)
39 ..E Q
40 ..S PSBXORDN=$$GET1^DIQ(53.79,PSBIEN_",",.11) Q:'$D(^PSB(53.79,"AORDX",DFN,PSBXORDN,PSBSRCH))
41 ..Q:($$GET1^DIQ(53.79,PSBIEN_",",.06,"I")>PSBSRCH)
42 ..Q:($$GET1^DIQ(53.79,PSBIEN_",",.09,"I")="N")
43 ..S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=PSBIEN
44 ..S $P(RESULTS(PSBCNT),U,2)=PSBSRCH
45 ..S $P(RESULTS(PSBCNT),U,3)=$$GET1^DIQ(53.79,PSBIEN_",",.08)
46 ..S:$$GET1^DIQ(53.79,PSBIEN_",",.26) $P(RESULTS(PSBCNT),U,4)=$$GET1^DIQ(53.79,PSBIEN_",",.26)
47 ..S $P(RESULTS(PSBCNT),U,5)=$S($$GET1^DIQ(53.79,PSBIEN_",",.09,"I")']"":"U",1:$$GET1^DIQ(53.79,PSBIEN_",",.09,"I"))
48 ..D ; Get order information
49 ...K ^TMP("PSJ1",$J) D EN^PSJBCMA1(DFN,PSBXORDN,1)
50 ...S $P(RESULTS(PSBCNT),U,3)=$P(^TMP("PSJ1",$J,2),U,2) ;OItem_" "_Dosage Form
51 ...S $P(RESULTS(PSBCNT),U,6)=$P(^TMP("PSJ1",$J,4),U) ;Sched Type
52 ...K ^TMP("PSJ1",$J)
53 ..S $P(RESULTS(PSBCNT),U,7)=$$GET1^DIQ(53.79,PSBIEN_",",.06,"I")
54 ..S $P(RESULTS(PSBCNT),U,8)=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:INITIAL")
55 ..S:$D(^PSB(53.79,PSBIEN,.2)) $P(RESULTS(PSBCNT),U,9)=$P(^PSB(53.79,PSBIEN,.2),U),$P(RESULTS(PSBCNT),U,10)=$P(^PSB(53.79,PSBIEN,.2),U,2)
56 S:+$G(RESULTS(1))>0 $P(RESULTS(0),U)=PSBCNT
57 Q
58 ;
59CHKKEY(PSBIENX) ;
60 I '(($D(^XUSEC("PSB MANAGER",DUZ)))!($$GET1^DIQ(53.79,+PSBIENX,.07,"I")=DUZ)) Q 0
61 Q 1
62 ;
63PTLKUP(RESULTS,PSBREC) ; Patient lookup handled separately for security
64 ; input - PSBREC (array) User entered patient lookup data
65 ;
66 ; outpt - RESULTS (array)
67 ; (Person(s) in PATIENT File (#2) meeting search criteria)
68 ;
69 ;
70 K RESULTS
71 S PSBDATA=$E(PSBREC(1),1,60)
72 S PSBDATA1=PSBDATA
73 N PSBINDX S PSBINDX="" K ^TMP("DILIST",$J)
74 I $E(PSBDATA,$L(PSBDATA)-10,60)=" [MAS WARD]" S PSBINDX="CN" S PSBDATA=$P(PSBDATA," [MAS WARD]")
75 I $E(PSBDATA,$L(PSBDATA)-11,60)=" [NURS UNIT]" S PSBINDX="CN" S PSBDATA=$P(PSBDATA," [NURS UNIT]") D
76 .K PSBPT S PSBPT(0)=0
77 .S PSBZ=0 F S PSBZ=$O(^NURSF(211.4,PSBZ)) Q:PSBZ'?.N I $$GET1^DIQ(211.4,PSBZ_",",.01)=PSBDATA S PSBY=PSBZ Q
78 .K PSBDATA S PSBDATA=""
79 .S PSBX=0 F S PSBX=$O(^NURSF(211.4,PSBY,3,PSBX)) Q:PSBX="" S PSBDATA(PSBX)=$$GET1^DIQ(42,$P(^NURSF(211.4,PSBY,3,PSBX,0),U)_",",.01)
80 I PSBINDX="" S PSBINDX=$S(PSBDATA?9N.1P:"SSN",PSBDATA?4N.1P:"BS5^BS",1:PSBINDX)
81 I ($O(PSBDATA(""))'>0) D FIND^DIC(2,"","@;.01;.02;.03;.09","MP",PSBDATA,200,PSBINDX)
82 I ($O(PSBDATA(""))>0) D
83 .S PSBX="",PSBY=1 F S PSBX=$O(PSBDATA(PSBX)) Q:PSBX="" D K ^TMP("DILIST",$J) Q:$P(PSBPT(0),U,3)=1
84 ..D FIND^DIC(2,"","@;.01;.02;.03;.09","MP",PSBDATA(PSBX),200,PSBINDX)
85 ..S PSBZ=0 F S PSBZ=$O(^TMP("DILIST",$J,PSBZ)) Q:PSBZ="" S PSBPT(PSBY,0)=^TMP("DILIST",$J,PSBZ,0),PSBPT(0)=PSBY,PSBY=PSBY+1 I PSBY>200 S $P(PSBPT(0),U,3)=1
86 K:+$G(PSBPT(0))=0 PSBPT
87 I $D(PSBPT) M ^TMP("DILIST",$J)=PSBPT
88 I $P($G(^TMP("DILIST",$J,0)),U,3) D Q
89 .S RESULTS(0)=1,RESULTS(1)="-1^Too many patients found matching '"_PSBDATA1_"'. Please be more specific."
90 I $D(^TMP("DILIST",$J,0)) D
91 .F PSBXX=0:0 S PSBXX=$O(^TMP("DILIST",$J,PSBXX)) Q:'PSBXX D
92 ..S RESULTS(PSBXX)=$$PTREC(+^TMP("DILIST",$J,PSBXX,0))
93 I '$D(RESULTS) S RESULTS(0)=1,RESULTS(1)="-1^No patients matching '"_PSBDATA1_"'"
94 E S RESULTS(0)=+$O(RESULTS(""),-1)
95 Q
96 ;
97PTREC(DFN) ;
98 ; Extrinsic to return a Pt Rec in standard list format
99 N PSBXX
100 S PSBXX=$G(^DPT(DFN,0))
101 S PSBXX=DFN_U_$P(PSBXX,U,1)_U_$P(PSBXX,U,2)_U_$P(PSBXX,U,3)_U_$P(PSBXX,U,9)
102 S $P(PSBXX,U,6)=$$GET1^DIQ(2,DFN_",",.1)
103 S $P(PSBXX,U,7)=$$GET1^DIQ(2,DFN_",",.101)
104 S $P(PSBXX,U,10)=$$DOB^DPTLK1(DFN)
105 S $P(PSBXX,U,11)=$$SSN^DPTLK1(DFN)
106 Q PSBXX
107 ;
108SELECTAD(RESULTS,PSBREC) ; Select Administration
109 ;
110 ; Process the SELECTed ADministration
111 ; input - PSBREC(1) = PSB Med Log File (#53.79) IEN
112 ;
113 ;
114 ; outpt - RESULTS (array)
115 ; (Administration data that can be subsequently updated via GUI MED LOG EDIT)
116 ;
117 ;
118 K RESULTS,PSBXIV,PSBPTCHX
119 N PSBIEN,PSBCNT,PSBX S PSBIEN=PSBREC(1),PSBCNT=2
120 ; Construct form data Patient^SSN^Med^BagID^AdminStat^AdminD/T^InjctSt^PRNReas^PRNEff^DisDrg^UntsGiven^Unt^
121 S RESULTS(0)=0
122 D:$$CHKKEY(PSBIEN)
123 .L +^PSB(53.79,PSBIEN):1
124 .E I $P(^PSB(53.79,PSBIEN,0),U,9)]"" S PSBCNT=1,RESULTS(1)="-1^ This administration is being modified by another process at this moment." L -^PSB(53.79,PSBIEN) Q
125 .S $P(RESULTS(1),U)=PSBIEN
126 .S $P(RESULTS(1),U,2)=$$GET1^DIQ(53.79,PSBIEN_",",.01,"I")
127 .S $P(RESULTS(1),U,3)=$$GET1^DIQ(53.79,PSBIEN_",",.01)
128 .S $P(RESULTS(1),U,4)=$$GET1^DIQ(2,$P(RESULTS(1),U,2)_",",.09)
129 .S $P(RESULTS(1),U,5)=$$GET1^DIQ(53.79,PSBIEN_",",.08,"I")_"~"_$$GET1^DIQ(53.79,PSBIEN_",",.08)
130 .S $P(RESULTS(1),U,6)=$$GET1^DIQ(53.79,PSBIEN_",",.26)
131 .S $P(RESULTS(1),U,7)=$S($$GET1^DIQ(53.79,PSBIEN_",",.09,"I")']"":"U",1:$$GET1^DIQ(53.79,PSBIEN_",",.09,"I"))
132 .;
133 .D:($P(RESULTS(1),U,7)'="N")&($P(RESULTS(1),U,7)]"") SELSTTUS(.RESULTS) ; Amend RESULTS(1) data...
134 .S Y=$E($$GET1^DIQ(53.79,PSBIEN_",",.06,"I"),1,12) D DD^%DT
135 .S $P(RESULTS(1),U,8)=Y
136 .S $P(RESULTS(1),U,9)=$$GET1^DIQ(53.79,PSBIEN_",",.06,"I")
137 .S $P(RESULTS(1),U,10)=$$GET1^DIQ(53.79,PSBIEN_",",.16)
138 .S $P(RESULTS(1),U,16)=0
139 .S $P(RESULTS(2),U)=$$GET1^DIQ(53.79,PSBIEN_",",.21),$P(RESULTS(2),U,2)=$$GET1^DIQ(53.79,PSBIEN_",",.22)
140 .; Determine if there are any active IVs/Patchs per order
141 .D:$G(PSBPTCHX)
142 ..S PSBX="",PSBX="^PSB(53.79,""APATCH"","_$P(RESULTS(1),U,2)_")"
143 ..F S PSBX=$Q(@PSBX) Q:PSBX="" Q:$QS(PSBX,3)'=$P(RESULTS(1),U,2) D Q:$P(RESULTS(1),U,16)
144 ...S PSBXX=$QS(PSBX,5),PSBXXX=$S(($P(^PSB(53.79,PSBXX,0),U,9)="G")&(PSBXX'=PSBIEN):1,1:0)
145 ...I PSBXXX&($P(^PSB(53.79,PSBXX,.1),U)=$P(RESULTS(1),U,15)) S $P(RESULTS(1),U,16)=1
146 .D:$G(PSBXIV)
147 ..S PSBX="",PSBX="^PSB(53.79,""AUID"","_$P(RESULTS(1),U,2)_")"
148 ..F S PSBX=$Q(@PSBX) Q:PSBX="" Q:$QS(PSBX,3)'=$P(RESULTS(1),U,2) Q:$QS(PSBX,4)>$P(RESULTS(1),U,15) D Q:$P(RESULTS(1),U,16)
149 ...Q:$QS(PSBX,4)'=$P(RESULTS(1),U,15)
150 ...S PSBXX=$QS(PSBX,6) S:(PSBXX'=PSBIEN) $P(RESULTS(1),U,16)=$S($P(^PSB(53.79,PSBXX,0),U,9)="I":1,$P(^PSB(53.79,PSBXX,0),U,9)="S":1,1:0)
151 .;
152 .; LOOP - Place DD in RESULTS
153 .S PSBX=0 F S PSBX=$O(^PSB(53.79,PSBIEN,.5,PSBX)) Q:'(+PSBX) D
154 ..S PSBCNT=PSBCNT+1
155 ..S RESULTS(PSBCNT)="DD^"_$P(^PSB(53.79,PSBIEN,.5,PSBX,0),U)_"^"_$$GET1^DIQ(50,$P(^PSB(53.79,PSBIEN,.5,PSBX,0),U)_",",.01)
156 ..S $P(RESULTS(PSBCNT),U,4)=$P(^PSB(53.79,PSBIEN,.5,PSBX,0),U,2)_"^"_$P(^PSB(53.79,PSBIEN,.5,PSBX,0),U,3)_"^"_$P(^PSB(53.79,PSBIEN,.5,PSBX,0),U,4)
157 ..S:$P(RESULTS(PSBCNT),U,4)?1"."1.N $P(RESULTS(PSBCNT),U,4)=0_+$P(RESULTS(PSBCNT),U,4)
158 ..S:$P(RESULTS(PSBCNT),U,5)?1"."1.N $P(RESULTS(PSBCNT),U,5)=0_+$P(RESULTS(PSBCNT),U,5)
159 .; LOOP - Place ADD in RESULTS
160 .S PSBX=0 F S PSBX=$O(^PSB(53.79,PSBIEN,.6,PSBX)) Q:'(+PSBX) D
161 ..S PSBCNT=PSBCNT+1
162 ..S RESULTS(PSBCNT)="ADD^"_$P(^PSB(53.79,PSBIEN,.6,PSBX,0),U)_"^"_$$GET1^DIQ(52.6,$P(^PSB(53.79,PSBIEN,.6,PSBX,0),U)_",",.01)
163 ..S $P(RESULTS(PSBCNT),U,4)=$P(^PSB(53.79,PSBIEN,.6,PSBX,0),U,2)_"^"_$P(^PSB(53.79,PSBIEN,.6,PSBX,0),U,3)_"^"_$P(^PSB(53.79,PSBIEN,.6,PSBX,0),U,4)
164 .; LOOP - Place SOL in RESULTS
165 .S PSBX=0 F S PSBX=$O(^PSB(53.79,PSBIEN,.7,PSBX)) Q:'(+PSBX) D
166 ..S PSBCNT=PSBCNT+1
167 ..S RESULTS(PSBCNT)="SOL^"_$P(^PSB(53.79,PSBIEN,.7,PSBX,0),U)_"^"_$$GET1^DIQ(52.7,$P(^PSB(53.79,PSBIEN,.7,PSBX,0),U)_",",.01)
168 ..S $P(RESULTS(PSBCNT),U,4)=$P(^PSB(53.79,PSBIEN,.7,PSBX,0),U,2)_"^"_$P(^PSB(53.79,PSBIEN,.7,PSBX,0),U,3)_"^"_$P(^PSB(53.79,PSBIEN,.7,PSBX,0),U,4)
169 .L -^PSB(53.79,PSBIEN)
170 S:PSBCNT>0 RESULTS(0)=PSBCNT
171 Q
172 ;
173SELSTTUS(RESULTS) ;
174 ; Provide the SELectable STaTUS
175 ;
176 ; Get TAB, ScheduleType, Current Status, provide Selectable Staus(s) in ^8
177 N PSBORTYP,PSBIVTYP,PSBINTSY,PSBCHMTY,PSBIVPSH,PSBXTAB
178 K ^TMP("PSJ1",$J) D EN^PSJBCMA1($$GET1^DIQ(53.79,PSBIEN_",",.01,"I"),$$GET1^DIQ(53.79,PSBIEN_",",.11),1)
179 I ^TMP("PSJ1",$J,0)>0 D
180 .S PSBORTYP=$TR($P(^TMP("PSJ1",$J,0),U,3),"1234567890"),PSBIVTYP=$P(^TMP("PSJ1",$J,0),U,6)
181 .S PSBINTSY=$P(^TMP("PSJ1",$J,0),U,7),PSBCHMTY=$P(^TMP("PSJ1",$J,0),U,8),PSBIVPSH=+$P($G(^TMP("PSJ1",$J,1,0)),U,2)
182 .S:$$IVPTAB^PSBVDLU3(PSBORTYP,PSBIVTYP,PSBINTSY,PSBCHMTY,PSBIVPSH) PSBXTAB="PB"
183 .D:'$D(PSBXTAB)
184 ..I PSBORTYP="U" S PSBXTAB="UD"
185 ..I PSBORTYP="V" S PSBXTAB="IV"
186 ; Set Results(1) and other flags...
187 I ^TMP("PSJ1",$J,0)>0 D
188 .S $P(RESULTS(1),U,13)=$P(^TMP("PSJ1",$J,4),U)
189 .S $P(RESULTS(1),U,14)=$P(^TMP("PSJ1",$J,1),U,10)
190 .S $P(RESULTS(1),U,15)=$P(^TMP("PSJ1",$J,0),U,3)
191 .I (PSBXTAB="UD"),($P(^TMP("PSJ1",$J,2),U,6)="PATCH") S PSBPTCHX=1
192 .I PSBXTAB="IV" S PSBXIV=1
193 .S:$G(PSBXTAB)]"" $P(RESULTS(1),U,11)=$G(PSBXTAB)
194 K ^TMP("PSJ1",$J)
195 Q
196 ;
197KILLAADT ;
198 ; Here because there is an errorant index entry via version 1.0/2.0
199 ; Cleansing!
200 ;
201 K ^PSB(53.79,"AADT",DFN,PSBSRCH,PSBIEN)
202 Q
203 ;
Note: See TracBrowser for help on using the repository browser.