- 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 Feb 19, 2025@00:06:40 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)
