ORGUEM1 ; slc/KCM - Build menu in seq #, name format ;2/5/92 17:16;
;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997
SET(DA) ;From: ORGUEM Entry: DA Exit: DA
I $L($G(^ORD(101,DA,99))),$P($G(^(99)),"^")=$P($G(^XUTL("XQORM",DA_";"_$J,0)),"^") Q
N ORCOL,ORCCOL,ORROW,ORCROW,ORPOS,ORTOT,S1,S2,X,X1
K ^TMP("XQORM",$J) D KILL
S ORCOL=1 I $P($G(^ORD(101,DA,4)),"^")>0 S ORCOL=80\$P(^(4),"^",1)
S ^XUTL("XQORM",DA_";"_$J,"COL")=ORCOL,(ORTOT,S2)=0
F S S2=$O(^ORD(101,DA,10,S2)) Q:S2'>0 D
. S X=^ORD(101,DA,10,S2,0)
. S X=$S(+$P(X,"^",3):+$P(X,"^",3),+$P(X,"^",2):+$P(X,"^",2),$L($P(X,"^",2)):"M"_$P(X,"^",2),1:"Z"_$P(^ORD(101,+X,0),"^",2))
. S ^TMP("XQORM",$J,X,S2)="",ORTOT=ORTOT+1
S ORROW=ORTOT\ORCOL+$S(ORTOT#ORCOL:1,1:0),ORCCOL=1,ORCROW=0,S1=""
F S S1=$O(^TMP("XQORM",$J,S1)) Q:S1="" S S2=0 D ;S1 is sequence (#,M_,Z_)
. F S S2=$O(^TMP("XQORM",$J,S1,S2)) Q:S2'>0 D ;S2 is IEN of item multiple
. . S X=^ORD(101,DA,10,S2,0) ;X is the item node
. . I '$D(^ORD(101,+X,0)) K ^ORD(101,DA,10,S2),^("B",+X,S2) S $P(^ORD(101,DA,10,0),"^",3,4)=S2_"^"_($P(^ORD(101,DA,10,0),"^",4)-1) Q
. . S ORCROW=ORCROW+1 I ORCROW>ORROW S ORCROW=1,ORCCOL=ORCCOL+1
. . S ORPOS=ORCROW+(ORCCOL/10) D
. . . S X1=$TR($P(^ORD(101,+X,0),"^"),",=;-"," ") Q:'$L(X1)
. . . S ^XUTL("XQORM",DA_";"_$J,ORPOS,0)=S2_"^"_+X_"^"_$E(X1,1,80\ORCOL-5)_"^"_$P(X,"^",3)
. . . S ^XUTL("XQORM",DA_";"_$J,"B",$$UP(X1),ORPOS)=""
. . . I $L($P(X,"^",3)) S ^XUTL("XQORM",DA_";"_$J,"B",$$UP($P(X,"^",3)),ORPOS)=1
S ^XUTL("XQORM",DA_";"_$J,0)=$G(^ORD(101,DA,99))
K ^TMP("XQORM",$J)
Q
UP(X) ;Convert X to upper case
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
KILL ;From: File 101, Field 99 Entry: DA Exit: DA
K ^XUTL("XQORM",DA_";"_$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORGUEM1 1810 printed Dec 13, 2024@02:30:53 Page 2
ORGUEM1 ; slc/KCM - Build menu in seq #, name format ;2/5/92 17:16;
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997
SET(DA) ;From: ORGUEM Entry: DA Exit: DA
+1 IF $LENGTH($GET(^ORD(101,DA,99)))
IF $PIECE($GET(^(99)),"^")=$PIECE($GET(^XUTL("XQORM",DA_";"_$JOB,0)),"^")
QUIT
+2 NEW ORCOL,ORCCOL,ORROW,ORCROW,ORPOS,ORTOT,S1,S2,X,X1
+3 KILL ^TMP("XQORM",$JOB)
DO KILL
+4 SET ORCOL=1
IF $PIECE($GET(^ORD(101,DA,4)),"^")>0
SET ORCOL=80\$PIECE(^(4),"^",1)
+5 SET ^XUTL("XQORM",DA_";"_$JOB,"COL")=ORCOL
SET (ORTOT,S2)=0
+6 FOR
SET S2=$ORDER(^ORD(101,DA,10,S2))
if S2'>0
QUIT
Begin DoDot:1
+7 SET X=^ORD(101,DA,10,S2,0)
+8 SET X=$SELECT(+$PIECE(X,"^",3):+$PIECE(X,"^",3),+$PIECE(X,"^",2):+$PIECE(X,"^",2),$LENGTH($PIECE(X,"^",2)):"M"_$PIECE(X,"^",2),1:"Z"_$PIECE(^ORD(101,+X,0),"^",2))
+9 SET ^TMP("XQORM",$JOB,X,S2)=""
SET ORTOT=ORTOT+1
End DoDot:1
+10 SET ORROW=ORTOT\ORCOL+$SELECT(ORTOT#ORCOL:1,1:0)
SET ORCCOL=1
SET ORCROW=0
SET S1=""
+11 ;S1 is sequence (#,M_,Z_)
FOR
SET S1=$ORDER(^TMP("XQORM",$JOB,S1))
if S1=""
QUIT
SET S2=0
Begin DoDot:1
+12 ;S2 is IEN of item multiple
FOR
SET S2=$ORDER(^TMP("XQORM",$JOB,S1,S2))
if S2'>0
QUIT
Begin DoDot:2
+13 ;X is the item node
SET X=^ORD(101,DA,10,S2,0)
+14 IF '$DATA(^ORD(101,+X,0))
KILL ^ORD(101,DA,10,S2),^("B",+X,S2)
SET $PIECE(^ORD(101,DA,10,0),"^",3,4)=S2_"^"_($PIECE(^ORD(101,DA,10,0),"^",4)-1)
QUIT
+15 SET ORCROW=ORCROW+1
IF ORCROW>ORROW
SET ORCROW=1
SET ORCCOL=ORCCOL+1
+16 SET ORPOS=ORCROW+(ORCCOL/10)
Begin DoDot:3
+17 SET X1=$TRANSLATE($PIECE(^ORD(101,+X,0),"^"),",=;-"," ")
if '$LENGTH(X1)
QUIT
+18 SET ^XUTL("XQORM",DA_";"_$JOB,ORPOS,0)=S2_"^"_+X_"^"_$EXTRACT(X1,1,80\ORCOL-5)_"^"_$PIECE(X,"^",3)
+19 SET ^XUTL("XQORM",DA_";"_$JOB,"B",$$UP(X1),ORPOS)=""
+20 IF $LENGTH($PIECE(X,"^",3))
SET ^XUTL("XQORM",DA_";"_$JOB,"B",$$UP($PIECE(X,"^",3)),ORPOS)=1
End DoDot:3
End DoDot:2
End DoDot:1
+21 SET ^XUTL("XQORM",DA_";"_$JOB,0)=$GET(^ORD(101,DA,99))
+22 KILL ^TMP("XQORM",$JOB)
+23 QUIT
UP(X) ;Convert X to upper case
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
KILL ;From: File 101, Field 99 Entry: DA Exit: DA
+1 KILL ^XUTL("XQORM",DA_";"_$JOB)
+2 QUIT
