ORUS2 ; slc/KCM - Process Selected Items ;11/7/90 18:21 ;
;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997
ADD I $D(@(ORUS_"$P(ORITM,""^""),0)")) S X=$P(^(0),"^"),ORTOT=ORTOT+1,Y=Y+1,Y(Y)=$P(ORITM,"^")_"^"_X_"^"_$P(ORITM,"^",2)_"^"_ORWRK_ORFLG,Y("B",$P(ORITM,"^"),Y)=""
Q
SUB S ORBUF=$O(Y("B",+ORITM,"")) I $L(ORBUF) K Y(ORBUF),Y("B",+ORITM,ORBUF) S ORTOT=ORTOT-1
Q
ADD9 S ORT9=ORT9+1 S:+ORITM=999 ORMOR=1,P=P+1 I +ORITM=998 S OROTHER=1,OR9Y=OR9Y+1,OR9Y(OR9Y)=$P(OR9(998),"^"),OR9Y("B",998,OR9Y)=""
I +ORITM'=999,+ORITM'=998 S OR9Y=OR9Y+1,OR9Y(OR9Y)=$P(OR9(+ORITM),"^"),OR9Y("B",+ORITM,OR9Y)="" S X=OR9(+ORITM),X=$P(X,"^",3,99) I $L(X) X X
Q
SUB9 W " ""'"" NOT ALLOWED ON '900' ITEMS." S ORERR=1,ORSEL="?" Q
S ORT9=ORT9-1 S:+ORITM=999 ORMOR=0 I +ORITM=998 S OROTHER=0,ORBUF=$O(OR9Y("B",998,"")) I $L(ORBUF) K OR9Y(ORBUF),OR9Y("B",+ORITM,ORBUF)
I +ORITM'=999,+ORITM'=998 S X=OR9(+ORITM),X=$P(X,"^",4) X:$L(X) X S ORBUF=$O(OR9Y("B",+ORITM,"")) K:$L(ORBUF) OR9Y(ORBUF),OR9Y("B",+ORITM,ORBUF)
Q
PROC I '$L(ORITM) S ORERR=1 Q
I ORITM=-1 D ALL Q
I $P(ORITM,"^",3)=9 D @$S(ORSUB:"SUB9",1:"ADD9") Q
D @$S(ORSUB:"SUB",1:"ADD")
Q
ALL I 'OREN S A="" F I=0:0 S A=$O(@(OROD_"A)")) Q:A="" S B="" F I=0:0 S B=$O(@(OROD_"A,B)")) Q:B="" I $D(@(ORUS_"B,0)")) S ORDA=B X ORSC I $T,$D(@(ORUS_"B,0)")) X ORWR I $L(X) S ORITM=ORDA_"^"_X D @$S(ORSUB:"SUB",1:"ADD")
I OREN S B=0 F I=0:0 S B=$O(@(ORUS_"B)")) Q:B="" I $D(@(ORUS_"B,0)")) S ORDA=B X ORSC I $T,$D(@(ORUS_"B,0)")) X ORWR I $L(X) S ORITM=ORDA_"^"_X D @$S(ORSUB:"SUB",1:"ADD")
Q
EN Q:$D(^XUTL("OR",$J,"ORU")) ;K ^XUTL("OR",$J,"ORU")
S ORDA=0 I $D(ORUS("M")) S X=ORUS("M"),ORND=$P(X,";",1),ORPC=$P(X,";",2)
F I=0:0 S ORDA=$O(@(ORUS_"ORDA)")) Q:ORDA="" I $D(^(ORDA,0)) X ORSC I $T,$D(@(ORUS_"ORDA,0)")) X ORWR S ^XUTL("OR",$J,"ORU",X,ORDA)="" I $D(ORUS("M")),$D(@(ORUS_"ORDA,ORND)")) S X=$P(^(ORND),"^",ORPC) I $L(X) S ^XUTL("OR",$J,"ORU",X,ORDA)=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORUS2 1936 printed Dec 13, 2024@02:34:33 Page 2
ORUS2 ; slc/KCM - Process Selected Items ;11/7/90 18:21 ;
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997
ADD IF $DATA(@(ORUS_"$P(ORITM,""^""),0)"))
SET X=$PIECE(^(0),"^")
SET ORTOT=ORTOT+1
SET Y=Y+1
SET Y(Y)=$PIECE(ORITM,"^")_"^"_X_"^"_$PIECE(ORITM,"^",2)_"^"_ORWRK_ORFLG
SET Y("B",$PIECE(ORITM,"^"),Y)=""
+1 QUIT
SUB SET ORBUF=$ORDER(Y("B",+ORITM,""))
IF $LENGTH(ORBUF)
KILL Y(ORBUF),Y("B",+ORITM,ORBUF)
SET ORTOT=ORTOT-1
+1 QUIT
ADD9 SET ORT9=ORT9+1
if +ORITM=999
SET ORMOR=1
SET P=P+1
IF +ORITM=998
SET OROTHER=1
SET OR9Y=OR9Y+1
SET OR9Y(OR9Y)=$PIECE(OR9(998),"^")
SET OR9Y("B",998,OR9Y)=""
+1 IF +ORITM'=999
IF +ORITM'=998
SET OR9Y=OR9Y+1
SET OR9Y(OR9Y)=$PIECE(OR9(+ORITM),"^")
SET OR9Y("B",+ORITM,OR9Y)=""
SET X=OR9(+ORITM)
SET X=$PIECE(X,"^",3,99)
IF $LENGTH(X)
XECUTE X
+2 QUIT
SUB9 WRITE " ""'"" NOT ALLOWED ON '900' ITEMS."
SET ORERR=1
SET ORSEL="?"
QUIT
+1 SET ORT9=ORT9-1
if +ORITM=999
SET ORMOR=0
IF +ORITM=998
SET OROTHER=0
SET ORBUF=$ORDER(OR9Y("B",998,""))
IF $LENGTH(ORBUF)
KILL OR9Y(ORBUF),OR9Y("B",+ORITM,ORBUF)
+2 IF +ORITM'=999
IF +ORITM'=998
SET X=OR9(+ORITM)
SET X=$PIECE(X,"^",4)
if $LENGTH(X)
XECUTE X
SET ORBUF=$ORDER(OR9Y("B",+ORITM,""))
if $LENGTH(ORBUF)
KILL OR9Y(ORBUF),OR9Y("B",+ORITM,ORBUF)
+3 QUIT
PROC IF '$LENGTH(ORITM)
SET ORERR=1
QUIT
+1 IF ORITM=-1
DO ALL
QUIT
+2 IF $PIECE(ORITM,"^",3)=9
DO @$SELECT(ORSUB:"SUB9",1:"ADD9")
QUIT
+3 DO @$SELECT(ORSUB:"SUB",1:"ADD")
+4 QUIT
ALL IF 'OREN
SET A=""
FOR I=0:0
SET A=$ORDER(@(OROD_"A)"))
if A=""
QUIT
SET B=""
FOR I=0:0
SET B=$ORDER(@(OROD_"A,B)"))
if B=""
QUIT
IF $DATA(@(ORUS_"B,0)"))
SET ORDA=B
XECUTE ORSC
IF $TEST
IF $DATA(@(ORUS_"B,0)"))
XECUTE ORWR
IF $LENGTH(X)
SET ORITM=ORDA_"^"_X
DO @$SELECT(ORSUB:"SUB",1:"ADD")
+1 IF OREN
SET B=0
FOR I=0:0
SET B=$ORDER(@(ORUS_"B)"))
if B=""
QUIT
IF $DATA(@(ORUS_"B,0)"))
SET ORDA=B
XECUTE ORSC
IF $TEST
IF $DATA(@(ORUS_"B,0)"))
XECUTE ORWR
IF $LENGTH(X)
SET ORITM=ORDA_"^"_X
DO @$SELECT(ORSUB:"SUB",1:"ADD")
+2 QUIT
EN ;K ^XUTL("OR",$J,"ORU")
if $DATA(^XUTL("OR",$JOB,"ORU"))
QUIT
+1 SET ORDA=0
IF $DATA(ORUS("M"))
SET X=ORUS("M")
SET ORND=$PIECE(X,";",1)
SET ORPC=$PIECE(X,";",2)
+2 FOR I=0:0
SET ORDA=$ORDER(@(ORUS_"ORDA)"))
if ORDA=""
QUIT
IF $DATA(^(ORDA,0))
XECUTE ORSC
IF $TEST
IF $DATA(@(ORUS_"ORDA,0)"))
XECUTE ORWR
SET ^XUTL("OR",$JOB,"ORU",X,ORDA)=""
IF $DATA(ORUS("M"))
IF $DATA(@(ORUS_"ORDA,ORND)"))
SET X=$PIECE(^(ORND),"^",ORPC)
IF $LENGTH(X)
SET ^XUTL("OR",$JOB,"ORU",X,ORDA)=1
+3 QUIT
