source: FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBVDLU3.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 7.5 KB
Line 
1PSBVDLU3 ;BIRMINGHAM/TEJ-BCMA VDL UTILITIES 3 ;Mar 2004
2 ;;3.0;BAR CODE MED ADMIN;**13,38**;Mar 2004;Build 8
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;This routine file has been created to serve as a container
6 ;for Extrinsic Variables/Functions
7 ;
8 ; Reference/IA
9 ; EN^PSJBCMA/2828
10 ;
11IVPTAB(PSBORTYP,PSBIVTYP,PSBINTSY,PSBCHMTY,PSBPUSH) ;
12 ;
13 ; This function will return
14 ; the value 1 (one) if the
15 ; specified order input will cause
16 ; the order to display on the "IVP/IVPB"
17 ; tab of the VDL BCMA Virtual Due List (VDL)
18 ; else return the value 0 (zero).
19 ;
20 ; Input Parameters:
21 ;
22 ; PSBORTYP - Order type (e.g. "U","V")
23 ; PSBIVTYP - IV Type (e.g. "P","S","C")
24 ; PSBINTSY - Intermittent Syringe value
25 ; PSBCHMTY - Chemo type (e.g. "P","S")
26 ; PSBPUSH - IV PUSH Flag (e.g. 0 or 1, 1=IV PUSH)
27 ;
28 ; Output:
29 ; 1 - order will display on the "IVP/IVPB" Tab of BCMA VDL
30 ; 0 - order will NOT display on the "IVP/IVPB" Tab of BCMA VDL
31 ; -1 - error processed
32 ;
33 Q:'$D(PSBORTYP) "-1^Missing Parameter"
34 I PSBORTYP="U"&(PSBPUSH) Q 1
35 I '(PSBORTYP="V") Q 0
36 I $G(PSBIVTYP)="P" Q 1
37 I $G(PSBIVTYP)="S",$G(PSBINTSY)=1 Q 1
38 I $G(PSBIVTYP)="C",$G(PSBCHMTY)="P" Q 1
39 I $G(PSBIVTYP)="C",$G(PSBCHMTY)="S",$G(PSBINTSY)=1 Q 1
40 Q 0
41 ;
42SHOVDL(DFN,BDATE,OTDATE,PSBTAB) ;
43 ;
44 ; This function will find orders such as discontinued or expired infusing IV bags
45 ; or discontinued or expired "given" patches. Recognizing these types of orders
46 ; will allow these orders to be displayed on the VDL and permits the user to take
47 ; action on them. This routine determines if such orders exist for patient,
48 ; time, and "BCMA VDL tab." This routine is an "extention" to the API EN^PSJBCMA.
49 ;
50 ; INPUT Parameters:
51 ; DFN (req) Patient Internal File Number.
52 ; BDATE (opt) Start searching for "order stop" after this date.
53 ; OTDATE (opt) Include One-Time orders from this date.
54 ; PSBTAB (opt) "UDTAB" or "IVTAB" - expedites process if specific tab
55 ; is given.
56 ;
57 ; OUTPUT Values
58 ; 0 absolutely no orders to display on VDL
59 ; 1 displayable orders have been located.
60 ;
61 ;
62 D EN^PSJBCMA(DFN,$G(BDATE),$G(OTDATE))
63 ; any active Patch orders to show on VDL?
64 S PSBFLG=0
65 I $G(^TMP("PSJ",$J,1,0))=-1 D
66 .;
67 .; Check the indexice for given patches or infusing IVs
68 .;
69 .; Check APATCH
70 .D:($G(PSBTAB)="UDTAB")!($G(PSBTAB)="") Q:PSBFLG
71 ..S PSBGNODE="^PSB(53.79,"_"""APATCH"""_","_DFN_")" Q:'$D(PSBGNODE)
72 ..F S PSBGNODE=$Q(@PSBGNODE) Q:PSBGNODE="" Q:$QS(PSBGNODE,3)'=DFN Q:PSBFLG S PSBIEN=$QS(PSBGNODE,5),PSBFLG=$S($P(^PSB(53.79,PSBIEN,0),U,9)="G":1,1:0)
73 .;
74 .; Check AUID
75 .;
76 .D:(($G(PSBTAB)="IVTAB")!($G(PSBTAB)=""))&('PSBFLG) Q:PSBFLG
77 ..S PSBGNODE="^PSB(53.79,"_"""AUID"""_","_DFN_")" Q:'$D(PSBGNODE)
78 ..F S PSBGNODE=$Q(@PSBGNODE) Q:PSBGNODE="" Q:$QS(PSBGNODE,3)'=DFN Q:PSBFLG S PSBIEN=$QS(PSBGNODE,6),PSBFLG=$S($P(^PSB(53.79,PSBIEN,0),U,9)="I":1,1:0)
79 .;
80 .; NOTE: Infusing bags will not display if DCed more than 3 days ago!
81 .;
82 S:$G(^TMP("PSJ",$J,1,0))'=-1 PSBFLG=1
83 ;
84 Q PSBFLG
85 ;
86FNDACTV(RESULTS,PARAMS) ; Utility to check and order for the latest " ? (parameter #3) " order activities per patient (parameter #1)
87 ; #parameter= # "^"piece
88 ; #1 DFN - Patient's IEN e.g. 1234 (required)
89 ; #2 Order Number_Order Type e.g. "1V" "" = all orders
90 ; #3 Search for Activity e.g. "H" "" = *unknown* activity
91 ; #4 Search "back"time(hours) e.g. 12 "" = search back 3 admins
92 ; NOTE: ="FREQ" This Function will use order's frequency.
93 ; 1. If the order is a PRN, On Call or One-Time
94 ; the look back a default of 72 hours.
95 ; 2. if the order is a Continuous order key off
96 ; of the frequency as follows.
97 ; a.) if the frequency is <24 hours use the
98 ; default of 72 hours.
99 ; b.) if the frequency is >= 24 hour, look back
100 ; 3.5 times the frequency
101 ; NOTE: ["X#" This Function will search back # of admins.
102 ;
103 ; Example call: D FNDACTV^PSBVDLU3(.results,"1234^1U^H^12")
104 ;
105 ;
106 N PSBNOW,PSBDFN,PSBON,PSBCNT,PSBACT,PSBTMFRM,PSBX,PSBSET,PSBFRQ
107 K RESULTS
108 S PSBDFN=$P(PARAMS,U),PSBON=$P(PARAMS,U,2),PSBACT=$P(PARAMS,U,3),PSBTMFRM=$P(PARAMS,U,4)
109 S RESULTS(0)=1
110 I $G(PSBDFN)']"" S RESULTS(0)=1,RESULTS(1)="-1^ERROR - MISSING PARAMETER (DFN REQ.)" Q
111 I $G(PSBTMFRM)="" S PSBX=3
112 I $G(PSBTMFRM)["X" S PSBX=+($P(PSBTMFRM,"X",2)),PSBTMFRM=""
113 I $G(PSBTMFRM)]"",$G(PSBTMFRM)'["FREQ" D NOW^%DTC S PSBNOW=% S PSBTMFRM=$$FMADD^XLFDT(PSBNOW,"",-1*PSBTMFRM),PSBSET=1 S RESULTS(1)="0^ None found after "_PSBTMFRM
114 I $G(PSBX)="" S PSBX=9999999
115 D:$G(PSBON)'=""
116 .K ^TMP("PSJ",$J) D EN^PSJBCMA1(PSBDFN,PSBON)
117 .;Maintain Time Frame and other order information
118 .I $G(PSBTMFRM)["FREQ" D
119 ..S PSBFRQ=+$P(^TMP("PSJ",$J,4),"^",11) I PSBFRQ=0 S PSBFRQ=1440
120 ..I "P^OC^O^"[($P(^TMP("PSJ",$J,4),"^")_"^") S PSBTMFRM=72 Q
121 ..I (PSBFRQ/60)<24 S PSBTMFRM=72 Q
122 ..I (PSBFRQ/60)'<24 S PSBTMFRM=(PSBFRQ/60)*3.5
123 .I '$G(PSBSET) D NOW^%DTC S PSBNOW=% S PSBTMFRM=$$FMADD^XLFDT(PSBNOW,"",-1*PSBTMFRM) S RESULTS(1)="0^ None found after "_PSBTMFRM
124 .S I="",X=0 F S I=$O(^PSB(53.79,"AORDX",PSBDFN,PSBON,I),-1) Q:(I="")!(I<$S(PSBTMFRM]"":PSBTMFRM,1:-1)) D Q:X
125 ..S Z=0,J="",PSBCNT=0 F S J=$O(^PSB(53.79,"AORDX",PSBDFN,PSBON,I,J),-1) Q:(J="") S Z=Z+1 Q:Z>PSBX D Q:X
126 ...L +^PSB(53.79,J):1
127 ...I L -^PSB(53.79,J)
128 ...E Q
129 ...I ($P(^PSB(53.79,J,0),U,9)=PSBACT) S X=1 D
130 ....S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=$$GET1^DIQ(53.79,J_",",.02)
131 ....S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=$P(^TMP("PSJ",$J,2),U,2)_"^"_($$GET1^DIQ(53.79,J_",",.11))
132 ....S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=$$GET1^DIQ(53.79,J_",",.06,"I")
133 ....S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=$$GET1^DIQ(53.79,J_",",.13,"I")
134 D:$G(PSBON)=""
135 .S Z="",X=0 F S Z=$O(^PSB(53.79,"AORDX",PSBDFN,Z),-1) Q:(Z="") S PSBON=Z D Q:X
136 ..;Maintain Time Frame and other order information
137 ..K ^TMP("PSJ",$J) D EN^PSJBCMA1(PSBDFN,PSBON)
138 ..I $G(PSBTMFRM)["FREQ" D
139 ...S PSBFRQ=+$P(^TMP("PSJ",$J,4),"^",11) I PSBFRQ=0 S PSBFRQ=1440
140 ...I "P^OC^O^"[($P(^TMP("PSJ",$J,4),"^")_"^") S PSBTMFRM=72 Q
141 ...I (PSBFRQ/60)<24 S PSBTMFRM=72 Q
142 ...I (PSBFRQ/60)'<24 S PSBTMFRM=(PSBFRQ/60)*3.5
143 ..I '$G(PSBSET) D NOW^%DTC S PSBNOW=% S PSBTMFRM=$$FMADD^XLFDT(PSBNOW,"",-1*PSBTMFRM) S RESULTS(1)="0^ None found after "_PSBTMFRM
144 ..S I="" F S I=$O(^PSB(53.79,"AORDX",PSBDFN,PSBON,I),-1) Q:(I="")!(I<$S(PSBTMFRM]"":PSBTMFRM,1:-1)) D Q:X
145 ...S ZZ=0,J="",PSBCNT=0 F S J=$O(^PSB(53.79,"AORDX",PSBDFN,PSBON,I,J),-1) Q:(J="") S ZZ=ZZ+1 Q:ZZ>PSBX D Q:X
146 ....L +^PSB(53.79,J):1
147 ....I L -^PSB(53.79,J)
148 ....E Q
149 ....I ($P(^PSB(53.79,J,0),U,9)=PSBACT) S X=1 D
150 .....S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=$$GET1^DIQ(53.79,J_",",.02)
151 .....S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=$P(^TMP("PSJ",$J,2),U,2)_"^"_($$GET1^DIQ(53.79,J_",",.11))
152 .....S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=$$GET1^DIQ(53.79,J_",",.06,"I")
153 .....S PSBCNT=PSBCNT+1,RESULTS(PSBCNT)=$$GET1^DIQ(53.79,J_",",.13,"I")
154 I $G(PSBCNT)>0 S RESULTS(0)=PSBCNT
155 K ^TMP("PSJ",$J)
156 Q
157 ;
Note: See TracBrowser for help on using the repository browser.