source: WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBVDLIV.m@ 846

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

initial load of WorldVistAEHR
File size: 7.7 KB
Line 
1PSBVDLIV ;BIRMINGHAM/EFC-BCMA IV VIRTUAL DUE LIST ;Mar 2004
2 ;;3.0;BAR CODE MED ADMIN;**6,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 ; EN^PSJBCMA1/2829
8 ;
9EN(DFN,PSBDT) ; Default Order List Return for Today
10 ;
11 ; RPC: PSB GETORDERLIST
12 ;
13 ; Description:
14 ; Returns the current IV order set for today to display on the
15 ; client VDL
16 ;
17 N PSBDATA,PSBTBOUT,PSBDOADD
18 S PSBTBOUT=0,PSBDOADD=0
19 S:PSBTAB="IVTAB" PSBDOADD=1
20 ;
21 ; Passing PSBDT as 3rd parameter turns off the V.1.0 One-Time lookback
22 K ^TMP("PSJ",$J),^TMP("PSB",$J,"ON IVTAB") S X1=PSBDT,X2=-3 D C^%DTC S PSBDT2=X D EN^PSJBCMA(DFN,PSBDT2,PSBDT)
23 ;
24 I $G(^TMP("PSJ",$J,1,0))=-1 Q ; No orders
25 ;
26 F PSBX=0:0 S PSBX=$O(^TMP("PSJ",$J,PSBX)) Q:('PSBX)!(PSBTBOUT) D
27 .D CLEAN^PSBVT,PSJ^PSBVT(PSBX)
28 .;
29 .; << Standard checks for ALL orders >>
30 .;
31 .Q:PSBONX'["V" ; IVs only
32 .Q:PSBIVT["P" ; No piggybacks
33 .Q:PSBONX["P" ; No Pending Orders
34 .Q:PSBOST>($$FMADD^XLFDT($$NOW^XLFDT,,,$$GET^XPAR("DIV","PSB ADMIN BEFORE")))
35 .; Need to see if "last order" in chain is active/not pending.
36 .S PSBFON1=PSBFON,PSBLOOP=0 I $G(PSBFON)]"" S PSBLACTV=$S($G(PSBFON)["P":0,1:1) S PSBFON2=$G(PSBFON) I 'PSBLACTV F D Q:($G(PSBFON)="")!($G(PSBFON1)=$G(PSBFON2))!(PSBLOOP)!(PSBLACTV) ;
37 ..I $G(PSBFON)["P" K ^TMP("PSJ1",$J) D EN^PSJBCMA1(DFN,PSBFON2,1) I ^TMP("PSJ1",$J,0)=-1 S PSBFON=""
38 ..D:$G(PSBFON)["" CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBFON2)
39 ..I PSBFON=PSBFON2 S PSBLOOP=1,PSBLACTV=0 Q
40 ..S PSBLACTV=$S($G(PSBFON)["P":0,$G(PSBFON)']"":PSBLACTV,1:1),PSBFON2=$G(PSBFON)
41 ..S:(PSBLACTV)&($G(PSBOST)>($$FMADD^XLFDT($$NOW^XLFDT,,,$$GET^XPAR("DIV","PSB ADMIN BEFORE")))) PSBLACTV=0
42 .D CLEAN^PSBVT,PSJ^PSBVT(PSBX) ;Refresh data
43 .K PSBCOMP,PSBCOMPX,PSBINFDT,PSBINFST D INFUSING^PSBVDLU2
44 .D NOW^%DTC
45 .I ((PSBOSTS="A")!(PSBOSTS="R"))&(PSBOSP<%) S PSBOSTS="E"
46 .I (PSBOSTS["D")&(PSBCOMP=0) Q ; Is it DC'd and not infusing or stopped
47 .I PSBOSTS="E",PSBCOMP=0 Q ; Is expired and not infusing or stopped
48 .I PSBOSTS="D",PSBCOMP=1,($G(PSBFON)]""),PSBLACTV Q ; order is DC'ed will be picked up by following order
49 .I PSBOSTS="E",PSBCOMP=1,($G(PSBFON)]""),PSBLACTV Q ; order is expired will be picked up by following order
50 .I PSBOSTS="R",PSBFOR="R",PSBOSP<PSBWBEG Q ; order is renewed bag picked up by following order
51 .Q:$G(^TMP("PSB",$J,"ON IVTAB",PSBDFN,PSBONX))=1 ; The "previous order" is displayed on the VDL!
52 .I (PSBOSTS["E")&(PSBCOMP=0) Q ; Is it expired and not infusing
53 .I PSBIVT["S",PSBISYR=1 Q ; No intermittent syringes - done on PB tab
54 .I PSBIVT["C",PSBISYR=1 Q ; No intermittent syringes - done on PB tab
55 .I PSBIVT["C",PSBCHEMT="P" Q ; No Piggyback Chemos
56 .I PSBNGF&(PSBCOMP=1) Q ; Is it marked DO NOT GIVE!
57 .;
58 .; Non One-Times with stop date/time < now
59 .;
60 .D NOW^%DTC
61 .I PSBOSP<%,PSBOSTS'="R",PSBCOMP'=1 Q
62 .;
63 .; include Active, Renewed, ReInstated and On Call and Hold and Expired infusing
64 .; (Is it not one time)&(Is it not active or renewed or On Call or Hold)
65 .Q:PSBSCHT'="O"&((PSBOSTS'="A")&(PSBOSTS'="R")&(PSBOSTS'="RE")&(PSBOSTS'="O")&(PSBOSTS'="D")&(PSBOSTS'="H")&(PSBOSTS'="E"))
66 .;
67 .; Is One Time Given
68 .;
69 .I PSBSCHT="O" D Q:PSBGVN
70 ..S (PSBGVN,X,Y)=""
71 ..F S X=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X),-1) Q:'X D
72 ...F S Y=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X,Y),-1) Q:'Y D
73 ....I $P(^PSB(53.79,Y,.1),U)=PSBON,$P(^PSB(53.79,Y,0),U,9)="G" S PSBGVN=1,(X,Y)=0
74 .;
75 .; Is On-Call Given, Can it be given more than once
76 .;
77 .I PSBSCHT="OC" D Q:PSBGVN&('$$GET^XPAR("DIV","PSB ADMIN MULTIPLE ONCALL"))
78 ..S (PSBGVN,X,Y)=""
79 ..F S X=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X),-1) Q:'X D
80 ...F S Y=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X,Y),-1) Q:'Y D
81 ....I $P(^PSB(53.79,Y,.1),U)=PSBON,$P(^PSB(53.79,Y,0),U,9)="G" S PSBGVN=1,(X,Y)=0
82 .;
83OK .S PSBSTRT=PSBOST ; Order Start Date/Time
84 .S PSBSTOP=PSBOSP ; Order Stop Date/Time
85 .;
86 .S PSBREC=""
87 .S $P(PSBREC,U,1)=DFN ; dfn
88 .S $P(PSBREC,U,2)=PSBONX ; Order
89 .S $P(PSBREC,U,3)=+PSBON ; order ien
90 .S $P(PSBREC,U,4)=PSBOTYP ; iv/ud/pending
91 .S $P(PSBREC,U,5)=PSBSCHT ; schedule type
92 .S $P(PSBREC,U,6)=PSBSCH ; schedule
93 .S Y=""
94 .S:PSBSM Y="SM"
95 .S:PSBHSM Y="HSM"
96 .S $P(PSBREC,U,7)=Y ; self med
97 .S $P(PSBREC,U,8)=PSBOITX ; drugname
98 .S $P(PSBREC,U,9)=PSBDOSE_" "_PSBIFR ; dosage
99 .S $P(PSBREC,U,10)=PSBMR ; med route
100 .; IV Information Column *new* - status date/time
101 .; (only stopped or infusing)
102 .;
103 .D:PSBCOMP
104 ..S $P(PSBREC,U,11)=PSBINFDT K PSBINFDT
105 ..S PSBSTUS=PSBINFST,$P(PSBREC,U,20)=PSBSTUS K PSBINFST
106 .S $P(PSBREC,U,14)="" ; admin date inserted below
107 .S $P(PSBREC,U,15)=PSBOIT ; OI Pointer
108 .S $P(PSBREC,U,16)=PSBNJECT ;Set injectable med route flag
109 .; Variable dosage entered as ####-####?
110 .I $P(PSBREC,U,9)?1.4N1"-"1.4N.E S $P(PSBREC,U,17)=1
111 .E S $P(PSBREC,U,17)=0
112 .S $P(PSBREC,U,18)=PSBIVT ;IV TYPE
113 .S $P(PSBREC,U,21)=PSBOST
114 .S $P(PSBREC,U,22)=PSBOSTS
115 .S $P(PSBREC,U,26)=PSBSTOP
116 .S $P(PSBREC,U,27)=$$LASTG^PSBCSUTL(DFN,PSBOIT)
117 .;
118 .; Gather Dispense Drugs
119 .D NOW^%DTC
120 .S (PSBDDS,PSBSOLS,PSBADDS)="0"
121 .F Y=0:0 S Y=$O(PSBDDA(Y)) Q:'Y D
122 ..Q:$P(PSBDDA(Y),U,4)&($P(PSBDDA(Y),U,4)<%) ; Inactive
123 ..S:$P(PSBDDA(Y),U,3)="" $P(PSBDDA(Y),U,3)=1
124 ..S PSBDDS=PSBDDS_U_$P(PSBDDA(Y),U,1,3)
125 ..S $P(PSBDDS,U,1)=PSBDDS+1
126 .; On-Call One Time PRN orders
127 .S PSBQRR=0
128 .I "^O^OC^P^"[(U_PSBSCHT_U) D Q
129 ..I 'PSBDOADD S PSBTBOUT=1,^TMP("PSB",$J,"IVTAB",0)=2,^TMP("PSB",$J,"IVTAB",1)=1,^TMP("PSB",$J,"IVTAB",2)=1 Q
130 ..D ADD^PSBVDLU1(PSBREC,PSBOTXT,PSBNOW\1,PSBDDS,PSBSOLS,PSBADDS,"IVTAB")
131 ..S:$G(PSBFON)'="" ^TMP("PSB",$J,"ON IVTAB",PSBDFN,PSBFON)=1 ; Now do not have to place "following order" on VDL!
132 .;
133 .; IV's - don't worry about admin times if blank
134 .I PSBONX["V",PSBIVT'="P",PSBADST="" D Q
135 ..I 'PSBDOADD S PSBTBOUT=1,^TMP("PSB",$J,"IVTAB",0)=2,^TMP("PSB",$J,"IVTAB",1)=1,^TMP("PSB",$J,"IVTAB",2)=1 Q
136 ..D ADD^PSBVDLU1(PSBREC,PSBOTXT,PSBNOW\1_".",PSBDDS,PSBSOLS,PSBADDS,"IVTAB")
137 ..S:$G(PSBFON)'="" ^TMP("PSB",$J,"ON IVTAB",PSBDFN,PSBFON)=1 ; Now do not have to place "following order" on VDL!
138 .;
139 .; Now we deal with only continuous
140 .; process admintimes
141 .S PSBFREQ=$$GETFREQ^PSBVDLU1(DFN,PSBONX)
142 .S PSBADMIN=PSBADST
143 .; process admin times against beginning and ending date
144 .; build all orders for both days.
145 .F PSBY=1:1 Q:$P(PSBADMIN,"-",PSBY)="" D
146 ..; apply this time to the beginning window date
147 ..S PSB=+(PSBWBEG\1_"."_$P(PSBADMIN,"-",PSBY))
148 ..D:(PSB'<PSBWBEG)&(PSB'>PSBWEND) ; Make sure it is in the window
149 ...D:(PSB'<PSBSTRT)&(PSB<PSBSTOP) ; Make sure this time is active
150 ....D:$$OKAY^PSBVDLU1(PSBSTRT,$P(PSB,"."),PSBSCH,PSBON,PSBOITX,PSBFREQ) ; Okay on this date?
151 .....I 'PSBDOADD S PSBTBOUT=1,^TMP("PSB",$J,"IVTAB",0)=2,^TMP("PSB",$J,"IVTAB",1)=1,^TMP("PSB",$J,"IVTAB",2)=1 Q
152 .....D ADD^PSBVDLU1(PSBREC,PSBOTXT,PSB,PSBDDS,PSBSOLS,PSBADDS,"IVTAB")
153 .....S:$G(PSBFON)'="" ^TMP("PSB",$J,"ON IVTAB",PSBDFN,PSBFON)=1 ; Now do not have to place "following order" on VDL!
154 ..;
155 ..Q:(PSBWBEG\1)=(PSBWEND\1) ; Window only has one day rare but possible
156 ..;
157 ..; apply this time to the ending window date
158 ..S PSB=+(PSBWEND\1_"."_$P(PSBADMIN,"-",PSBY))
159 ..D:(PSB'<PSBWBEG)&(PSB'>PSBWEND) ; Make sure it is in the window
160 ...D:(PSB'<PSBSTRT)&(PSB<PSBSTOP) ; Make sure this time is active
161 ....D:$$OKAY^PSBVDLU1(PSBSTRT,$P(PSB,"."),PSBSCH,PSBON,PSBOITX,PSBFREQ) ; Okay on this date?
162 .....I 'PSBDOADD S PSBTBOUT=1,^TMP("PSB",$J,"IVTAB",0)=2,^TMP("PSB",$J,"IVTAB",1)=1,^TMP("PSB",$J,"IVTAB",2)=1 Q
163 .....D ADD^PSBVDLU1(PSBREC,PSBOTXT,PSB,PSBDDS,PSBSOLS,PSBADDS,"IVTAB")
164 .....S:$G(PSBFON)'="" ^TMP("PSB",$J,"ON IVTAB",PSBDFN,PSBFON)=1 ; Now do not have to place "following order" on VDL!
165 K ^TMP("PSB",$J,"ON IVTAB")
166 ;
167 ;add initials of verifying pharmacist/verifying nurse
168 D:PSBDOADD VNURSE^PSBVDLU1("IVTAB")
169 Q
170 ;
Note: See TracBrowser for help on using the repository browser.