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

Last change on this file since 1474 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 5.3 KB
Line 
1XPARDD ; SLC/KCM - DD Logic for Parameters (8989.5) ;05/14/2003 07:28
2 ;;7.3;TOOLKIT;**26,35,39,63,69**;Apr 25, 1995
3 ;
4ALLOW(ENT,PAR) ; function
5 ; Screen for PARAMETER (.02) field
6 ; Returns 1 (true) if parameter allowed for this entity, otherwise 0
7 S ENT=$P($P($G(^XTV(8989.5,ENT,0)),"^",1),";",2)
8 I $L(ENT),$D(^XTV(8989.51,PAR,30,"AG",ENT)) Q 1
9 Q 0
10 ;
11DDVALID(FLD) ; procedure
12 ; Input transform for both INSTANCE (.03) and VALUE (1) fields
13 ; FLD: field (I=instance, V=value)
14 N X0,ENT,PAR,ERR
15 S X0=$G(^XTV(8989.5,DA,0)),ENT=$P(X0,"^",1),PAR=$P(X0,"^",2)
16 D VALID(PAR,.X,FLD,.ERR)
17 I FLD="I",'ERR,$D(^XTV(8989.5,"AC",PAR,ENT,X)),($O(^(X,0))'=DA) D
18 . S ERR=$$ERR(89895006) ;Duplicate
19 I ERR K X D EN^DDIOL($P(ERR,"^",2))
20 Q
21VALID(PAR,VAL,FLD,ERR) ; procedure
22 ; Validate both INSTANCE (.03) and VALUE (1) fields
23 ; PAR: parameter (internal form)
24 ; [.]VAL: value (external form), internal form returned
25 ; FLD: field (I=instance, V=value)
26 ; .ERR: returns error flag & description
27 N DIR,DDER,DTOUT,DUOUT,DIRUT,DIROUT,MULT,SUB,X,Y
28 S ERR=0
29 I 'PAR S ERR=$$ERR(89895001) Q ;Invalid Param
30 I $D(^XTV(8989.51,PAR))<10 S ERR=$$ERR(89895002) Q ;Missing Param
31 I '$D(XPARGET),($P(^XTV(8989.51,PAR,0),"^",6)=1),($G(DIUTIL)'="VERIFY FIELDS") S ERR=$$ERR(89895014) Q
32 S MULT=$P($G(^XTV(8989.51,PAR,0)),"^",3)
33 I (FLD="I"),(VAL'=1),'MULT S ERR=$$ERR(89895003) Q ;Not Multi Valued
34 I (FLD="I"),(VAL=1),'MULT Q ;Single valued instance, no checking req'd
35 S:FLD="V" SUB=0 S:FLD="I" SUB=5
36 S DIR(0)=$P($G(^XTV(8989.51,PAR,SUB+1)),"^",1,2),DIR("V")=""
37 I '$L(DIR(0)) S ERR=$$ERR(89895004) Q ;Missing Type
38 I "S"[$E(DIR(0)) S DIR(0)=$P(DIR(0),U)_"V^"_$P(DIR(0),U,2,9) ;Make silent
39 I $L($G(^XTV(8989.51,PAR,SUB+3))) S DIR("S")=^(SUB+3)
40 I $E(DIR(0))="S",(DIR(0)[(VAL_":")) S VAL=$P($P(DIR(0),VAL_":",2),";")
41 I $E(DIR(0))="P" D
42 . N X S X=$P(DIR(0),"^",2)
43 . S $P(DIR(0),"^",2)=X_$S(X'[":":":X",X'["X":"X",1:"")
44 . I $G(DIUTIL)="VERIFY FIELDS" S VAL="`"_VAL ;for Verify only
45 I $E(DIR(0))="W" S $P(DIR(0),"^",1)="F" ;Check WP Title
46 I $E(DIR(0))="Y",VAL?1.N S VAL=$S(VAL=0:"NO",1:"YES")
47 I $E(DIR(0))="D",$L($P(DIR(0),"^",2)) D ;Resolve Date
48 . N %,X,T1,T2,T3
49 . S X=$P(DIR(0),"^",2),T1=$P(X,":",1),T2=$P(X,":",2),T3=$P(X,":",3)
50 . D NOW^%DTC
51 . S:T1="NOW" T1=% S:T1="DT" T1=X S:T2="NOW" T2=% S:T2="DT" T2=X
52 . S $P(DIR(0),"^",2)=T1_":"_T2_":"_T3
53 I $E(DIR(0))="W" S $P(DIR(0),"^",1)="F"
54 S X=VAL D ^DIR I $G(DDER)=1 K X ;Check with DIR
55 I $D(X),$L($G(^XTV(8989.51,PAR,SUB+2))) X ^(SUB+2) ;Execute 3rd Piece
56 I '$D(X) S ERR=$$ERR($S(FLD="V":89895005,1:89895013)) Q ;Fail Validate
57 S VAL=$P(Y,"^",1) ;Pass Validate
58 Q
59 ;
60TYPE(DA,FLD) ; function **********************
61 ; Find value type and return external value
62 N X S X=$P($G(^XTV(8989.51,DA,$S(FLD="I":6,1:1))),"^",1)
63 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")
64 ;
65ERR(IEN) ; function
66 ; Return error number and message in format: nnn^error message
67 Q IEN_"^"_$$EZBLD^DIALOG(IEN)
68 ;
69HELP(FLD) ; procedure
70 ; Executable Help for both INSTANCE (.03) and VALUE (1) fields
71 N PDEFNOD,PROOT,PDESC,PHELP
72 S PDEFNOD=$P($G(^XTV(8989.5,DA,0)),"^",2) ;Get param definition
73 I 'PDEFNOD D EN^DDIOL("Parameter must be entered before the value.")
74 I PDEFNOD D
75 . S PHELP=$P($G(^XTV(8989.51,PDEFNOD,$S(FLD="I":6,1:1))),"^",3)
76 . I '$L(PHELP) S PHELP="Enter a "_$$TYPE(PDEFNOD,FLD)_" value."
77 . D EN^DDIOL(PHELP,"","!?5")
78 . I X["??" D
79 . . D EN^DDIOL("Parameter Description: ","","!!")
80 . . S PROOT=$$GET1^DIQ(8989.51,PDEFNOD_",",20,"","PDESC")
81 . . D EN^DDIOL(.PDESC),EN^DDIOL($S(FLD="I":"Instance",1:"Value")_" Field Description:","","!!")
82 Q
83OUT(Y,FLD) ; function
84 ; returns external value (for OUTPUT TRANSFORM of .03, 1)
85 Q:$D(D0)#2'=1 Y ; ** D0 tells current record for output transform?
86 N PAR S PAR=$P($G(^XTV(8989.5,D0,0)),"^",2)
87 Q:'$L(PAR) Y ;Check that PAR has a value
88 Q $$EXT(Y,PAR,FLD)
89 ;
90EXT(X,PAR,FLD) ; function
91 ; return external value of INSTANCE or VALUE fields
92 ; X: internal value
93 ; PAR: parameter IEN
94 ; FLD: "I" for instance, "V" for value fields, default="V"
95 N TYP,FN S FLD=$G(FLD,"V")
96 Q:$G(X)="" "" Q:$G(PAR)="" "" ;Check parameters
97 S TYP=$P($G(^XTV(8989.51,PAR,$S(FLD="I":6,1:1))),"^",1)
98 I "NFWMC"[TYP Q X
99 I TYP="D" Q $$EXTDATE(X)
100 I TYP="S" Q $$EXTSET(X,PAR,FLD)
101 I TYP="Y" Q $S(X=1:"YES",1:"NO")
102 I TYP="P" D Q $$EXTPTR(X,FN)
103 . S FN=+$P(^XTV(8989.51,PAR,$S(FLD="I":6,1:1)),"^",2)
104 Q ;force error, not quitting before here is erroneous condition
105EXTDATE(Y) ; function
106 ; return external form of date
107 ; Y: date in internal FM format
108 D DD^%DT
109 Q Y
110EXTPTR(APTR,FN) ; function
111 ; return external form of pointer
112 ; APTR: pointer value
113 ; FN: pointed to file number
114 I (+APTR'=APTR)!(APTR'>0) Q APTR ;not a valid pointer
115 N REF S REF=$G(^DIC(FN,0,"GL"))
116 I $L(REF) S @("REF=$G("_REF_APTR_",0))")
117 Q:'$L(REF) APTR
118 S APTR=$P(REF,"^",1)
119 Q $$EXTERNAL^DILFD(FN,.01,"",APTR)
120EXTSET(X,PAR,FLD) ; function
121 ; return external form for set of codes
122 ; X: internal code
123 ; PAR: parameter IEN
124 ; FLD: "I" for instance, "V" for value fields, default = "V"
125 N CODES S FLD=$G(FLD,"V")
126 S CODES=$P($G(^XTV(8989.51,PAR,$S(FLD="I":6,1:1))),"^",2)
127 Q $P($P(CODES,X_":",2),";",1)
Note: See TracBrowser for help on using the repository browser.