ORUTL ; slc/dcm,RWF - Order utilities; ;4/24/01 17:14
;;3.0;ORDER ENTRY/RESULTS REPORTING;**95**Dec 17, 1997
LOC ;;GET PT. LOCATION
S C(1)=$S($D(ORL(2))#2:$S(ORL(2)[";":$S($D(@("^"_$P(ORL(2),";",2)_+ORL(2)_",0)")):$P(^(0),"^"),1:""),1:""),1:"")
I 'OR4,ORVP[";DPT(",$D(ORL(2)),ORL(2) Q
G:$L(C(1)) LOC1 S (CT,C)=0,O=1 I ORVP[";DPT(",$O(^DPT(+ORVP,"DE",0))>0 W !!,"Currently enrolled in the following clinics: ",!
I S I=0 F L=0:0 S I=$O(^DPT(+ORVP,"DE",I)) Q:I'>0 I $D(^(I,0)) S Y=^(0) I $P(Y,"^",2)'="I",'$P(Y,"^",3) I $D(^SC(+Y,0)) S X=^(0) D
. I $D(^SC(+Y,"I")) S ORIA=+^("I"),ORRA=$P(^("I"),"^",2) I $S('ORIA:0,ORIA>DT:0,ORRA'>DT&(ORRA):0,1:1) Q
. S CT=CT+1 W:(CT#2) !?17 W:'(CT#2) ?47 W $P(X,"^") S C=C+1,C(1)=$P(X,"^") S:C'=1 C=-1
W !
LOC1 S C=1 W !,"Patient Location: " W:C=1&($L(C(1))) C(1),"//" R X:DTIME G QUIT:'$T,QUIT:C'=1&(X=""),LOC:$L(X)>20!(X'?.ANP),QUIT:X[U
S DIC("S")="I ""FI""'[$P(^(0),""^"",3),'$P($G(^(""OOS"")),""^"")",DIC=44,DIC(0)=$S(C=1&($L(C(1)))&(X=""):"EMQOZX",1:"EMQZ")
S:X="" X=C(1) D ^DIC G LOC:X["?" S:Y>0 ORL=+Y_";SC(",ORL(0)=$S($L($P(Y(0),"^",2)):$P(Y(0),"^",2),1:$E($P(Y(0),"^"),1,4))
K ORIA,ORRA I $D(^SC(+Y,"I")) S ORIA=+^("I"),ORRA=$P(^("I"),U,2)
I $S('$D(ORIA):0,'ORIA:0,ORIA>DT:0,ORRA'>DT&(ORRA):0,1:1) W $C(7)," This location has been inactivated." K ORL G LOC
I Y<0 W " You must select a standard location." G LOC
K DIC,C,ORIA,ORRA Q
QUIT S OREND=1 K DIC,C Q
READ ;;Hold screen
I $D(IOST) Q:$E(IOST)'="C"
W ! I $D(IOSL),$Y<(IOSL-4) G READ
W !?5,"Press return to continue " R X:$S($D(DTIME):DTIME,1:300)
Q
CHKNAM(X,Y) ;Input transform to not allow certain characters
;X is the text to be checked, Y are the characters not allowed as sent in by the input transform of the field
N I,J I '$D(Y) S Y="-;,=^" ;if no special characters sent in, set list to all
F I=1:1:$L(Y) I X[($E(Y,I)) S J=1
Q +$G(J)
CHKMNE(X) ;Input transform to not allow use of standard Lmgr Mnemonics
N Y
S Y=$$UP^XLFSTR(X) ;check to make sure mnemonic isn't set to lower case of restricted entries. List Manager is case insensitive
I Y="ADPL"!(Y="DN")!(Y="Q")!(Y="FS")!(Y="GO")!(Y="?")!(Y="??")!(Y="LS")!(Y="+")!(Y="-")!(Y="PL")!(Y="PS")!(Y="RD")!(Y="SL")!(Y="<")!(Y=">")!(Y="UP")!(Y="PI")!(Y="CWAD")!(Y="TD")!(Y="EX") Q 1
Q 0
ORUTL ; slc/dcm,RWF - Order utilities; ;4/24/01 17:14
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**95**Dec 17, 1997
LOC ;;GET PT. LOCATION
+1 SET C(1)=$SELECT($DATA(ORL(2))#2:$SELECT(ORL(2)[";":$SELECT($DATA(@("^"_$PIECE(ORL(2),";",2)_+ORL(2)_",0)")):$PIECE(^(0),"^"),1:""),1:""),1:"")
+2 IF 'OR4
IF ORVP[";DPT("
IF $DATA(ORL(2))
IF ORL(2)
QUIT
+3 IF $LENGTH(C(1))
GOTO LOC1
SET (CT,C)=0
SET O=1
IF ORVP[";DPT("
IF $ORDER(^DPT(+ORVP,"DE",0))>0
WRITE !!,"Currently enrolled in the following clinics: ",!
+4 IF $TEST
SET I=0
FOR L=0:0
SET I=$ORDER(^DPT(+ORVP,"DE",I))
IF I'>0
QUIT
IF $DATA(^(I,0))
SET Y=^(0)
IF $PIECE(Y,"^",2)'="I"
IF '$PIECE(Y,"^",3)
IF $DATA(^SC(+Y,0))
SET X=^(0)
Begin DoDot:1
+5 IF $DATA(^SC(+Y,"I"))
SET ORIA=+^("I")
SET ORRA=$PIECE(^("I"),"^",2)
IF $SELECT('ORIA:0,ORIA>DT:0,ORRA'>DT&(ORRA):0,1:1)
QUIT
+6 SET CT=CT+1
IF (CT#2)
WRITE !?17
IF '(CT#2)
WRITE ?47
WRITE $PIECE(X,"^")
SET C=C+1
SET C(1)=$PIECE(X,"^")
IF C'=1
SET C=-1
End DoDot:1
+7 WRITE !
LOC1 SET C=1
WRITE !,"Patient Location: "
IF C=1&($LENGTH(C(1)))
WRITE C(1),"//"
READ X:DTIME
IF '$TEST
GOTO QUIT
IF C'=1&(X="")
GOTO QUIT
IF $LENGTH(X)>20!(X'?.ANP)
GOTO LOC
IF X[U
GOTO QUIT
+1 SET DIC("S")="I ""FI""'[$P(^(0),""^"",3),'$P($G(^(""OOS"")),""^"")"
SET DIC=44
SET DIC(0)=$SELECT(C=1&($LENGTH(C(1)))&(X=""):"EMQOZX",1:"EMQZ")
+2 IF X=""
SET X=C(1)
DO ^DIC
IF X["?"
GOTO LOC
IF Y>0
SET ORL=+Y_";SC("
SET ORL(0)=$SELECT($LENGTH($PIECE(Y(0),"^",2)):$PIECE(Y(0),"^",2),1:$EXTRACT($PIECE(Y(0),"^"),1,4))
+3 KILL ORIA,ORRA
IF $DATA(^SC(+Y,"I"))
SET ORIA=+^("I")
SET ORRA=$PIECE(^("I"),U,2)
+4 IF $SELECT('$DATA(ORIA):0,'ORIA:0,ORIA>DT:0,ORRA'>DT&(ORRA):0,1:1)
WRITE $CHAR(7)," This location has been inactivated."
KILL ORL
GOTO LOC
+5 IF Y<0
WRITE " You must select a standard location."
GOTO LOC
+6 KILL DIC,C,ORIA,ORRA
QUIT
QUIT SET OREND=1
KILL DIC,C
QUIT
READ ;;Hold screen
+1 IF $DATA(IOST)
IF $EXTRACT(IOST)'="C"
QUIT
+2 WRITE !
IF $DATA(IOSL)
IF $Y<(IOSL-4)
GOTO READ
+3 WRITE !?5,"Press return to continue "
READ X:$SELECT($DATA(DTIME):DTIME,1:300)
+4 QUIT
CHKNAM(X,Y) ;Input transform to not allow certain characters
+1 ;X is the text to be checked, Y are the characters not allowed as sent in by the input transform of the field
+2 ;if no special characters sent in, set list to all
NEW I,J
IF '$DATA(Y)
SET Y="-;,=^"
+3 FOR I=1:1:$LENGTH(Y)
IF X[($EXTRACT(Y,I))
SET J=1
+4 QUIT +$GET(J)
CHKMNE(X) ;Input transform to not allow use of standard Lmgr Mnemonics
+1 NEW Y
+2 ;check to make sure mnemonic isn't set to lower case of restricted entries. List Manager is case insensitive
SET Y=$$UP^XLFSTR(X)
+3 IF Y="ADPL"!(Y="DN")!(Y="Q")!(Y="FS")!(Y="GO")!(Y="?")!(Y="??")!(Y="LS")!(Y="+")!(Y="-")!(Y="PL")!(Y="PS")!(Y="RD")!(Y="SL")!(Y="<")!(Y=">")!(Y="UP")!(Y="PI")!(Y="CWAD")!(Y="TD")!(Y="EX")
QUIT 1
+4 QUIT 0
