ORDD41 ;slc/KCM,MKB-Build menus in XUTL (file 101.41) ;10:36 AM 11 Feb 1999
;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,46,57**;Dec 17, 1997
SET(DLG) ; -- create dialog menu in ^XUTL("XQORM")
Q:$D(^ORD(101.41,DLG,0))[0 Q:$P(^(0),U,4)'="M"
N ITM,POS,COL,ROW,XQORM,TXT,PTR,X,R,C
S (POS,COL,ROW)=0,XQORM=DLG_";ORD(101.41,"
F S POS=$O(^ORD(101.41,DLG,10,"B",POS)) Q:POS="" S ITM=0 D
. F S ITM=$O(^ORD(101.41,DLG,10,"B",POS,ITM)) Q:ITM'>0 D
. . S X=$G(^ORD(101.41,DLG,10,ITM,0)),PTR=$P(X,U,2)
. . S TXT=$S($L($P(X,U,4)):$P(X,U,4),PTR:$P($G(^ORD(101.41,+PTR,0)),U,2),1:""),TXT=$TR(TXT,",=;-"," ") Q:'$L(TXT)
. . S ^XUTL("XQORM",XQORM,POS,0)=ITM_U_PTR_U_TXT_U_$P(X,U,3)_U_$TR($P(X,U,5),"120","OH")
. . S:$P(POS,".",2)>COL COL=$P(POS,".",2) Q:'PTR Q:$P(X,U,5)
. . S ^XUTL("XQORM",XQORM,"B",$$UP(TXT),POS)="" ;text
. . S:$L($P(X,U,3)) ^XUTL("XQORM",DLG_";ORD(101.41,","B",$$UP($P(X,U,3)),POS)=1 ;mnemonic
. S:$P(POS,".")>ROW ROW=$P(POS,".") ;hold last row
F R=1:1:ROW F C=1:1:COL S POS=R_"."_C S:'$D(^XUTL("XQORM",XQORM,POS,0)) ^(0)="^^ ^^O" ;blank
S X=$H,^XUTL("XQORM",DLG_";ORD(101.41,",0)=X,^("COL")=COL
S ^ORD(101.41,DLG,99)=X
Q
;
KILL(DLG) ; -- Cleanup ^XUTL("XQORM")
K ^XUTL("XQORM",DLG_";ORD(101.41,")
Q
;
UP(X) ;Convert X to upper case
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
;
REDO ; -- Rebuild menu in ^XUTL when changed
I $D(^ORD(101.41,DA,0)) S ^(99)=$H
Q
;
REDOM ; -- Rebuild menu(s) in ^XUTL when DISPLAY TEXT changed
N X,MENU S X=$H
I $D(^ORD(101.41,DA,0)) S ^(99)=X
S MENU=0 F S MENU=$O(^ORD(101.41,"AD",DA,MENU)) Q:MENU'>0 I $D(^ORD(101.41,MENU,0)) S ^(99)=X
Q
;
REDOX ; -- Rebuild menu in ^XUTL when ITEMS changed
I $D(^ORD(101.41,+$G(DA(1)),0)) S ^(99)=$H
Q
;
TREE ; -- Ck menu tree to ensure new item is not an ancestor
; Input Xform for Item field #2 of Items subfile #101.412
; expecting DA, DA(1), X from FileMan
N ORDDA,ORDD S ORDDA=DA(1)
K:X=ORDDA X D TREE1
Q
TREE1 ; -- Look for X in ancestors
F ORDD=0:0 Q:'$D(X) S ORDD=$O(^ORD(101.41,"AD",ORDDA,ORDD)) Q:ORDD'>0 K:X=ORDD X Q:'$D(X) D TREE2
Q
TREE2 ; -- Back up another level
N ORDDA S ORDDA=ORDD N ORDD D TREE1
Q
;
LIST(MENU) ; -- List items on MENU for ?-help in editor
N XQORM,TXT,POS,LCNT,QUIT,ITEM S (LCNT,QUIT)=0,TXT=""
S XQORM=+$G(MENU)_";"_$J Q:'$D(^XUTL("XQORM",XQORM))
F S TXT=$O(^XUTL("XQORM",XQORM,"B",TXT)) Q:TXT="" D Q:QUIT
. S POS=0 F S POS=$O(^XUTL("XQORM",XQORM,"B",TXT,POS)) Q:POS'>0 Q:^(POS) D Q:QUIT
. . S ITEM=$G(^XUTL("XQORM",XQORM,POS,0)),LCNT=LCNT+1
. . I LCNT>(IOSL-2) R !,"Press <return> to continue ...",X:DTIME S LCNT=0 I X["^" S QUIT=1 Q
. . W !?3,$P(ITEM,U,4),?10,$P(ITEM,U,3),$S($P(ITEM,U,2):" ["_$P($G(^ORD(101.41,+$P(ITEM,U,2),0)),U)_"]",1:"")
Q
;
LOCK(MENU) ; -- Lock [and rebuild?] Order Dialog menu
N OK,XQORM S OK=1,XQORM=+MENU_";ORD(101.41,"
I $S('XQORM:1,'$D(^ORD(101.41,+MENU,0)):1,1:0) S OK="0^Invalid menu." G LKQ
I $D(^XUTL("XQORM",XQORM,0)),$P(^XUTL("XQORM",XQORM,0),U)'=$P($G(^ORD(101.41,+MENU,99)),U) D REBLD(+MENU)
I '$D(^XUTL("XQORM",XQORM,0)) D REBLD(+MENU,.OK) G:'OK LKQ
L +^XUTL("XQORM",XQORM,"XQORM PROTECT",$J):10 E S OK="0^Can't access menu at this time - try again later."
LKQ Q OK
;
UNLOCK(MENU) ; -- Unlock Order Dialog menu
L -^XUTL("XQORM",+MENU_";ORD(101.41,","XQORM PROTECT",$J)
Q
;
REBLD(MENU,RES) ; -- Lock, rebuild Order Dialog menu
N XQORM,DIE,DA,DR
S XQORM=+MENU_";ORD(101.41,",DIE="^ORD(101.41,",DA=+MENU,DR="99///"_$H
L +(^XUTL("XQORM",XQORM),^ORD(101.41,+MENU)):5 E S RES="0^Can't access menu at this time - try again later." Q
D ^DIE S RES=1
L -(^XUTL("XQORM",XQORM),^ORD(101.41,+MENU))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORDD41 3738 printed Oct 16, 2024@18:30:25 Page 2
ORDD41 ;slc/KCM,MKB-Build menus in XUTL (file 101.41) ;10:36 AM 11 Feb 1999
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,46,57**;Dec 17, 1997
SET(DLG) ; -- create dialog menu in ^XUTL("XQORM")
+1 if $DATA(^ORD(101.41,DLG,0))[0
QUIT
if $PIECE(^(0),U,4)'="M"
QUIT
+2 NEW ITM,POS,COL,ROW,XQORM,TXT,PTR,X,R,C
+3 SET (POS,COL,ROW)=0
SET XQORM=DLG_";ORD(101.41,"
+4 FOR
SET POS=$ORDER(^ORD(101.41,DLG,10,"B",POS))
if POS=""
QUIT
SET ITM=0
Begin DoDot:1
+5 FOR
SET ITM=$ORDER(^ORD(101.41,DLG,10,"B",POS,ITM))
if ITM'>0
QUIT
Begin DoDot:2
+6 SET X=$GET(^ORD(101.41,DLG,10,ITM,0))
SET PTR=$PIECE(X,U,2)
+7 SET TXT=$SELECT($LENGTH($PIECE(X,U,4)):$PIECE(X,U,4),PTR:$PIECE($GET(^ORD(101.41,+PTR,0)),U,2),1:"")
SET TXT=$TRANSLATE(TXT,",=;-"," ")
if '$LENGTH(TXT)
QUIT
+8 SET ^XUTL("XQORM",XQORM,POS,0)=ITM_U_PTR_U_TXT_U_$PIECE(X,U,3)_U_$TRANSLATE($PIECE(X,U,5),"120","OH")
+9 if $PIECE(POS,".",2)>COL
SET COL=$PIECE(POS,".",2)
if 'PTR
QUIT
if $PIECE(X,U,5)
QUIT
+10 ;text
SET ^XUTL("XQORM",XQORM,"B",$$UP(TXT),POS)=""
+11 ;mnemonic
if $LENGTH($PIECE(X,U,3))
SET ^XUTL("XQORM",DLG_";ORD(101.41,","B",$$UP($PIECE(X,U,3)),POS)=1
End DoDot:2
+12 ;hold last row
if $PIECE(POS,".")>ROW
SET ROW=$PIECE(POS,".")
End DoDot:1
+13 ;blank
FOR R=1:1:ROW
FOR C=1:1:COL
SET POS=R_"."_C
if '$DATA(^XUTL("XQORM",XQORM,POS,0))
SET ^(0)="^^ ^^O"
+14 SET X=$HOROLOG
SET ^XUTL("XQORM",DLG_";ORD(101.41,",0)=X
SET ^("COL")=COL
+15 SET ^ORD(101.41,DLG,99)=X
+16 QUIT
+17 ;
KILL(DLG) ; -- Cleanup ^XUTL("XQORM")
+1 KILL ^XUTL("XQORM",DLG_";ORD(101.41,")
+2 QUIT
+3 ;
UP(X) ;Convert X to upper case
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 ;
REDO ; -- Rebuild menu in ^XUTL when changed
+1 IF $DATA(^ORD(101.41,DA,0))
SET ^(99)=$HOROLOG
+2 QUIT
+3 ;
REDOM ; -- Rebuild menu(s) in ^XUTL when DISPLAY TEXT changed
+1 NEW X,MENU
SET X=$HOROLOG
+2 IF $DATA(^ORD(101.41,DA,0))
SET ^(99)=X
+3 SET MENU=0
FOR
SET MENU=$ORDER(^ORD(101.41,"AD",DA,MENU))
if MENU'>0
QUIT
IF $DATA(^ORD(101.41,MENU,0))
SET ^(99)=X
+4 QUIT
+5 ;
REDOX ; -- Rebuild menu in ^XUTL when ITEMS changed
+1 IF $DATA(^ORD(101.41,+$GET(DA(1)),0))
SET ^(99)=$HOROLOG
+2 QUIT
+3 ;
TREE ; -- Ck menu tree to ensure new item is not an ancestor
+1 ; Input Xform for Item field #2 of Items subfile #101.412
+2 ; expecting DA, DA(1), X from FileMan
+3 NEW ORDDA,ORDD
SET ORDDA=DA(1)
+4 if X=ORDDA
KILL X
DO TREE1
+5 QUIT
TREE1 ; -- Look for X in ancestors
+1 FOR ORDD=0:0
if '$DATA(X)
QUIT
SET ORDD=$ORDER(^ORD(101.41,"AD",ORDDA,ORDD))
if ORDD'>0
QUIT
if X=ORDD
KILL X
if '$DATA(X)
QUIT
DO TREE2
+2 QUIT
TREE2 ; -- Back up another level
+1 NEW ORDDA
SET ORDDA=ORDD
NEW ORDD
DO TREE1
+2 QUIT
+3 ;
LIST(MENU) ; -- List items on MENU for ?-help in editor
+1 NEW XQORM,TXT,POS,LCNT,QUIT,ITEM
SET (LCNT,QUIT)=0
SET TXT=""
+2 SET XQORM=+$GET(MENU)_";"_$JOB
if '$DATA(^XUTL("XQORM",XQORM))
QUIT
+3 FOR
SET TXT=$ORDER(^XUTL("XQORM",XQORM,"B",TXT))
if TXT=""
QUIT
Begin DoDot:1
+4 SET POS=0
FOR
SET POS=$ORDER(^XUTL("XQORM",XQORM,"B",TXT,POS))
if POS'>0
QUIT
if ^(POS)
QUIT
Begin DoDot:2
+5 SET ITEM=$GET(^XUTL("XQORM",XQORM,POS,0))
SET LCNT=LCNT+1
+6 IF LCNT>(IOSL-2)
READ !,"Press <return> to continue ...",X:DTIME
SET LCNT=0
IF X["^"
SET QUIT=1
QUIT
+7 WRITE !?3,$PIECE(ITEM,U,4),?10,$PIECE(ITEM,U,3),$SELECT($PIECE(ITEM,U,2):" ["_$PIECE($GET(^ORD(101.41,+$PIECE(ITEM,U,2),0)),U)_"]",1:"")
End DoDot:2
if QUIT
QUIT
End DoDot:1
if QUIT
QUIT
+8 QUIT
+9 ;
LOCK(MENU) ; -- Lock [and rebuild?] Order Dialog menu
+1 NEW OK,XQORM
SET OK=1
SET XQORM=+MENU_";ORD(101.41,"
+2 IF $SELECT('XQORM:1,'$DATA(^ORD(101.41,+MENU,0)):1,1:0)
SET OK="0^Invalid menu."
GOTO LKQ
+3 IF $DATA(^XUTL("XQORM",XQORM,0))
IF $PIECE(^XUTL("XQORM",XQORM,0),U)'=$PIECE($GET(^ORD(101.41,+MENU,99)),U)
DO REBLD(+MENU)
+4 IF '$DATA(^XUTL("XQORM",XQORM,0))
DO REBLD(+MENU,.OK)
if 'OK
GOTO LKQ
+5 LOCK +^XUTL("XQORM",XQORM,"XQORM PROTECT",$JOB):10
IF '$TEST
SET OK="0^Can't access menu at this time - try again later."
LKQ QUIT OK
+1 ;
UNLOCK(MENU) ; -- Unlock Order Dialog menu
+1 LOCK -^XUTL("XQORM",+MENU_";ORD(101.41,","XQORM PROTECT",$JOB)
+2 QUIT
+3 ;
REBLD(MENU,RES) ; -- Lock, rebuild Order Dialog menu
+1 NEW XQORM,DIE,DA,DR
+2 SET XQORM=+MENU_";ORD(101.41,"
SET DIE="^ORD(101.41,"
SET DA=+MENU
SET DR="99///"_$HOROLOG
+3 LOCK +(^XUTL("XQORM",XQORM),^ORD(101.41,+MENU)):5
IF '$TEST
SET RES="0^Can't access menu at this time - try again later."
QUIT
+4 DO ^DIE
SET RES=1
+5 LOCK -(^XUTL("XQORM",XQORM),^ORD(101.41,+MENU))
+6 QUIT
