- ORDD101 ; slc/KCM - Build menus in XUTL (file 101) ;10/31/91 14:53 ;
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997
- SET ;From: Cross reference in file 101, field 99 Entry: DA Exit: DA
- ;NOTE: Lock ^ORD(101,DA) when calling
- Q:$D(^ORD(101,DA,0))[0
- I $D(^ORD(101,DA,99)),$D(^XUTL("XQORM",DA_";ORD(101,",0)),$P(^ORD(101,DA,99),"^")=$P(^XUTL("XQORM",DA_";ORD(101,",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_";ORD(101,","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=$S($L($P(X,"^",6)):$P(X,"^",6),1:$P(^ORD(101,+X,0),"^",2)),X1=$TR(X1,",=;-"," ") Q:'$L(X1)
- . . . S ^XUTL("XQORM",DA_";ORD(101,",ORPOS,0)=S2_"^"_+X_"^"_X1_"^"_$P(X,"^",2)_"^"_$P(X,"^",5)
- . . . I $P(X,"^",5)'="O" D
- . . . . S ^XUTL("XQORM",DA_";ORD(101,","B",$$UP(X1),ORPOS)=""
- . . . . I $L($P(X,"^",2)) S ^XUTL("XQORM",DA_";ORD(101,","B",$$UP($P(X,"^",2)),ORPOS)=1
- . . . . I $D(^ORD(101,+X,2)) S X1=0 F S X1=$O(^ORD(101,+X,2,X1)) Q:X1'>0 I $L($G(^ORD(101,+X,2,X1,0))) S ^XUTL("XQORM",DA_";ORD(101,","B",$$UP($P(^(0),"^")),ORPOS)=1
- S X=$H,^XUTL("XQORM",DA_";ORD(101,",0)=X,^ORD(101,DA,99)=X
- 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_";ORD(101,") Q
- REDO ;From: File 101, Field 7 Entry: DA Exit: DA
- N I,X S X=$H I $D(^ORD(101,DA,0)) S ^(99)=X
- F I=0:0 S I=$O(^ORD(101,"AD",DA,I)) Q:I'>0 I $D(^ORD(101,I,0)) S ^(99)=X
- Q
- REDOM ;From: File 101, Field 1.1 Entry: DA(1) Exit: DA(1)
- N I,X S I=0,X=$H
- F S I=$O(^ORD(101,"AD",DA(1),I)) Q:I'>0 I $D(^ORD(101,I,0)) S ^(99)=X
- Q
- REDOX ;From: Subfile 101.01, Fields .01,2,3 Entry: DA(1) Exit: DA(1)
- I $D(^ORD(101,DA(1),0)) S ^(99)=$H Q
- TREE ;Look back up tree to make sure item is not ancestor (input xform)
- ;From: 101.01,.01 101.01,4 100.981,.01 Entry: DA(1),X,ORDDF
- S ORDDA=DA(1) K:X=ORDDA X D TREE1 K ORDDA,ORDDF,ORDD Q
- TREE1 F ORDD=0:0 Q:'$D(X) S ORDD=$O(^ORD(ORDDF,"AD",ORDDA,ORDD)) Q:ORDD'>0 K:ORDD=X X Q:'$D(X) D TREE2
- Q
- TREE2 N ORDDA S ORDDA=ORDD N ORDD D TREE1 Q
- NAME ;CHECK NAMESPACING IN PACKAGE FILE.
- I $E(X,1)="A"!($E(X,1)="Z") S %=1,%1="Local" Q
- F %=4:-1:2 G:$D(^DIC(9.4,"C",$E(X,1,%))) NAMEOK
- I 0
- Q
- NAMEOK S %1=$O(^DIC(9.4,"C",$E(X,1,%),0)) I %1 S:$D(^DIC(9.4,%1,0)) %1=$P(^(0),U) I 1 Q
- I 0 Q
- CHKNAME ;CHECK A NAME, AND DISPLAY APPROPRIATE MESSAGE
- I $D(^ORD(101,"B",X)) D EN^DDIOL("Duplicate names not allowed.") K X Q
- D NAME E D EN^DDIOL("Not a known package or a local namespace.") Q
- I '$D(DIFROM) D EN^DDIOL("Located in the "_$E(X,1,%)_" ("_%1_") namespace.")
- Q
- TEST W !,"Enter a name, and the computer will respond with the namespace to which",!,"that name belongs. It does this by looking at the package file.",!!
- T1 R !,"NAME: ",X:DTIME," " Q:X="" D CHKNAME G T1
- ORDD101 ; slc/KCM - Build menus in XUTL (file 101) ;10/31/91 14:53 ;
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997
- SET ;From: Cross reference in file 101, field 99 Entry: DA Exit: DA
- +1 ;NOTE: Lock ^ORD(101,DA) when calling
- +2 IF $DATA(^ORD(101,DA,0))[0
- QUIT
- +3 IF $DATA(^ORD(101,DA,99))
- IF $DATA(^XUTL("XQORM",DA_";ORD(101,",0))
- IF $PIECE(^ORD(101,DA,99),"^")=$PIECE(^XUTL("XQORM",DA_";ORD(101,",0),"^")
- QUIT
- +4 NEW ORCOL,ORCCOL,ORROW,ORCROW,ORPOS,ORTOT,S1,S2,X,X1
- +5 KILL ^TMP("XQORM",$JOB)
- DO KILL
- +6 SET ORCOL=1
- IF $PIECE($GET(^ORD(101,DA,4)),"^")>0
- SET ORCOL=80\$PIECE(^(4),"^",1)
- +7 SET ^XUTL("XQORM",DA_";ORD(101,","COL")=ORCOL
- SET (ORTOT,S2)=0
- +8 FOR
- SET S2=$ORDER(^ORD(101,DA,10,S2))
- IF S2'>0
- QUIT
- Begin DoDot:1
- +9 SET X=^ORD(101,DA,10,S2,0)
- +10 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))
- +11 SET ^TMP("XQORM",$JOB,X,S2)=""
- SET ORTOT=ORTOT+1
- End DoDot:1
- +12 SET ORROW=ORTOT\ORCOL+$SELECT(ORTOT#ORCOL:1,1:0)
- SET ORCCOL=1
- SET ORCROW=0
- SET S1=""
- +13 ;S1 is sequence (#,M_,Z_)
- FOR
- SET S1=$ORDER(^TMP("XQORM",$JOB,S1))
- IF S1=""
- QUIT
- SET S2=0
- Begin DoDot:1
- +14 ;S2 is IEN of item multiple
- FOR
- SET S2=$ORDER(^TMP("XQORM",$JOB,S1,S2))
- IF S2'>0
- QUIT
- Begin DoDot:2
- +15 ;X is the item node
- SET X=^ORD(101,DA,10,S2,0)
- +16 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
- +17 SET ORCROW=ORCROW+1
- IF ORCROW>ORROW
- SET ORCROW=1
- SET ORCCOL=ORCCOL+1
- +18 SET ORPOS=ORCROW+(ORCCOL/10)
- Begin DoDot:3
- +19 SET X1=$SELECT($LENGTH($PIECE(X,"^",6)):$PIECE(X,"^",6),1:$PIECE(^ORD(101,+X,0),"^",2))
- SET X1=$TRANSLATE(X1,",=;-"," ")
- IF '$LENGTH(X1)
- QUIT
- +20 SET ^XUTL("XQORM",DA_";ORD(101,",ORPOS,0)=S2_"^"_+X_"^"_X1_"^"_$PIECE(X,"^",2)_"^"_$PIECE(X,"^",5)
- +21 IF $PIECE(X,"^",5)'="O"
- Begin DoDot:4
- +22 SET ^XUTL("XQORM",DA_";ORD(101,","B",$$UP(X1),ORPOS)=""
- +23 IF $LENGTH($PIECE(X,"^",2))
- SET ^XUTL("XQORM",DA_";ORD(101,","B",$$UP($PIECE(X,"^",2)),ORPOS)=1
- +24 IF $DATA(^ORD(101,+X,2))
- SET X1=0
- FOR
- SET X1=$ORDER(^ORD(101,+X,2,X1))
- IF X1'>0
- QUIT
- IF $LENGTH($GET(^ORD(101,+X,2,X1,0)))
- SET ^XUTL("XQORM",DA_";ORD(101,","B",$$UP($PIECE(^(0),"^")),ORPOS)=1
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +25 SET X=$HOROLOG
- SET ^XUTL("XQORM",DA_";ORD(101,",0)=X
- SET ^ORD(101,DA,99)=X
- +26 KILL ^TMP("XQORM",$JOB)
- +27 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_";ORD(101,")
- QUIT
- REDO ;From: File 101, Field 7 Entry: DA Exit: DA
- +1 NEW I,X
- SET X=$HOROLOG
- IF $DATA(^ORD(101,DA,0))
- SET ^(99)=X
- +2 FOR I=0:0
- SET I=$ORDER(^ORD(101,"AD",DA,I))
- IF I'>0
- QUIT
- IF $DATA(^ORD(101,I,0))
- SET ^(99)=X
- +3 QUIT
- REDOM ;From: File 101, Field 1.1 Entry: DA(1) Exit: DA(1)
- +1 NEW I,X
- SET I=0
- SET X=$HOROLOG
- +2 FOR
- SET I=$ORDER(^ORD(101,"AD",DA(1),I))
- IF I'>0
- QUIT
- IF $DATA(^ORD(101,I,0))
- SET ^(99)=X
- +3 QUIT
- REDOX ;From: Subfile 101.01, Fields .01,2,3 Entry: DA(1) Exit: DA(1)
- +1 IF $DATA(^ORD(101,DA(1),0))
- SET ^(99)=$HOROLOG
- QUIT
- TREE ;Look back up tree to make sure item is not ancestor (input xform)
- +1 ;From: 101.01,.01 101.01,4 100.981,.01 Entry: DA(1),X,ORDDF
- +2 SET ORDDA=DA(1)
- IF X=ORDDA
- KILL X
- DO TREE1
- KILL ORDDA,ORDDF,ORDD
- QUIT
- TREE1 FOR ORDD=0:0
- IF '$DATA(X)
- QUIT
- SET ORDD=$ORDER(^ORD(ORDDF,"AD",ORDDA,ORDD))
- IF ORDD'>0
- QUIT
- IF ORDD=X
- KILL X
- IF '$DATA(X)
- QUIT
- DO TREE2
- +1 QUIT
- TREE2 NEW ORDDA
- SET ORDDA=ORDD
- NEW ORDD
- DO TREE1
- QUIT
- NAME ;CHECK NAMESPACING IN PACKAGE FILE.
- +1 IF $EXTRACT(X,1)="A"!($EXTRACT(X,1)="Z")
- SET %=1
- SET %1="Local"
- QUIT
- +2 FOR %=4:-1:2
- IF $DATA(^DIC(9.4,"C",$EXTRACT(X,1,%)))
- GOTO NAMEOK
- +3 IF 0
- +4 QUIT
- NAMEOK SET %1=$ORDER(^DIC(9.4,"C",$EXTRACT(X,1,%),0))
- IF %1
- IF $DATA(^DIC(9.4,%1,0))
- SET %1=$PIECE(^(0),U)
- IF 1
- QUIT
- +1 IF 0
- QUIT
- CHKNAME ;CHECK A NAME, AND DISPLAY APPROPRIATE MESSAGE
- +1 IF $DATA(^ORD(101,"B",X))
- DO EN^DDIOL("Duplicate names not allowed.")
- KILL X
- QUIT
- +2 DO NAME
- IF '$TEST
- DO EN^DDIOL("Not a known package or a local namespace.")
- QUIT
- +3 IF '$DATA(DIFROM)
- DO EN^DDIOL("Located in the "_$EXTRACT(X,1,%)_" ("_%1_") namespace.")
- +4 QUIT
- TEST WRITE !,"Enter a name, and the computer will respond with the namespace to which",!,"that name belongs. It does this by looking at the package file.",!!
- T1 READ !,"NAME: ",X:DTIME," "
- IF X=""
- QUIT
- DO CHKNAME
- GOTO T1