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

XPARDD ; SLC/KCM - DD Logic for Parameters (8989.5) ;05/14/2003  07:28

 ;;7.3;TOOLKIT;**26,35,39,63,69**;Apr 25, 1995

 ;

ALLOW(ENT,PAR) ; function

 ; Screen for PARAMETER (.02) field

 ; Returns 1 (true) if parameter allowed for this entity, otherwise 0

 S ENT=$P($P($G(^XTV(8989.5,ENT,0)),"^",1),";",2)

 I $L(ENT),$D(^XTV(8989.51,PAR,30,"AG",ENT)) Q 1

 Q 0

 ;

DDVALID(FLD) ; procedure

 ; Input transform for both INSTANCE (.03) and VALUE (1) fields

 ;    FLD: field (I=instance, V=value)

 N X0,ENT,PAR,ERR

 S X0=$G(^XTV(8989.5,DA,0)),ENT=$P(X0,"^",1),PAR=$P(X0,"^",2)

 D VALID(PAR,.X,FLD,.ERR)

 I FLD="I",'ERR,$D(^XTV(8989.5,"AC",PAR,ENT,X)),($O(^(X,0))'=DA) D

 . S ERR=$$ERR(89895006)                               ;Duplicate

 I ERR K X D EN^DDIOL($P(ERR,"^",2))

 Q

