source: FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCMEDT6.m@ 974

Last change on this file since 974 was 628, checked in by George Lilly, 16 years ago

initial load of FOIAVistA 6/30/08 version
File size: 5.0 KB
Line 
1ORCMEDT6 ;SLC/MKB-QO editor utilities ;12/18/02 13:33
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**164**;Dec 17, 1997
3 ;
4QO ; -- Enter/edit QO restriction on orderable items
5 N X,Y,DA,DR,DIE,ORIT,OLDVAL,OREBLD
6 F S ORIT=$$OI("S.RX^S.LAB","Select an ORDERABLE ITEM (meds or labs only): ") Q:ORIT'>0 D W !!
7 . W !!,"Select the type of usage for which you wish to restrict ordering of this item."
8 . F S ORDG=$$SET(+ORIT) Q:"^"[ORDG D
9 .. S DA(1)=+ORIT,DA=+$O(^ORD(101.43,+ORIT,9,"B",ORDG,0))
10 .. S OLDVAL=$G(^ORD(101.43,+ORIT,9,DA,0))
11 .. S DR=2,DIE="^ORD(101.43,"_DA(1)_",9," D ^DIE W !
12 .. I ORDG="O RX"!(ORDG="UD RX"),OLDVAL'=$G(^ORD(101.43,+ORIT,9,DA,0)) S OREBLD(ORDG)=1
13 F ORDG="O RX","UD RX" I $G(OREBLD(ORDG)) D FVBLDQ^ORWUL(ORDG)
14 Q
15 ;
16SET(OI) ; -- Returns Set Membership for OI
17 N X,Y,I,DOMAIN,NAME,HELP,DONE
18 S X="",I=0 F S X=$O(^ORD(101.43,+OI,9,"B",X)) Q:X="" S NAME=$$NAME(X),I=I+1,DOMAIN(I)=X_U_NAME,DOMAIN("B",NAME)=I
19 S DOMAIN(0)=I,HELP="Select the type of usage for which you wish to restrict ordering of this item."
20 S DONE=0,Y="" F D Q:DONE
21 . W !,"Usage: "
22 . R X:DTIME S:'$T X="^" I X["^" S Y="^",DONE=1 Q
23 . I X="" S Y="^",DONE=1 Q
24 . I X["?" W !!,HELP D LIST Q
25 . D I 'Y W $C(7),!,HELP Q
26 . . N XP,XY,CNT,MATCH,DIR,I
27 . . S X=$$UP^XLFSTR(X),Y=+$G(DOMAIN("B",X)) Q:Y ; done
28 . . S CNT=0,XP=X F S XP=$O(DOMAIN("B",XP)) Q:XP="" Q:$E(XP,1,$L(X))'=X S CNT=CNT+1,XY=+DOMAIN("B",XP),MATCH(CNT)=XY_U_$P(DOMAIN(XY),U,2)
29 . . Q:'CNT
30 . . I CNT=1 S Y=+MATCH(1),XP=$P(MATCH(1),U,2) W $E(XP,$L(X)+1,$L(XP)) Q
31 . . S DIR(0)="NAO^1:"_CNT,DIR("A")="Select 1-"_CNT_": "
32 . . F I=1:1:CNT S DIR("A",I)=$J(I,3)_" "_$P(MATCH(I),U,2)
33 . . S DIR("?")="Select the desired value, by number"
34 . . D ^DIR I $D(DIRUT) S Y="" Q
35 . . S Y=+MATCH(Y) W " "_$P(DOMAIN(Y),U,2)
36 . S Y=$P(DOMAIN(Y),U),DONE=1
37 Q Y
38 ;
39LIST ; -- List order statuses in DOMAIN
40 N I,Z,CNT,DONE
41 S CNT=0 W !,"Choose from:"
42 F I=1:1:DOMAIN(0) D Q:$G(DONE)
43 . S CNT=CNT+1 W ! I CNT>(IOSL-3) D Q:$G(DONE)
44 .. W ?3,"'^' TO STOP: " R Z:DTIME S:'$T!(Z["^") DONE=1 S CNT=1
45 . W $C(13)," "_$P(DOMAIN(I),U,2)
46 Q
47 ;
48NAME(X) ; -- Returns full name of set X
49 N Y,I S Y=$S(X="IVA RX":"IV ADDITIVES",X="IVB RX":"IV SOLUTIONS",X="IVM RX":"IV MEDICATIONS",1:"")
50 I Y="" S I=+$O(^ORD(100.98,"B",X,0)),Y=$S(I:$P($G(^ORD(100.98,I,0)),U),1:X)
51 Q Y
52 ;
53OI(IDX,CAPTION) ; -- Returns selected OI from file #101.43 using IDX xrefs
54 N X,Y,D,DIC,DTOUT,DUOUT,DIRUT,DIROUT,ORDIC
55 S DIC="^ORD(101.43,",DIC(0)="AEQS" S:$L($G(CAPTION)) DIC("A")=CAPTION
56 S DIC("W")="W:$S('$D(%):0,'$D(DIY):0,%=DIY:0,1:1) $G(DIY)"
57 S D=IDX,ORDIC="IX^DIC" S:$L(D,U)>1 ORDIC="MIX^DIC1",DIC(0)=DIC(0)_"M"
58 D @ORDIC
59 Q Y
60 ;
61OIB(CAPTION) ; -- Returns selected OI from file #101.43 using B xref
62 N X,Y,DIC,DTOUT,DUOUT,DIRUT,DIROUT
63 S DIC="^ORD(101.43,",DIC(0)="AEQ"
64 S:$L($G(CAPTION)) DIC("A")=CAPTION
65 D ^DIC
66 Q Y
67 ;
68SEARCH ; -- Search/replace orderables in QO responses
69 N I,ORP,ORIT
70 S I=0 F S I=$O(^ORD(101.41,I)) Q:I<1 I $P($G(^(I,0)),U,4)="P",$P($G(^(1)),U)="P",+$P($G(^(1)),U,2)=101.43 S ORP(I)="" ;OI prompts
71 F S ORIT=$$OIB("Search for: ") Q:ORIT<1 D SR1 W !!
72 Q
73 ;
74SR1 ; -- list QO's & Dlgs where ORIT is used, get replacement
75 N I,X,ORDAD,ORDG,ORY,ORNMBR,NUM,DA,ORNM,TYPE,SET
76 D FIND(ORIT,.ORDAD) I ORDAD<1 W !,$P(ORIT,U,2)_" is not used by any quick orders or dialogs." Q
77 W @IOF,"Quick Orders and Dialogs containing "_$P(ORIT,U,2),!,$$REPEAT^XLFSTR("-",79)
78 S I=0 F S I=$O(ORDAD(I)) Q:I'>0 D
79 . S X=+ORDAD(I) W !,I,?4,$P(^ORD(101.41,X,0),U)
80 W !,$$REPEAT^XLFSTR("-",79)
81 S ORDG=+$P($G(^ORD(101.43,+ORIT,0)),U,5),ORDG=$P($G(^ORD(100.98,ORDG,0)),U,3)
82 S ORY=$$OI("S."_ORDG,"Replace with: ") Q:ORY<1
83 D SELECT(ORDAD,.ORNMBR) Q:ORNMBR="^"
84 Q:'$$OK W !!,"Replacing "_$P(ORIT,U,2)_" with "_$P(ORY,U,2)_" in:"
85 F I=1:1:$L(ORNMBR,",") S NUM=$P(ORNMBR,",",I) I NUM D
86 . S DA(1)=+ORDAD(NUM),DA=$P(ORDAD(NUM),U,2),SET=$P(ORDAD(NUM),U,3)
87 . S ORNM=$P(^ORD(101.41,DA(1),0),U),TYPE=$P($G(^(0)),U,4)
88 . I '$O(^ORD(101.43,+ORY,9,"B",SET,0)) W !?3,ORNM_" canceled: item invalid for this dialog." Q
89 . I TYPE="Q" S ^ORD(101.41,DA(1),6,DA,1)=+ORY
90 . I TYPE="D" S ^ORD(101.41,DA(1),10,DA,7)="S Y="_+ORY
91 . W !?3,ORNM_" ...done."
92 Q
93 ;
94FIND(X,QO) ; -- Find QO's, Dlg's that use ord item X
95 N IFN,P,TYPE,NODE,DEF,DA,DLG,PRMT,SET S IFN=0,QO=0
96 F S IFN=+$O(^ORD(101.41,IFN)) Q:IFN<1 S TYPE=$P($G(^(IFN,0)),U,4) D
97 . S NODE=$S(TYPE="Q":6,TYPE="D":10,1:0) Q:'NODE
98 . S P=0 F S P=$O(ORP(P)) Q:P<1 S DA=$O(^ORD(101.41,IFN,NODE,"D",P,0)) I DA D
99 .. I TYPE="Q" Q:+$G(^ORD(101.41,IFN,6,DA,1))'=+X S DLG=$$DEFDLG^ORCD(IFN),PRMT=+$O(^ORD(101.41,DLG,10,"D",P,0))
100 .. I TYPE="D" S DEF=$G(^ORD(101.41,IFN,10,DA,7)) Q:DEF'?1"S Y=".E S DEF=$P(DEF,"=",2) S:$E(DEF)="""" DEF=$P(DEF,"""",2) Q:+DEF'=+X S DLG=IFN,PRMT=DA
101 .. S SET=$P($G(^ORD(101.41,DLG,10,PRMT,0)),U,10),SET=$P($P(SET,";"),".",2)
102 .. S QO=QO+1,QO(QO)=IFN_U_DA_U_SET
103 Q
104 ;
105SELECT(MAX,Y) ; -- Select which QOs to replace Ord Item
106 N X,DIR
107 S DIR(0)="LA^1:"_MAX,DIR("A")="Replace in: ",DIR("B")=$S(MAX>1:"1-"_MAX,1:"1")
108 ; S DIR("?")
109 D ^DIR S:$D(DTOUT)!(X["^") Y="^"
110 Q
111 ;
112OK() ; -- Are you ready?
113 N X,Y,DIR
114 S DIR(0)="YA",DIR("A")="Are you ready? ",DIR("B")="NO"
115 W ! D ^DIR
116 Q +Y
Note: See TracBrowser for help on using the repository browser.