source: WorldVistAEHR/trunk/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XPAR.m@ 1800

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

initial load of WorldVistAEHR
File size: 6.1 KB
Line 
1XPAR ; SLC/KCM - Parameters File Calls ;11/03/2003 16:17
2 ;;7.3;TOOLKIT;**26,60,63,79,82**;Apr 25, 1995
3 ;
4 ; (Need to add proper locking)
5 ;
6 ; Calls to Add/Change/Delete Parameters
7 ; ENT: entity, required (internal or external form)
8 ; PAR: parameter, required (internal or external form)
9 ; INST: instance, defaults to 1 (external or `internal)
10 ; VAL: value, defaults to "" (external or 'internal)
11 ; .ERR: returns error (0 if none, otherwise "1^error text")
12 ;
13ADD(ENT,PAR,INST,VAL,ERR) ; add new parameter instance
14 N TYP S TYP="A"
15 D UPD
16 Q
17CHG(ENT,PAR,INST,VAL,ERR) ; change parameter value for a given instance
18 N TYP S TYP="C"
19 D UPD
20 Q
21DEL(ENT,PAR,INST,ERR) ; delete a parameter instance
22 N TYP,VAL S TYP="D"
23 D UPD
24 Q
25REP(ENT,PAR,INST,NEWINST,ERR) ; replace existing instance value
26 N TYP,VAL S TYP="R"
27 D UPD
28 Q
29PUT(ENT,PAR,INST,VAL,ERR) ; add/update, bypassing input transforms
30PUT1 ; ; called here from old entry point EN^ORXP
31 N TYP,XPARCHK ; XPARVCHK undefined to bypass validation
32 D UPD1
33 Q
34EN(ENT,PAR,INST,VAL,ERR) ; add/change/delete parameters
35 N TYP
36UPD ; ; enter here if transaction type known
37 N XPARCHK S XPARCHK=""
38UPD1 ; ; enter here if data already validated
39 S ERR=0,INST=$G(INST,1),VAL=$G(VAL)
40 I ($L(ENT,"^")>1)!(ENT["ALL") S ERR=$$ERR^XPARDD(89895007) Q ;no lists
41 D INTERN^XPAR1 Q:ERR
42 I '$D(TYP) S TYP=$S(VAL="@":"D",+$O(^XTV(8989.5,"AC",PAR,ENT,INST,0)):"C",1:"A")
43 I TYP="A" G DOADD^XPAR2 ; use GO to emulate case statement
44 I TYP="C" G DOCHG^XPAR2
45 I TYP="D" G DODEL^XPAR2
46 I TYP="R" G DOREP^XPAR2
47 Q
48NDEL(ENT,PAR,ERR) ; Delete all instances of a parameter for an entity
49 N INST,DA
50 I ($L(ENT,"^")>1)!(ENT["ALL") S ERR=$$ERR^XPARDD(89895007) Q
51 S ERR=0 D INTERN^XPAR1 Q:ERR
52 S INST="",DIK="^XTV(8989.5,"
53 F S INST=$O(^XTV(8989.5,"AC",PAR,ENT,INST)) Q:INST="" D
54 . S DA=$O(^XTV(8989.5,"AC",PAR,ENT,INST,0))
55 . D ^DIK
56 Q
57 ;
58 ; Calls to Retrieve Values for Parameters --------------------------
59 ; ENT: entity, required, may take on several forms -
60 ; internal vptr: ien;GLO(FN,
61 ; external vptr: prefix.entryname
62 ; 'use current' form: prefix
63 ; chained list: use any of above, ^ delimited, or 'ALL'
64 ; PAR: parameter, required (internal or external form)
65 ; .ERR: returns error (0 if none, otherwise "error number^text")
66 ;
67GET(ENT,PAR,INST,FMT) ; function - returns a parameter value
68 ; INST: instance, defaults to 1 (external or `internal)
69 ; FMT: format of returned data, defaults to "Q" (internal values)
70 ; "Q" - quick, returns internal value
71 ; "I" - internal, returns internal value, inst must be internal
72 ; "E" - external, returns external value
73 ; "B" - both, returns internal value^external value
74 N ERR,XPARCHK,XPARGET
75 S ERR=0,FMT=$G(FMT,"Q"),INST=$G(INST,1),XPARGET="" S:FMT'="I" XPARCHK=""
76 D INTERN^XPAR1 I ERR Q ""
77 N VAL S VAL=$G(^XTV(8989.5,"AC",PAR,ENT,INST))
78 I FMT="I"!(FMT="Q") Q VAL
79 I FMT="E",$L(VAL) Q $$EXT^XPARDD(VAL,PAR)
80 I FMT="B",$L(VAL) Q VAL_"^"_$$EXT^XPARDD(VAL,PAR)
81 Q ""
82GETWP(WPTEXT,ENT,PAR,INST,ERR) ; get value of word processing type
83 ; .WPTEXT: array in which the word processing text is returned
84 ; WPTEXT contains the title (VALUE field)
85 ; WPTEXT(n,0) contains the actual text
86 ; INST: instance, defaults to 1 (internal only - XPARCHK not defined)
87 N IEN,I,XPARGET,XPARCHK K WPTEXT
88 S ERR=0,INST=$G(INST,1),XPARGET=""
89 D INTERN^XPAR1 Q:ERR
90 S IEN=$O(^XTV(8989.5,"AC",PAR,ENT,INST,0)) Q:'IEN
91 M WPTEXT=^XTV(8989.5,IEN,2) S WPTEXT=^(1) K WPTEXT(0)
92 Q
93GETLST(LIST,ENT,PAR,FMT,ERR,GBL) ; return all parameter instances for an entity
94 ; .LIST: array in which instances are returned
95 ; FMT: format of returned data, defaults to "Q" (internal values)
96 ; "I" - internal instance)=internal value
97 ; "Q" - quick, #)=internal instance^internal value
98 ; "E" - external, #)=external instance^external value
99 ; "B" - both, #,"N")=internal instance^external instance
100 ; #,"V")=internal value^external value
101 ; "N" - external instance)=internal value^external value
102 ; GBL: Set to 1 if LIST holds a Closed Global root
103 N INST,EINST,VAL,XPARGET,XPARCHK,ROOT ;leave XPARCHK undefined
104 S ERR=0,INST="",FMT=$G(FMT,"Q"),XPARGET=""
105 ;Setup ROOT
106 I '$G(GBL) K LIST S ROOT=$NA(LIST)
107 I $G(GBL) D Q:ERR
108 . I $E($G(LIST),1)'="^" S ERR=$$ERR^XPARDD(89895015) Q
109 . S ROOT=LIST
110 . Q
111 ;
112 S @ROOT=0
113 D INTERN^XPAR1 Q:ERR
114 F S INST=$O(^XTV(8989.5,"AC",PAR,ENT,INST)) Q:INST="" D
115 . S @ROOT=@ROOT+1,VAL=^XTV(8989.5,"AC",PAR,ENT,INST)
116 . I FMT="I" S @ROOT@(INST)=VAL Q
117 . I FMT="Q" S @ROOT@(@ROOT)=INST_U_VAL Q
118 . S VAL=VAL_U_$$EXT^XPARDD(VAL,PAR)
119 . S EINST=INST_U_$$EXT^XPARDD(INST,PAR,"I")
120 . I FMT="E" S @ROOT@(@ROOT)=$P(EINST,"^",2)_U_$P(VAL,"^",2) Q
121 . I FMT="B" S @ROOT@(@ROOT,"N")=EINST,@ROOT@(@ROOT,"V")=VAL Q
122 . I FMT="N" S @ROOT@($P(EINST,"^",2))=VAL Q
123 Q
124ENVAL(LIST,PAR,INST,ERR,GBL) ; return all parameter instances
125 ; .LIST: array of returned entity/instance/values in the format:
126 ; LIST(entity,instance)=value (LIST = # of array elements)
127 ; or a Closed Global root ($NA(^TMP($J)))
128 ; PAR: parameter in external or internal format
129 ; INST: instance (optional) in external or internal format
130 ; ERR: error (0 if no error found)
131 ; GBL: Set to 1 if LIST holds a Closed Global root
132 N ENT,VAL,XPARGET,ROOT
133 S ENT="",VAL="",ERR=0,XPARGET=""
134 ;Setup ROOT
135 I '$G(GBL) K LIST S ROOT=$NA(LIST)
136 I $G(GBL) D Q:ERR
137 . I $E($G(LIST),1)'="^" S ERR=$$ERR^XPARDD(89895015) Q
138 . S ROOT=LIST
139 . Q
140 ;
141 S @ROOT=0
142 ; -- parameter to internal format:
143 I PAR'?1.N S PAR=+$O(^XTV(8989.51,"B",PAR,0))
144 I '$D(^XTV(8989.51,PAR,0)) S ERR=$$ERR^XPARDD(89895001) Q ;missing par
145 ; -- instance
146 I $L($G(INST)) D VALID^XPARDD(PAR,.INST,"I",.ERR) Q:ERR
147 F S ENT=$O(^XTV(8989.5,"AC",PAR,ENT)) Q:ENT="" D
148 . I $L($G(INST)) D
149 .. S VAL=$G(^XTV(8989.5,"AC",PAR,ENT,INST))
150 .. S:$L($G(VAL)) @ROOT@(ENT,INST)=VAL,@ROOT=@ROOT+1
151 . I '$L($G(INST)) D
152 .. S INST="" F S INST=$O(^XTV(8989.5,"AC",PAR,ENT,INST)) Q:INST="" D
153 ... S VAL=$G(^XTV(8989.5,"AC",PAR,ENT,INST))
154 ... S:$L($G(VAL)) @ROOT@(ENT,INST)=VAL,@ROOT=@ROOT+1
155 Q
Note: See TracBrowser for help on using the repository browser.