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