ORUS1 ; slc/KCM - Select Items from List ; 12/4/09 4:59pm
;;3.0;ORDER ENTRY/RESULTS REPORTING;**322**;Dec 17, 1997 ;Build 15
;
;DJE/VM *322 added Q:ORMOR to avoid processing of "+" index
;EN F I=0:0 D INIT R X:DTIME S:'$T X="^" S:X["^"&(X'="^^") DUOUT=1 S:'$L(X) X=ORDFLT S:X["^^" DIROUT=1 S:X["^" Y=-1 Q:'$L(X)!(X["^")!(+$G(ORNOSEL)=1&(X'["?")&(ORUS(0)'["O")) D CHK Q:ORQUIT Q:ORBACK Q:(ORTOT+ORT9)>0 W:ORSEL'["?" $C(7)," ??"
EN F I=0:0 D Q:'$L(X)!(X["^")!(+$G(ORNOSEL)=1&(X'["?")&(ORUS(0)'["O")) D CHK Q:ORQUIT Q:ORBACK Q:ORMOR Q:(ORTOT+ORT9)>0 W:ORSEL'["?" $C(7)," ??"
. D INIT R X:DTIME S:'$T X="^" S:X["^"&(X'="^^") DUOUT=1 S:'$L(X) X=ORDFLT S:X["^^" DIROUT=1 S:X["^" Y=-1
Q:ORQUIT Q:ORBACK K Y("B"),OR9Y("B") Q:'$L(X)!(X["^")
S:Y>0 (Y,Y(0))=ORTOT
W " " S ORTTAB=$X,J=1 I Y>0 K ^DISV(DUZ,ORUS) D SDISV S ^DISV(DUZ,ORUS,0)=X,I=0 F J=1:1 S I=$O(Y(I)) Q:I="" S X=$P(Y(I),"^",3),^DISV(DUZ,ORUS)=+Y(I),^DISV(DUZ,ORUS,J)=X W:($X+$L(X))>(IOM-4) !?ORTTAB W X," "
I OR9Y S I=0 F J=J:1 S I=$O(OR9Y(I)) Q:I="" S X=$P(OR9Y(I),"^"),^DISV(DUZ,ORUS,J)=X W:($X+$L(X))>(IOM-4) !?ORTTAB W X," "
Q
CHK ;
I X="+",'$D(OR9("+")) W !," THIS IS THE END OF THE LIST" S ORSEL="?" Q ;DJE/VM *322 replace 999 with +
S ORSEL=X,Y=0 ;DJE/VM *322 removed S:X="+" X=999
I X["?" D EN^ORUS3 Q
I X="-" S ORBACK=1,P=$S(P=0:0,1:P-1) Q
I X="+" S ORMOR=1,P=P+1 Q ;DJE/VM *322 avoid processing just go to the next page.
I X=" " D SPAC Q:+$G(ORTOT)>0
S X=$$UPPER^ORU(X)
I ORUS(0)["S",X[",",$D(ORUS("ALT")),ORTOT+ORT9'>0,$L(ORSEL) X ORUS("ALT") S:$T ORQUIT=1 Q
I ORUS(0)["S",X[","!(X["-")!(X["'") D SING Q
F ORSEQ=1:1:$L(ORSEL,",") Q:ORERR S X=$P(ORSEL,",",ORSEQ) D SET D:X["-" RNG Q:ORERR S W=X F K=1:1:$L(W,",") S ORWRK=$P(W,",",K) D EAT I $L(ORWRK) D LOOK^ORUS4 Q:ORERR D PROC^ORUS2 Q:ORERR
I $L(ORUS(0),"^")=2,(ORTOT>+$P(ORUS(0),"^",2)) S ORERR=1 W " ONLY "_+$P(ORUS(0),"^",2)_" ITEMS ALLOWED"
S:ORERR (ORTOT,ORT9)=0
I $D(ORUS("ALT")),ORTOT+ORT9'>0,$L(ORSEL) X ORUS("ALT") S:$T ORQUIT=1 Q
Q
SET S (ORERR,ORSUB)=0 S:$E(X)["'" ORSUB=1,X=$P(X,"'",2) S:$E(X)["*" X=$P(X,"*",2),X=$S(X["=":X_"*",1:X_"=*") S ORPC=X,ORFLG=$P(X,"=",2),X=$P(X,"=") S:$L(ORFLG) ORFLG="="_ORFLG
Q
SPAC S ORERR=1 Q:'$D(^DISV(DUZ,ORUS,0)) D SDISV Q:^DISV(DUZ,ORUS,0)'=X
S ORSEQ=0 F I=0:0 S ORSEQ=$O(^DISV(DUZ,ORUS,ORSEQ)) Q:ORSEQ'>0 S (X,ORWRK)=^(ORSEQ) D SET,LOOK^ORUS4,PROC^ORUS2
S ORERR=0 Q
SDISV S X=$S($D(ORUS("L")):ORUS("L"),1:"")_"^"_$S($D(ORUS("S")):ORUS("S"),1:"")_"^"_$S(ORUS(0)["S":1,1:0) ;_"^"_$S(ORUS(0)["A":1,1:0)
Q
RNG Q:X["E" I X'?.N1"-".N!($P(X,"-",1)'<$P(X,"-",2)) S ORERR=1 Q
S W="" F J=$P(X,"-",1):1:$P(X,"-",2) S W=W_J_"," I $L(W)>245 W $C(7)," RANGE OF NUMBERS TOO LARGE." S ORERR=1,ORSEL="?" Q
S X=W
Q
SING W $C(7)," -- ONLY ONE SELECTION ALLOWED." S ORSEL="?" Q
EAT F I=0:0 Q:$E(ORWRK)]" " Q:'$L(ORWRK) S ORWRK=$E(ORWRK,2,999)
F I=0:0 Q:$E(ORWRK,$L(ORWRK))]" " Q:'$L(ORWRK) S ORWRK=$E(ORWRK,1,$L(ORWRK)-1)
F J=1:1:$L(ORWRK) I $A(ORWRK,J)'>31 S ORWRK="" Q
Q
INIT K Y,OR9Y,ORSEL S (Y,OR9Y,ORBACK,ORERR,ORQUIT,ORTOT,ORT9)=0
S ORPRMT=$S($D(ORUS("A")):ORUS("A"),+ORFN:"Select "_ORFNM_": ",1:"Select Item: ")
S ORDFLT=$S($D(ORUS("B")):ORUS("B"),1:""),ORMOR=0
W !!,ORPRMT,$S($L(ORDFLT):ORDFLT_"// ",1:"")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORUS1 3284 printed Apr 09, 2024@21:39:40 Page 2
ORUS1 ; slc/KCM - Select Items from List ; 12/4/09 4:59pm
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**322**;Dec 17, 1997 ;Build 15
+2 ;
+3 ;DJE/VM *322 added Q:ORMOR to avoid processing of "+" index
+4 ;EN F I=0:0 D INIT R X:DTIME S:'$T X="^" S:X["^"&(X'="^^") DUOUT=1 S:'$L(X) X=ORDFLT S:X["^^" DIROUT=1 S:X["^" Y=-1 Q:'$L(X)!(X["^")!(+$G(ORNOSEL)=1&(X'["?")&(ORUS(0)'["O")) D CHK Q:ORQUIT Q:ORBACK Q:(ORTOT+ORT9)>0 W:ORSEL'["?" $C(7)," ??"
EN FOR I=0:0
Begin DoDot:1
+1 DO INIT
READ X:DTIME
if '$TEST
SET X="^"
if X["^"&(X'="^^")
SET DUOUT=1
if '$LENGTH(X)
SET X=ORDFLT
if X["^^"
SET DIROUT=1
if X["^"
SET Y=-1
End DoDot:1
if '$LENGTH(X)!(X["^")!(+$GET(ORNOSEL)=1&(X'["?")&(ORUS(0)'["O"))
QUIT
DO CHK
if ORQUIT
QUIT
if ORBACK
QUIT
if ORMOR
QUIT
if (ORTOT+ORT9)>0
QUIT
if ORSEL'["?"
WRITE $CHAR(7)," ??"
+2 if ORQUIT
QUIT
if ORBACK
QUIT
KILL Y("B"),OR9Y("B")
if '$LENGTH(X)!(X["^")
QUIT
+3 if Y>0
SET (Y,Y(0))=ORTOT
+4 WRITE " "
SET ORTTAB=$X
SET J=1
IF Y>0
KILL ^DISV(DUZ,ORUS)
DO SDISV
SET ^DISV(DUZ,ORUS,0)=X
SET I=0
FOR J=1:1
SET I=$ORDER(Y(I))
if I=""
QUIT
SET X=$PIECE(Y(I),"^",3)
SET ^DISV(DUZ,ORUS)=+Y(I)
SET ^DISV(DUZ,ORUS,J)=X
if ($X+$LENGTH(X))>(IOM-4)
WRITE !?ORTTAB
WRITE X," "
+5 IF OR9Y
SET I=0
FOR J=J:1
SET I=$ORDER(OR9Y(I))
if I=""
QUIT
SET X=$PIECE(OR9Y(I),"^")
SET ^DISV(DUZ,ORUS,J)=X
if ($X+$LENGTH(X))>(IOM-4)
WRITE !?ORTTAB
WRITE X," "
+6 QUIT
CHK ;
+1 ;DJE/VM *322 replace 999 with +
IF X="+"
IF '$DATA(OR9("+"))
WRITE !," THIS IS THE END OF THE LIST"
SET ORSEL="?"
QUIT
+2 ;DJE/VM *322 removed S:X="+" X=999
SET ORSEL=X
SET Y=0
+3 IF X["?"
DO EN^ORUS3
QUIT
+4 IF X="-"
SET ORBACK=1
SET P=$SELECT(P=0:0,1:P-1)
QUIT
+5 ;DJE/VM *322 avoid processing just go to the next page.
IF X="+"
SET ORMOR=1
SET P=P+1
QUIT
+6 IF X=" "
DO SPAC
if +$GET(ORTOT)>0
QUIT
+7 SET X=$$UPPER^ORU(X)
+8 IF ORUS(0)["S"
IF X[","
IF $DATA(ORUS("ALT"))
IF ORTOT+ORT9'>0
IF $LENGTH(ORSEL)
XECUTE ORUS("ALT")
if $TEST
SET ORQUIT=1
QUIT
+9 IF ORUS(0)["S"
IF X[","!(X["-")!(X["'")
DO SING
QUIT
+10 FOR ORSEQ=1:1:$LENGTH(ORSEL,",")
if ORERR
QUIT
SET X=$PIECE(ORSEL,",",ORSEQ)
DO SET
if X["-"
DO RNG
if ORERR
QUIT
SET W=X
FOR K=1:1:$LENGTH(W,",")
SET ORWRK=$PIECE(W,",",K)
DO EAT
IF $LENGTH(ORWRK)
DO LOOK^ORUS4
if ORERR
QUIT
DO PROC^ORUS2
if ORERR
QUIT
+11 IF $LENGTH(ORUS(0),"^")=2
IF (ORTOT>+$PIECE(ORUS(0),"^",2))
SET ORERR=1
WRITE " ONLY "_+$PIECE(ORUS(0),"^",2)_" ITEMS ALLOWED"
+12 if ORERR
SET (ORTOT,ORT9)=0
+13 IF $DATA(ORUS("ALT"))
IF ORTOT+ORT9'>0
IF $LENGTH(ORSEL)
XECUTE ORUS("ALT")
if $TEST
SET ORQUIT=1
QUIT
+14 QUIT
SET SET (ORERR,ORSUB)=0
if $EXTRACT(X)["'"
SET ORSUB=1
SET X=$PIECE(X,"'",2)
if $EXTRACT(X)["*"
SET X=$PIECE(X,"*",2)
SET X=$SELECT(X["=":X_"*",1:X_"=*")
SET ORPC=X
SET ORFLG=$PIECE(X,"=",2)
SET X=$PIECE(X,"=")
if $LENGTH(ORFLG)
SET ORFLG="="_ORFLG
+1 QUIT
SPAC SET ORERR=1
if '$DATA(^DISV(DUZ,ORUS,0))
QUIT
DO SDISV
if ^DISV(DUZ,ORUS,0)'=X
QUIT
+1 SET ORSEQ=0
FOR I=0:0
SET ORSEQ=$ORDER(^DISV(DUZ,ORUS,ORSEQ))
if ORSEQ'>0
QUIT
SET (X,ORWRK)=^(ORSEQ)
DO SET
DO LOOK^ORUS4
DO PROC^ORUS2
+2 SET ORERR=0
QUIT
SDISV ;_"^"_$S(ORUS(0)["A":1,1:0)
SET X=$SELECT($DATA(ORUS("L")):ORUS("L"),1:"")_"^"_$SELECT($DATA(ORUS("S")):ORUS("S"),1:"")_"^"_$SELECT(ORUS(0)["S":1,1:0)
+1 QUIT
RNG if X["E"
QUIT
IF X'?.N1"-".N!($PIECE(X,"-",1)'<$PIECE(X,"-",2))
SET ORERR=1
QUIT
+1 SET W=""
FOR J=$PIECE(X,"-",1):1:$PIECE(X,"-",2)
SET W=W_J_","
IF $LENGTH(W)>245
WRITE $CHAR(7)," RANGE OF NUMBERS TOO LARGE."
SET ORERR=1
SET ORSEL="?"
QUIT
+2 SET X=W
+3 QUIT
SING WRITE $CHAR(7)," -- ONLY ONE SELECTION ALLOWED."
SET ORSEL="?"
QUIT
EAT FOR I=0:0
if $EXTRACT(ORWRK)]" "
QUIT
if '$LENGTH(ORWRK)
QUIT
SET ORWRK=$EXTRACT(ORWRK,2,999)
+1 FOR I=0:0
if $EXTRACT(ORWRK,$LENGTH(ORWRK))]" "
QUIT
if '$LENGTH(ORWRK)
QUIT
SET ORWRK=$EXTRACT(ORWRK,1,$LENGTH(ORWRK)-1)
+2 FOR J=1:1:$LENGTH(ORWRK)
IF $ASCII(ORWRK,J)'>31
SET ORWRK=""
QUIT
+3 QUIT
INIT KILL Y,OR9Y,ORSEL
SET (Y,OR9Y,ORBACK,ORERR,ORQUIT,ORTOT,ORT9)=0
+1 SET ORPRMT=$SELECT($DATA(ORUS("A")):ORUS("A"),+ORFN:"Select "_ORFNM_": ",1:"Select Item: ")
+2 SET ORDFLT=$SELECT($DATA(ORUS("B")):ORUS("B"),1:"")
SET ORMOR=0
+3 WRITE !!,ORPRMT,$SELECT($LENGTH(ORDFLT):ORDFLT_"// ",1:"")
+4 QUIT
