XPAR ; SLC/KCM - Parameters File Calls ;11/03/2003 16:17
;;7.3;TOOLKIT;**26,60,63,79,82**;Apr 25, 1995
;
; (Need to add proper locking)
;
; Calls to Add/Change/Delete Parameters
; ENT: entity, required (internal or external form)
; PAR: parameter, required (internal or external form)
; INST: instance, defaults to 1 (external or `internal)
; VAL: value, defaults to "" (external or 'internal)
; .ERR: returns error (0 if none, otherwise "1^error text")
;
ADD(ENT,PAR,INST,VAL,ERR) ; add new parameter instance
N TYP S TYP="A"
D UPD
Q
CHG(ENT,PAR,INST,VAL,ERR) ; change parameter value for a given instance
N TYP S TYP="C"
D UPD
Q
DEL(ENT,PAR,INST,ERR) ; delete a parameter instance
N TYP,VAL S TYP="D"
D UPD
Q
REP(ENT,PAR,INST,NEWINST,ERR) ; replace existing instance value
N TYP,VAL S TYP="R"
D UPD
Q
PUT(ENT,PAR,INST,VAL,ERR) ; add/update, bypassing input transforms
PUT1 ; ; called here from old entry point EN^ORXP
N TYP,XPARCHK ; XPARVCHK undefined to bypass validation
D UPD1
Q
EN(ENT,PAR,INST,VAL,ERR) ; add/change/delete parameters
N TYP
UPD ; ; enter here if transaction type known
N XPARCHK S XPARCHK=""
UPD1 ; ; enter here if data already validated
S ERR=0,INST=$G(INST,1),VAL=$G(VAL)
I ($L(ENT,"^")>1)!(ENT["ALL") S ERR=$$ERR^XPARDD(89895007) Q ;no lists
D INTERN^XPAR1 Q:ERR
I '$D(TYP) S TYP=$S(VAL="@":"D",+$O(^XTV(8989.5,"AC",PAR,ENT,INST,0)):"C",1:"A")
I TYP="A" G DOADD^XPAR2 ; use GO to emulate case statement
I TYP="C" G DOCHG^XPAR2
I TYP="D" G DODEL^XPAR2
I TYP="R" G DOREP^XPAR2
Q
NDEL(ENT,PAR,ERR) ; Delete all instances of a parameter for an entity
N INST,DA
I ($L(ENT,"^")>1)!(ENT["ALL") S ERR=$$ERR^XPARDD(89895007) Q
S ERR=0 D INTERN^XPAR1 Q:ERR
S INST="",DIK="^XTV(8989.5,"
F S INST=$O(^XTV(8989.5,"AC",PAR,ENT,INST)) Q:INST="" D
. S DA=$O(^XTV(8989.5,"AC",PAR,ENT,INST,0))
. D ^DIK
Q
;
; Calls to Retrieve Values for Parameters --------------------------
; ENT: entity, required, may take on several forms -
; internal vptr: ien;GLO(FN,
; external vptr: prefix.entryname
; 'use current' form: prefix
; chained list: use any of above, ^ delimited, or 'ALL'
; PAR: parameter, required (internal or external form)
; .ERR: returns error (0 if none, otherwise "error number^text")
;
GET(ENT,PAR,INST,FMT) ; function - returns a parameter value
; INST: instance, defaults to 1 (external or `internal)
; FMT: format of returned data, defaults to "Q" (internal values)
; "Q" - quick, returns internal value
; "I" - internal, returns internal value, inst must be internal
; "E" - external, returns external value
; "B" - both, returns internal value^external value
N ERR,XPARCHK,XPARGET
S ERR=0,FMT=$G(FMT,"Q"),INST=$G(INST,1),XPARGET="" S:FMT'="I" XPARCHK=""
D INTERN^XPAR1 I ERR Q ""
N VAL S VAL=$G(^XTV(8989.5,"AC",PAR,ENT,INST))
I FMT="I"!(FMT="Q") Q VAL
I FMT="E",$L(VAL) Q $$EXT^XPARDD(VAL,PAR)
I FMT="B",$L(VAL) Q VAL_"^"_$$EXT^XPARDD(VAL,PAR)
Q ""
GETWP(WPTEXT,ENT,PAR,INST,ERR) ; get value of word processing type
; .WPTEXT: array in which the word processing text is returned
; WPTEXT contains the title (VALUE field)
; WPTEXT(n,0) contains the actual text
; INST: instance, defaults to 1 (internal only - XPARCHK not defined)
N IEN,I,XPARGET,XPARCHK K WPTEXT
S ERR=0,INST=$G(INST,1),XPARGET=""
D INTERN^XPAR1 Q:ERR
S IEN=$O(^XTV(8989.5,"AC",PAR,ENT,INST,0)) Q:'IEN
M WPTEXT=^XTV(8989.5,IEN,2) S WPTEXT=^(1) K WPTEXT(0)
Q
GETLST(LIST,ENT,PAR,FMT,ERR,GBL) ; return all parameter instances for an entity
; .LIST: array in which instances are returned
; FMT: format of returned data, defaults to "Q" (internal values)
; "I" - internal instance)=internal value
; "Q" - quick, #)=internal instance^internal value
; "E" - external, #)=external instance^external value
; "B" - both, #,"N")=internal instance^external instance
; #,"V")=internal value^external value
; "N" - external instance)=internal value^external value
; GBL: Set to 1 if LIST holds a Closed Global root
N INST,EINST,VAL,XPARGET,XPARCHK,ROOT ;leave XPARCHK undefined
S ERR=0,INST="",FMT=$G(FMT,"Q"),XPARGET=""
;Setup ROOT
I '$G(GBL) K LIST S ROOT=$NA(LIST)
I $G(GBL) D Q:ERR
. I $E($G(LIST),1)'="^" S ERR=$$ERR^XPARDD(89895015) Q
. S ROOT=LIST
. Q
;
S @ROOT=0
D INTERN^XPAR1 Q:ERR
F S INST=$O(^XTV(8989.5,"AC",PAR,ENT,INST)) Q:INST="" D
. S @ROOT=@ROOT+1,VAL=^XTV(8989.5,"AC",PAR,ENT,INST)
. I FMT="I" S @ROOT@(INST)=VAL Q
. I FMT="Q" S @ROOT@(@ROOT)=INST_U_VAL Q
. S VAL=VAL_U_$$EXT^XPARDD(VAL,PAR)
. S EINST=INST_U_$$EXT^XPARDD(INST,PAR,"I")
. I FMT="E" S @ROOT@(@ROOT)=$P(EINST,"^",2)_U_$P(VAL,"^",2) Q
. I FMT="B" S @ROOT@(@ROOT,"N")=EINST,@ROOT@(@ROOT,"V")=VAL Q
. I FMT="N" S @ROOT@($P(EINST,"^",2))=VAL Q
Q
ENVAL(LIST,PAR,INST,ERR,GBL) ; return all parameter instances
; .LIST: array of returned entity/instance/values in the format:
; LIST(entity,instance)=value (LIST = # of array elements)
; or a Closed Global root ($NA(^TMP($J)))
; PAR: parameter in external or internal format
; INST: instance (optional) in external or internal format
; ERR: error (0 if no error found)
; GBL: Set to 1 if LIST holds a Closed Global root
N ENT,VAL,XPARGET,ROOT
S ENT="",VAL="",ERR=0,XPARGET=""
;Setup ROOT
I '$G(GBL) K LIST S ROOT=$NA(LIST)
I $G(GBL) D Q:ERR
. I $E($G(LIST),1)'="^" S ERR=$$ERR^XPARDD(89895015) Q
. S ROOT=LIST
. Q
;
S @ROOT=0
; -- parameter to internal format:
I PAR'?1.N S PAR=+$O(^XTV(8989.51,"B",PAR,0))
I '$D(^XTV(8989.51,PAR,0)) S ERR=$$ERR^XPARDD(89895001) Q ;missing par
; -- instance
I $L($G(INST)) D VALID^XPARDD(PAR,.INST,"I",.ERR) Q:ERR
F S ENT=$O(^XTV(8989.5,"AC",PAR,ENT)) Q:ENT="" D
. I $L($G(INST)) D
.. S VAL=$G(^XTV(8989.5,"AC",PAR,ENT,INST))
.. S:$L($G(VAL)) @ROOT@(ENT,INST)=VAL,@ROOT=@ROOT+1
. I '$L($G(INST)) D
.. S INST="" F S INST=$O(^XTV(8989.5,"AC",PAR,ENT,INST)) Q:INST="" D
... S VAL=$G(^XTV(8989.5,"AC",PAR,ENT,INST))
... S:$L($G(VAL)) @ROOT@(ENT,INST)=VAL,@ROOT=@ROOT+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXPAR 6378 printed Dec 13, 2024@02:40:11 Page 2
XPAR ; SLC/KCM - Parameters File Calls ;11/03/2003 16:17
+1 ;;7.3;TOOLKIT;**26,60,63,79,82**;Apr 25, 1995
+2 ;
+3 ; (Need to add proper locking)
+4 ;
+5 ; Calls to Add/Change/Delete Parameters
+6 ; ENT: entity, required (internal or external form)
+7 ; PAR: parameter, required (internal or external form)
+8 ; INST: instance, defaults to 1 (external or `internal)
+9 ; VAL: value, defaults to "" (external or 'internal)
+10 ; .ERR: returns error (0 if none, otherwise "1^error text")
+11 ;
ADD(ENT,PAR,INST,VAL,ERR) ; add new parameter instance
+1 NEW TYP
SET TYP="A"
+2 DO UPD
+3 QUIT
CHG(ENT,PAR,INST,VAL,ERR) ; change parameter value for a given instance
+1 NEW TYP
SET TYP="C"
+2 DO UPD
+3 QUIT
DEL(ENT,PAR,INST,ERR) ; delete a parameter instance
+1 NEW TYP,VAL
SET TYP="D"
+2 DO UPD
+3 QUIT
REP(ENT,PAR,INST,NEWINST,ERR) ; replace existing instance value
+1 NEW TYP,VAL
SET TYP="R"
+2 DO UPD
+3 QUIT
PUT(ENT,PAR,INST,VAL,ERR) ; add/update, bypassing input transforms
PUT1 ; ; called here from old entry point EN^ORXP
+1 ; XPARVCHK undefined to bypass validation
NEW TYP,XPARCHK
+2 DO UPD1
+3 QUIT
EN(ENT,PAR,INST,VAL,ERR) ; add/change/delete parameters
+1 NEW TYP
UPD ; ; enter here if transaction type known
+1 NEW XPARCHK
SET XPARCHK=""
UPD1 ; ; enter here if data already validated
+1 SET ERR=0
SET INST=$GET(INST,1)
SET VAL=$GET(VAL)
+2 ;no lists
IF ($LENGTH(ENT,"^")>1)!(ENT["ALL")
SET ERR=$$ERR^XPARDD(89895007)
QUIT
+3 DO INTERN^XPAR1
if ERR
QUIT
+4 IF '$DATA(TYP)
SET TYP=$SELECT(VAL="@":"D",+$ORDER(^XTV(8989.5,"AC",PAR,ENT,INST,0)):"C",1:"A")
+5 ; use GO to emulate case statement
IF TYP="A"
GOTO DOADD^XPAR2
+6 IF TYP="C"
GOTO DOCHG^XPAR2
+7 IF TYP="D"
GOTO DODEL^XPAR2
+8 IF TYP="R"
GOTO DOREP^XPAR2
+9 QUIT
NDEL(ENT,PAR,ERR) ; Delete all instances of a parameter for an entity
+1 NEW INST,DA
+2 IF ($LENGTH(ENT,"^")>1)!(ENT["ALL")
SET ERR=$$ERR^XPARDD(89895007)
QUIT
+3 SET ERR=0
DO INTERN^XPAR1
if ERR
QUIT
+4 SET INST=""
SET DIK="^XTV(8989.5,"
+5 FOR
SET INST=$ORDER(^XTV(8989.5,"AC",PAR,ENT,INST))
if INST=""
QUIT
Begin DoDot:1
+6 SET DA=$ORDER(^XTV(8989.5,"AC",PAR,ENT,INST,0))
+7 DO ^DIK
End DoDot:1
+8 QUIT
+9 ;
+10 ; Calls to Retrieve Values for Parameters --------------------------
+11 ; ENT: entity, required, may take on several forms -
+12 ; internal vptr: ien;GLO(FN,
+13 ; external vptr: prefix.entryname
+14 ; 'use current' form: prefix
+15 ; chained list: use any of above, ^ delimited, or 'ALL'
+16 ; PAR: parameter, required (internal or external form)
+17 ; .ERR: returns error (0 if none, otherwise "error number^text")
+18 ;
GET(ENT,PAR,INST,FMT) ; function - returns a parameter value
+1 ; INST: instance, defaults to 1 (external or `internal)
+2 ; FMT: format of returned data, defaults to "Q" (internal values)
+3 ; "Q" - quick, returns internal value
+4 ; "I" - internal, returns internal value, inst must be internal
+5 ; "E" - external, returns external value
+6 ; "B" - both, returns internal value^external value
+7 NEW ERR,XPARCHK,XPARGET
+8 SET ERR=0
SET FMT=$GET(FMT,"Q")
SET INST=$GET(INST,1)
SET XPARGET=""
if FMT'="I"
SET XPARCHK=""
+9 DO INTERN^XPAR1
IF ERR
QUIT ""
+10 NEW VAL
SET VAL=$GET(^XTV(8989.5,"AC",PAR,ENT,INST))
+11 IF FMT="I"!(FMT="Q")
QUIT VAL
+12 IF FMT="E"
IF $LENGTH(VAL)
QUIT $$EXT^XPARDD(VAL,PAR)
+13 IF FMT="B"
IF $LENGTH(VAL)
QUIT VAL_"^"_$$EXT^XPARDD(VAL,PAR)
+14 QUIT ""
GETWP(WPTEXT,ENT,PAR,INST,ERR) ; get value of word processing type
+1 ; .WPTEXT: array in which the word processing text is returned
+2 ; WPTEXT contains the title (VALUE field)
+3 ; WPTEXT(n,0) contains the actual text
+4 ; INST: instance, defaults to 1 (internal only - XPARCHK not defined)
+5 NEW IEN,I,XPARGET,XPARCHK
KILL WPTEXT
+6 SET ERR=0
SET INST=$GET(INST,1)
SET XPARGET=""
+7 DO INTERN^XPAR1
if ERR
QUIT
+8 SET IEN=$ORDER(^XTV(8989.5,"AC",PAR,ENT,INST,0))
if 'IEN
QUIT
+9 MERGE WPTEXT=^XTV(8989.5,IEN,2)
SET WPTEXT=^(1)
KILL WPTEXT(0)
+10 QUIT
GETLST(LIST,ENT,PAR,FMT,ERR,GBL) ; return all parameter instances for an entity
+1 ; .LIST: array in which instances are returned
+2 ; FMT: format of returned data, defaults to "Q" (internal values)
+3 ; "I" - internal instance)=internal value
+4 ; "Q" - quick, #)=internal instance^internal value
+5 ; "E" - external, #)=external instance^external value
+6 ; "B" - both, #,"N")=internal instance^external instance
+7 ; #,"V")=internal value^external value
+8 ; "N" - external instance)=internal value^external value
+9 ; GBL: Set to 1 if LIST holds a Closed Global root
+10 ;leave XPARCHK undefined
NEW INST,EINST,VAL,XPARGET,XPARCHK,ROOT
+11 SET ERR=0
SET INST=""
SET FMT=$GET(FMT,"Q")
SET XPARGET=""
+12 ;Setup ROOT
+13 IF '$GET(GBL)
KILL LIST
SET ROOT=$NAME(LIST)
+14 IF $GET(GBL)
Begin DoDot:1
+15 IF $EXTRACT($GET(LIST),1)'="^"
SET ERR=$$ERR^XPARDD(89895015)
QUIT
+16 SET ROOT=LIST
+17 QUIT
End DoDot:1
if ERR
QUIT
+18 ;
+19 SET @ROOT=0
+20 DO INTERN^XPAR1
if ERR
QUIT
+21 FOR
SET INST=$ORDER(^XTV(8989.5,"AC",PAR,ENT,INST))
if INST=""
QUIT
Begin DoDot:1
+22 SET @ROOT=@ROOT+1
SET VAL=^XTV(8989.5,"AC",PAR,ENT,INST)
+23 IF FMT="I"
SET @ROOT@(INST)=VAL
QUIT
+24 IF FMT="Q"
SET @ROOT@(@ROOT)=INST_U_VAL
QUIT
+25 SET VAL=VAL_U_$$EXT^XPARDD(VAL,PAR)
+26 SET EINST=INST_U_$$EXT^XPARDD(INST,PAR,"I")
+27 IF FMT="E"
SET @ROOT@(@ROOT)=$PIECE(EINST,"^",2)_U_$PIECE(VAL,"^",2)
QUIT
+28 IF FMT="B"
SET @ROOT@(@ROOT,"N")=EINST
SET @ROOT@(@ROOT,"V")=VAL
QUIT
+29 IF FMT="N"
SET @ROOT@($PIECE(EINST,"^",2))=VAL
QUIT
End DoDot:1
+30 QUIT
ENVAL(LIST,PAR,INST,ERR,GBL) ; return all parameter instances
+1 ; .LIST: array of returned entity/instance/values in the format:
+2 ; LIST(entity,instance)=value (LIST = # of array elements)
+3 ; or a Closed Global root ($NA(^TMP($J)))
+4 ; PAR: parameter in external or internal format
+5 ; INST: instance (optional) in external or internal format
+6 ; ERR: error (0 if no error found)
+7 ; GBL: Set to 1 if LIST holds a Closed Global root
+8 NEW ENT,VAL,XPARGET,ROOT
+9 SET ENT=""
SET VAL=""
SET ERR=0
SET XPARGET=""
+10 ;Setup ROOT
+11 IF '$GET(GBL)
KILL LIST
SET ROOT=$NAME(LIST)
+12 IF $GET(GBL)
Begin DoDot:1
+13 IF $EXTRACT($GET(LIST),1)'="^"
SET ERR=$$ERR^XPARDD(89895015)
QUIT
+14 SET ROOT=LIST
+15 QUIT
End DoDot:1
if ERR
QUIT
+16 ;
+17 SET @ROOT=0
+18 ; -- parameter to internal format:
+19 IF PAR'?1.N
SET PAR=+$ORDER(^XTV(8989.51,"B",PAR,0))
+20 ;missing par
IF '$DATA(^XTV(8989.51,PAR,0))
SET ERR=$$ERR^XPARDD(89895001)
QUIT
+21 ; -- instance
+22 IF $LENGTH($GET(INST))
DO VALID^XPARDD(PAR,.INST,"I",.ERR)
if ERR
QUIT
+23 FOR
SET ENT=$ORDER(^XTV(8989.5,"AC",PAR,ENT))
if ENT=""
QUIT
Begin DoDot:1
+24 IF $LENGTH($GET(INST))
Begin DoDot:2
+25 SET VAL=$GET(^XTV(8989.5,"AC",PAR,ENT,INST))
+26 if $LENGTH($GET(VAL))
SET @ROOT@(ENT,INST)=VAL
SET @ROOT=@ROOT+1
End DoDot:2
+27 IF '$LENGTH($GET(INST))
Begin DoDot:2
+28 SET INST=""
FOR
SET INST=$ORDER(^XTV(8989.5,"AC",PAR,ENT,INST))
if INST=""
QUIT
Begin DoDot:3
+29 SET VAL=$GET(^XTV(8989.5,"AC",PAR,ENT,INST))
+30 if $LENGTH($GET(VAL))
SET @ROOT@(ENT,INST)=VAL
SET @ROOT=@ROOT+1
End DoDot:3
End DoDot:2
End DoDot:1
+31 QUIT
