source: WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORGUEM2.m@ 1608

Last change on this file since 1608 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.2 KB
RevLine 
[613]1ORGUEM2 ; slc/KCM - Set Up Formatted Protocol Menus (cont) ;6/1/92 17:08
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;;Dec 17, 1997
3 ;;
4GMENU(X,Y) ; Select or Create Menu to be set up
5 ;Y is array returned by DIC, it should be call by reference
6 N DIC,DLAYGO,DA,ORGOK
7 S DIC="^ORD(101,",DIC(0)=X_"Z",DLAYGO=101,DIC("DR")=""
8 S DIC("S")="I ""QM""[$P(^(0),""^"",4)"
9 F D Q:$D(ORGOK)
10 . D ^DIC
11 . I DIC(0)["L",$P(Y,"^",2)?1"OR ADD MENU".E D I $D(ORGPOP) S ORGOK=1 Q
12 . . N X W !!,"NOTE: You should only modify locally namespaced add order menus.",!,"Press RETURN to continue or '^' to exit: "
13 . . R X:DTIME S:X="^^" DIROUT=1 S:X["^" ORGPOP=1
14 . . Q
15 . I Y'>1 S ORGPOP=1,ORGOK=1 Q
16 . I $P(Y,"^",3) S ORGOK=1 Q
17 . ; I +$G(ORGMENU)=+Y W !,"Can't copy from the menu you just created." Q
18 . I "QM"[$P(Y(0),"^",4) S ORGOK=1 Q
19 . W !,Y(0,0)," is not a menu type."
20 Q
21NEW ; Copy from existing menu or get required fields for new menu
22 N ORGCOPY
23 W !,ORGMENU(0,0)," is a new menu."
24 S ORGCOPY=$$ASK("Do you want to copy an existing menu? ","Yes")
25 I ORGCOPY="^" S ORGPOP=1 Q
26 I ORGCOPY D GMENU("AEMQ",.Y) Q:$D(ORGPOP) D
27 . N %X,%Y,DA,DIK
28 . S %X="^ORD(101,"_+Y_",",%Y="^ORD(101,"_+ORGMENU_"," D %XY^%RCR
29 . S $P(^ORD(101,+ORGMENU,0),"^")=ORGMENU(0,0)
30 . W !,"Please wait. Copying the menu may take a few minutes."
31 . S DA=+ORGMENU,DIK="^ORD(101," D IX1^DIK
32 I 'ORGCOPY D
33 . N DA,DR,DIE
34 . ;Check namespace to see if can guess default for package name
35 . S DA=+ORGMENU,DIE="^ORD(101,",DR="1;4//Q;12" D ^DIE
36 . I $D(Y) S ORGPOP=1
37 Q
38ASK(X,Y) ; Ask a Yes or No question
39 ;X is question, Y is default
40 S DIR(0)="YAO" S:$D(X) DIR("A")=X S:$D(Y) DIR("B")=Y
41 D ^DIR
42 Q Y
43FLDS(DA,ORGFLG) ; Edit item fields without updating database
44 N DR,DIE,DIC
45 S DIE="^ORD(101,"_+ORGMENU_",10,",DA(1)=+ORGMENU,DR=".01;3;2;6"
46 D ^DIE S ORGFLG=$D(Y) ; Y undef if no up arrow out
47 Q
48LOOK(X) ; Lookup an item on the menu
49 N LST,XQORM
50 D SMENU
51 S XQORM(0)="A"_$S(ORGMENU("TOG")="R":"h",1:""),XQORM("A")=X
52 D:ORGMENU("TOG")="R" SET^ORGUEM1(+ORGMENU) D EN^XQORM
53 S Y=0,LST="" F S Y=$O(Y(Y)) Q:'Y S LST=LST_+Y(Y)_","
54 Q LST
55SMENU ; Set up for call to display menu
56 S XQORM("W")="W:$E(^ORD(101,+$P(X,""^"",2),0),1,8)=""OR GFAKE"" $$INHI W $P(X,""^"",3),$$INLO"
57 I ORGMENU("TOG")="R" S XQORM=+ORGMENU_";"_$J,XQORM(0)="Dh",XQORM("M")=4 Q
58 S XQORM=+ORGMENU_";ORD(101,",XQORM(0)="D"
59 I $L($G(^ORD(101,+ORGMENU,28))) S XQORM("A")=^(28)
60 I $L($G(^ORD(101,+ORGMENU,29))) S XQORM("B")=^(29)
61 I $D(^ORD(101,+ORGMENU,4)) S XQORM("M")=$P(^(4),"^",2) S:'XQORM("M") XQORM("M")=5
62 Q
63BLANKS ; Renumber blank line protocols
64 N COUNT,LIST,ITM,DIE,DIC,DR,DA
65 W ! ; Checking 'blank line' items
66 D SEQ^ORGUEM3(+ORGMENU,.LIST)
67 S COUNT=0,DIE="^ORD(101,"_+ORGMENU_",10,",DA(1)=+ORGMENU
68 F ITM=1:1:LIST I ^ORD(101,$P(LIST(ITM),"^",2),0)?1"ORB BLANK LINE".E D
69 . S COUNT=COUNT+1 Q:COUNT>20
70 . S X=$O(^ORD(101,"B","ORB BLANK LINE"_COUNT,0)) Q:'X Q:X=$P(LIST(ITM),"^",2)
71 . S DA=+LIST(ITM),DR=".01///`"_X D ^DIE
72 Q
73MOVE ; Resequence items
74 N ORGIDX,ORGLST,DIR
75 S ORGLST=$$LOOK("Select item(s) to be resequenced: ")
76 S DIR(0)="LOA^1:999",DIR("A")="Enter new range of sequence numbers (i.e. 2-8): "
77 D ^DIR Q:$D(DIRUT)
78 I $L(ORGLST,",")'=$L(Y,",") D
79 . I $L(Y,",")=2 F I=1:1:$L(ORGLST,",")-1 S $P(Y,",",I+1)=Y+I
80 . E D
81 . . N X1,X2,X3 S X1=$P(Y,","),X2=$P(Y,",",$L(Y,",")-1),X3=(X2-X1)/($L(ORGLST,",")-2)
82 . . S Y="" F I=1:1:$L(ORGLST,",")-1 S Y=Y_$J(X1,0,2)_",",X1=X1+X3
83 F ORGIDX=1:1:$L(ORGLST,",")-1 I +$P(ORGLST,",",ORGIDX) D STUF(+$P(ORGLST,",",ORGIDX),3,+$P(Y,",",ORGIDX))
84 Q
85STUF(DA,FLD,VAL) ;Stuff value into field for entry
86 N DIC,DIE,DR,X,Y
87 S DIE="^ORD(101,"_+ORGMENU_",10,",DA(1)=+ORGMENU,DR=FLD_"///"_VAL
88 D ^DIE
89 Q
90USER ; Assign menu to individual users
91 N DIR,DIC,DIE,DA,DR,ORGTYP
92 W !,"Individual users may be assigned primary menus of the following types:"
93 W !!," 1 OE/RR MENU - contains selections like Add Orders, Review Orders, etc."
94 W !," 2 ADD ORDERS MENU - contains orderable items.",!
95 S DIR(0)="SOA^1:OE/RR MENU;2:ADD ORDERS MENU"
96 S DIR("A")="Type of this menu: "
97 D ^DIR Q:$D(DIRUT)
98 S ORGTYP=$S(Y=1:100.11,1:100.12)
99 F D Q:Y'>0
100 . S DIC="^VA(200,",DIC(0)="AEMQ"
101 . S DIC("A")="Select user to be assigned this menu: "
102 . D ^DIC Q:Y'>0
103 . S DIE=DIC,DA=+Y,DR=ORGTYP_"///"_+ORGMENU
104 . D ^DIE S Y=1
105 Q
Note: See TracBrowser for help on using the repository browser.