XPAR1 ; SLC/KCM - Supporting Calls - Validate;03:32 PM 22 Apr 1998
;;7.3;TOOLKIT;**26,118**;Apr 25, 1995;Build 5
;Per VHA Directive 2004-038, this routine should not be modified.
;
INTERN ;convert ENT, PAR, and INST to internal form - called from XPAR only
; ENT: entity in external or internal form
; PAR: parameter in external or internal form
; INST: instance in external or internal form, or null
; (may be null when retrieving all instances)
; ERR: returns error (0 if none, otherwise #^error text)
; -- parameter
I 'PAR S PAR=+$O(^XTV(8989.51,"B",PAR,0))
; -- instance
I $D(XPARCHK) D VALID^XPARDD(PAR,.INST,"I",.ERR) Q:ERR
; -- entity formats are: nnn;GLO( vptr int
; PRE.NAME vptr ext
; PRE.`nnn vptr ien
; PRE default
; ALL search chain
; begin case
I ($L(ENT,"^")>1)!(ENT="ALL") D ENTLST(.ENT,PAR,INST) G C1
I ENT?3U D ENTDFLT(.ENT) G C1 ;resolve default entity
I '(+ENT&(ENT[";")) D ENTEXT(.ENT) D:ENT="" G C1 ;resolve external vptr fmt
. S ERR=$$ERR^XPARDD(89895012) ;ENT didn't resolve, set error
C1 ; end case
; by this time, ENT should be in internal variable ptr format
I '$D(XPARGET) D ;tighter checks when storing data
. I '(+ENT&(ENT[";")) S ERR=$$ERR^XPARDD(89895011) Q ;not VP fmt
. I $D(@("^"_$P(ENT,";",2)_$P(ENT,";",1)_")"))'>1 D Q ;not found
. . S ERR=$$ERR^XPARDD(89895012)
Q
ENTEXT(ENT) ; change entity from external form (PRE.NAME) to VP form
; .ENT: entity in external VP form
; .FN: optionally returns file number for entity
I ENT'["." S ENT="" Q
N FN,PRE,X
S PRE=$P(ENT,".",1),X=$P(ENT,".",2,$L(ENT,".")),ENT=""
S FN=$O(^XTV(8989.518,"C",PRE,0))
I $E(X)="`" S ENT=+$E(X,2,99)_$$MAKEVP(FN) Q
S ENT=$$FIND1^DIC(FN,"","X",X)_$$MAKEVP(FN)
I 'ENT S ENT=""
Q
ENTDFLT(ENT) ; change default form (prefix only) to actual value in VP format
; .ENT: entity prefix only
; XPARSYS should be a system wide variable, identifies current domain
I ENT="SYS" D:'$D(XPARSYS) S ENT=XPARSYS Q ; current site
. S XPARSYS=$$FIND1^DIC(4.2,"","QX",$$KSP^XUPARAM("WHERE"))_";DIC(4.2,"
I ENT="USR" S ENT=DUZ_";VA(200," Q ; user in DUZ
I ENT="CLS" S ENT="" Q ; no default
I ENT="TEA" S ENT="" Q ; no default
I ENT="BED" S ENT="" Q ; no default
I ENT="LOC" S ENT="" Q ; no default
I ENT="SRV" S ENT="" Q ; no default
I ENT="DIV" D Q ; division in DUZ(2)
. S ENT="" I +DUZ(2) S ENT=DUZ(2)_";DIC(4,"
I ENT="PKG" D Q ; package of param namespace
. N PKG,NAM
. S NAM=$P(^XTV(8989.51,PAR,0),"^",1),PKG=NAM
. F S PKG=$O(^DIC(9.4,"C",PKG),-1) Q:$E(NAM,1,$L(PKG))=PKG
. S PKG=$O(^DIC(9.4,"C",PKG,0))
. I PKG S ENT=PKG_";DIC(9.4,"
Q
ENTLST(ENT,PAR,INST) ; resolve entity list to entity with highest precedence
; .ENT: multiple entity pieces or keyword 'ALL'
; PAR: parameter IEN
; INST: instance (may be null)
I $E(ENT,1,3)="ALL" D
. N FND,IEN,FN,GREF,LIST,I,X
. ; set up list of entity values that were passed in
. F I=2:1:$L(ENT,"^") S X=$P(ENT,"^",I) I $L(X) D
. . I $D(^XTV(8989.518,"C",X)) D ENTDFLT(.X)
. . I '(+X&(X[";")) D ENTEXT(.X)
. . S GREF=$P(X,";",2) Q:GREF=""
. . I $D(^XTV(8989.51,PAR,30,"AG",GREF)) S IEN=$O(^(GREF,0)) D
. . . S LIST($P(^XTV(8989.51,PAR,30,IEN,0),"^",2))=X
. ; using precedence defined for parameter, look up entities
. S I=0,FND=0
. F S I=$O(^XTV(8989.51,PAR,30,"B",I)) Q:'I S IEN=$O(^(I,0)) D Q:FND
. . S FN=$P(^XTV(8989.51,PAR,30,IEN,0),"^",2),X=$G(LIST(FN))
. . I '$L(X) S X=$P(^XTV(8989.518,FN,0),U,2) D ENTDFLT(.X)
. . I $L(X),'$L(INST),$D(^XTV(8989.5,"AC",PAR,X)) S ENT=X,FND=1 Q
. . I $L(X),$L(INST),$D(^XTV(8989.5,"AC",PAR,X,INST)) S ENT=X,FND=1 Q
E D
. ; use only entity values that were passed in
. N I,FND
. S FND=0
. F I=1:1:$L(ENT,"^") S X=$P(ENT,"^",I) I $L(X) D Q:FND
. . I $D(^XTV(8989.518,"C",X)) D ENTDFLT(.X)
. . I '(+X&(X[";")) D ENTEXT(.X)
. . I $L(X),'$L(INST),$D(^XTV(8989.5,"AC",PAR,X)) S ENT=X,FND=1 Q
. . I $L(X),$L(INST),$D(^XTV(8989.5,"AC",PAR,X,INST)) S ENT=X,FND=1 Q
Q
MAKEVP(FN) ; function - returns VP suffix given file number
; N Y
; D FILE^DID(FN,"","GLOBAL NAME","Y")
; Q ";"_$P($G(Y("GLOBAL NAME")),"^",2)
Q ";"_$P($G(^DIC(FN,0,"GL")),U,2)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXPAR1 4495 printed Apr 09, 2024@21:44:24 Page 2
XPAR1 ; SLC/KCM - Supporting Calls - Validate;03:32 PM 22 Apr 1998
+1 ;;7.3;TOOLKIT;**26,118**;Apr 25, 1995;Build 5
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
INTERN ;convert ENT, PAR, and INST to internal form - called from XPAR only
+1 ; ENT: entity in external or internal form
+2 ; PAR: parameter in external or internal form
+3 ; INST: instance in external or internal form, or null
+4 ; (may be null when retrieving all instances)
+5 ; ERR: returns error (0 if none, otherwise #^error text)
+6 ; -- parameter
+7 IF 'PAR
SET PAR=+$ORDER(^XTV(8989.51,"B",PAR,0))
+8 ; -- instance
+9 IF $DATA(XPARCHK)
DO VALID^XPARDD(PAR,.INST,"I",.ERR)
if ERR
QUIT
+10 ; -- entity formats are: nnn;GLO( vptr int
+11 ; PRE.NAME vptr ext
+12 ; PRE.`nnn vptr ien
+13 ; PRE default
+14 ; ALL search chain
+15 ; begin case
+16 IF ($LENGTH(ENT,"^")>1)!(ENT="ALL")
DO ENTLST(.ENT,PAR,INST)
GOTO C1
+17 ;resolve default entity
IF ENT?3U
DO ENTDFLT(.ENT)
GOTO C1
+18 ;resolve external vptr fmt
IF '(+ENT&(ENT[";"))
DO ENTEXT(.ENT)
if ENT=""
Begin DoDot:1
+19 ;ENT didn't resolve, set error
SET ERR=$$ERR^XPARDD(89895012)
End DoDot:1
GOTO C1
C1 ; end case
+1 ; by this time, ENT should be in internal variable ptr format
+2 ;tighter checks when storing data
IF '$DATA(XPARGET)
Begin DoDot:1
+3 ;not VP fmt
IF '(+ENT&(ENT[";"))
SET ERR=$$ERR^XPARDD(89895011)
QUIT
+4 ;not found
IF $DATA(@("^"_$PIECE(ENT,";",2)_$PIECE(ENT,";",1)_")"))'>1
Begin DoDot:2
+5 SET ERR=$$ERR^XPARDD(89895012)
End DoDot:2
QUIT
End DoDot:1
+6 QUIT
ENTEXT(ENT) ; change entity from external form (PRE.NAME) to VP form
+1 ; .ENT: entity in external VP form
+2 ; .FN: optionally returns file number for entity
+3 IF ENT'["."
SET ENT=""
QUIT
+4 NEW FN,PRE,X
+5 SET PRE=$PIECE(ENT,".",1)
SET X=$PIECE(ENT,".",2,$LENGTH(ENT,"."))
SET ENT=""
+6 SET FN=$ORDER(^XTV(8989.518,"C",PRE,0))
+7 IF $EXTRACT(X)="`"
SET ENT=+$EXTRACT(X,2,99)_$$MAKEVP(FN)
QUIT
+8 SET ENT=$$FIND1^DIC(FN,"","X",X)_$$MAKEVP(FN)
+9 IF 'ENT
SET ENT=""
+10 QUIT
ENTDFLT(ENT) ; change default form (prefix only) to actual value in VP format
+1 ; .ENT: entity prefix only
+2 ; XPARSYS should be a system wide variable, identifies current domain
+3 ; current site
IF ENT="SYS"
if '$DATA(XPARSYS)
Begin DoDot:1
+4 SET XPARSYS=$$FIND1^DIC(4.2,"","QX",$$KSP^XUPARAM("WHERE"))_";DIC(4.2,"
End DoDot:1
SET ENT=XPARSYS
QUIT
+5 ; user in DUZ
IF ENT="USR"
SET ENT=DUZ_";VA(200,"
QUIT
+6 ; no default
IF ENT="CLS"
SET ENT=""
QUIT
+7 ; no default
IF ENT="TEA"
SET ENT=""
QUIT
+8 ; no default
IF ENT="BED"
SET ENT=""
QUIT
+9 ; no default
IF ENT="LOC"
SET ENT=""
QUIT
+10 ; no default
IF ENT="SRV"
SET ENT=""
QUIT
+11 ; division in DUZ(2)
IF ENT="DIV"
Begin DoDot:1
+12 SET ENT=""
IF +DUZ(2)
SET ENT=DUZ(2)_";DIC(4,"
End DoDot:1
QUIT
+13 ; package of param namespace
IF ENT="PKG"
Begin DoDot:1
+14 NEW PKG,NAM
+15 SET NAM=$PIECE(^XTV(8989.51,PAR,0),"^",1)
SET PKG=NAM
+16 FOR
SET PKG=$ORDER(^DIC(9.4,"C",PKG),-1)
if $EXTRACT(NAM,1,$LENGTH(PKG))=PKG
QUIT
+17 SET PKG=$ORDER(^DIC(9.4,"C",PKG,0))
+18 IF PKG
SET ENT=PKG_";DIC(9.4,"
End DoDot:1
QUIT
+19 QUIT
ENTLST(ENT,PAR,INST) ; resolve entity list to entity with highest precedence
+1 ; .ENT: multiple entity pieces or keyword 'ALL'
+2 ; PAR: parameter IEN
+3 ; INST: instance (may be null)
+4 IF $EXTRACT(ENT,1,3)="ALL"
Begin DoDot:1
+5 NEW FND,IEN,FN,GREF,LIST,I,X
+6 ; set up list of entity values that were passed in
+7 FOR I=2:1:$LENGTH(ENT,"^")
SET X=$PIECE(ENT,"^",I)
IF $LENGTH(X)
Begin DoDot:2
+8 IF $DATA(^XTV(8989.518,"C",X))
DO ENTDFLT(.X)
+9 IF '(+X&(X[";"))
DO ENTEXT(.X)
+10 SET GREF=$PIECE(X,";",2)
if GREF=""
QUIT
+11 IF $DATA(^XTV(8989.51,PAR,30,"AG",GREF))
SET IEN=$ORDER(^(GREF,0))
Begin DoDot:3
+12 SET LIST($PIECE(^XTV(8989.51,PAR,30,IEN,0),"^",2))=X
End DoDot:3
End DoDot:2
+13 ; using precedence defined for parameter, look up entities
+14 SET I=0
SET FND=0
+15 FOR
SET I=$ORDER(^XTV(8989.51,PAR,30,"B",I))
if 'I
QUIT
SET IEN=$ORDER(^(I,0))
Begin DoDot:2
+16 SET FN=$PIECE(^XTV(8989.51,PAR,30,IEN,0),"^",2)
SET X=$GET(LIST(FN))
+17 IF '$LENGTH(X)
SET X=$PIECE(^XTV(8989.518,FN,0),U,2)
DO ENTDFLT(.X)
+18 IF $LENGTH(X)
IF '$LENGTH(INST)
IF $DATA(^XTV(8989.5,"AC",PAR,X))
SET ENT=X
SET FND=1
QUIT
+19 IF $LENGTH(X)
IF $LENGTH(INST)
IF $DATA(^XTV(8989.5,"AC",PAR,X,INST))
SET ENT=X
SET FND=1
QUIT
End DoDot:2
if FND
QUIT
End DoDot:1
+20 IF '$TEST
Begin DoDot:1
+21 ; use only entity values that were passed in
+22 NEW I,FND
+23 SET FND=0
+24 FOR I=1:1:$LENGTH(ENT,"^")
SET X=$PIECE(ENT,"^",I)
IF $LENGTH(X)
Begin DoDot:2
+25 IF $DATA(^XTV(8989.518,"C",X))
DO ENTDFLT(.X)
+26 IF '(+X&(X[";"))
DO ENTEXT(.X)
+27 IF $LENGTH(X)
IF '$LENGTH(INST)
IF $DATA(^XTV(8989.5,"AC",PAR,X))
SET ENT=X
SET FND=1
QUIT
+28 IF $LENGTH(X)
IF $LENGTH(INST)
IF $DATA(^XTV(8989.5,"AC",PAR,X,INST))
SET ENT=X
SET FND=1
QUIT
End DoDot:2
if FND
QUIT
End DoDot:1
+29 QUIT
MAKEVP(FN) ; function - returns VP suffix given file number
+1 ; N Y
+2 ; D FILE^DID(FN,"","GLOBAL NAME","Y")
+3 ; Q ";"_$P($G(Y("GLOBAL NAME")),"^",2)
+4 QUIT ";"_$PIECE($GET(^DIC(FN,0,"GL")),U,2)
