source: WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBVDLPB.m@ 1608

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

initial load of WorldVistAEHR
File size: 8.7 KB
Line 
1PSBVDLPB ;BIRMINGHAM/EFC-BCMA IV VIRTUAL DUE LIST ;Mar 2004
2 ;;3.0;BAR CODE MED ADMIN;**11,13,38,32**;Mar 2004;Build 32
3 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
4 ;
5 ; Reference/IA
6 ; EN^PSJBCMA/2828
7 ; $$GET^XPAR/2263
8 ; File 200/10060
9 ;
10EN(DFN,PSBDT) ; Default Order List Return for Today
11 ;
12 ; RPC: PSB GETORDERLIST
13 ;
14 ; Description:
15 ; Returns the current IV order set for today to display on the
16 ; client VDL
17 ;
18 ;
19 N PSBDATA,PSBTBOUT
20 S PSBTBOUT=0,PSBDOADD=0
21 S:PSBTAB="PBTAB" PSBDOADD=1
22 ;
23 ;This routine now re-uses the ^TMP("PSJ",$J global built in PSBVDLTB
24 ;
25 I $G(^TMP("PSJ",$J,1,0))=-1 Q ; No orders
26 ;
27 F PSBX=0:0 S PSBX=$O(^TMP("PSJ",$J,PSBX)) Q:('PSBX)!(PSBTBOUT) D
28 .D CLEAN^PSBVT,PSJ^PSBVT(PSBX)
29 .;
30 .; << Standard checks for ALL orders >>
31 .;
32 .Q:PSBONX["P" ; No Pending Orders
33 .Q:'$$IVPTAB^PSBVDLU3(PSBOTYP,PSBIVT,PSBISYR,PSBCHEMT,PSBIVPSH)
34 .Q:PSBOST>PSBWADM ; Order Start Date/Time > admin window
35 .Q:PSBOSP<PSBWBEG ; For all Order Stop Date/Time < vdl window
36 .Q:PSBOSTS["D" ; Is it DC'd
37 .Q:PSBNGF ; Is it marked DO NOT GIVE!
38 .; Non One-Times with stop date/time < now
39 .;
40 .D NOW^%DTC
41 .Q:PSBOSP<%
42 .;
43 .; include Active, Renewed, ReInstated and On Call
44 .; (Is it not one time)&(Is it not active or renewed or On Call)
45 .Q:PSBSCHT'="O"&((PSBOSTS'="A")&(PSBOSTS'="R")&(PSBOSTS'="RE")&(PSBOSTS'="O")&(PSBOSTS'="H"))
46 .;
47 .; Is One Time Given
48 .;
49 .I PSBSCHT="O" D Q:PSBGVN
50 ..S (PSBGVN,X,Y)=""
51 ..F S X=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X),-1) Q:'X D
52 ...F S Y=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X,Y),-1) Q:'Y S:($P(^PSB(53.79,Y,.1),U)=PSBONX)&($P(^PSB(53.79,Y,0),U,9)="G") PSBGVN=1,(X,Y)=0
53 .;
54 .; How long does One Time remain on VDL ?
55 .S PSBRMN=1
56 .I PSBSCHT="O",PSBOSP'=PSBOST,%>PSBOSP S PSBRMN=0
57 .Q:'PSBRMN
58 .;
59 .; Is On-Call Given, Can it be given more than once
60 .;
61 .I PSBSCHT="OC" D Q:PSBGVN&('$$GET^XPAR("DIV","PSB ADMIN MULTIPLE ONCALL"))
62 ..S (PSBGVN,X,Y)=""
63 ..F S X=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X),-1) Q:'X D
64 ...F S Y=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X,Y),-1) Q:'Y S:($P(^PSB(53.79,Y,.1),U)=PSBON)&($P(^PSB(53.79,Y,0),U,9)="G") PSBGVN=1,(X,Y)=0
65 .;
66 .S PSBSTRT=PSBOST ; Order Start Date/Time
67 .S PSBSTOP=PSBOSP ; Order Stop Date/Time
68 .;
69 .S PSBREC=""
70 .S $P(PSBREC,U,1)=DFN ; dfn
71 .S $P(PSBREC,U,2)=PSBONX ; Order
72 .S $P(PSBREC,U,3)=+PSBON ; order ien
73 .S $P(PSBREC,U,4)=PSBOTYP ; iv/ud/pending
74 .S $P(PSBREC,U,5)=PSBSCHT ; schedule type
75 .S $P(PSBREC,U,6)=PSBSCH ; schedule
76 .S Y=""
77 .S:PSBSM Y="SM"
78 .S:PSBHSM Y="HSM"
79 .S $P(PSBREC,U,7)=Y ; self med
80 .S $P(PSBREC,U,8)=PSBOITX ; drugname
81 .S $P(PSBREC,U,9)=PSBDOSE_" "_PSBIFR ; dosage
82 .S $P(PSBREC,U,10)=PSBMR ;med route
83 .; Last Given from the AOIP X-Ref - not given status not excepted
84 .S (YZ,PSBSTUS,PSBADMER)="" K PSBHSTA,PSBHSTAX
85 .F XZ=1:1:20 S YZ=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,YZ),-1),(PSBCNT,PSBFLAG)=0 Q:YZ="" D
86 ..S:YZ>0 $P(PSBREC,U,11)=YZ
87 ..S X="" F S X=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,YZ,X),-1) Q:X="" D
88 ...K PSBLCK L +^PSB(53.79,X):1 I L -^PSB(53.79,X) S PSBLCK=1
89 ...S PSBSTUS=$P(^PSB(53.79,X,0),U,9)
90 ...I $G(PSBSTUS)="" S:'$G(PSBLCK) PSBSTUS="X" I $G(PSBLCK) S PSBADMER=1 D
91 ....K PSBPARM3,PSBPARM5,PSBPARM6,PSBPARM7
92 ....S PSBPARM6=X,Y=$P(^PSB(53.79,X,.1),U,3) D DD^%DT S PSBPARM3=Y,Y=$P(^PSB(53.79,X,0),U,6) D DD^%DT S PSBPARM5=Y
93 ....S PSBPARM7=$P(^PSB(53.79,X,0),U,7) S PSBPARM7="( # "_PSBPARM7_" ) "_$$GET1^DIQ(200,PSBPARM7_",",.01)
94 ....K PSBXTMP S PSBXTMP=PSBONX
95 ....D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$$GET1^DIQ(53.79,PSBPARM6_",",.11))
96 ....D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,PSBPARM3_" admin's ACTION STATUS is ""UNKNOWN"".",PSBSCH,PSBPARM5,PSBPARM6,PSBPARM7) ; SEND AN E-MAIL
97 ....D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBXTMP) ;Reset Variables
98 ....S X=PSBPARM6 K PSBPARM3,PSBPARM5,PSBPARM6,PSBPARM7
99 ...K PSBLCK S:(PSBSTUS']"") PSBSTUS="U" I PSBSTUS'="N",($G(PSBSTUS)'="X") S PSBFLAG=1,PSBHSTA(YZ,$G(PSBSTUS))="ORIG"_U_X
100 ...D:PSBSTUS="N"
101 ....S $P(PSBREC,U,11)=""
102 ....S Z="" F S Z=$O(^PSB(53.79,X,.9,Z),-1) Q:'Z Q:PSBFLAG=1 S PSBDATA=$G(^(Z,0)) D
103 .....I (PSBDATA["Set to 'NOT GIVEN'")!(PSBDATA["Set to 'GIVEN'")!(PSBDATA["Set to 'REFUSED'")!(PSBDATA["Set to 'HELD'")!(PSBDATA["Set to 'MISSING DOSE'")!(PSBDATA["Set to 'REMOVED'") S PSBCNT=PSBCNT+1
104 .....I (PSBDATA["STATUS 'HELD'")!(PSBDATA["STATUS 'GIVEN'")!(PSBDATA["STATUS 'REFUSED'")!(PSBDATA["STATUS 'MISSING DOSE'")!(PSBDATA["STATUS 'REMOVED'") S PSBCNT=PSBCNT+1
105 .....I PSBCNT#2=0,PSBDATA["'REFUSED'" S PSBSTUS="R" D LAST^PSBVDLU1
106 .....I PSBCNT#2=0,PSBDATA["'HELD'" S PSBSTUS="H" D LAST^PSBVDLU1
107 .....I PSBCNT#2=0,PSBDATA["'MISSING DOSE'" S PSBSTUS="M" D LAST^PSBVDLU1
108 .....I PSBCNT#2=0,PSBDATA["'REMOVED'" S PSBSTUS="RM" D LAST^PSBVDLU1
109 .....I PSBFLAG=1,'$D(PSBHSTA($P(PSBREC,U,11),$G(PSBSTUS))) S PSBHSTA($P(PSBREC,U,11),$G(PSBSTUS))=Z_U_X
110 .I $D(PSBHSTA) S $P(PSBREC,U,11)=$O(PSBHSTA(""),-1),PSBSTUS=$O(PSBHSTA($P(PSBREC,U,11),""),-1) M PSBHSTAX(PSBOIT)=PSBHSTA K PSBHSTA ;last action date/time
111 .S $P(PSBREC,U,12)="" ;med log ien inserted below for actual date
112 .S $P(PSBREC,U,13)="" ;med log status inserted below for actual date
113 .S $P(PSBREC,U,14)="" ;admin date inserted below
114 .S $P(PSBREC,U,15)=PSBOIT ; OI Pointer
115 .S $P(PSBREC,U,16)=PSBNJECT ;Set injectable med route flag
116 .; Variable dosage entered as ####-####?
117 .I $P(PSBREC,U,9)?1.4N1"-"1.4N.E S $P(PSBREC,U,17)=1
118 .E S $P(PSBREC,U,17)=0
119 .S $P(PSBREC,U,18)=PSBIVT ;IV TYPE - dosage form
120 .S $P(PSBREC,U,20)=$S((PSBSTUS="X")!(PSBSTUS="N"):"",1:PSBSTUS) ;last action status
121 .S $P(PSBREC,U,21)=PSBOST
122 .S $P(PSBREC,U,22)=PSBOSTS
123 .S $P(PSBREC,U,26)=PSBSTOP
124 .S $P(PSBREC,U,27)=$$LASTG^PSBCSUTL(DFN,PSBOIT)
125 .;
126 .; Gather Dispense Drugs
127 .D NOW^%DTC
128 .S (PSBDDS,PSBSOLS,PSBADDS)="0"
129 .F Y=0:0 S Y=$O(PSBDDA(Y)) Q:'Y D
130 ..Q:$P(PSBDDA(Y),U,4)&($P(PSBDDA(Y),U,4)<%) ; Inactive
131 ..S:$P(PSBDDA(Y),U,3)="" $P(PSBDDA(Y),U,3)=1
132 ..S PSBDDS=PSBDDS_U_$P(PSBDDA(Y),U,1,3)
133 ..S $P(PSBDDS,U,1)=PSBDDS+1
134 .; On-Call One Time PRN orders
135 .S PSBQRR=0
136 .I "^O^OC^P^"[(U_PSBSCHT_U) D Q
137 ..I 'PSBDOADD S PSBTBOUT=1,^TMP("PSB",$J,"PBTAB",0)=2,^TMP("PSB",$J,"PBTAB",1)=1,^TMP("PSB",$J,"PBTAB",2)=1 Q
138 ..D ADD^PSBVDLU1(PSBREC,PSBOTXT,PSBNOW\1,PSBDDS,PSBSOLS,PSBADDS,"PBTAB")
139 .;
140 .; IV's - don't worry about admin times if blank
141 .I PSBONX["V","PSC"'[PSBIVT,PSBADST="" D Q
142 ..I 'PSBDOADD S PSBTBOUT=1,^TMP("PSB",$J,"PBTAB",0)=2,^TMP("PSB",$J,"PBTAB",1)=1,^TMP("PSB",$J,"PBTAB",2)=1 Q
143 ..D ADD^PSBVDLU1(PSBREC,PSBOTXT,PSBNOW\1_".",PSBDDS,PSBSOLS,PSBADDS,"PBTAB")
144 .;
145 .; Now we deal with only continuous
146 .; process admintimes
147 .S (PSBYES,PSBODD,PSBYTF)=0
148 .S:$$PSBDCHK1^PSBVT1(PSBSCH) PSBYES=1
149 .I PSBYES,PSBADST="" D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Admin times required",PSBSCH) Q
150 .F I=1:1 Q:$P(PSBSCH,"-",I)="" I $P(PSBSCH,"-",I)?2N!($P(PSBSCH,"-",I)?4N) S PSBYES=1,PSBYTF=1
151 .I PSBSCHT="C",PSBYTF="1",PSBADST="" D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Admin times required",PSBSCH) Q
152 .S PSBFREQ=$$GETFREQ^PSBVDLU1(DFN,PSBONX)
153 .I PSBFREQ="O" S PSBFREQ=1440
154 .I PSBFREQ="D" S PSBFREQ=""
155 .I 'PSBYES,PSBFREQ<1 D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Invalid frequency received from order",PSBSCH) Q
156 .S PSBADMIN=PSBADST
157 .I (PSBADMIN="")&(+PSBFREQ>0) D ODDSCH^PSBVDLU1("PBTAB") Q ;calculate admin times based on frequency
158 .; No admin times, MAYDAY MAYDAY!!
159 .I +PSBFREQ>0 I (PSBFREQ#1440'=0),(1440#PSBFREQ'=0) S PSBODD=1
160 .I PSBODD,PSBADST'="" D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Administration Times on ODD SCHEDULE",PSBSCH) Q
161 .; process admin times against beginning and ending date
162 .; build all orders for both days.
163 .F PSBY=1:1 Q:$P(PSBADMIN,"-",PSBY)="" D
164 ..;For invalid admin times
165 ..I ($P(PSBADST,"-",PSBY)'?2N)&($P(PSBADST,"-",PSBY)'?4N) D ERROR^PSBMLU(PSBONX,PSBOITX,DFN,"Invalid Admin times",PSBSCH)
166 ..; apply this time to the beginning window date
167 ..S PSB=+(PSBWBEG\1_"."_$P(PSBADMIN,"-",PSBY))
168 ..D:(PSB'<PSBWBEG)&(PSB'>PSBWEND) ; Make sure it is in the window
169 ...D:(PSB'<PSBSTRT)&(PSB<PSBSTOP) ; Make sure this time is active
170 ....D:$$OKAY^PSBVDLU1(PSBSTRT,PSB,PSBSCH,PSBON,PSBOITX,PSBFREQ,PSBOSTS) ; Okay on this date?
171 .....I 'PSBDOADD S PSBTBOUT=1,^TMP("PSB",$J,"PBTAB",0)=2,^TMP("PSB",$J,"PBTAB",1)=1,^TMP("PSB",$J,"PBTAB",2)=1 Q
172 .....D ADD^PSBVDLU1(PSBREC,PSBOTXT,PSB,PSBDDS,PSBSOLS,PSBADDS,"PBTAB")
173 ..;
174 ..Q:(PSBWBEG\1)=(PSBWEND\1) ; Window only has one day rare but possible
175 ..;
176 ..; apply this time to the ending window date
177 ..S PSB=+(PSBWEND\1_"."_$P(PSBADMIN,"-",PSBY))
178 ..D:(PSB'<PSBWBEG)&(PSB'>PSBWEND) ; Make sure it is in the window
179 ...D:(PSB'<PSBSTRT)&(PSB<PSBSTOP) ; Make sure this time is active
180 ....D:$$OKAY^PSBVDLU1(PSBSTRT,PSB,PSBSCH,PSBON,PSBOITX,PSBFREQ,PSBOSTS) ; Okay on this date?
181 .....I 'PSBDOADD S PSBTBOUT=1,^TMP("PSB",$J,"PBTAB",0)=2,^TMP("PSB",$J,"PBTAB",1)=1,^TMP("PSB",$J,"PBTAB",2)=1 Q
182 .....D ADD^PSBVDLU1(PSBREC,PSBOTXT,PSB,PSBDDS,PSBSOLS,PSBADDS,"PBTAB")
183 ;
184 ;add initials of verifying pharmacist/verifying nurse
185 D:PSBDOADD VNURSE^PSBVDLU1("PBTAB")
186 Q
187 ;
Note: See TracBrowser for help on using the repository browser.