ORGUEM2 ; slc/KCM - Set Up Formatted Protocol Menus (cont) ;6/1/92 17:08
;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997
;;
;Y is array returned by DIC, it should be call by reference
N DIC,DLAYGO,DA,ORGOK
S DIC="^ORD(101,",DIC(0)=X_"Z",DLAYGO=101,DIC("DR")=""
S DIC("S")="I ""QM""[$P(^(0),""^"",4)"
F D Q:$D(ORGOK)
. D ^DIC
. I DIC(0)["L",$P(Y,"^",2)?1"OR ADD MENU".E D I $D(ORGPOP) S ORGOK=1 Q
. . N X W !!,"NOTE: You should only modify locally namespaced add order menus.",!,"Press RETURN to continue or '^' to exit: "
. . R X:DTIME S:X="^^" DIROUT=1 S:X["^" ORGPOP=1
. . Q
. I Y'>1 S ORGPOP=1,ORGOK=1 Q
. I $P(Y,"^",3) S ORGOK=1 Q
. ; I +$G(ORGMENU)=+Y W !,"Can't copy from the menu you just created." Q
. I "QM"[$P(Y(0),"^",4) S ORGOK=1 Q
. W !,Y(0,0)," is not a menu type."
Q
NEW ; Copy from existing menu or get required fields for new menu
N ORGCOPY
W !,ORGMENU(0,0)," is a new menu."
S ORGCOPY=$$ASK("Do you want to copy an existing menu? ","Yes")
I ORGCOPY="^" S ORGPOP=1 Q
I ORGCOPY D GMENU("AEMQ",.Y) Q:$D(ORGPOP) D
. N %X,%Y,DA,DIK
. S %X="^ORD(101,"_+Y_",",%Y="^ORD(101,"_+ORGMENU_"," D %XY^%RCR
. S $P(^ORD(101,+ORGMENU,0),"^")=ORGMENU(0,0)
. W !,"Please wait. Copying the menu may take a few minutes."
. S DA=+ORGMENU,DIK="^ORD(101," D IX1^DIK
I 'ORGCOPY D
. N DA,DR,DIE
. ;Check namespace to see if can guess default for package name
. S DA=+ORGMENU,DIE="^ORD(101,",DR="1;4//Q;12" D ^DIE
. I $D(Y) S ORGPOP=1
Q
ASK(X,Y) ; Ask a Yes or No question
;X is question, Y is default
S DIR(0)="YAO" S:$D(X) DIR("A")=X S:$D(Y) DIR("B")=Y
D ^DIR
Q Y
FLDS(DA,ORGFLG) ; Edit item fields without updating database
N DR,DIE,DIC
S DIE="^ORD(101,"_+ORGMENU_",10,",DA(1)=+ORGMENU,DR=".01;3;2;6"
D ^DIE S ORGFLG=$D(Y) ; Y undef if no up arrow out
Q
LOOK(X) ; Lookup an item on the menu
N LST,XQORM
D SMENU
S XQORM(0)="A"_$S(ORGMENU("TOG")="R":"h",1:""),XQORM("A")=X
D:ORGMENU("TOG")="R" SET^ORGUEM1(+ORGMENU) D EN^XQORM
S Y=0,LST="" F S Y=$O(Y(Y)) Q:'Y S LST=LST_+Y(Y)_","
Q LST
S XQORM("W")="W:$E(^ORD(101,+$P(X,""^"",2),0),1,8)=""OR GFAKE"" $$INHI W $P(X,""^"",3),$$INLO"
I ORGMENU("TOG")="R" S XQORM=+ORGMENU_";"_$J,XQORM(0)="Dh",XQORM("M")=4 Q
S XQORM=+ORGMENU_";ORD(101,",XQORM(0)="D"
I $L($G(^ORD(101,+ORGMENU,28))) S XQORM("A")=^(28)
I $L($G(^ORD(101,+ORGMENU,29))) S XQORM("B")=^(29)
I $D(^ORD(101,+ORGMENU,4)) S XQORM("M")=$P(^(4),"^",2) S:'XQORM("M") XQORM("M")=5
Q
BLANKS ; Renumber blank line protocols
N COUNT,LIST,ITM,DIE,DIC,DR,DA
W ! ; Checking 'blank line' items
D SEQ^ORGUEM3(+ORGMENU,.LIST)
S COUNT=0,DIE="^ORD(101,"_+ORGMENU_",10,",DA(1)=+ORGMENU
F ITM=1:1:LIST I ^ORD(101,$P(LIST(ITM),"^",2),0)?1"ORB BLANK LINE".E D
. S COUNT=COUNT+1 Q:COUNT>20
. S X=$O(^ORD(101,"B","ORB BLANK LINE"_COUNT,0)) Q:'X Q:X=$P(LIST(ITM),"^",2)
. S DA=+LIST(ITM),DR=".01///`"_X D ^DIE
Q
MOVE ; Resequence items
N ORGIDX,ORGLST,DIR
S ORGLST=$$LOOK("Select item(s) to be resequenced: ")
S DIR(0)="LOA^1:999",DIR("A")="Enter new range of sequence numbers (i.e. 2-8): "
D ^DIR Q:$D(DIRUT)
I $L(ORGLST,",")'=$L(Y,",") D
. I $L(Y,",")=2 F I=1:1:$L(ORGLST,",")-1 S $P(Y,",",I+1)=Y+I
. E D
. . N X1,X2,X3 S X1=$P(Y,","),X2=$P(Y,",",$L(Y,",")-1),X3=(X2-X1)/($L(ORGLST,",")-2)
. . S Y="" F I=1:1:$L(ORGLST,",")-1 S Y=Y_$J(X1,0,2)_",",X1=X1+X3
F ORGIDX=1:1:$L(ORGLST,",")-1 I +$P(ORGLST,",",ORGIDX) D STUF(+$P(ORGLST,",",ORGIDX),3,+$P(Y,",",ORGIDX))
Q
STUF(DA,FLD,VAL) ;Stuff value into field for entry
N DIC,DIE,DR,X,Y
S DIE="^ORD(101,"_+ORGMENU_",10,",DA(1)=+ORGMENU,DR=FLD_"///"_VAL
D ^DIE
Q
USER ; Assign menu to individual users
N DIR,DIC,DIE,DA,DR,ORGTYP
W !,"Individual users may be assigned primary menus of the following types:"
W !!," 1 OE/RR MENU - contains selections like Add Orders, Review Orders, etc."
W !," 2 ADD ORDERS MENU - contains orderable items.",!
S DIR(0)="SOA^1:OE/RR MENU;2:ADD ORDERS MENU"
S DIR("A")="Type of this menu: "
D ^DIR Q:$D(DIRUT)
S ORGTYP=$S(Y=1:100.11,1:100.12)
F D Q:Y'>0
. S DIC="^VA(200,",DIC(0)="AEMQ"
. S DIC("A")="Select user to be assigned this menu: "
. D ^DIC Q:Y'>0
. S DIE=DIC,DA=+Y,DR=ORGTYP_"///"_+ORGMENU
. D ^DIE S Y=1
Q
ORGUEM2 ; slc/KCM - Set Up Formatted Protocol Menus (cont) ;6/1/92 17:08
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997
+2 ;;
+1 ;Y is array returned by DIC, it should be call by reference
+2 NEW DIC,DLAYGO,DA,ORGOK
+3 SET DIC="^ORD(101,"
SET DIC(0)=X_"Z"
SET DLAYGO=101
SET DIC("DR")=""
+4 SET DIC("S")="I ""QM""[$P(^(0),""^"",4)"
+5 FOR
Begin DoDot:1
+6 DO ^DIC
+7 IF DIC(0)["L"
IF $PIECE(Y,"^",2)?1"OR ADD MENU".E
Begin DoDot:2
+8 NEW X
WRITE !!,"NOTE: You should only modify locally namespaced add order menus.",!,"Press RETURN to continue or '^' to exit: "
+9 READ X:DTIME
IF X="^^"
SET DIROUT=1
IF X["^"
SET ORGPOP=1
+10 QUIT
End DoDot:2
IF $DATA(ORGPOP)
SET ORGOK=1
QUIT
+11 IF Y'>1
SET ORGPOP=1
SET ORGOK=1
QUIT
+12 IF $PIECE(Y,"^",3)
SET ORGOK=1
QUIT
+13 ; I +$G(ORGMENU)=+Y W !,"Can't copy from the menu you just created." Q
+14 IF "QM"[$PIECE(Y(0),"^",4)
SET ORGOK=1
QUIT
+15 WRITE !,Y(0,0)," is not a menu type."
End DoDot:1
IF $DATA(ORGOK)
QUIT
+16 QUIT
NEW ; Copy from existing menu or get required fields for new menu
+1 NEW ORGCOPY
+2 WRITE !,ORGMENU(0,0)," is a new menu."
+3 SET ORGCOPY=$$ASK("Do you want to copy an existing menu? ","Yes")
+4 IF ORGCOPY="^"
SET ORGPOP=1
QUIT
+5 IF ORGCOPY
DO GMENU("AEMQ",.Y)
IF $DATA(ORGPOP)
QUIT
Begin DoDot:1
+6 NEW %X,%Y,DA,DIK
+7 SET %X="^ORD(101,"_+Y_","
SET %Y="^ORD(101,"_+ORGMENU_","
DO %XY^%RCR
+8 SET $PIECE(^ORD(101,+ORGMENU,0),"^")=ORGMENU(0,0)
+9 WRITE !,"Please wait. Copying the menu may take a few minutes."
+10 SET DA=+ORGMENU
SET DIK="^ORD(101,"
DO IX1^DIK
End DoDot:1
+11 IF 'ORGCOPY
Begin DoDot:1
+12 NEW DA,DR,DIE
+13 ;Check namespace to see if can guess default for package name
+14 SET DA=+ORGMENU
SET DIE="^ORD(101,"
SET DR="1;4//Q;12"
DO ^DIE
+15 IF $DATA(Y)
SET ORGPOP=1
End DoDot:1
+16 QUIT
ASK(X,Y) ; Ask a Yes or No question
+1 ;X is question, Y is default
+2 SET DIR(0)="YAO"
IF $DATA(X)
SET DIR("A")=X
IF $DATA(Y)
SET DIR("B")=Y
+3 DO ^DIR
+4 QUIT Y
FLDS(DA,ORGFLG) ; Edit item fields without updating database
+1 NEW DR,DIE,DIC
+2 SET DIE="^ORD(101,"_+ORGMENU_",10,"
SET DA(1)=+ORGMENU
SET DR=".01;3;2;6"
+3 ; Y undef if no up arrow out
DO ^DIE
SET ORGFLG=$DATA(Y)
+4 QUIT
LOOK(X) ; Lookup an item on the menu
+1 NEW LST,XQORM
+2 DO SMENU
+3 SET XQORM(0)="A"_$SELECT(ORGMENU("TOG")="R":"h",1:"")
SET XQORM("A")=X
+4 IF ORGMENU("TOG")="R"
DO SET^ORGUEM1(+ORGMENU)
DO EN^XQORM
+5 SET Y=0
SET LST=""
FOR
SET Y=$ORDER(Y(Y))
IF 'Y
QUIT
SET LST=LST_+Y(Y)_","
+6 QUIT LST
+1 SET XQORM("W")="W:$E(^ORD(101,+$P(X,""^"",2),0),1,8)=""OR GFAKE"" $$INHI W $P(X,""^"",3),$$INLO"
+2 IF ORGMENU("TOG")="R"
SET XQORM=+ORGMENU_";"_$JOB
SET XQORM(0)="Dh"
SET XQORM("M")=4
QUIT
+3 SET XQORM=+ORGMENU_";ORD(101,"
SET XQORM(0)="D"
+4 IF $LENGTH($GET(^ORD(101,+ORGMENU,28)))
SET XQORM("A")=^(28)
+5 IF $LENGTH($GET(^ORD(101,+ORGMENU,29)))
SET XQORM("B")=^(29)
+6 IF $DATA(^ORD(101,+ORGMENU,4))
SET XQORM("M")=$PIECE(^(4),"^",2)
IF 'XQORM("M")
SET XQORM("M")=5
+7 QUIT
BLANKS ; Renumber blank line protocols
+1 NEW COUNT,LIST,ITM,DIE,DIC,DR,DA
+2 ; Checking 'blank line' items
WRITE !
+3 DO SEQ^ORGUEM3(+ORGMENU,.LIST)
+4 SET COUNT=0
SET DIE="^ORD(101,"_+ORGMENU_",10,"
SET DA(1)=+ORGMENU
+5 FOR ITM=1:1:LIST
IF ^ORD(101,$PIECE(LIST(ITM),"^",2),0)?1"ORB BLANK LINE".E
Begin DoDot:1
+6 SET COUNT=COUNT+1
IF COUNT>20
QUIT
+7 SET X=$ORDER(^ORD(101,"B","ORB BLANK LINE"_COUNT,0))
IF 'X
QUIT
IF X=$PIECE(LIST(ITM),"^",2)
QUIT
+8 SET DA=+LIST(ITM)
SET DR=".01///`"_X
DO ^DIE
End DoDot:1
+9 QUIT
MOVE ; Resequence items
+1 NEW ORGIDX,ORGLST,DIR
+2 SET ORGLST=$$LOOK("Select item(s) to be resequenced: ")
+3 SET DIR(0)="LOA^1:999"
SET DIR("A")="Enter new range of sequence numbers (i.e. 2-8): "
+4 DO ^DIR
IF $DATA(DIRUT)
QUIT
+5 IF $LENGTH(ORGLST,",")'=$LENGTH(Y,",")
Begin DoDot:1
+6 IF $LENGTH(Y,",")=2
FOR I=1:1:$LENGTH(ORGLST,",")-1
SET $PIECE(Y,",",I+1)=Y+I
+7 IF '$TEST
Begin DoDot:2
+8 NEW X1,X2,X3
SET X1=$PIECE(Y,",")
SET X2=$PIECE(Y,",",$LENGTH(Y,",")-1)
SET X3=(X2-X1)/($LENGTH(ORGLST,",")-2)
+9 SET Y=""
FOR I=1:1:$LENGTH(ORGLST,",")-1
SET Y=Y_$JUSTIFY(X1,0,2)_","
SET X1=X1+X3
End DoDot:2
End DoDot:1
+10 FOR ORGIDX=1:1:$LENGTH(ORGLST,",")-1
IF +$PIECE(ORGLST,",",ORGIDX)
DO STUF(+$PIECE(ORGLST,",",ORGIDX),3,+$PIECE(Y,",",ORGIDX))
+11 QUIT
STUF(DA,FLD,VAL) ;Stuff value into field for entry
+1 NEW DIC,DIE,DR,X,Y
+2 SET DIE="^ORD(101,"_+ORGMENU_",10,"
SET DA(1)=+ORGMENU
SET DR=FLD_"///"_VAL
+3 DO ^DIE
+4 QUIT
USER ; Assign menu to individual users
+1 NEW DIR,DIC,DIE,DA,DR,ORGTYP
+2 WRITE !,"Individual users may be assigned primary menus of the following types:"
+3 WRITE !!," 1 OE/RR MENU - contains selections like Add Orders, Review Orders, etc."
+4 WRITE !," 2 ADD ORDERS MENU - contains orderable items.",!
+5 SET DIR(0)="SOA^1:OE/RR MENU;2:ADD ORDERS MENU"
+6 SET DIR("A")="Type of this menu: "
+7 DO ^DIR
IF $DATA(DIRUT)
QUIT
+8 SET ORGTYP=$SELECT(Y=1:100.11,1:100.12)
+9 FOR
Begin DoDot:1
+10 SET DIC="^VA(200,"
SET DIC(0)="AEMQ"
+11 SET DIC("A")="Select user to be assigned this menu: "
+12 DO ^DIC
IF Y'>0
QUIT
+13 SET DIE=DIC
SET DA=+Y
SET DR=ORGTYP_"///"_+ORGMENU
+14 DO ^DIE
SET Y=1
End DoDot:1
IF Y'>0
QUIT
+15 QUIT
