- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWU.m
r613 r623 1 ORWU ; 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,243**;Dec 17, 1997;Build 242 3 ; 4 DT(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 9 VALDT(Y,X,%DT) ; Validate date/time 10 S:'$D(%DT) %DT="TX" D ^%DT 11 Q 12 USERINFO(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 ; 83 HASKEY(VAL,KEY) ; returns TRUE if the user possesses the security key 84 S VAL=''$D(^XUSEC(KEY,DUZ)) 85 Q 86 HASOPTN(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 91 NPHASKEY(VAL,NP,KEY) ; returns TRUE if the person has the security key 92 S VAL=''$D(^XUSEC(KEY,NP)) 93 Q 94 ORDROLE() ; 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 103 VALIDSIG(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 108 TOOLMENU(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 113 ACTLOC(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 ; 121 CLINLOC(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 129 INPLOC(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 138 HOSPLOC(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 146 NEWPERS(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 150 GBLREF(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 156 GENERIC(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 163 EXTNAME(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 168 PARAM(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 172 PARAMS(ORLIST,APARAM) ; return a list of parameter values 173 ; call assumes current user, default entities, multiple instances 174 D GETLST^XPAR(.ORLIST,"ALL",APARAM,"Q") 175 Q 176 DEVICE(Y,FROM,DIR) ; Return a subset of entries from the Device file 177 ; .LST(n)=IEN;Name^DisplayName^Location^RMar^PLen 178 ; FROM=text to $O from, DIR=$O direction 179 N I,IEN,CNT,SHOW,X S I=0,CNT=20 180 I FROM["<" S FROM=$RE($P($RE(FROM),"< ",2)) 181 F Q:I'<CNT S FROM=$O(^%ZIS(1,"B",FROM),DIR) Q:FROM="" D 182 . S IEN=0 F S IEN=$O(^%ZIS(1,"B",FROM,IEN)) Q:'IEN D 183 .. N X0,X1,X90,X91,X95,XTYPE,XSTYPE,XTIME,ORA,ORPX,POP 184 .. 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")) 185 .. I $E($G(^%ZIS(2,+XSTYPE,0)))'="P" Q ;Printers only 186 .. S X=$P(XTYPE,"^") I X'="TRM",X'="HG",X'="HFS",X'="CHAN" Q ;Device Types 187 .. S X=X0 I ($P(X,U,2)="0")!($P(X,U,12)=2) Q ;Queuing allowed 188 .. S X=+X90 I X,(X'>DT) Q ;Out of Service 189 .. 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 190 .. S POP=0 191 .. 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 192 .. Q:POP ;Security check 193 .. S SHOW=$P(X0,U) I SHOW'=FROM S SHOW=FROM_" <"_SHOW_">" 194 .. 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) 195 Q 196 URGENCY(Y) ; -- retrieve set values from dd for discharge summary urgency 197 N ORDD,I,X 198 D FIELD^DID(8925,.09,"","POINTER","ORDD") 199 F I=1:1 S X=$P(ORDD("POINTER"),";",I) Q:X="" S Y(I)=$TR(X,":","^") 200 Q 201 PATCH(VAL,X) ; Return 1 if patch X is installed 202 S VAL=$$PATCH^XPDUTL(X) 203 Q 204 VERSION(VAL,X) ;Return version of package or namespace 205 S VAL=$$VERSION^XPDUTL(X) 206 Q 207 VERSRV(VAL,X,CLVER) ; Return server version of option name 208 S ORWCLVER=$G(CLVER) ; leave in partition for session 209 N BADVAL,ORLST 210 D FIND^DIC(19,"",1,"X",X,1,,,,"ORLST") 211 I 'ORLST("DILIST",0) S VAL="0.0.0.0" Q 212 S VAL=ORLST("DILIST","ID",1,1) 213 S VAL=$P(VAL,"version ",2) 214 S BADVAL=0 215 I $P(VAL,".",1)="" S BADVAL=1 216 I $P(VAL,".",2)="" S BADVAL=1 217 I $P(VAL,".",3)="" S BADVAL=1 218 I $P(VAL,".",4)="" S BADVAL=1 219 I ((BADVAL)!('VAL)!(VAL="")) S VAL="0.0.0.0" 220 Q 1 ORWU ; 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 ; 4 DT(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 9 VALDT(Y,X,%DT) ; Validate date/time 10 S:'$D(%DT) %DT="TX" D ^%DT 11 Q 12 USERINFO(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 ; 83 HASKEY(VAL,KEY) ; returns TRUE if the user possesses the security key 84 S VAL=''$D(^XUSEC(KEY,DUZ)) 85 Q 86 HASOPTN(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 91 NPHASKEY(VAL,NP,KEY) ; returns TRUE if the person has the security key 92 S VAL=''$D(^XUSEC(KEY,NP)) 93 Q 94 ORDROLE() ; 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 103 VALIDSIG(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 108 TOOLMENU(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 113 ACTLOC(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 ; 121 CLINLOC(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 129 INPLOC(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 138 HOSPLOC(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 146 NEWPERS(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 150 GBLREF(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 156 GENERIC(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 163 EXTNAME(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 168 PARAM(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 172 DEVICE(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 192 URGENCY(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 197 PATCH(VAL,X) ; Return 1 if patch X is installed 198 S VAL=$$PATCH^XPDUTL(X) 199 Q 200 VERSION(VAL,X) ;Return version of package or namespace 201 S VAL=$$VERSION^XPDUTL(X) 202 Q 203 VERSRV(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 TracChangeset
for help on using the changeset viewer.
