- Timestamp:
- Dec 4, 2009, 12:11:15 AM (16 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBPOIV.m
r613 r623 1 PSBPOIV 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 7 ; EN^PSJBCMA2/2830 8 ; VADPT/10061 9 ; 10 11 EN(PSBDFN,PSBORD) 12 13 14 15 16 17 18 D INP^VADPT S PSBWARD=$P(VAIN(4),"^"),PSBWDIV=PSBWARD D KVAR^VADPT 19 20 21 22 23 24 ..S PSBWDIV=$$GET1^DIQ(42,PSBWDIV_",",.015,"I")25 26 ..E S PSBWDIV=$P($$SITE^VASITE(DT,PSBWDIV),U,1),PSBWDIV="DIV.`"_PSBWDIV27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 SAVEPAR 75 76 77 78 79 80 81 82 83 84 85 86 87 CHKORD 88 89 90 91 92 93 94 95 96 97 98 99 100 CHKADD 101 102 103 104 105 106 107 108 109 110 111 CHKSOL 112 113 114 115 116 117 118 119 120 121 122 BWAR 123 124 125 126 127 128 129 130 131 132 133 134 MSG(PSBMVAR,PSBDATE) 135 136 137 138 139 140 141 142 143 144 145 1 PSBPOIV ;BIRMINGHAM/EFC-IV PARAMETER VALIDATION ;Mar 2004 2 ;;3.0;BAR CODE MED ADMIN;;Mar 2004 3 ; 4 ; Reference/IA 5 ; ^DIC(42/1377 6 ; ^DIC(42/2440 7 ; EN^PSJCBMA1/2829 8 ; EN^PSJBCMA2/2830 9 ; DIQ(2/10035 10 ; 11 EN(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 S PSBWARD=$$GET1^DIQ(2,PSBDFN_",",.1),PSBWARD=$$FIND1^DIC(42,"","X",PSBWARD),PSBWDIV=PSBWARD 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"),PSBWDIV=$P($$SITE^VASITE(DT,PSBWDIV),U,1) 25 ..I $G(PSBWDIV)']"" S PSBWDIV="DIV" 26 ..E S 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 ; 74 SAVEPAR ; 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 ; 87 CHKORD ; 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 100 CHKADD ; 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 ; 111 CHKSOL ; 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 ; 122 BWAR ; 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 ; 134 MSG(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 TracChangeset
for help on using the changeset viewer.
