ORWU.m

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

TOOLMENU(ORLST) ; returns a list of items for the Tools menu

 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 

TOOLMENU(ORLST) ; returns a list of items for the Tools menu

 +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)