ORWU ; SLC/KCM - General Utilites for Windows Calls;17-May-2010 08:32;PLS
;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,132,148,149,187,1004,195,215,243,1010**;Dec 17, 1997;Build 47
;Modified - IHS/MSC/PLS - 5/3/2006 - Line DEVICE+10
DT(Y,X,%DT) ; Internal Fileman Date/Time
; change the '00:00' that could be passed so Fileman doesn't reject
I $L($P(X,"@",2)),("00000000"[$TR($P(X,"@",2),":","")) S $P(X,"@",2)="00:00:01"
S %DT=$G(%DT,"TS") D ^%DT K %DT
Q
VALDT(Y,X,%DT) ; Validate date/time
S:'$D(%DT) %DT="TX" D ^%DT
Q
USERINFO(REC) ; Relevant info for current user
; return DUZ^NAME^USRCLS^CANSIGN^ISPROVIDER^ORDERROLE^NOORDER^DTIME^
; COUNTDOWN^ENABLEVERIFY^NOTIFYAPPS^MSGHANG^DOMAIN^SERVICE^
; AUTOSAVE^INITTAB^LASTTAB^WEBACCESS^ALLOWHOLD^ISRPL^RPLLIST^
; CORTABS^RPTTAB^STANUM^GECSTATUS^PRODACCT
N X,ORRPL,ORRPL1,ORRPL2,ORTAB,CORTABS,RPTTAB,ORDT,OREFF,OREXP,ORDATEOK
S REC=DUZ_U_$P(^VA(200,DUZ,0),U)
S $P(REC,U,3)=$S($D(^XUSEC("ORES",DUZ)):3,$D(^XUSEC("ORELSE",DUZ)):2,$D(^XUSEC("OREMAS",DUZ)):1,1:0)
S $P(REC,U,4)=$D(^XUSEC("ORES",DUZ))&$D(^XUSEC("PROVIDER",DUZ))
S $P(REC,U,5)=$D(^XUSEC("PROVIDER",DUZ))
S $P(REC,U,6)=$$ORDROLE
S $P(REC,U,7)=$$GET^XPAR("USR^SYS^PKG","ORWOR DISABLE ORDERING",1,"I")
S $P(REC,U,8)=$$GET^XPAR("USR^SYS","ORWOR TIMEOUT CHART",1,"I")
I '$P(REC,U,8),$G(DTIME) S $P(REC,U,8)=DTIME
S $P(REC,U,9)=$$GET^XPAR("USR^SYS^PKG","ORWOR TIMEOUT COUNTDOWN",1,"I")
S X=$$GET^XPAR("USR^SYS^PKG","ORWOR ENABLE VERIFY",1,"I")
S $P(REC,U,10)=$S(X=1:1,X=2:0,1:'$P(REC,U,7))
S $P(REC,U,11)=$$GET^XPAR("USR^SYS^PKG","ORWOR BROADCAST MESSAGES",1,"I")
S $P(REC,U,12)=$$GET^XPAR("USR^SYS^PKG","ORWOR AUTO CLOSE PT MSG",1,"I")
S $P(REC,U,13)=$$KSP^XUPARAM("WHERE") ; domain
S $P(REC,U,14)=+$G(^VA(200,DUZ,5)) ; service/section
S $P(REC,U,15)=$$GET^XPAR("USR^SYS^PKG","ORWOR AUTOSAVE NOTE",1,"I")
S $P(REC,U,16)=$$GET^XPAR("USR^DIV^SYS^PKG","ORCH INITIAL TAB",1,"I")
S $P(REC,U,17)=$$GET^XPAR("USR^DIV^SYS^PKG","ORCH USE LAST TAB",1,"I")
S $P(REC,U,18)=$$GET^XPAR("USR^DIV^SYS^PKG","ORWOR DISABLE WEB ACCESS",1,"I")
S $P(REC,U,19)=$$GET^XPAR("SYS^PKG","ORWOR DISABLE HOLD ORDERS",1,"I")
; 2 pieces added by PKS on 11/5/2001 for "Reports Only:"
; IA# 10060 allows read access to ^VA(200 file.
S ORRPL=$G(^VA(200,DUZ,101)) ; RPL node.
S ORRPL1=$P(ORRPL,U)
S $P(REC,U,20)=ORRPL1 ; ISRPL piece.
S ORRPL2=$P(ORRPL,U,2)
S $P(REC,U,21)=ORRPL2 ; RPLLIST piece.
;
; Additional pieces for CPRS tabs access:
; IA# 10060 allows read access to ^VA(200.01013 multiple.
S ORDT=DT ; Today.
S (CORTABS,RPTTAB)=0
S ORRPL=0
F S ORRPL=$O(^VA(200,DUZ,"ORD",ORRPL)) Q:ORRPL<1 D
.S ORTAB=$G(^VA(200,DUZ,"ORD",ORRPL,0))
.I ORTAB="" Q
.S OREFF=$P(ORTAB,U,2)
.S OREXP=$P(ORTAB,U,3)
.S ORTAB=$P(ORTAB,U)
.I ORTAB="" Q
.S ORTAB=$G(^ORD(101.13,ORTAB,0))
.I ORTAB="" Q
.S ORTAB=$P(ORTAB,U)
.I ORTAB="" Q
.S ORTAB=$$UP^XLFSTR(ORTAB)
.S ORDATEOK=1 ; Default.
.I ((OREFF="")!(OREFF>ORDT)) S ORDATEOK=0 ; Eff. date NG.
.I ORDATEOK D
..I OREXP="" Q ; No exp. date.
..I (OREXP<ORDT) S ORDATEOK=0 ; Exp. date NG.
..I (OREXP=ORDT) S ORDATEOK=0 ; Exp. date NG.
.;
.; Set TRUE if OK:
.I ((ORTAB="COR")&(ORDATEOK)) S CORTABS=1
.I ((ORTAB="RPT")&(ORDATEOK)) S RPTTAB=1
;
; When done, set all valid tabs for access:
S $P(REC,U,22)=CORTABS ; "Core" tabs.
S $P(REC,U,23)=RPTTAB ; "Reports" tab.
;
S $P(REC,U,24)=$P($$SITE^VASITE,U,3)
S $P(REC,U,25)=$$GET^XPAR("USR^TEA","PXRM GEC STATUS CHECK",1,"I")
S $P(REC,U,26)=$$PROD^XUPROD
Q
;
HASKEY(VAL,KEY) ; returns TRUE if the user possesses the security key
S VAL=''$D(^XUSEC(KEY,DUZ))
Q
HASOPTN(VAL,OPTION) ; returns TRUE if the user has access to a menu option
S VAL=+$$ACCESS^XQCHK(DUZ,OPTION)
I VAL'>0 S VAL=0
E S VAL=1
Q
NPHASKEY(VAL,NP,KEY) ; returns TRUE if the person has the security key
S VAL=''$D(^XUSEC(KEY,NP))
Q
ORDROLE() ; returns the role a person takes in ordering
; VAL: 0=nokey, 1=clerk, 2=nurse, 3=physician, 4=student, 5=bad keys
;I '$G(ORWCLVER) Q 0 ; version of client is to old for ordering
I ($D(^XUSEC("OREMAS",DUZ))+$D(^XUSEC("ORELSE",DUZ))+$D(^XUSEC("ORES",DUZ)))>1 Q 5
I $D(^XUSEC("OREMAS",DUZ)) Q 1 ; clerk
I $D(^XUSEC("ORELSE",DUZ)) Q 2 ; nurse
I $D(^XUSEC("ORES",DUZ)),$D(^XUSEC("PROVIDER",DUZ)) Q 3 ; doctor
I $D(^XUSEC("PROVIDER",DUZ)) Q 4 ; student
Q 0
VALIDSIG(ESOK,X) ; returns TRUE if valid electronic signature
S X=$$DECRYP^XUSRB1(X),ESOK=0 ; network encrypted
D HASH^XUSHSHP
I X=$P($G(^VA(200,+DUZ,20)),U,4) S ESOK=1
Q
N ANENT
S ANENT="ALL^"_$S($G(^VA(200,DUZ,5)):"^SRV.`"_+$G(^(5)),1:"")
D GETLST^XPAR(.ORLST,ANENT,"ORWT TOOLS MENU","N")
Q
ACTLOC(LOC) ; Function: returns TRUE if active hospital location
; IA# 10040.
N D0,X I +$G(^SC(LOC,"OOS")) Q 0 ; screen out OOS entry
S D0=+$G(^SC(LOC,42)) I D0 D WIN^DGPMDDCF Q 'X ; chk out of svc wards
S X=$G(^SC(LOC,"I")) I +X=0 Q 1 ; no inactivate date
I DT>$P(X,U)&($P(X,U,2)=""!(DT<$P(X,U,2))) Q 0 ; chk reactivate date
Q 1 ; must still be active
;
CLINLOC(Y,FROM,DIR) ; Return a set of clinics from HOSPITAL LOCATION
; .Y=returned list, FROM=text to $O from, DIR=$O direction,
N I,IEN,CNT S I=0,CNT=44
F Q:I'<CNT S FROM=$O(^SC("B",FROM),DIR) Q:FROM="" D ; IA# 10040.
. S IEN="" F S IEN=$O(^SC("B",FROM,IEN),DIR) Q:'IEN D
. . I ($P($G(^SC(IEN,0)),U,3)'="C")!('$$ACTLOC(IEN)) Q
. . S I=I+1,Y(I)=IEN_"^"_FROM
Q
INPLOC(Y,FROM,DIR) ;Return a set of wards from HOSPITAL LOCATION
; .Y=returned list, FROM=text to $O from, DIR=$O direction,
N I,IEN,CNT S I=0,CNT=44
F Q:I'<CNT S FROM=$O(^SC("B",FROM),DIR) Q:FROM="" D ; IA# 10040.
. S IEN="" F S IEN=$O(^SC("B",FROM,IEN),DIR) Q:'IEN D
. . I ($P($G(^SC(IEN,0)),U,3)'="W") Q
. . I '$$ACTLOC(IEN) Q
. . S I=I+1,Y(I)=IEN_"^"_FROM
Q
HOSPLOC(Y,FROM,DIR) ; Return a set of locations from HOSPITAL LOCATION
; .Y=returned list, FROM=text to $O from, DIR=$O direction,
N I,IEN,CNT S I=0,CNT=44
F Q:I'<CNT S FROM=$O(^SC("B",FROM),DIR) Q:FROM="" D ; IA# 10040.
. S IEN="" F S IEN=$O(^SC("B",FROM,IEN),DIR) Q:'IEN D
. . Q:("CW"'[$P($G(^SC(IEN,0)),U,3)!('$$ACTLOC(IEN)))
. . S I=I+1,Y(I)=IEN_"^"_FROM
Q
NEWPERS(ORY,ORFROM,ORDIR,ORKEY,ORDATE,ORVIZ,ORALL) ; Return a set of names from the NEW PERSON file.
; SLC/PKS: Code moved to ORWU1 on 12/3/2002.
D NP1^ORWU1
Q
GBLREF(VAL,FN) ; return global reference for file number
S VAL="" Q:'FN
S VAL=$$ROOT^DILFD(+FN)
; I $E($RE(VAL))="," S VAL=$E(VAL,1,$L(VAL)-1)_")"
; I $E($RE(VAL))="(" S VAL=$P(VAL,"(",1)
Q
GENERIC(Y,FROM,DIR,REF) ; Return a set of entries from xref in REF
; .Y=returned list, FROM=text to $O from, DIR=$O direction,
N I,IEN,CNT S I=0,CNT=44
F Q:I'<CNT S FROM=$O(@REF@(FROM),DIR) Q:FROM="" D
. S IEN="" F S IEN=$O(@REF@(FROM,IEN),DIR) Q:'IEN D
. . S I=I+1,Y(I)=IEN_"^"_FROM
Q
EXTNAME(VAL,IEN,FN) ; return external form of pointer
; IEN=internal number, FN=file number
N REF S REF=$G(^DIC(FN,0,"GL")),VAL=""
I $L(REF),+IEN S VAL=$P($G(@(REF_IEN_",0)")),U)
Q
PARAM(VAL,APARAM) ; return a parameter value for a user
; call assumes current user, default entities, single instance
S VAL=$$GET^XPAR("ALL",APARAM,1,"I")
Q
PARAMS(ORLIST,APARAM) ; return a list of parameter values
; call assumes current user, default entities, multiple instances
D GETLST^XPAR(.ORLIST,"ALL",APARAM,"Q")
Q
DEVICE(Y,FROM,DIR) ; Return a subset of entries from the Device file
; .LST(n)=IEN;Name^DisplayName^Location^RMar^PLen
; FROM=text to $O from, DIR=$O direction
N I,IEN,CNT,SHOW,X S I=0,CNT=20
I FROM["<" S FROM=$RE($P($RE(FROM),"< ",2))
F Q:I'<CNT S FROM=$O(^%ZIS(1,"B",FROM),DIR) Q:FROM="" D
. S IEN=0 F S IEN=$O(^%ZIS(1,"B",FROM,IEN)) Q:'IEN D
.. N X0,X1,X90,X91,X95,XTYPE,XSTYPE,XTIME,ORA,ORPX,POP
.. 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"))
.. I $E($G(^%ZIS(2,+XSTYPE,0)))'="P" Q ;Printers only
..; S X=$P(XTYPE,"^") I X'="TRM",X'="HG",X'="HFS",X'="CHAN" Q ;Device Types ; IHS/CIA/PLS - 04/07/04 - Added "OTH" types
.. S X=$P(XTYPE,"^") I X'="TRM",X'="HG",X'="HFS",X'="CHAN",X'="OTH" Q ;Device Types
.. S X=X0 I ($P(X,U,2)="0")!($P(X,U,12)=2) Q ;Queuing allowed
.. S X=+X90 I X,(X'>DT) Q ;Out of Service
.. 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
.. S POP=0
.. 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
.. Q:POP ;Security check
.. S SHOW=$P(X0,U) I SHOW'=FROM S SHOW=FROM_" <"_SHOW_">"
.. 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)
Q
URGENCY(Y) ; -- retrieve set values from dd for discharge summary urgency
N ORDD,I,X
D FIELD^DID(8925,.09,"","POINTER","ORDD")
F I=1:1 S X=$P(ORDD("POINTER"),";",I) Q:X="" S Y(I)=$TR(X,":","^")
Q
PATCH(VAL,X) ; Return 1 if patch X is installed
S VAL=$$PATCH^XPDUTL(X)
Q
VERSION(VAL,X) ;Return version of package or namespace
S VAL=$$VERSION^XPDUTL(X)
Q
VERSRV(VAL,X,CLVER) ; Return server version of option name
S ORWCLVER=$G(CLVER) ; leave in partition for session
N BADVAL,ORLST
D FIND^DIC(19,"",1,"X",X,1,,,,"ORLST")
I 'ORLST("DILIST",0) S VAL="0.0.0.0" Q
S VAL=ORLST("DILIST","ID",1,1)
S VAL=$P(VAL,"version ",2)
S BADVAL=0
I $P(VAL,".",1)="" S BADVAL=1
I $P(VAL,".",2)="" S BADVAL=1
I $P(VAL,".",3)="" S BADVAL=1
I $P(VAL,".",4)="" S BADVAL=1
I ((BADVAL)!('VAL)!(VAL="")) S VAL="0.0.0.0"
Q
ORWU ; SLC/KCM - General Utilites for Windows Calls;17-May-2010 08:32;PLS
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,132,148,149,187,1004,195,215,243,1010**;Dec 17, 1997;Build 47
+2 ;Modified - IHS/MSC/PLS - 5/3/2006 - Line DEVICE+10
DT(Y,X,%DT) ; Internal Fileman Date/Time
+1 ; change the '00:00' that could be passed so Fileman doesn't reject
+2 IF $LENGTH($PIECE(X,"@",2))
IF ("00000000"[$TRANSLATE($PIECE(X,"@",2),":",""))
SET $PIECE(X,"@",2)="00:00:01"
+3 SET %DT=$GET(%DT,"TS")
DO ^%DT
KILL %DT
+4 QUIT
VALDT(Y,X,%DT) ; Validate date/time
+1 IF '$DATA(%DT)
SET %DT="TX"
DO ^%DT
+2 QUIT
USERINFO(REC) ; Relevant info for current user
+1 ; return DUZ^NAME^USRCLS^CANSIGN^ISPROVIDER^ORDERROLE^NOORDER^DTIME^
+2 ; COUNTDOWN^ENABLEVERIFY^NOTIFYAPPS^MSGHANG^DOMAIN^SERVICE^
+3 ; AUTOSAVE^INITTAB^LASTTAB^WEBACCESS^ALLOWHOLD^ISRPL^RPLLIST^
+4 ; CORTABS^RPTTAB^STANUM^GECSTATUS^PRODACCT
+5 NEW X,ORRPL,ORRPL1,ORRPL2,ORTAB,CORTABS,RPTTAB,ORDT,OREFF,OREXP,ORDATEOK
+6 SET REC=DUZ_U_$PIECE(^VA(200,DUZ,0),U)
+7 SET $PIECE(REC,U,3)=$SELECT($DATA(^XUSEC("ORES",DUZ)):3,$DATA(^XUSEC("ORELSE",DUZ)):2,$DATA(^XUSEC("OREMAS",DUZ)):1,1:0)
+8 SET $PIECE(REC,U,4)=$DATA(^XUSEC("ORES",DUZ))&$DATA(^XUSEC("PROVIDER",DUZ))
+9 SET $PIECE(REC,U,5)=$DATA(^XUSEC("PROVIDER",DUZ))
+10 SET $PIECE(REC,U,6)=$$ORDROLE
+11 SET $PIECE(REC,U,7)=$$GET^XPAR("USR^SYS^PKG","ORWOR DISABLE ORDERING",1,"I")
+12 SET $PIECE(REC,U,8)=$$GET^XPAR("USR^SYS","ORWOR TIMEOUT CHART",1,"I")
+13 IF '$PIECE(REC,U,8)
IF $GET(DTIME)
SET $PIECE(REC,U,8)=DTIME
+14 SET $PIECE(REC,U,9)=$$GET^XPAR("USR^SYS^PKG","ORWOR TIMEOUT COUNTDOWN",1,"I")
+15 SET X=$$GET^XPAR("USR^SYS^PKG","ORWOR ENABLE VERIFY",1,"I")
+16 SET $PIECE(REC,U,10)=$SELECT(X=1:1,X=2:0,1:'$PIECE(REC,U,7))
+17 SET $PIECE(REC,U,11)=$$GET^XPAR("USR^SYS^PKG","ORWOR BROADCAST MESSAGES",1,"I")
+18 SET $PIECE(REC,U,12)=$$GET^XPAR("USR^SYS^PKG","ORWOR AUTO CLOSE PT MSG",1,"I")
+19 ; domain
SET $PIECE(REC,U,13)=$$KSP^XUPARAM("WHERE")
+20 ; service/section
SET $PIECE(REC,U,14)=+$GET(^VA(200,DUZ,5))
+21 SET $PIECE(REC,U,15)=$$GET^XPAR("USR^SYS^PKG","ORWOR AUTOSAVE NOTE",1,"I")
+22 SET $PIECE(REC,U,16)=$$GET^XPAR("USR^DIV^SYS^PKG","ORCH INITIAL TAB",1,"I")
+23 SET $PIECE(REC,U,17)=$$GET^XPAR("USR^DIV^SYS^PKG","ORCH USE LAST TAB",1,"I")
+24 SET $PIECE(REC,U,18)=$$GET^XPAR("USR^DIV^SYS^PKG","ORWOR DISABLE WEB ACCESS",1,"I")
+25 SET $PIECE(REC,U,19)=$$GET^XPAR("SYS^PKG","ORWOR DISABLE HOLD ORDERS",1,"I")
+26 ; 2 pieces added by PKS on 11/5/2001 for "Reports Only:"
+27 ; IA# 10060 allows read access to ^VA(200 file.
+28 ; RPL node.
SET ORRPL=$GET(^VA(200,DUZ,101))
+29 SET ORRPL1=$PIECE(ORRPL,U)
+30 ; ISRPL piece.
SET $PIECE(REC,U,20)=ORRPL1
+31 SET ORRPL2=$PIECE(ORRPL,U,2)
+32 ; RPLLIST piece.
SET $PIECE(REC,U,21)=ORRPL2
+33 ;
+34 ; Additional pieces for CPRS tabs access:
+35 ; IA# 10060 allows read access to ^VA(200.01013 multiple.
+36 ; Today.
SET ORDT=DT
+37 SET (CORTABS,RPTTAB)=0
+38 SET ORRPL=0
+39 FOR
SET ORRPL=$ORDER(^VA(200,DUZ,"ORD",ORRPL))
IF ORRPL<1
QUIT
Begin DoDot:1
+40 SET ORTAB=$GET(^VA(200,DUZ,"ORD",ORRPL,0))
+41 IF ORTAB=""
QUIT
+42 SET OREFF=$PIECE(ORTAB,U,2)
+43 SET OREXP=$PIECE(ORTAB,U,3)
+44 SET ORTAB=$PIECE(ORTAB,U)
+45 IF ORTAB=""
QUIT
+46 SET ORTAB=$GET(^ORD(101.13,ORTAB,0))
+47 IF ORTAB=""
QUIT
+48 SET ORTAB=$PIECE(ORTAB,U)
+49 IF ORTAB=""
QUIT
+50 SET ORTAB=$$UP^XLFSTR(ORTAB)
+51 ; Default.
SET ORDATEOK=1
+52 ; Eff. date NG.
IF ((OREFF="")!(OREFF>ORDT))
SET ORDATEOK=0
+53 IF ORDATEOK
Begin DoDot:2
+54 ; No exp. date.
IF OREXP=""
QUIT
+55 ; Exp. date NG.
IF (OREXP<ORDT)
SET ORDATEOK=0
+56 ; Exp. date NG.
IF (OREXP=ORDT)
SET ORDATEOK=0
End DoDot:2
+57 ;
+58 ; Set TRUE if OK:
+59 IF ((ORTAB="COR")&(ORDATEOK))
SET CORTABS=1
+60 IF ((ORTAB="RPT")&(ORDATEOK))
SET RPTTAB=1
End DoDot:1
+61 ;
+62 ; When done, set all valid tabs for access:
+63 ; "Core" tabs.
SET $PIECE(REC,U,22)=CORTABS
+64 ; "Reports" tab.
SET $PIECE(REC,U,23)=RPTTAB
+65 ;
+66 SET $PIECE(REC,U,24)=$PIECE($$SITE^VASITE,U,3)
+67 SET $PIECE(REC,U,25)=$$GET^XPAR("USR^TEA","PXRM GEC STATUS CHECK",1,"I")
+68 SET $PIECE(REC,U,26)=$$PROD^XUPROD
+69 QUIT
+70 ;
HASKEY(VAL,KEY) ; returns TRUE if the user possesses the security key
+1 SET VAL=''$DATA(^XUSEC(KEY,DUZ))
+2 QUIT
HASOPTN(VAL,OPTION) ; returns TRUE if the user has access to a menu option
+1 SET VAL=+$$ACCESS^XQCHK(DUZ,OPTION)
+2 IF VAL'>0
SET VAL=0
+3 IF '$TEST
SET VAL=1
+4 QUIT
NPHASKEY(VAL,NP,KEY) ; returns TRUE if the person has the security key
+1 SET VAL=''$DATA(^XUSEC(KEY,NP))
+2 QUIT
ORDROLE() ; returns the role a person takes in ordering
+1 ; VAL: 0=nokey, 1=clerk, 2=nurse, 3=physician, 4=student, 5=bad keys
+2 ;I '$G(ORWCLVER) Q 0 ; version of client is to old for ordering
+3 IF ($DATA(^XUSEC("OREMAS",DUZ))+$DATA(^XUSEC("ORELSE",DUZ))+$DATA(^XUSEC("ORES",DUZ)))>1
QUIT 5
+4 ; clerk
IF $DATA(^XUSEC("OREMAS",DUZ))
QUIT 1
+5 ; nurse
IF $DATA(^XUSEC("ORELSE",DUZ))
QUIT 2
+6 ; doctor
IF $DATA(^XUSEC("ORES",DUZ))
IF $DATA(^XUSEC("PROVIDER",DUZ))
QUIT 3
+7 ; student
IF $DATA(^XUSEC("PROVIDER",DUZ))
QUIT 4
+8 QUIT 0
VALIDSIG(ESOK,X) ; returns TRUE if valid electronic signature
+1 ; network encrypted
SET X=$$DECRYP^XUSRB1(X)
SET ESOK=0
+2 DO HASH^XUSHSHP
+3 IF X=$PIECE($GET(^VA(200,+DUZ,20)),U,4)
SET ESOK=1
+4 QUIT
+1 NEW ANENT
+2 SET ANENT="ALL^"_$SELECT($GET(^VA(200,DUZ,5)):"^SRV.`"_+$GET(^(5)),1:"")
+3 DO GETLST^XPAR(.ORLST,ANENT,"ORWT TOOLS MENU","N")
+4 QUIT
ACTLOC(LOC) ; Function: returns TRUE if active hospital location
+1 ; IA# 10040.
+2 ; screen out OOS entry
NEW D0,X
IF +$GET(^SC(LOC,"OOS"))
QUIT 0
+3 ; chk out of svc wards
SET D0=+$GET(^SC(LOC,42))
IF D0
DO WIN^DGPMDDCF
QUIT 'X
+4 ; no inactivate date
SET X=$GET(^SC(LOC,"I"))
IF +X=0
QUIT 1
+5 ; chk reactivate date
IF DT>$PIECE(X,U)&($PIECE(X,U,2)=""!(DT<$PIECE(X,U,2)))
QUIT 0
+6 ; must still be active
QUIT 1
+7 ;
CLINLOC(Y,FROM,DIR) ; Return a set of clinics from HOSPITAL LOCATION
+1 ; .Y=returned list, FROM=text to $O from, DIR=$O direction,
+2 NEW I,IEN,CNT
SET I=0
SET CNT=44
+3 ; IA# 10040.
FOR
IF I'<CNT
QUIT
SET FROM=$ORDER(^SC("B",FROM),DIR)
IF FROM=""
QUIT
Begin DoDot:1
+4 SET IEN=""
FOR
SET IEN=$ORDER(^SC("B",FROM,IEN),DIR)
IF 'IEN
QUIT
Begin DoDot:2
+5 IF ($PIECE($GET(^SC(IEN,0)),U,3)'="C")!('$$ACTLOC(IEN))
QUIT
+6 SET I=I+1
SET Y(I)=IEN_"^"_FROM
End DoDot:2
End DoDot:1
+7 QUIT
INPLOC(Y,FROM,DIR) ;Return a set of wards from HOSPITAL LOCATION
+1 ; .Y=returned list, FROM=text to $O from, DIR=$O direction,
+2 NEW I,IEN,CNT
SET I=0
SET CNT=44
+3 ; IA# 10040.
FOR
IF I'<CNT
QUIT
SET FROM=$ORDER(^SC("B",FROM),DIR)
IF FROM=""
QUIT
Begin DoDot:1
+4 SET IEN=""
FOR
SET IEN=$ORDER(^SC("B",FROM,IEN),DIR)
IF 'IEN
QUIT
Begin DoDot:2
+5 IF ($PIECE($GET(^SC(IEN,0)),U,3)'="W")
QUIT
+6 IF '$$ACTLOC(IEN)
QUIT
+7 SET I=I+1
SET Y(I)=IEN_"^"_FROM
End DoDot:2
End DoDot:1
+8 QUIT
HOSPLOC(Y,FROM,DIR) ; Return a set of locations from HOSPITAL LOCATION
+1 ; .Y=returned list, FROM=text to $O from, DIR=$O direction,
+2 NEW I,IEN,CNT
SET I=0
SET CNT=44
+3 ; IA# 10040.
FOR
IF I'<CNT
QUIT
SET FROM=$ORDER(^SC("B",FROM),DIR)
IF FROM=""
QUIT
Begin DoDot:1
+4 SET IEN=""
FOR
SET IEN=$ORDER(^SC("B",FROM,IEN),DIR)
IF 'IEN
QUIT
Begin DoDot:2
+5 IF ("CW"'[$PIECE($GET(^SC(IEN,0)),U,3)!('$$ACTLOC(IEN)))
QUIT
+6 SET I=I+1
SET Y(I)=IEN_"^"_FROM
End DoDot:2
End DoDot:1
+7 QUIT
NEWPERS(ORY,ORFROM,ORDIR,ORKEY,ORDATE,ORVIZ,ORALL) ; Return a set of names from the NEW PERSON file.
+1 ; SLC/PKS: Code moved to ORWU1 on 12/3/2002.
+2 DO NP1^ORWU1
+3 QUIT
GBLREF(VAL,FN) ; return global reference for file number
+1 SET VAL=""
IF 'FN
QUIT
+2 SET VAL=$$ROOT^DILFD(+FN)
+3 ; I $E($RE(VAL))="," S VAL=$E(VAL,1,$L(VAL)-1)_")"
+4 ; I $E($RE(VAL))="(" S VAL=$P(VAL,"(",1)
+5 QUIT
GENERIC(Y,FROM,DIR,REF) ; Return a set of entries from xref in REF
+1 ; .Y=returned list, FROM=text to $O from, DIR=$O direction,
+2 NEW I,IEN,CNT
SET I=0
SET CNT=44
+3 FOR
IF I'<CNT
QUIT
SET FROM=$ORDER(@REF@(FROM),DIR)
IF FROM=""
QUIT
Begin DoDot:1
+4 SET IEN=""
FOR
SET IEN=$ORDER(@REF@(FROM,IEN),DIR)
IF 'IEN
QUIT
Begin DoDot:2
+5 SET I=I+1
SET Y(I)=IEN_"^"_FROM
End DoDot:2
End DoDot:1
+6 QUIT
EXTNAME(VAL,IEN,FN) ; return external form of pointer
+1 ; IEN=internal number, FN=file number
+2 NEW REF
SET REF=$GET(^DIC(FN,0,"GL"))
SET VAL=""
+3 IF $LENGTH(REF)
IF +IEN
SET VAL=$PIECE($GET(@(REF_IEN_",0)")),U)
+4 QUIT
PARAM(VAL,APARAM) ; return a parameter value for a user
+1 ; call assumes current user, default entities, single instance
+2 SET VAL=$$GET^XPAR("ALL",APARAM,1,"I")
+3 QUIT
PARAMS(ORLIST,APARAM) ; return a list of parameter values
+1 ; call assumes current user, default entities, multiple instances
+2 DO GETLST^XPAR(.ORLIST,"ALL",APARAM,"Q")
+3 QUIT
DEVICE(Y,FROM,DIR) ; Return a subset of entries from the Device file
+1 ; .LST(n)=IEN;Name^DisplayName^Location^RMar^PLen
+2 ; FROM=text to $O from, DIR=$O direction
+3 NEW I,IEN,CNT,SHOW,X
SET I=0
SET CNT=20
+4 IF FROM["<"
SET FROM=$REVERSE($PIECE($REVERSE(FROM),"< ",2))
+5 FOR
IF I'<CNT
QUIT
SET FROM=$ORDER(^%ZIS(1,"B",FROM),DIR)
IF FROM=""
QUIT
Begin DoDot:1
+6 SET IEN=0
FOR
SET IEN=$ORDER(^%ZIS(1,"B",FROM,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+7 NEW X0,X1,X90,X91,X95,XTYPE,XSTYPE,XTIME,ORA,ORPX,POP
+8 IF '$DATA(^%ZIS(1,IEN,0))
QUIT
SET X0=^(0)
SET X1=$GET(^(1))
SET X90=$GET(^(90))
SET X91=$GET(^(91))
SET X95=$GET(^(95))
SET XSTYPE=$GET(^("SUBTYPE"))
SET XTIME=$GET(^("TIME"))
SET XTYPE=$GET(^("TYPE"))
+9 ;Printers only
IF $EXTRACT($GET(^%ZIS(2,+XSTYPE,0)))'="P"
QUIT
+10 ; S X=$P(XTYPE,"^") I X'="TRM",X'="HG",X'="HFS",X'="CHAN" Q ;Device Types ; IHS/CIA/PLS - 04/07/04 - Added "OTH" types
+11 ;Device Types
SET X=$PIECE(XTYPE,"^")
IF X'="TRM"
IF X'="HG"
IF X'="HFS"
IF X'="CHAN"
IF X'="OTH"
QUIT
+12 ;Queuing allowed
SET X=X0
IF ($PIECE(X,U,2)="0")!($PIECE(X,U,12)=2)
QUIT
+13 ;Out of Service
SET X=+X90
IF X
IF (X'>DT)
QUIT
+14 ;Prohibited Times
IF XTIME]""
SET ORA=$PIECE(XTIME,"^")
SET ORPX=$PIECE($HOROLOG,",",2)
SET ORPCNT=ORPX\60#60+(ORPX\3600*100)
SET ORPX=$PIECE(ORA,"-",2)
IF ORPX'<ORA&(ORPCNT'>ORPX&(ORPCNT'<ORA))!(ORPX<ORA&(ORPCNT'<ORA!(ORPCNT'>ORPX)))
QUIT
+15 SET POP=0
+16 IF X95]""
SET ORPX=$GET(DUZ(0))
IF ORPX'="@"
SET POP=1
FOR ORA=1:1:$LENGTH(ORPX)
IF X95[$EXTRACT(ORPX,ORA)
SET POP=0
QUIT
+17 ;Security check
IF POP
QUIT
+18 SET SHOW=$PIECE(X0,U)
IF SHOW'=FROM
SET SHOW=FROM_" <"_SHOW_">"
+19 SET I=I+1
SET Y(I)=IEN_";"_$PIECE(X0,U)_U_SHOW_U_$PIECE(X1,U)_U_$PIECE(X91,U)_U_$PIECE(X91,U,3)
End DoDot:2
End DoDot:1
+20 QUIT
URGENCY(Y) ; -- retrieve set values from dd for discharge summary urgency
+1 NEW ORDD,I,X
+2 DO FIELD^DID(8925,.09,"","POINTER","ORDD")
+3 FOR I=1:1
SET X=$PIECE(ORDD("POINTER"),";",I)
IF X=""
QUIT
SET Y(I)=$TRANSLATE(X,":","^")
+4 QUIT
PATCH(VAL,X) ; Return 1 if patch X is installed
+1 SET VAL=$$PATCH^XPDUTL(X)
+2 QUIT
VERSION(VAL,X) ;Return version of package or namespace
+1 SET VAL=$$VERSION^XPDUTL(X)
+2 QUIT
VERSRV(VAL,X,CLVER) ; Return server version of option name
+1 ; leave in partition for session
SET ORWCLVER=$GET(CLVER)
+2 NEW BADVAL,ORLST
+3 DO FIND^DIC(19,"",1,"X",X,1,,,,"ORLST")
+4 IF 'ORLST("DILIST",0)
SET VAL="0.0.0.0"
QUIT
+5 SET VAL=ORLST("DILIST","ID",1,1)
+6 SET VAL=$PIECE(VAL,"version ",2)
+7 SET BADVAL=0
+8 IF $PIECE(VAL,".",1)=""
SET BADVAL=1
+9 IF $PIECE(VAL,".",2)=""
SET BADVAL=1
+10 IF $PIECE(VAL,".",3)=""
SET BADVAL=1
+11 IF $PIECE(VAL,".",4)=""
SET BADVAL=1
+12 IF ((BADVAL)!('VAL)!(VAL=""))
SET VAL="0.0.0.0"
+13 QUIT
