Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XPARDD

XPARDD.m

Go to the documentation of this file.
  1. XPARDD ; SLC/KCM - DD Logic for Parameters (8989.5) ;05/14/2003 07:28
  1. ;;7.3;TOOLKIT;**26,35,39,63,69**;Apr 25, 1995
  1. ;
  1. ALLOW(ENT,PAR) ; function
  1. ; Screen for PARAMETER (.02) field
  1. ; Returns 1 (true) if parameter allowed for this entity, otherwise 0
  1. S ENT=$P($P($G(^XTV(8989.5,ENT,0)),"^",1),";",2)
  1. I $L(ENT),$D(^XTV(8989.51,PAR,30,"AG",ENT)) Q 1
  1. Q 0
  1. ;
  1. DDVALID(FLD) ; procedure
  1. ; Input transform for both INSTANCE (.03) and VALUE (1) fields
  1. ; FLD: field (I=instance, V=value)
  1. N X0,ENT,PAR,ERR
  1. S X0=$G(^XTV(8989.5,DA,0)),ENT=$P(X0,"^",1),PAR=$P(X0,"^",2)
  1. D VALID(PAR,.X,FLD,.ERR)
  1. I FLD="I",'ERR,$D(^XTV(8989.5,"AC",PAR,ENT,X)),($O(^(X,0))'=DA) D
  1. . S ERR=$$ERR(89895006) ;Duplicate
  1. I ERR K X D EN^DDIOL($P(ERR,"^",2))
  1. Q
  1. VALID(PAR,VAL,FLD,ERR) ; procedure
  1. ; Validate both INSTANCE (.03) and VALUE (1) fields
  1. ; PAR: parameter (internal form)
  1. ; [.]VAL: value (external form), internal form returned
  1. ; FLD: field (I=instance, V=value)
  1. ; .ERR: returns error flag & description
  1. N DIR,DDER,DTOUT,DUOUT,DIRUT,DIROUT,MULT,SUB,X,Y
  1. S ERR=0
  1. I 'PAR S ERR=$$ERR(89895001) Q ;Invalid Param
  1. I $D(^XTV(8989.51,PAR))<10 S ERR=$$ERR(89895002) Q ;Missing Param
  1. I '$D(XPARGET),($P(^XTV(8989.51,PAR,0),"^",6)=1),($G(DIUTIL)'="VERIFY FIELDS") S ERR=$$ERR(89895014) Q
  1. S MULT=$P($G(^XTV(8989.51,PAR,0)),"^",3)
  1. I (FLD="I"),(VAL'=1),'MULT S ERR=$$ERR(89895003) Q ;Not Multi Valued
  1. I (FLD="I"),(VAL=1),'MULT Q ;Single valued instance, no checking req'd
  1. S:FLD="V" SUB=0 S:FLD="I" SUB=5
  1. S DIR(0)=$P($G(^XTV(8989.51,PAR,SUB+1)),"^",1,2),DIR("V")=""
  1. I '$L(DIR(0)) S ERR=$$ERR(89895004) Q ;Missing Type
  1. I "S"[$E(DIR(0)) S DIR(0)=$P(DIR(0),U)_"V^"_$P(DIR(0),U,2,9) ;Make silent
  1. I $L($G(^XTV(8989.51,PAR,SUB+3))) S DIR("S")=^(SUB+3)
  1. I $E(DIR(0))="S",(DIR(0)[(VAL_":")) S VAL=$P($P(DIR(0),VAL_":",2),";")
  1. I $E(DIR(0))="P" D
  1. . N X S X=$P(DIR(0),"^",2)
  1. . S $P(DIR(0),"^",2)=X_$S(X'[":":":X",X'["X":"X",1:"")
  1. . I $G(DIUTIL)="VERIFY FIELDS" S VAL="`"_VAL ;for Verify only
  1. I $E(DIR(0))="W" S $P(DIR(0),"^",1)="F" ;Check WP Title
  1. I $E(DIR(0))="Y",VAL?1.N S VAL=$S(VAL=0:"NO",1:"YES")
  1. I $E(DIR(0))="D",$L($P(DIR(0),"^",2)) D ;Resolve Date
  1. . N %,X,T1,T2,T3
  1. . S X=$P(DIR(0),"^",2),T1=$P(X,":",1),T2=$P(X,":",2),T3=$P(X,":",3)
  1. . D NOW^%DTC
  1. . S:T1="NOW" T1=% S:T1="DT" T1=X S:T2="NOW" T2=% S:T2="DT" T2=X
  1. . S $P(DIR(0),"^",2)=T1_":"_T2_":"_T3
  1. I $E(DIR(0))="W" S $P(DIR(0),"^",1)="F"
  1. S X=VAL D ^DIR I $G(DDER)=1 K X ;Check with DIR
  1. I $D(X),$L($G(^XTV(8989.51,PAR,SUB+2))) X ^(SUB+2) ;Execute 3rd Piece
  1. I '$D(X) S ERR=$$ERR($S(FLD="V":89895005,1:89895013)) Q ;Fail Validate
  1. S VAL=$P(Y,"^",1) ;Pass Validate
  1. Q
  1. ;
  1. TYPE(DA,FLD) ; function **********************
  1. ; Find value type and return external value
  1. N X S X=$P($G(^XTV(8989.51,DA,$S(FLD="I":6,1:1))),"^",1)
  1. Q $S(X="D":"Date/Time",X="F":"Free Text",X="N":"Numeric",X="S":"Set",X="Y":"Yes/No",X="P":"Pointer",X="W":"Word Processing",1:"undefined")
  1. ;
  1. ERR(IEN) ; function
  1. ; Return error number and message in format: nnn^error message
  1. Q IEN_"^"_$$EZBLD^DIALOG(IEN)
  1. ;
  1. HELP(FLD) ; procedure
  1. ; Executable Help for both INSTANCE (.03) and VALUE (1) fields
  1. N PDEFNOD,PROOT,PDESC,PHELP
  1. S PDEFNOD=$P($G(^XTV(8989.5,DA,0)),"^",2) ;Get param definition
  1. I 'PDEFNOD D EN^DDIOL("Parameter must be entered before the value.")
  1. I PDEFNOD D
  1. . S PHELP=$P($G(^XTV(8989.51,PDEFNOD,$S(FLD="I":6,1:1))),"^",3)
  1. . I '$L(PHELP) S PHELP="Enter a "_$$TYPE(PDEFNOD,FLD)_" value."
  1. . D EN^DDIOL(PHELP,"","!?5")
  1. . I X["??" D
  1. . . D EN^DDIOL("Parameter Description: ","","!!")
  1. . . S PROOT=$$GET1^DIQ(8989.51,PDEFNOD_",",20,"","PDESC")
  1. . . D EN^DDIOL(.PDESC),EN^DDIOL($S(FLD="I":"Instance",1:"Value")_" Field Description:","","!!")
  1. Q
  1. OUT(Y,FLD) ; function
  1. ; returns external value (for OUTPUT TRANSFORM of .03, 1)
  1. Q:$D(D0)#2'=1 Y ; ** D0 tells current record for output transform?
  1. N PAR S PAR=$P($G(^XTV(8989.5,D0,0)),"^",2)
  1. Q:'$L(PAR) Y ;Check that PAR has a value
  1. Q $$EXT(Y,PAR,FLD)
  1. ;
  1. EXT(X,PAR,FLD) ; function
  1. ; return external value of INSTANCE or VALUE fields
  1. ; X: internal value
  1. ; PAR: parameter IEN
  1. ; FLD: "I" for instance, "V" for value fields, default="V"
  1. N TYP,FN S FLD=$G(FLD,"V")
  1. Q:$G(X)="" "" Q:$G(PAR)="" "" ;Check parameters
  1. S TYP=$P($G(^XTV(8989.51,PAR,$S(FLD="I":6,1:1))),"^",1)
  1. I "NFWMC"[TYP Q X
  1. I TYP="D" Q $$EXTDATE(X)
  1. I TYP="S" Q $$EXTSET(X,PAR,FLD)
  1. I TYP="Y" Q $S(X=1:"YES",1:"NO")
  1. I TYP="P" D Q $$EXTPTR(X,FN)
  1. . S FN=+$P(^XTV(8989.51,PAR,$S(FLD="I":6,1:1)),"^",2)
  1. Q ;force error, not quitting before here is erroneous condition
  1. EXTDATE(Y) ; function
  1. ; return external form of date
  1. ; Y: date in internal FM format
  1. D DD^%DT
  1. Q Y
  1. EXTPTR(APTR,FN) ; function
  1. ; return external form of pointer
  1. ; APTR: pointer value
  1. ; FN: pointed to file number
  1. I (+APTR'=APTR)!(APTR'>0) Q APTR ;not a valid pointer
  1. N REF S REF=$G(^DIC(FN,0,"GL"))
  1. I $L(REF) S @("REF=$G("_REF_APTR_",0))")
  1. Q:'$L(REF) APTR
  1. S APTR=$P(REF,"^",1)
  1. Q $$EXTERNAL^DILFD(FN,.01,"",APTR)
  1. EXTSET(X,PAR,FLD) ; function
  1. ; return external form for set of codes
  1. ; X: internal code
  1. ; PAR: parameter IEN
  1. ; FLD: "I" for instance, "V" for value fields, default = "V"
  1. N CODES S FLD=$G(FLD,"V")
  1. S CODES=$P($G(^XTV(8989.51,PAR,$S(FLD="I":6,1:1))),"^",2)
  1. Q $P($P(CODES,X_":",2),";",1)