source: FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBPOIV.m@ 757

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

initial load of FOIAVistA 6/30/08 version

File size: 8.2 KB
Line 
1PSBPOIV ;BIRMINGHAM/EFC-IV PARAMETER VALIDATION ;Mar 2004
2 ;;3.0;BAR CODE MED ADMIN;**2**;Mar 2004;Build 22
3 ;;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
4 ;
5 ; Reference/IA
6 ; ^DIC(42/2440
7 ; EN^PSJBCMA2/2830
8 ; VADPT/10061
9 ;
10 ;
11EN(PSBDFN,PSBORD) ;
12 ;
13 S DFN=PSBDFN,(PSBMI,PSBMW,PSBMWC,PSBMAUD)=0,(PSBMIDT,PSBMIM)="",PSBONXS=PSBORD_"^"
14 K ^TMP("PSBAR",$J) S ^TMP("PSBAR",$J,"W",0)=0
15 D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBORD)
16 ; get IV parameters for the current ward
17 S PSBCSTR="^ADDITIVE^STRENGTH^BOTTLE^SOLUTION^VOLUME^INFUSION RATE^MED ROUTE^SCHEDULE^ADMIN TIME^REMARKS^OTHER PRINT INFO^PROVIDER^START DATE/TIME^STOP DATE/TIME^PROVIDER COMMENTS"
18 D INP^VADPT S PSBWARD=$P(VAIN(4),"^"),PSBWDIV=PSBWARD D KVAR^VADPT
19 I $G(PSBWARD)'="",$D(^PSB(53.66,"B",PSBWARD)) D ; if IV paramaters defined for ward use them
20 .S PSBWARD=$O(^PSB(53.66,"B",PSBWARD,""))
21 .S:$D(^PSB(53.66,PSBWARD,1,"B",PSBIVT)) PSBIVPAR=^PSB(53.66,PSBWARD,1,$O(^PSB(53.66,PSBWARD,1,"B",PSBIVT,""),-1),0)
22 I '$D(PSBIVPAR) S PSBIVPAR=PSBIVT D ; if IV parameters not defined for ward get defaults for division
23 .D:$D(PSBWDIV) ; Get the appropriate DIV for ward and DIVISIONAL IV PARAMETERS
24 ..S PSBWDIV=$$GET1^DIQ(42,PSBWDIV_",",.015,"I")
25 ..I $G(PSBWDIV)']"" S PSBWDIV="DIV"
26 ..E S PSBWDIV=$P($$SITE^VASITE(DT,PSBWDIV),U,1),PSBWDIV="DIV.`"_PSBWDIV
27 ..F X=2:1 Q:$P(PSBCSTR,U,X)="" S PSBIVPAR=PSBIVPAR_U_$P($P($$GET^XPAR(PSBWDIV,"PSBIV "_$P(PSBCSTR,U,X),PSBIVT,"B"),U,2),"-",1)
28 ..K PSBWDIV ; Kill temp variable.
29 F PSBC1=1:1 Q:$P(PSBONXS,U,PSBC1)="" D ; process all orders
30 .D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1))
31 .K PSBPONX2 I $G(PSBPONX)]"",$G(PSBPONX)["P" S PSBPONX2=PSBPONX D ; Must compare "active" orders for changes made - look beyond "pendings"
32 ..F D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBPONX2) S PSBPONX2=PSBPONX Q:(PSBPONX2="")!(PSBPONX2'["P") ;
33 ..D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1)) ; Refresh data
34 ..S:$D(PSBPONX2) PSBPONX=PSBPONX2 K PSBPONX2
35 .Q:($L(U_PSBONXS,U_PSBPONX_U)-1)>0
36 .I $G(PSBPONX)]"" S PSBONXS=PSBONXS_PSBPONX_U
37 .K ^TMP("PSJ2",$J) S PSBMAUD=0 D EN^PSJBCMA2(PSBDFN,PSBONX,1) ; check IV parameters against activity log for this order when no "I"nvalid message
38 .I PSBMI=0 F X=1:1 Q:'$D(^TMP("PSJ2",$J,X)) S PSBCHKV=U_$P(^TMP("PSJ2",$J,X,1),U,3)_U I PSBCSTR[PSBCHKV D MSG(PSBCHKV,$P(^TMP("PSJ2",$J,X,1),U,1)) S PSBMAUD=1
39 .K ^TMP("PSJ2",$J)
40 .I PSBMI=0,$G(PSBPONX)]"" D SAVEPAR,CHKORD ; check IV parameters against previous order when no "I"nvalid message
41 .D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1)) ; restore variable for this order
42 .; okay - we have invalids and warnings through this order so process bags for this order
43 .I '$D(PSBUIDA) Q ; got errors and warning but no bags printed for this order - go to the next
44 .S PSBUID="" F S PSBUID=$O(PSBUIDA(PSBUID),-1) Q:PSBUID="" D
45 ..F PSBC2=1:1 S PSBMONX=$P(PSBONXS,U,PSBC2) Q:PSBMONX="" D ; check if bag is in 53.79
46 ...I $D(^PSB(53.79,"AUID",PSBDFN,PSBMONX,PSBUID)) D
47 ....S PSBIEN=$O(^PSB(53.79,"AUID",PSBDFN,PSBMONX,PSBUID,""))
48 ....S PSBPDT=$P(PSBLBLA(PSBUID),U,1),PSBLSTS=$P(PSBLBLA(PSBUID),3)
49 ....S $P(X,U,2)=$P(^PSB(53.79,PSBIEN,0),U,9) ; add action status
50 ....S $P(X,U,3)=$P(^PSB(53.79,PSBIEN,0),U,6) ; add action date/time
51 ....S $P(X,U,4)=$P(^PSB(53.79,PSBIEN,.1),U,1) ; add order ID was administered for
52 ..S $P(X,U,5)=PSBONX ; add order ID was printed for
53 ..S $P(X,U,6)=PSBOSTS ; add order status
54 ..S $P(X,U,7)=$P(PSBLBLA(PSBUID),U,1) ; add date/time ID was printed
55 ..S $P(X,U,8)=$P(PSBLBLA(PSBUID),U,3) ; add lable status from pharmacy
56 ..S $P(X,U,9)="" ; 9 open for later development
57 ..S $P(X,U,10)=PSBUIDA(PSBUID) ; add return from PSJ1
58 ..D BWAR
59 ..I PSBMW=1 S PSBMWS="W;" F I=1:1:^TMP("PSBAR",$J,"W",0) D S $P(X,U,1)=$P(PSBMWS,";",1,$L(PSBMWS,";")-1)
60 ...I $P(PSBLBLA(PSBUID),U,1)'>$P(^TMP("PSBAR",$J,"W",I),U,2) D
61 ....S:(PSBONX=$P(PSBONXS,U,1))&(PSBMAUD=1) PSBMWS=PSBMWS_I_";"
62 ....S:PSBONX'=$P(PSBONXS,U,1) PSBMWS=PSBMWS_I_";"
63 ..I PSBMIDT'="",$P(PSBLBLA(PSBUID),U,1)<PSBMIDT D
64 ...S:(PSBONX=$P(PSBONXS,U,1))&(PSBMAUD=1) $P(X,U,1)="I"
65 ...S:(PSBONX'=$P(PSBONXS,U,1)) $P(X,U,1)="I"
66 ..S ^TMP("PSBAR",$J,PSBUID)=X K X
67 D CLEAN^PSBVT
68 K PSBC1,PSBC2,PSBSCHV,PSBCSTR,PSBIVPAR,PSBMI,PSBMIDT,PSBMIM,PSBMONX,PSBMW,PSBSPAR,PSBUID,PSBWARD
69 K PSBADA,PSBSOLA,PSBOTMP
70 I ^TMP("PSBAR",$J,"W",0)=0 K ^TMP("PSBAR",$J,"W",0)
71 D PSJ1^PSBVT(DFN,PSBORD) ; restore variables for calling order
72 Q
73 ;
74SAVEPAR ; save parameters from current order
75 K PSBOTMP
76 I $D(PSBADA) M PSBOTMP("ADD")=PSBADA E S PSBOTMP("ADD")="" ; additive, strength, bottle
77 I $D(PSBSOLA) M PSBOTMP("SOL")=PSBSOLA E S PSBOTMP("SOL")="" ; solution, volume,
78 K PSBADA,PSBSOLA
79 S PSBOTMP("INFUSION RATE")=$G(PSBIFR),PSBOTMP("MED ROUTE")=$G(PSBMR)
80 S PSBOTMP("SCHEDULE")=$G(PSBSCH),PSBOTMP("ADMIN TIME")=$G(PSBADST)
81 S PSBOTMP("REMARKS")=$G(PSBRMRK),PSBOTMP("OTHER PRINT INFO")=$G(PSBOTXT)
82 S PSBOTMP("PROVIDER")=PSBMD,PSBOTMP("START DATE/TIME")=PSBOST
83 S PSBOTMP("STOP DATE/TIME")=PSBOSP
84 D CLEAN^PSBVT,PSJ1^PSBVT(DFN,$P(PSBONXS,U,PSBC1+1)) ; setup previous order variables
85 Q
86 ;
87CHKORD ; check previous order against current order
88 I $D(PSBADA)!($D(PSBOTMP("ADD"))) D CHKADD Q:PSBMI=1
89 I $D(PSBSOLA)!($D(PSBOTMP("SOL"))) D CHKSOL Q:PSBMI=1
90 I PSBIFR'=PSBOTMP("INFUSION RATE") D MSG("INFUSION RATE",PSBOSP) Q:PSBMI=1
91 I PSBMR'=PSBOTMP("MED ROUTE") D MSG("MED ROUTE",PSBOSP) Q:PSBMI=1
92 I PSBSCH'=PSBOTMP("SCHEDULE") D MSG("SCHEDULE",PSBOSP) Q:PSBMI=1
93 I PSBADST'=PSBOTMP("ADMIN TIME") D MSG("ADMIN TIME",PSBOSP) Q:PSBMI=1
94 I PSBRMRK'=PSBOTMP("REMARKS") D MSG("REMARKS",PSBOSP) Q:PSBMI=1
95 I PSBOTXT'=PSBOTMP("OTHER PRINT INFO") D MSG("OTHER PRINT INFO",PSBOSP) Q:PSBMI=1
96 I PSBMD'=PSBOTMP("PROVIDER") D MSG("PROVIDER",PSBOSP) Q:PSBMI=1
97 I $E(PSBOST,1,10)'=$E(PSBOTMP("START DATE/TIME"),1,10) D MSG("START DATE/TIME",PSBOSP) Q:PSBMI=1
98 I $E(PSBOSP,1,10)'=$E(PSBOTMP("STOP DATE/TIME"),1,10) D MSG("STOP DATE/TIME",PSBOSP)
99 Q
100CHKADD ;
101 N X,Y
102 I '$D(PSBADA),'$D(PSBOTMP("ADD")) Q ; no additives
103 I $O(PSBADA(""),-1)>$O(PSBOTMP("ADD",""),-1) D MSG("ADDITIVE",PSBOSP) Q ;previous order has addtives not in current order
104 I $O(PSBADA(""),-1)<$O(PSBOTMP("ADD",""),-1) D MSG("ADDITIVE",PSBOSP) Q ;previous order missing additives in current order
105 S X="" F S X=$O(PSBADA(X)) Q:X="" D Q ; check that additives, strength, and bottle are the same
106 .I PSBADA(X)=PSBOTMP("ADD",X) Q ; everything the same
107 .I $P(PSBADA(X),U,2)'=$P(PSBOTMP("ADD",X),U,2) D MSG("ADDITIVE",PSBOSP) Q
108 .I $P(PSBADA(X),U,4)'=$P(PSBOTMP("ADD",X),U,4) D MSG("STRENGTH",PSBOSP) Q
109 Q
110 ;
111CHKSOL ;
112 N X,Y
113 I '$D(PSBSOLA),'$D(PSBOTMP("SOL")) Q ; no solutions
114 I $O(PSBSOLA(""),-1)>$O(PSBOTMP("SOL",""),-1) D MSG("SOLUTION",PSBOSP) Q ;previous order has solutions not in current order
115 I $O(PSBSOLA(""),-1)<$O(PSBOTMP("SOL",""),-1) D MSG("SOLUTION",PSBOSP) Q ;previous order missing solutions in current order
116 S X="" F S X=$O(PSBSOLA(X)) Q:X="" D Q ; check that solutions volume are the same
117 .I PSBSOLA(X)=PSBOTMP("SOL",X) Q ; everything the same
118 .I $P(PSBSOLA(X),U,2)'=$P(PSBOTMP("SOL",X),U,2) D MSG("SOLUTION",PSBOSP) Q
119 .I $P(PSBSOLA(X),U,4)'=$P(PSBOTMP("SOL",X),U,4) D MSG("VOLUME",PSBOSP) Q
120 Q
121 ;
122BWAR ;
123 N X,Y,Z,PSBONX
124 S X=^TMP("PSBAR",$J,"W",0)+1
125 S Z="" F Z=1:1 S PSBONX=$P(PSBONXS,U,Z) Q:$G(PSBONX)="" D ; Display "Warning"s for changes
126 .I '$D(PSBMWAR(PSBONX)) Q
127 .S Y="" F S Y=$O(PSBMWAR(PSBONX,Y)) Q:Y'?.N1".".N D
128 ..S Z="",PSBYS="" F S Z=$O(PSBMWAR(PSBONX,Y,Z)) Q:Z="" S PSBYS=PSBYS_Z_";"
129 ..S PSBYS=$P(PSBYS,";",1,$L(PSBYS,";")-1)
130 ..S ^TMP("PSBAR",$J,"W",X)=PSBONX_U_Y_U_"2^The "_PSBYS_" was changed on",^TMP("PSBAR",$J,"W",0)=X,X=X+1
131 .K PSBMWAR(PSBONX)
132 Q
133 ;
134MSG(PSBMVAR,PSBDATE) ;
135 I PSBMI=1 Q ;already have an invalid don't need anymore
136 F Y=1:1 S PSBSPAR=$P(PSBCSTR,U,Y) I PSBSPAR=$TR(PSBMVAR,"^") D Q
137 .I $P(PSBIVPAR,U,Y)="W" D
138 ..S PSBMVAR=$TR(PSBMVAR,"^")
139 ..I PSBMW=0 S PSBMW=1
140 ..S PSBMWC=PSBMWC+1,PSBMWM="2^The "_PSBSPAR_" has been changed."
141 ..I $D(PSBMWAR(PSBONX,PSBMVAR)) S PSBOLDT=$O(PSBMWAR(PSBONX,PSBMVAR,"")) I PSBOLDT<$E(PSBDATE,1,12) K PSBMWAR(PSBONX,PSBMVAR,PSBOLDT)
142 ..S PSBMWAR(PSBONX,PSBMVAR,$E(PSBDATE,1,12))=""
143 ..S PSBMWAR(PSBONX,$E(PSBDATE,1,12),PSBMVAR)=""
144 .I $P(PSBIVPAR,U,Y)="I" S PSBMI=1,PSBMIDT=PSBDATE,PSBMIM="-1^IV invalid "_PSBSPAR_".",^TMP("PSBAR",$J,"I")=PSBONX_U_PSBMIDT_U_PSBMIM
145 Q
Note: See TracBrowser for help on using the repository browser.