source: FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBVDLVL.m@ 1119

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

initial load of FOIAVistA 6/30/08 version

File size: 8.3 KB
Line 
1PSBVDLVL ;BIRMINGHAM/EFC-BCMA VIRTUAL DUE LIST FUNCTIONS ;Mar 2004
2 ;;3.0;BAR CODE MED ADMIN;**6,3,12,11,13,32**;Mar 2004;Build 32
3 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
4 ;
5 ;
6 ; Reference/IA
7 ; $$GET^XPAR/2263
8 ;
9EN(RESULTS,DFN,PSBXOR,PSBTYPE,PSBADMIN,PSBTAB,PSBUID,PSBASTS,PSBORSTS,PSBRMV) ;
10 ;
11 ; RPC: PSB VALIDATE ORDER
12 ;
13 ; Description: Final check of order against an actual administration
14 ; date/time used immediately after scanned med has been
15 ; validated to be a good un-administered order.
16 ;
17 K PSBTST
18 N PSBFLAG
19 I PSBRMV="I" D GETOHIST^PSBRPC2(.PSBTST,DFN,PSBXOR_PSBTYPE) S I=0 F S I=$O(PSBTST(I)) Q:I="" I $P(PSBTST(I),U,5)="I" S RESULTS(0)=1,RESULTS(1)="-2^" K PSBTST Q
20 K PSBOKAY D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBXOR_PSBTYPE) S PSB=0
21 S RESULTS(0)=1,RESULTS(1)="-1^***Unable to determine administration" ; Default Flag will be overwritten by anything
22 D NOW^%DTC
23 I ((PSBOSTS="A")!(PSBOSTS="R"))&(PSBOSP<%) S PSBOSTS="E"
24 I PSBORSTS'=PSBOSTS,((PSBSCHT'="O")&(PSBOSTS'="E")) S PSB=PSB+1,RESULTS(0)=PSB,RESULTS(PSB)="-2^ORDER STATUS MISMATCH" Q
25 I ((PSBTAB="UDTAB")!(PSBTAB="PBTAB")),((PSBRMV="RM")!(PSBRMV="N")) D Q
26 .S PSB=PSB+1,RESULTS(0)=PSB,RESULTS(PSB)="0^OKAY TO REMOVE" ; patch removal does not follow rest of validte rules
27 .I PSBASTS="" Q ;status is not given - don't check for missmatch
28 .I $D(^PSB(53.79,"AORD",DFN,PSBXOR_PSBTYPE,+PSBADMIN)) S X=$O(^PSB(53.79,"AORD",DFN,PSBXOR_PSBTYPE,+PSBADMIN,"")) I $P($G(^PSB(53.79,+X,0)),U,9)'=PSBASTS S PSB=PSB+1,RESULTS(0)=PSB,RESULTS(PSB)="-2^Admin status mismatch"
29 I PSBTYPE="V",PSBSCHT'="P",((PSBUID="")!(PSBUID["WS")) S RESULTS(0)=1,RESULTS(1)="0^Okay to administer" Q:PSBTAB="IVTAB"
30 I PSBTYPE="V",PSBUID'="" D Q:PSBTAB="IVTAB" ; validate IV bags Piggybacks have additional tests
31 .S PSB=0,PSBSUID=PSBUID D EN^PSBPOIV(DFN,PSBXOR_PSBTYPE)
32 .S X="" F S X=$O(^TMP("PSBAR",$J,X)) Q:X="" D
33 ..I PSBSUID'=X Q
34 ..S PSBUIDS=^TMP("PSBAR",$J,X)
35 ..I $P(PSBUIDS,U,2)="I"!($P(PSBUIDS,U,2)="S") S PSB=PSB+1,RESULTS(0)=PSB,RESULTS(PSB)="0^Okay to administer" Q ; is infusing or stopped
36 ..I $P(PSBUIDS,U,1)="I" S Y=$P(^TMP("PSBAR",$J,"I"),U,2) D DD^%DT S PSB=PSB+1,RESULTS(0)=PSB,RESULTS(PSB)=$P(^TMP("PSBAR",$J,"I"),U,3,99)_" "_Y Q
37 ..I $P(PSBUIDS,U,1)["W" S PSBWS=$P(PSBUIDS,U,1) F PSBWM=2:1 Q:$P(PSBWS,";",PSBWM)="" D
38 ...S Y=$P(^TMP("PSBAR",$J,"W",$P(PSBWS,";",PSBWM)),U,2) D DD^%DT S PSB=PSB+1,RESULTS(0)=PSB,RESULTS(PSB)=$P(^TMP("PSBAR",$J,"W",$P(PSBWS,";",PSBWM)),U,3,99)_" "_Y
39 ..S PSB=PSB+1,RESULTS(0)=PSB,RESULTS(PSB)="0^Okay to administer"
40 .K ^TMP("PSBAR",$J)
41 ;
42 ; no IV orders
43 ;
44 D NOW^%DTC
45 I PSBOSTS="H" S PSB=PSB+1,RESULTS(0)=PSB,RESULTS(PSB)="0^Order is on Provider Hold" Q
46 I PSBSCHT'="O"&(%<($$FMADD^XLFDT(PSBOST,"","",$$GET^XPAR("ALL","PSB ADMIN BEFORE")*-1))) S PSB=PSB+1,RESULTS(0)=PSB,RESULTS(PSB)="-1^Order Not Active" Q
47 I PSBSCHT'="O"&(%>PSBOSP) S PSB=PSB+1,RESULTS(0)=PSB,RESULTS(PSB)="-1^Order Not Active" Q
48 I (PSBSCHT="C")!((PSBSCHT="P")&(PSBDOSEF="PATCH")) D
49 .S PSBOKAY="0^Okay to administer"
50 .I PSBASTS["*UNKNOWN*" S PSBOKAY="-1^This administration has *UNKNOWN* status" Q
51 .I PSBOSTS'="A",PSBOSTS'="R",PSBOSTS'="O" S PSBOKAY="-1^Order Not Active" Q
52 .I PSBNGF S PSBOKAY="-1^marked DO NOT GIVE" Q
53 .S PSBFLAG=0 I PSBRMV="M"!(PSBRMV="H")!(PSBRMV="R") S PSBFLAG=1
54 .I $D(^PSB(53.79,"AORDX",DFN,PSBXOR_PSBTYPE)) D Q:X
55 ..S X=0,PSBLADT=$O(^PSB(53.79,"AORDX",DFN,PSBXOR_PSBTYPE,""),-1),PSBLAIEN=$O(^PSB(53.79,"AORDX",DFN,PSBXOR_PSBTYPE,PSBLADT,""),-1)
56 ..I $P($G(^PSB(53.79,PSBLAIEN,0)),U,9)="G",$P($G(^PSB(53.79,PSBLAIEN,.5,1,0)),U,4)="PATCH",PSBFLAG=0 S X=1,PSBOKAY="-1^Previous patch has not been removed" Q
57 .I $D(^PSB(53.79,"AORD",DFN,PSBXOR_PSBTYPE,+PSBADMIN)) D Q:+PSBOKAY<0
58 ..S X=$O(^PSB(53.79,"AORD",DFN,PSBXOR_PSBTYPE,+PSBADMIN,""))
59 ..L +^PSB(53.79,+X):1
60 ..I L -^PSB(53.79,+X)
61 ..E S PSBOKAY="-1^The "_$$GET1^DIQ(53.79,+X_",",.13)_" administration is being edited by another" Q
62 ..I $G(PSBASTS)]"" D Q:+PSBOKAY<0
63 ...I $P($G(^PSB(53.79,+X,0)),U,9)="" Q
64 ...I $P($G(^PSB(53.79,+X,0)),U,9)'=PSBASTS S PSBOKAY="-2^Admin status mismatch" Q
65 .; Minutes before
66 .S PSBWIN1=$$GET^XPAR("DIV","PSB ADMIN BEFORE")*-1
67 .; Minutes After
68 .S PSBWIN2=$$GET^XPAR("DIV","PSB ADMIN AFTER")
69 .D NOW^%DTC S PSBMIN=$$DIFF^PSBUTL(PSBADMIN,%)
70 .; PENDING A PC SOLUTION!
71 .I PSBMIN<PSBWIN1 S PSBOKAY="1^Admin is "_(PSBMIN*-1)_" minutes before the scheduled administration time" Q
72 .I PSBMIN>PSBWIN2 S PSBOKAY="1^Admin is "_(PSBMIN)_" minutes after the scheduled administration time" Q
73 .S PSBOKAY="0^Okay to administer"
74 ; Validate a PRN Order
75 D:(PSBSCHT="P")
76 .I PSBOSTS'="A",PSBOSTS'="R",PSBOSTS'="O" S PSBOKAY="-1^Order Not Active" Q
77 .I PSBNGF S PSBOKAY="-1^marked DO NOT GIVE" Q
78 .I (+($G(PSBOKAY))<0)&(PSBDOSEF="PATCH") Q ;A Patch may have to be removed.
79 .S PSBOKAY="1^"
80 .; Get Last Four Givens
81 .S PSBDT=""
82 .F S PSBDT=$O(^PSB(53.79,"AOIP",DFN,+PSBOIT,PSBDT),-1) Q:PSBDT="" D
83 ..S PSBDA=""
84 ..F S PSBDA=$O(^PSB(53.79,"AOIP",DFN,+PSBOIT,PSBDT,PSBDA),-1) Q:'PSBDA D
85 ...S (PSBCNT1,PSBCNT2,PSBCNT3)=0
86 ...S PSBLADT=$$GET1^DIQ(53.79,PSBDA_",",.06,"I")
87 ...S PSBSTUS=$$GET1^DIQ(53.79,PSBDA_",",.09)
88 ...S:PSBSTUS="" PSBSTUS="U"
89 ...S PSBSCH=$$GET1^DIQ(53.79,PSBDA_",",.12)
90 ...S PSBRSN=$$GET1^DIQ(53.79,PSBDA_",",.21)
91 ...S PSBINJ=$$GET1^DIQ(53.79,PSBDA_",",.16)
92 ...Q:$P(^PSB(53.79,PSBDA,0),U,9)="N"
93 ...F PSBZ=.5,.6,.7 F PSBY=0:0 S PSBY=$O(^PSB(53.79,PSBDA,PSBZ,PSBY)) Q:'PSBY D
94 ....Q:'$D(^PSB(53.79,PSBDA,PSBZ,PSBY))
95 ....S PSBDD=$S(PSBZ=.5:53.795,PSBZ=.6:53.796,1:53.797)
96 ....S PSBUNIT=$$GET1^DIQ(PSBDD,PSBY_","_PSBDA_",",.03)
97 ....S PSBUNFR=$$GET1^DIQ(PSBDD,PSBY_","_PSBDA_",",.04)
98 ....I PSBZ=.5 S PSBCNT1=PSBCNT1+1
99 ....I PSBZ=.6 S PSBCNT2=PSBCNT2+1
100 ....I PSBZ=.7 S PSBCNT3=PSBCNT3+1
101 ...;Units given or free text not to display for multiple dispense drugs or additives and solution
102 ...I (PSBCNT1>1)!(PSBCNT2>0)!(PSBCNT3>0) S (PSBUNIT,PSBUNFR)=""
103 ...S X=PSBLADT_U
104 ...S X=X_PSBSTUS_U_PSBSCH_U_$G(PSBRSN)_U_$G(PSBINJ)_U_$G(PSBUNIT)_U_$G(PSBUNFR)
105 ...S PSBOKAY($O(PSBOKAY(""),-1)+1)=3_U_X
106 ...S:$D(PSBOKAY(4)) PSBDT=0
107 .S X1=$$LASTG^PSBCSUTL(DFN,+PSBOIT) I X1>0 S PSBOKAY($O(PSBOKAY(""),-1)+1)=4_U_X1
108 ; Validate a One-Time Order
109 D:PSBSCHT="O"
110 .S (PSBGVN,X,Y)=""
111 .F S X=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X),-1) Q:'X F S Y=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X,Y),-1) Q:'Y I $P(^PSB(53.79,Y,.1),U)=PSBONX,"G"[$P(^PSB(53.79,Y,0),U,9) S PSBGVN=1,(X,Y)=0
112 .I PSBGVN S PSBOKAY="-1^Dose Already on medication Log" Q
113 .; One Time are automatically expired so we don't check STATUS here
114 .I PSBNGF S PSBOKAY="-1^marked DO NOT GIVE" Q
115 .S PSBOKAY="0^Okay to administer"
116 ; Validate an On Call Order
117 D:PSBSCHT="OC"
118 .S PSBOKAY="0^Okay to administer"
119 .S (PSBGVN,X,Y)=""
120 .F S X=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X),-1) Q:'X F S Y=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,X,Y),-1) Q:'Y I $P(^PSB(53.79,Y,.1),U)=PSBONX,"G"[$P(^PSB(53.79,Y,0),U,9) S PSBGVN=1,(X,Y)=0
121 .I PSBGVN&('$$GET^XPAR("DIV","PSB ADMIN MULTIPLE ONCALL")) S PSBOKAY="-1^Dose Already on medication Log" Q
122 .I PSBOSTS'="A",PSBOSTS'="R",PSBOSTS'="O" S PSBOKAY="-1^Order Not Active" Q
123 .I PSBNGF S PSBOKAY="-1^marked DO NOT GIVE" Q
124 .I PSBGVN&($$GET^XPAR("DIV","PSB ADMIN MULTIPLE ONCALL"))&(PSBDOSEF="PATCH") S PSBOKAY="-1^Previous patch has not been removed" Q
125 .S PSBOKAY="0^Okay to administer"
126 ;
127 D:+PSBOKAY'<0
128 .N PSBDIFF,Y
129 .D:(PSBSCHT="C")!(PSBSCHT="OC"&('$G(PSBGVN)))
130 ..; On-call or cont and not on the log.
131 ..S Y=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,""),-1)
132 ..;Check for the status of the medication and insert status in the text
133 ..I Y]"" S X=$O(^PSB(53.79,"AOIP",DFN,+PSBOIT,Y,""),-1),PSBSTUS=$P(^PSB(53.79,X,0),U,9)
134 ..S:Y']"" PSBSTUS=""
135 ..I PSBSTUS="N" D Q:$G(PSBQUIT)
136 ...S X=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,Y,X),-1)
137 ...D:X']""
138 ....S Y=$O(^PSB(53.79,"AOIP",DFN,PSBOIT,Y),-1) I Y']"" S PSBQUIT=1 Q
139 ....S X=$O(^PSB(53.79,"AOIP",DFN,+PSBOIT,Y,""),-1),PSBSTUS=$P(^PSB(53.79,X,0),U,9)
140 ..S PSBDIFF=$$FMDIFF^XLFDT($$NOW^XLFDT(),Y,2)
141 ..Q:PSBDIFF>7200 ; Greater than 2 hours
142 ..I (PSBSTUS="G")!(PSBSTUS="H")!(PSBSTUS="R")!(PSBSTUS="RM") D
143 ...S PSBSTUS=$$GET1^DIQ(53.79,X_",",.09)
144 ...I PSBSTUS'="" D
145 ....S Y="1^*** NOTICE, "_PSBOITX_" was "_PSBSTUS_" "_(PSBDIFF\60)_" minutes ago."
146 ....I +PSBOKAY=1 S PSBOKAY(1)=Y
147 ....E S PSBOKAY=Y
148 ;
149 S PSB=PSB+1,RESULTS(0)=PSB,RESULTS(PSB)=PSBOKAY
150 F X=1:1 Q:'$D(PSBOKAY(X)) S PSB=PSB+1,RESULTS(0)=PSB,RESULTS(PSB)=PSBOKAY(X)
151 Q
152 ;
Note: See TracBrowser for help on using the repository browser.