VALID(PAR,VAL,FLD,ERR) ; procedure

 ; Validate both INSTANCE (.03) and VALUE (1) fields

 ;    PAR: parameter (internal form)

 ; [.]VAL: value (external form), internal form returned

 ;    FLD: field (I=instance, V=value)

 ;   .ERR: returns error flag & description

 N DIR,DDER,DTOUT,DUOUT,DIRUT,DIROUT,MULT,SUB,X,Y

 S ERR=0

 I 'PAR S ERR=$$ERR(89895001) Q                        ;Invalid Param

 I $D(^XTV(8989.51,PAR))<10 S ERR=$$ERR(89895002) Q    ;Missing Param

 I '$D(XPARGET),($P(^XTV(8989.51,PAR,0),"^",6)=1),($G(DIUTIL)'="VERIFY FIELDS") S ERR=$$ERR(89895014) Q

 S MULT=$P($G(^XTV(8989.51,PAR,0)),"^",3)

 I (FLD="I"),(VAL'=1),'MULT S ERR=$$ERR(89895003) Q    ;Not Multi Valued

 I (FLD="I"),(VAL=1),'MULT Q  ;Single valued instance, no checking req'd

 S:FLD="V" SUB=0 S:FLD="I" SUB=5

 S DIR(0)=$P($G(^XTV(8989.51,PAR,SUB+1)),"^",1,2),DIR("V")=""

 I '$L(DIR(0)) S ERR=$$ERR(89895004) Q                 ;Missing Type

 I "S"[$E(DIR(0)) S DIR(0)=$P(DIR(0),U)_"V^"_$P(DIR(0),U,2,9) ;Make silent

 I $L($G(^XTV(8989.51,PAR,SUB+3))) S DIR("S")=^(SUB+3)

 I $E(DIR(0))="S",(DIR(0)[(VAL_":")) S VAL=$P($P(DIR(0),VAL_":",2),";")

 I $E(DIR(0))="P" D

 . N X S X=$P(DIR(0),"^",2)

 . S $P(DIR(0),"^",2)=X_$S(X'[":":":X",X'["X":"X",1:"")

 . I $G(DIUTIL)="VERIFY FIELDS" S VAL="`"_VAL          ;for Verify only

 I $E(DIR(0))="W" S $P(DIR(0),"^",1)="F"               ;Check WP Title

 I $E(DIR(0))="Y",VAL?1.N S VAL=$S(VAL=0:"NO",1:"YES")

 I $E(DIR(0))="D",$L($P(DIR(0),"^",2)) D               ;Resolve Date

 . N %,X,T1,T2,T3

 . S X=$P(DIR(0),"^",2),T1=$P(X,":",1),T2=$P(X,":",2),T3=$P(X,":",3)

 . D NOW^%DTC

 . S:T1="NOW" T1=% S:T1="DT" T1=X S:T2="NOW" T2=% S:T2="DT" T2=X

 . S $P(DIR(0),"^",2)=T1_":"_T2_":"_T3

 I $E(DIR(0))="W" S $P(DIR(0),"^",1)="F"

 S X=VAL D ^DIR I $G(DDER)=1 K X                       ;Check with DIR

 I $D(X),$L($G(^XTV(8989.51,PAR,SUB+2))) X ^(SUB+2)    ;Execute 3rd Piece

 I '$D(X) S ERR=$$ERR($S(FLD="V":89895005,1:89895013)) Q  ;Fail Validate

 S VAL=$P(Y,"^",1)                                        ;Pass Validate

 Q

 ;

TYPE(DA,FLD) ; function  **********************

 ; Find value type and return external value

 N X S X=$P($G(^XTV(8989.51,DA,$S(FLD="I":6,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")

 ;

ERR(IEN) ; function

 ; Return error number and message in format:  nnn^error message

 Q IEN_"^"_$$EZBLD^DIALOG(IEN)

 ;

HELP(FLD) ; procedure

 ; Executable Help for both INSTANCE (.03) and VALUE (1) fields

 N PDEFNOD,PROOT,PDESC,PHELP

 S PDEFNOD=$P($G(^XTV(8989.5,DA,0)),"^",2)    ;Get param definition

 I 'PDEFNOD D EN^DDIOL("Parameter must be entered before the value.")

 I PDEFNOD D

 . S PHELP=$P($G(^XTV(8989.51,PDEFNOD,$S(FLD="I":6,1:1))),"^",3)

 . I '$L(PHELP) S PHELP="Enter a "_$$TYPE(PDEFNOD,FLD)_" value."

 . D EN^DDIOL(PHELP,"","!?5")

 . I X["??" D

 . . D EN^DDIOL("Parameter Description: ","","!!")

 . . S PROOT=$$GET1^DIQ(8989.51,PDEFNOD_",",20,"","PDESC")

 . . D EN^DDIOL(.PDESC),EN^DDIOL($S(FLD="I":"Instance",1:"Value")_" Field Description:","","!!")

 Q

OUT(Y,FLD) ; function

 ; returns external value (for OUTPUT TRANSFORM of .03, 1)

 Q:$D(D0)#2'=1 Y ; ** D0 tells current record for output transform?

 N PAR S PAR=$P($G(^XTV(8989.5,D0,0)),"^",2)

 Q:'$L(PAR) Y ;Check that PAR has a value

 Q $$EXT(Y,PAR,FLD)

 ;

EXT(X,PAR,FLD) ; function

 ; return external value of INSTANCE or VALUE fields

 ;   X: internal value

 ; PAR: parameter IEN

 ; FLD: "I" for instance, "V" for value fields, default="V"

 N TYP,FN S FLD=$G(FLD,"V")

 Q:$G(X)="" "" Q:$G(PAR)="" "" ;Check parameters

 S TYP=$P($G(^XTV(8989.51,PAR,$S(FLD="I":6,1:1))),"^",1)

 I "NFWMC"[TYP Q X

 I TYP="D" Q $$EXTDATE(X)

 I TYP="S" Q $$EXTSET(X,PAR,FLD)

 I TYP="Y" Q $S(X=1:"YES",1:"NO")

 I TYP="P" D  Q $$EXTPTR(X,FN)

 . S FN=+$P(^XTV(8989.51,PAR,$S(FLD="I":6,1:1)),"^",2)

 Q  ;force error, not quitting before here is erroneous condition

EXTDATE(Y) ; function

 ; return external form of date

 ; Y: date in internal FM format

 D DD^%DT

 Q Y

EXTPTR(APTR,FN) ; function

 ; return external form of pointer

 ; APTR: pointer value

 ;   FN: pointed to file number

 I (+APTR'=APTR)!(APTR'>0) Q APTR ;not a valid pointer

 N REF S REF=$G(^DIC(FN,0,"GL"))

 I $L(REF) S @("REF=$G("_REF_APTR_",0))")

 Q:'$L(REF) APTR

 S APTR=$P(REF,"^",1)

 Q $$EXTERNAL^DILFD(FN,.01,"",APTR)

EXTSET(X,PAR,FLD) ; function

 ; return external form for set of codes

 ;   X: internal code

 ; PAR: parameter IEN

 ; FLD: "I" for instance, "V" for value fields, default = "V"

 N CODES S FLD=$G(FLD,"V")

 S CODES=$P($G(^XTV(8989.51,PAR,$S(FLD="I":6,1:1))),"^",2)

 Q $P($P(CODES,X_":",2),";",1)