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