ORCMEDIT ;SLC/MKB-Menu Editor ;4/19/01 11:27
;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,46,95,263**;Dec 17, 1997;Build 9
;;Per VHA Directive 2004-038, this routine should not be modified.
EN ; -- start here
S ORMENU=$$MENU D:ORMENU EN^VALM("OR MENU EDITOR")
Q
;
NEW ; -- Change menu
D FULL^VALM1 S VALMBCK="R",VALMBG=1
N X S X=$$MENU(ORMENU)
I X,+X'=+ORMENU S ORMENU=X D INIT,HDR
Q
;
N DIC,X,Y,DLAYGO,ORNEW,DA,DIK
MN1 S DIC="^ORD(101.41,",DIC(0)="AEQL",DLAYGO=101.41,DIC("DR")="4///^S X=""M"""
S DIC("A")="Select ORDER MENU: ",DIC("S")="I $P(^(0),U,4)=""M"""
S:$G(OROLD) DIC("B")=$P(OROLD,U,2) D ^DIC I Y'>0 Q "^"
L +^ORD(101.41,+Y,0):1 I '$T W !!,"Another user is currently editing this menu!",! G MN1
L +^XUTL("XQORM",+Y_";ORD(101.41,","XQORM PROTECT",$J):1 E W !!,"Cannot access menu at this time - try again later.",! G MN1
S ORNEW=Y I $P(ORNEW,U,3),$$COPY("M") D
. K DLAYGO,DIC("B") S DIC(0)="AEQZ",DIC("A")="Select MENU TO COPY: "
. D ^DIC Q:Y'>0 W !,"Copying menu items ..."
. M ^ORD(101.41,+ORNEW,10)=^ORD(101.41,+Y,10) ; menu items
. M ^ORD(101.41,+ORNEW,2)=^ORD(101.41,+Y,2) ; description
. S:$D(^ORD(101.41,+Y,5)) ^ORD(101.41,+ORNEW,5)=^ORD(101.41,+Y,5)
. S X=$P(Y(0),U,2),$P(^ORD(101.41,+ORNEW,0),U,2)=X S:X'="" ^ORD(101.41,"C",$$UP^XLFSTR(X),+ORNEW)="" ; display text
. S DA(1)=+ORNEW,DIK="^ORD(101.41,"_+ORNEW_",10,",DIK(1)="2^AD" D ENALL^DIK
I $P(ORNEW,U,3) S DA=+ORNEW,DIE="^ORD(101.41,",DR="2;20;51;52;53"_$S($G(DUZ(0))="@":";30;40",1:"") D ^DIE
I $G(OROLD) L -^ORD(101.41,+OROLD,0),-^XUTL("XQORM",+OROLD_";ORD(101.41,","XQORM PROTECT",$J)
Q ORNEW
;
COPY(TYPE) ; -- Returns 1 or 0, if new item is to be a copy
N X,Y,DIR,ITEM S ITEM=$S(TYPE="M":"menu",TYPE="Q":"quick order",TYPE="O":"order set",1:"order dialog")
S DIR(0)="YA",DIR("A")="Do you wish to copy an existing "_ITEM_"? "
S DIR("?")="Enter YES to copy the items from an existing "_ITEM_" into this one",DIR("B")="YES"
D ^DIR
Q +Y
;
EDIT ; -- Edit menu fields
N DA,DR,DIE,OR0,OR5,ORNAME D FULL^VALM1 S VALMBCK="R"
S ORNAME=$$NAME^ORCMEDT4(+ORMENU) Q:ORNAME="^"
I ORNAME="@" S VALMBCK="Q" Q ;deleted - quit ListMgr
S OR0=$G(^ORD(101.41,+ORMENU,0)),OR5=$G(^(5))
S DR=".01///^S X=ORNAME;2;20;51;52;53"_$S($G(DUZ(0))="@":";30;40",1:"")
S DIE="^ORD(101.41,",DA=+ORMENU D ^DIE
I OR0=$G(^ORD(101.41,+ORMENU,0)),OR5=$G(^(5)) Q ; no change
W !!,"Rebuilding menu display ..." D INIT,HDR
Q
;
VIEW ; -- Toggle display between Name and Display Text
N OR0 S OR0=$G(^TMP("ORMENU",$J,0))
S OR0=$P(OR0,U,1,4)_U_$S($P(OR0,U,5)="I":"E",1:"I")
S ^TMP("ORMENU",$J,0)=OR0,VALMBCK="R"
W !!,"Rebuilding menu display ..." D INIT
Q
;
INIT ; -- init variables and list array
N X,ROWS,ROW,COL,CW,MW,POS,CNT,ITEM,IFN,MNEM,TEXT,FLAG,LINE,XQORM,I,NAME,INT,DA,TS
S INT=$P($G(^TMP("ORMENU",$J,0)),U,5) ; int/ext flag
D CLEAN^VALM10,KILL(+ORMENU) ; kill array for rebuilding
S ROWS=$P($O(^ORD(101.41,+ORMENU,10,"B",""),-1),".")
S VALMCNT=$S(ROWS>51:ROWS,1:51) ; 3 full screens of row #
F ROW=1:1:VALMCNT D ; set-up grid
. S X=$S((ROW/10)=(ROW\10):ROW/10,(ROW/5)=(ROW\5):"+",1:"|")
. S ^TMP("ORMENU",$J,ROW,0)=X_$$REPEAT^XLFSTR(" ",79)
S CW=$P($G(^ORD(101.41,+ORMENU,5)),U),MW=$P($G(^(5)),U,2)
S:'CW CW=80 S:'MW MW=5 S XQORM=+ORMENU_";"_$J
S CNT=0 G:'$O(^ORD(101.41,+ORMENU,10,0)) INQ ; new menu, no items yet
IN1 S POS=0 F S POS=$O(^ORD(101.41,+ORMENU,10,"B",POS)) Q:POS'>0 S DA=0 F S DA=$O(^ORD(101.41,+ORMENU,10,"B",POS,DA)) Q:'DA D
. S ROW=$P(POS,"."),COL=$$COLUMN($P(POS,".",2),CW)
. S ITEM=$G(^ORD(101.41,+ORMENU,10,DA,0)),IFN=$P(ITEM,U,2)
. S MNEM=$P(ITEM,U,3),FLAG=$P(ITEM,U,5) S:IFN ITM=$G(^ORD(101.41,IFN,0))
. I INT="I" S TEXT=$S(IFN:$P(ITM,U),1:"")
. I INT'="I" S TEXT=$P(ITEM,U,4) I '$L(TEXT),IFN S TEXT=$P(ITM,U,2)
. Q:'$L(TEXT) I FLAG=2 S TEXT=$E(TEXT,1,CW),X=TEXT D SETVIDEO(ROW,COL+1,$L($G(TEXT)),IOUON,IOUOFF)
. I FLAG<2 S X=MNEM_$E(" ",1,MW-$L(MNEM))_$E(TEXT,1,CW-MW) D SETVIDEO(ROW,COL+1,MW,IOINHI,IOINORM)
. S LINE=$G(^TMP("ORMENU",$J,ROW,0)),^TMP("ORMENU",$J,ROW,0)=$$SETSTR^VALM1(X,LINE,COL+1,CW),CNT=CNT+1,TEXT=$$STRIP(TEXT) Q:'$L(TEXT)
. S ^TMP("ORMENU",$J,"B",$$UP(TEXT))=DA S:$L(MNEM) ^($$UP(MNEM))=DA
. S ^XUTL("XQORM",XQORM,POS,0)=DA_U_IFN_U_TEXT_U_MNEM,^XUTL("XQORM",XQORM,"B",$$UP(TEXT),POS)="" S:$L(MNEM) ^XUTL("XQORM",XQORM,"B",$$UP(MNEM),POS)=1
. I IFN,INT'="I" S NAME=$P(ITM,U) S:$L(NAME) ^XUTL("XQORM",XQORM,"B",$$UP(NAME),POS)=1
INQ S ^TMP("ORMENU",$J,0)=ROWS_U_CNT_U_CW_U_MW_U_INT ;,VALMBG=1
M ^TMP("VALM VIDEO",$J,VALMEVL)=^TMP("ORMENU",$J,"VIDEO")
S X="" F I=1:1 S COL=(I-1)*CW+1 Q:COL>80 S $E(X,COL)=I,ORCOL=I
D CHGCAP^VALM("LINE",X) S TS=$G(^ORD(101.41,+ORMENU,99)) ; set caption heading
S:$D(^XUTL("XQORM",XQORM)) ^(XQORM,"COL")=ORCOL,^(0)=TS
Q
;
SETVIDEO(ROW,COL,WIDTH,ON,OFF) ; -- Set video attributes
S ^TMP("ORMENU",$J,"VIDEO",ROW,COL,WIDTH)=ON
S ^TMP("ORMENU",$J,"VIDEO",ROW,COL+WIDTH,0)=OFF
Q
;
UP(X) ; -- Convert X to uppercase
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
;
STRIP(X) ; -- Strip leading spaces from text X
N I,Y S Y=""
F I=1:1:$L(X) I $E(X,I)'=" " S Y=$E(X,I,999) Q
Q Y
;
COLUMN(NUM,WIDTH) ; -- Returns position for column NUM per WIDTH
N Y S:'$G(NUM) NUM=1 S:'$G(WIDTH) WIDTH=80
S Y=(NUM-1)*WIDTH+1
Q Y
;
HDR ; -- header code
N X,Y S X="Menu: "_$P(ORMENU,U,2)
S Y="Column Width: "_$P($G(^TMP("ORMENU",$J,0)),U,3)
S VALMHDR(1)=X_$$REPEAT^XLFSTR(" ",79-$L(X)-$L(Y))_Y
Q
;
HELP ; -- help code
N X D FULL^VALM1 S VALMBCK="R"
W !," This is how this menu will appear to the user in the Add New Orders"
W !," option. Select ADD, REMOVE, or EDIT to make changes to this menu, or"
W !," ASSIGN to set it as the default for users. Use the ORDER DIALOGS option"
W !," to change or create quick orders for this menu."
W !,"Press <return> to continue ..." R X:DTIME
Q
;
MSG() ; -- Msg bar
Q "+ Next Screen - Prev Screen ?? More Actions"
;
EXIT ; -- exit code
L -^ORD(101.41,+ORMENU,0),-^XUTL("XQORM",+ORMENU_";ORD(101.41,","XQORM PROTECT",$J)
D KILL(+ORMENU) K VALMHDR,VALMCNT,VALMBG,ORMENU,ORCOL,^TMP("ORMENU",$J)
Q
;
KILL(DA) ; -- Cleanup compiled menu from editor
K ^XUTL("XQORM",DA_";"_$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORCMEDIT 6321 printed Jan 18, 2025@03:29:43 Page 2
ORCMEDIT ;SLC/MKB-Menu Editor ;4/19/01 11:27
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,46,95,263**;Dec 17, 1997;Build 9
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
EN ; -- start here
+1 SET ORMENU=$$MENU
if ORMENU
DO EN^VALM("OR MENU EDITOR")
+2 QUIT
+3 ;
NEW ; -- Change menu
+1 DO FULL^VALM1
SET VALMBCK="R"
SET VALMBG=1
+2 NEW X
SET X=$$MENU(ORMENU)
+3 IF X
IF +X'=+ORMENU
SET ORMENU=X
DO INIT
DO HDR
+4 QUIT
+5 ;
+1 NEW DIC,X,Y,DLAYGO,ORNEW,DA,DIK
MN1 SET DIC="^ORD(101.41,"
SET DIC(0)="AEQL"
SET DLAYGO=101.41
SET DIC("DR")="4///^S X=""M"""
+1 SET DIC("A")="Select ORDER MENU: "
SET DIC("S")="I $P(^(0),U,4)=""M"""
+2 if $GET(OROLD)
SET DIC("B")=$PIECE(OROLD,U,2)
DO ^DIC
IF Y'>0
QUIT "^"
+3 LOCK +^ORD(101.41,+Y,0):1
IF '$TEST
WRITE !!,"Another user is currently editing this menu!",!
GOTO MN1
+4 LOCK +^XUTL("XQORM",+Y_";ORD(101.41,","XQORM PROTECT",$JOB):1
IF '$TEST
WRITE !!,"Cannot access menu at this time - try again later.",!
GOTO MN1
+5 SET ORNEW=Y
IF $PIECE(ORNEW,U,3)
IF $$COPY("M")
Begin DoDot:1
+6 KILL DLAYGO,DIC("B")
SET DIC(0)="AEQZ"
SET DIC("A")="Select MENU TO COPY: "
+7 DO ^DIC
if Y'>0
QUIT
WRITE !,"Copying menu items ..."
+8 ; menu items
MERGE ^ORD(101.41,+ORNEW,10)=^ORD(101.41,+Y,10)
+9 ; description
MERGE ^ORD(101.41,+ORNEW,2)=^ORD(101.41,+Y,2)
+10 if $DATA(^ORD(101.41,+Y,5))
SET ^ORD(101.41,+ORNEW,5)=^ORD(101.41,+Y,5)
+11 ; display text
SET X=$PIECE(Y(0),U,2)
SET $PIECE(^ORD(101.41,+ORNEW,0),U,2)=X
if X'=""
SET ^ORD(101.41,"C",$$UP^XLFSTR(X),+ORNEW)=""
+12 SET DA(1)=+ORNEW
SET DIK="^ORD(101.41,"_+ORNEW_",10,"
SET DIK(1)="2^AD"
DO ENALL^DIK
End DoDot:1
+13 IF $PIECE(ORNEW,U,3)
SET DA=+ORNEW
SET DIE="^ORD(101.41,"
SET DR="2;20;51;52;53"_$SELECT($GET(DUZ(0))="@":";30;40",1:"")
DO ^DIE
+14 IF $GET(OROLD)
LOCK -^ORD(101.41,+OROLD,0),-^XUTL("XQORM",+OROLD_";ORD(101.41,","XQORM PROTECT",$JOB)
+15 QUIT ORNEW
+16 ;
COPY(TYPE) ; -- Returns 1 or 0, if new item is to be a copy
+1 NEW X,Y,DIR,ITEM
SET ITEM=$SELECT(TYPE="M":"menu",TYPE="Q":"quick order",TYPE="O":"order set",1:"order dialog")
+2 SET DIR(0)="YA"
SET DIR("A")="Do you wish to copy an existing "_ITEM_"? "
+3 SET DIR("?")="Enter YES to copy the items from an existing "_ITEM_" into this one"
SET DIR("B")="YES"
+4 DO ^DIR
+5 QUIT +Y
+6 ;
EDIT ; -- Edit menu fields
+1 NEW DA,DR,DIE,OR0,OR5,ORNAME
DO FULL^VALM1
SET VALMBCK="R"
+2 SET ORNAME=$$NAME^ORCMEDT4(+ORMENU)
if ORNAME="^"
QUIT
+3 ;deleted - quit ListMgr
IF ORNAME="@"
SET VALMBCK="Q"
QUIT
+4 SET OR0=$GET(^ORD(101.41,+ORMENU,0))
SET OR5=$GET(^(5))
+5 SET DR=".01///^S X=ORNAME;2;20;51;52;53"_$SELECT($GET(DUZ(0))="@":";30;40",1:"")
+6 SET DIE="^ORD(101.41,"
SET DA=+ORMENU
DO ^DIE
+7 ; no change
IF OR0=$GET(^ORD(101.41,+ORMENU,0))
IF OR5=$GET(^(5))
QUIT
+8 WRITE !!,"Rebuilding menu display ..."
DO INIT
DO HDR
+9 QUIT
+10 ;
VIEW ; -- Toggle display between Name and Display Text
+1 NEW OR0
SET OR0=$GET(^TMP("ORMENU",$JOB,0))
+2 SET OR0=$PIECE(OR0,U,1,4)_U_$SELECT($PIECE(OR0,U,5)="I":"E",1:"I")
+3 SET ^TMP("ORMENU",$JOB,0)=OR0
SET VALMBCK="R"
+4 WRITE !!,"Rebuilding menu display ..."
DO INIT
+5 QUIT
+6 ;
INIT ; -- init variables and list array
+1 NEW X,ROWS,ROW,COL,CW,MW,POS,CNT,ITEM,IFN,MNEM,TEXT,FLAG,LINE,XQORM,I,NAME,INT,DA,TS
+2 ; int/ext flag
SET INT=$PIECE($GET(^TMP("ORMENU",$JOB,0)),U,5)
+3 ; kill array for rebuilding
DO CLEAN^VALM10
DO KILL(+ORMENU)
+4 SET ROWS=$PIECE($ORDER(^ORD(101.41,+ORMENU,10,"B",""),-1),".")
+5 ; 3 full screens of row #
SET VALMCNT=$SELECT(ROWS>51:ROWS,1:51)
+6 ; set-up grid
FOR ROW=1:1:VALMCNT
Begin DoDot:1
+7 SET X=$SELECT((ROW/10)=(ROW\10):ROW/10,(ROW/5)=(ROW\5):"+",1:"|")
+8 SET ^TMP("ORMENU",$JOB,ROW,0)=X_$$REPEAT^XLFSTR(" ",79)
End DoDot:1
+9 SET CW=$PIECE($GET(^ORD(101.41,+ORMENU,5)),U)
SET MW=$PIECE($GET(^(5)),U,2)
+10 if 'CW
SET CW=80
if 'MW
SET MW=5
SET XQORM=+ORMENU_";"_$JOB
+11 ; new menu, no items yet
SET CNT=0
if '$ORDER(^ORD(101.41,+ORMENU,10,0))
GOTO INQ
IN1 SET POS=0
FOR
SET POS=$ORDER(^ORD(101.41,+ORMENU,10,"B",POS))
if POS'>0
QUIT
SET DA=0
FOR
SET DA=$ORDER(^ORD(101.41,+ORMENU,10,"B",POS,DA))
if 'DA
QUIT
Begin DoDot:1
+1 SET ROW=$PIECE(POS,".")
SET COL=$$COLUMN($PIECE(POS,".",2),CW)
+2 SET ITEM=$GET(^ORD(101.41,+ORMENU,10,DA,0))
SET IFN=$PIECE(ITEM,U,2)
+3 SET MNEM=$PIECE(ITEM,U,3)
SET FLAG=$PIECE(ITEM,U,5)
if IFN
SET ITM=$GET(^ORD(101.41,IFN,0))
+4 IF INT="I"
SET TEXT=$SELECT(IFN:$PIECE(ITM,U),1:"")
+5 IF INT'="I"
SET TEXT=$PIECE(ITEM,U,4)
IF '$LENGTH(TEXT)
IF IFN
SET TEXT=$PIECE(ITM,U,2)
+6 if '$LENGTH(TEXT)
QUIT
IF FLAG=2
SET TEXT=$EXTRACT(TEXT,1,CW)
SET X=TEXT
DO SETVIDEO(ROW,COL+1,$LENGTH($GET(TEXT)),IOUON,IOUOFF)
+7 IF FLAG<2
SET X=MNEM_$EXTRACT(" ",1,MW-$LENGTH(MNEM))_$EXTRACT(TEXT,1,CW-MW)
DO SETVIDEO(ROW,COL+1,MW,IOINHI,IOINORM)
+8 SET LINE=$GET(^TMP("ORMENU",$JOB,ROW,0))
SET ^TMP("ORMENU",$JOB,ROW,0)=$$SETSTR^VALM1(X,LINE,COL+1,CW)
SET CNT=CNT+1
SET TEXT=$$STRIP(TEXT)
if '$LENGTH(TEXT)
QUIT
+9 SET ^TMP("ORMENU",$JOB,"B",$$UP(TEXT))=DA
if $LENGTH(MNEM)
SET ^($$UP(MNEM))=DA
+10 SET ^XUTL("XQORM",XQORM,POS,0)=DA_U_IFN_U_TEXT_U_MNEM
SET ^XUTL("XQORM",XQORM,"B",$$UP(TEXT),POS)=""
if $LENGTH(MNEM)
SET ^XUTL("XQORM",XQORM,"B",$$UP(MNEM),POS)=1
+11 IF IFN
IF INT'="I"
SET NAME=$PIECE(ITM,U)
if $LENGTH(NAME)
SET ^XUTL("XQORM",XQORM,"B",$$UP(NAME),POS)=1
End DoDot:1
INQ ;,VALMBG=1
SET ^TMP("ORMENU",$JOB,0)=ROWS_U_CNT_U_CW_U_MW_U_INT
+1 MERGE ^TMP("VALM VIDEO",$JOB,VALMEVL)=^TMP("ORMENU",$JOB,"VIDEO")
+2 SET X=""
FOR I=1:1
SET COL=(I-1)*CW+1
if COL>80
QUIT
SET $EXTRACT(X,COL)=I
SET ORCOL=I
+3 ; set caption heading
DO CHGCAP^VALM("LINE",X)
SET TS=$GET(^ORD(101.41,+ORMENU,99))
+4 if $DATA(^XUTL("XQORM",XQORM))
SET ^(XQORM,"COL")=ORCOL
SET ^(0)=TS
+5 QUIT
+6 ;
SETVIDEO(ROW,COL,WIDTH,ON,OFF) ; -- Set video attributes
+1 SET ^TMP("ORMENU",$JOB,"VIDEO",ROW,COL,WIDTH)=ON
+2 SET ^TMP("ORMENU",$JOB,"VIDEO",ROW,COL+WIDTH,0)=OFF
+3 QUIT
+4 ;
UP(X) ; -- Convert X to uppercase
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 ;
STRIP(X) ; -- Strip leading spaces from text X
+1 NEW I,Y
SET Y=""
+2 FOR I=1:1:$LENGTH(X)
IF $EXTRACT(X,I)'=" "
SET Y=$EXTRACT(X,I,999)
QUIT
+3 QUIT Y
+4 ;
COLUMN(NUM,WIDTH) ; -- Returns position for column NUM per WIDTH
+1 NEW Y
if '$GET(NUM)
SET NUM=1
if '$GET(WIDTH)
SET WIDTH=80
+2 SET Y=(NUM-1)*WIDTH+1
+3 QUIT Y
+4 ;
HDR ; -- header code
+1 NEW X,Y
SET X="Menu: "_$PIECE(ORMENU,U,2)
+2 SET Y="Column Width: "_$PIECE($GET(^TMP("ORMENU",$JOB,0)),U,3)
+3 SET VALMHDR(1)=X_$$REPEAT^XLFSTR(" ",79-$LENGTH(X)-$LENGTH(Y))_Y
+4 QUIT
+5 ;
HELP ; -- help code
+1 NEW X
DO FULL^VALM1
SET VALMBCK="R"
+2 WRITE !," This is how this menu will appear to the user in the Add New Orders"
+3 WRITE !," option. Select ADD, REMOVE, or EDIT to make changes to this menu, or"
+4 WRITE !," ASSIGN to set it as the default for users. Use the ORDER DIALOGS option"
+5 WRITE !," to change or create quick orders for this menu."
+6 WRITE !,"Press <return> to continue ..."
READ X:DTIME
+7 QUIT
+8 ;
MSG() ; -- Msg bar
+1 QUIT "+ Next Screen - Prev Screen ?? More Actions"
+2 ;
EXIT ; -- exit code
+1 LOCK -^ORD(101.41,+ORMENU,0),-^XUTL("XQORM",+ORMENU_";ORD(101.41,","XQORM PROTECT",$JOB)
+2 DO KILL(+ORMENU)
KILL VALMHDR,VALMCNT,VALMBG,ORMENU,ORCOL,^TMP("ORMENU",$JOB)
+3 QUIT
+4 ;
KILL(DA) ; -- Cleanup compiled menu from editor
+1 KILL ^XUTL("XQORM",DA_";"_$JOB)
+2 QUIT
