source: FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWU.m@ 675

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

initial load of FOIAVistA 6/30/08 version
File size: 9.4 KB
Line 
1ORWU ; SLC/KCM - General Utilites for Windows Calls; 2/28/01 [1/15/04 11:43am]
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,132,148,149,187,195,215**;Dec 17, 1997
3 ;
4DT(Y,X,%DT) ; Internal Fileman Date/Time
5 ; change the '00:00' that could be passed so Fileman doesn't reject
6 I $L($P(X,"@",2)),("00000000"[$TR($P(X,"@",2),":","")) S $P(X,"@",2)="00:00:01"
7 S %DT=$G(%DT,"TS") D ^%DT K %DT
8 Q
9VALDT(Y,X,%DT) ; Validate date/time
10 S:'$D(%DT) %DT="TX" D ^%DT
11 Q
12USERINFO(REC) ; Relevant info for current user
13 ; return DUZ^NAME^USRCLS^CANSIGN^ISPROVIDER^ORDERROLE^NOORDER^DTIME^
14 ; COUNTDOWN^ENABLEVERIFY^NOTIFYAPPS^MSGHANG^DOMAIN^SERVICE^
15 ; AUTOSAVE^INITTAB^LASTTAB^WEBACCESS^ALLOWHOLD^ISRPL^RPLLIST^
16 ; CORTABS^RPTTAB^STANUM^GECSTATUS^PRODACCT
17 N X,ORRPL,ORRPL1,ORRPL2,ORTAB,CORTABS,RPTTAB,ORDT,OREFF,OREXP,ORDATEOK
18 S REC=DUZ_U_$P(^VA(200,DUZ,0),U)
19 S $P(REC,U,3)=$S($D(^XUSEC("ORES",DUZ)):3,$D(^XUSEC("ORELSE",DUZ)):2,$D(^XUSEC("OREMAS",DUZ)):1,1:0)
20 S $P(REC,U,4)=$D(^XUSEC("ORES",DUZ))&$D(^XUSEC("PROVIDER",DUZ))
21 S $P(REC,U,5)=$D(^XUSEC("PROVIDER",DUZ))
22 S $P(REC,U,6)=$$ORDROLE
23 S $P(REC,U,7)=$$GET^XPAR("USR^SYS^PKG","ORWOR DISABLE ORDERING",1,"I")
24 S $P(REC,U,8)=$$GET^XPAR("USR^SYS","ORWOR TIMEOUT CHART",1,"I")
25 I '$P(REC,U,8),$G(DTIME) S $P(REC,U,8)=DTIME
26 S $P(REC,U,9)=$$GET^XPAR("USR^SYS^PKG","ORWOR TIMEOUT COUNTDOWN",1,"I")
27 S X=$$GET^XPAR("USR^SYS^PKG","ORWOR ENABLE VERIFY",1,"I")
28 S $P(REC,U,10)=$S(X=1:1,X=2:0,1:'$P(REC,U,7))
29 S $P(REC,U,11)=$$GET^XPAR("USR^SYS^PKG","ORWOR BROADCAST MESSAGES",1,"I")
30 S $P(REC,U,12)=$$GET^XPAR("USR^SYS^PKG","ORWOR AUTO CLOSE PT MSG",1,"I")
31 S $P(REC,U,13)=$$KSP^XUPARAM("WHERE") ; domain
32 S $P(REC,U,14)=+$G(^VA(200,DUZ,5)) ; service/section
33 S $P(REC,U,15)=$$GET^XPAR("USR^SYS^PKG","ORWOR AUTOSAVE NOTE",1,"I")
34 S $P(REC,U,16)=$$GET^XPAR("USR^DIV^SYS^PKG","ORCH INITIAL TAB",1,"I")
35 S $P(REC,U,17)=$$GET^XPAR("USR^DIV^SYS^PKG","ORCH USE LAST TAB",1,"I")
36 S $P(REC,U,18)=$$GET^XPAR("USR^DIV^SYS^PKG","ORWOR DISABLE WEB ACCESS",1,"I")
37 S $P(REC,U,19)=$$GET^XPAR("SYS^PKG","ORWOR DISABLE HOLD ORDERS",1,"I")
38 ; 2 pieces added by PKS on 11/5/2001 for "Reports Only:"
39 ; IA# 10060 allows read access to ^VA(200 file.
40 S ORRPL=$G(^VA(200,DUZ,101)) ; RPL node.
41 S ORRPL1=$P(ORRPL,U)
42 S $P(REC,U,20)=ORRPL1 ; ISRPL piece.
43 S ORRPL2=$P(ORRPL,U,2)
44 S $P(REC,U,21)=ORRPL2 ; RPLLIST piece.
45 ;
46 ; Additional pieces for CPRS tabs access:
47 ; IA# 10060 allows read access to ^VA(200.01013 multiple.
48 S ORDT=DT ; Today.
49 S (CORTABS,RPTTAB)=0
50 S ORRPL=0
51 F S ORRPL=$O(^VA(200,DUZ,"ORD",ORRPL)) Q:ORRPL<1 D
52 .S ORTAB=$G(^VA(200,DUZ,"ORD",ORRPL,0))
53 .I ORTAB="" Q
54 .S OREFF=$P(ORTAB,U,2)
55 .S OREXP=$P(ORTAB,U,3)
56 .S ORTAB=$P(ORTAB,U)
57 .I ORTAB="" Q
58 .S ORTAB=$G(^ORD(101.13,ORTAB,0))
59 .I ORTAB="" Q
60 .S ORTAB=$P(ORTAB,U)
61 .I ORTAB="" Q
62 .S ORTAB=$$UP^XLFSTR(ORTAB)
63 .S ORDATEOK=1 ; Default.
64 .I ((OREFF="")!(OREFF>ORDT)) S ORDATEOK=0 ; Eff. date NG.
65 .I ORDATEOK D
66 ..I OREXP="" Q ; No exp. date.
67 ..I (OREXP<ORDT) S ORDATEOK=0 ; Exp. date NG.
68 ..I (OREXP=ORDT) S ORDATEOK=0 ; Exp. date NG.
69 .;
70 .; Set TRUE if OK:
71 .I ((ORTAB="COR")&(ORDATEOK)) S CORTABS=1
72 .I ((ORTAB="RPT")&(ORDATEOK)) S RPTTAB=1
73 ;
74 ; When done, set all valid tabs for access:
75 S $P(REC,U,22)=CORTABS ; "Core" tabs.
76 S $P(REC,U,23)=RPTTAB ; "Reports" tab.
77 ;
78 S $P(REC,U,24)=$P($$SITE^VASITE,U,3)
79 S $P(REC,U,25)=$$GET^XPAR("USR^TEA","PXRM GEC STATUS CHECK",1,"I")
80 S $P(REC,U,26)=$$PROD^XUPROD
81 Q
82 ;
83HASKEY(VAL,KEY) ; returns TRUE if the user possesses the security key
84 S VAL=''$D(^XUSEC(KEY,DUZ))
85 Q
86HASOPTN(VAL,OPTION) ; returns TRUE if the user has access to a menu option
87 S VAL=+$$ACCESS^XQCHK(DUZ,OPTION)
88 I VAL'>0 S VAL=0
89 E S VAL=1
90 Q
91NPHASKEY(VAL,NP,KEY) ; returns TRUE if the person has the security key
92 S VAL=''$D(^XUSEC(KEY,NP))
93 Q
94ORDROLE() ; returns the role a person takes in ordering
95 ; VAL: 0=nokey, 1=clerk, 2=nurse, 3=physician, 4=student, 5=bad keys
96 ;I '$G(ORWCLVER) Q 0 ; version of client is to old for ordering
97 I ($D(^XUSEC("OREMAS",DUZ))+$D(^XUSEC("ORELSE",DUZ))+$D(^XUSEC("ORES",DUZ)))>1 Q 5
98 I $D(^XUSEC("OREMAS",DUZ)) Q 1 ; clerk
99 I $D(^XUSEC("ORELSE",DUZ)) Q 2 ; nurse
100 I $D(^XUSEC("ORES",DUZ)),$D(^XUSEC("PROVIDER",DUZ)) Q 3 ; doctor
101 I $D(^XUSEC("PROVIDER",DUZ)) Q 4 ; student
102 Q 0
103VALIDSIG(ESOK,X) ; returns TRUE if valid electronic signature
104 S X=$$DECRYP^XUSRB1(X),ESOK=0 ; network encrypted
105 D HASH^XUSHSHP
106 I X=$P($G(^VA(200,+DUZ,20)),U,4) S ESOK=1
107 Q
108TOOLMENU(ORLST) ; returns a list of items for the Tools menu
109 N ANENT
110 S ANENT="ALL^"_$S($G(^VA(200,DUZ,5)):"^SRV.`"_+$G(^(5)),1:"")
111 D GETLST^XPAR(.ORLST,ANENT,"ORWT TOOLS MENU","N")
112 Q
113ACTLOC(LOC) ; Function: returns TRUE if active hospital location
114 ; IA# 10040.
115 N D0,X I +$G(^SC(LOC,"OOS")) Q 0 ; screen out OOS entry
116 S D0=+$G(^SC(LOC,42)) I D0 D WIN^DGPMDDCF Q 'X ; chk out of svc wards
117 S X=$G(^SC(LOC,"I")) I +X=0 Q 1 ; no inactivate date
118 I DT>$P(X,U)&($P(X,U,2)=""!(DT<$P(X,U,2))) Q 0 ; chk reactivate date
119 Q 1 ; must still be active
120 ;
121CLINLOC(Y,FROM,DIR) ; Return a set of clinics from HOSPITAL LOCATION
122 ; .Y=returned list, FROM=text to $O from, DIR=$O direction,
123 N I,IEN,CNT S I=0,CNT=44
124 F Q:I'<CNT S FROM=$O(^SC("B",FROM),DIR) Q:FROM="" D ; IA# 10040.
125 . S IEN="" F S IEN=$O(^SC("B",FROM,IEN),DIR) Q:'IEN D
126 . . I ($P($G(^SC(IEN,0)),U,3)'="C")!('$$ACTLOC(IEN)) Q
127 . . S I=I+1,Y(I)=IEN_"^"_FROM
128 Q
129INPLOC(Y,FROM,DIR) ;Return a set of wards from HOSPITAL LOCATION
130 ; .Y=returned list, FROM=text to $O from, DIR=$O direction,
131 N I,IEN,CNT S I=0,CNT=44
132 F Q:I'<CNT S FROM=$O(^SC("B",FROM),DIR) Q:FROM="" D ; IA# 10040.
133 . S IEN="" F S IEN=$O(^SC("B",FROM,IEN),DIR) Q:'IEN D
134 . . I ($P($G(^SC(IEN,0)),U,3)'="W") Q
135 . . I '$$ACTLOC(IEN) Q
136 . . S I=I+1,Y(I)=IEN_"^"_FROM
137 Q
138HOSPLOC(Y,FROM,DIR) ; Return a set of locations from HOSPITAL LOCATION
139 ; .Y=returned list, FROM=text to $O from, DIR=$O direction,
140 N I,IEN,CNT S I=0,CNT=44
141 F Q:I'<CNT S FROM=$O(^SC("B",FROM),DIR) Q:FROM="" D ; IA# 10040.
142 . S IEN="" F S IEN=$O(^SC("B",FROM,IEN),DIR) Q:'IEN D
143 . . Q:("CW"'[$P($G(^SC(IEN,0)),U,3)!('$$ACTLOC(IEN)))
144 . . S I=I+1,Y(I)=IEN_"^"_FROM
145 Q
146NEWPERS(ORY,ORFROM,ORDIR,ORKEY,ORDATE,ORVIZ,ORALL) ; Return a set of names from the NEW PERSON file.
147 ; SLC/PKS: Code moved to ORWU1 on 12/3/2002.
148 D NP1^ORWU1
149 Q
150GBLREF(VAL,FN) ; return global reference for file number
151 S VAL="" Q:'FN
152 S VAL=$$ROOT^DILFD(+FN)
153 ; I $E($RE(VAL))="," S VAL=$E(VAL,1,$L(VAL)-1)_")"
154 ; I $E($RE(VAL))="(" S VAL=$P(VAL,"(",1)
155 Q
156GENERIC(Y,FROM,DIR,REF) ; Return a set of entries from xref in REF
157 ; .Y=returned list, FROM=text to $O from, DIR=$O direction,
158 N I,IEN,CNT S I=0,CNT=44
159 F Q:I'<CNT S FROM=$O(@REF@(FROM),DIR) Q:FROM="" D
160 . S IEN="" F S IEN=$O(@REF@(FROM,IEN),DIR) Q:'IEN D
161 . . S I=I+1,Y(I)=IEN_"^"_FROM
162 Q
163EXTNAME(VAL,IEN,FN) ; return external form of pointer
164 ; IEN=internal number, FN=file number
165 N REF S REF=$G(^DIC(FN,0,"GL")),VAL=""
166 I $L(REF),+IEN S VAL=$P($G(@(REF_IEN_",0)")),U)
167 Q
168PARAM(VAL,APARAM) ; return a parameter value for a user
169 ; call assumes current user, default entities, single instance
170 S VAL=$$GET^XPAR("ALL",APARAM,1,"I")
171 Q
172DEVICE(Y,FROM,DIR) ; Return a subset of entries from the Device file
173 ; .LST(n)=IEN;Name^DisplayName^Location^RMar^PLen
174 ; FROM=text to $O from, DIR=$O direction
175 N I,IEN,CNT,SHOW,X S I=0,CNT=20
176 I FROM["<" S FROM=$RE($P($RE(FROM),"< ",2))
177 F Q:I'<CNT S FROM=$O(^%ZIS(1,"B",FROM),DIR) Q:FROM="" D
178 . S IEN=0 F S IEN=$O(^%ZIS(1,"B",FROM,IEN)) Q:'IEN D
179 .. N X0,X1,X90,X91,X95,XTYPE,XSTYPE,XTIME,ORA,ORPX,POP
180 .. Q:'$D(^%ZIS(1,IEN,0)) S X0=^(0),X1=$G(^(1)),X90=$G(^(90)),X91=$G(^(91)),X95=$G(^(95)),XSTYPE=$G(^("SUBTYPE")),XTIME=$G(^("TIME")),XTYPE=$G(^("TYPE"))
181 .. I $E($G(^%ZIS(2,+XSTYPE,0)))'="P" Q ;Printers only
182 .. S X=$P(XTYPE,"^") I X'="TRM",X'="HG",X'="HFS",X'="CHAN" Q ;Device Types
183 .. S X=X0 I ($P(X,U,2)="0")!($P(X,U,12)=2) Q ;Queuing allowed
184 .. S X=+X90 I X,(X'>DT) Q ;Out of Service
185 .. I XTIME]"" S ORA=$P(XTIME,"^"),ORPX=$P($H,",",2),ORPCNT=ORPX\60#60+(ORPX\3600*100),ORPX=$P(ORA,"-",2) I ORPX'<ORA&(ORPCNT'>ORPX&(ORPCNT'<ORA))!(ORPX<ORA&(ORPCNT'<ORA!(ORPCNT'>ORPX))) Q ;Prohibited Times
186 .. S POP=0
187 .. I X95]"" S ORPX=$G(DUZ(0)) I ORPX'="@" S POP=1 F ORA=1:1:$L(ORPX) I X95[$E(ORPX,ORA) S POP=0 Q
188 .. Q:POP ;Security check
189 .. S SHOW=$P(X0,U) I SHOW'=FROM S SHOW=FROM_" <"_SHOW_">"
190 .. S I=I+1,Y(I)=IEN_";"_$P(X0,U)_U_SHOW_U_$P(X1,U)_U_$P(X91,U)_U_$P(X91,U,3)
191 Q
192URGENCY(Y) ; -- retrieve set values from dd for discharge summary urgency
193 N ORDD,I,X
194 D FIELD^DID(8925,.09,"","POINTER","ORDD")
195 F I=1:1 S X=$P(ORDD("POINTER"),";",I) Q:X="" S Y(I)=$TR(X,":","^")
196 Q
197PATCH(VAL,X) ; Return 1 if patch X is installed
198 S VAL=$$PATCH^XPDUTL(X)
199 Q
200VERSION(VAL,X) ;Return version of package or namespace
201 S VAL=$$VERSION^XPDUTL(X)
202 Q
203VERSRV(VAL,X,CLVER) ; Return server version of option name
204 S ORWCLVER=$G(CLVER) ; leave in partition for session
205 N BADVAL,ORLST
206 D FIND^DIC(19,"",1,"X",X,1,,,,"ORLST")
207 I 'ORLST("DILIST",0) S VAL="0.0.0.0" Q
208 S VAL=ORLST("DILIST","ID",1,1)
209 S VAL=$P(VAL,"version ",2)
210 S BADVAL=0
211 I $P(VAL,".",1)="" S BADVAL=1
212 I $P(VAL,".",2)="" S BADVAL=1
213 I $P(VAL,".",3)="" S BADVAL=1
214 I $P(VAL,".",4)="" S BADVAL=1
215 I ((BADVAL)!('VAL)!(VAL="")) S VAL="0.0.0.0"
216 Q
Note: See TracBrowser for help on using the repository browser.