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)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXPARDD 5551 printed Apr 09, 2024@21:41:31 Page 2
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
+2 ;
ALLOW(ENT,PAR) ; function
+1 ; Screen for PARAMETER (.02) field
+2 ; Returns 1 (true) if parameter allowed for this entity, otherwise 0
+3 SET ENT=$PIECE($PIECE($GET(^XTV(8989.5,ENT,0)),"^",1),";",2)
+4 IF $LENGTH(ENT)
IF $DATA(^XTV(8989.51,PAR,30,"AG",ENT))
QUIT 1
+5 QUIT 0
+6 ;
DDVALID(FLD) ; procedure
+1 ; Input transform for both INSTANCE (.03) and VALUE (1) fields
+2 ; FLD: field (I=instance, V=value)
+3 NEW X0,ENT,PAR,ERR
+4 SET X0=$GET(^XTV(8989.5,DA,0))
SET ENT=$PIECE(X0,"^",1)
SET PAR=$PIECE(X0,"^",2)
+5 DO VALID(PAR,.X,FLD,.ERR)
+6 IF FLD="I"
IF 'ERR
IF $DATA(^XTV(8989.5,"AC",PAR,ENT,X))
IF ($ORDER(^(X,0))'=DA)
Begin DoDot:1
+7 ;Duplicate
SET ERR=$$ERR(89895006)
End DoDot:1
+8 IF ERR
KILL X
DO EN^DDIOL($PIECE(ERR,"^",2))
+9 QUIT
VALID(PAR,VAL,FLD,ERR) ; procedure
+1 ; Validate both INSTANCE (.03) and VALUE (1) fields
+2 ; PAR: parameter (internal form)
+3 ; [.]VAL: value (external form), internal form returned
+4 ; FLD: field (I=instance, V=value)
+5 ; .ERR: returns error flag & description
+6 NEW DIR,DDER,DTOUT,DUOUT,DIRUT,DIROUT,MULT,SUB,X,Y
+7 SET ERR=0
+8 ;Invalid Param
IF 'PAR
SET ERR=$$ERR(89895001)
QUIT
+9 ;Missing Param
IF $DATA(^XTV(8989.51,PAR))<10
SET ERR=$$ERR(89895002)
QUIT
+10 IF '$DATA(XPARGET)
IF ($PIECE(^XTV(8989.51,PAR,0),"^",6)=1)
IF ($GET(DIUTIL)'="VERIFY FIELDS")
SET ERR=$$ERR(89895014)
QUIT
+11 SET MULT=$PIECE($GET(^XTV(8989.51,PAR,0)),"^",3)
+12 ;Not Multi Valued
IF (FLD="I")
IF (VAL'=1)
IF 'MULT
SET ERR=$$ERR(89895003)
QUIT
+13 ;Single valued instance, no checking req'd
IF (FLD="I")
IF (VAL=1)
IF 'MULT
QUIT
+14 if FLD="V"
SET SUB=0
if FLD="I"
SET SUB=5
+15 SET DIR(0)=$PIECE($GET(^XTV(8989.51,PAR,SUB+1)),"^",1,2)
SET DIR("V")=""
+16 ;Missing Type
IF '$LENGTH(DIR(0))
SET ERR=$$ERR(89895004)
QUIT
+17 ;Make silent
IF "S"[$EXTRACT(DIR(0))
SET DIR(0)=$PIECE(DIR(0),U)_"V^"_$PIECE(DIR(0),U,2,9)
+18 IF $LENGTH($GET(^XTV(8989.51,PAR,SUB+3)))
SET DIR("S")=^(SUB+3)
+19 IF $EXTRACT(DIR(0))="S"
IF (DIR(0)[(VAL_":"))
SET VAL=$PIECE($PIECE(DIR(0),VAL_":",2),";")
+20 IF $EXTRACT(DIR(0))="P"
Begin DoDot:1
+21 NEW X
SET X=$PIECE(DIR(0),"^",2)
+22 SET $PIECE(DIR(0),"^",2)=X_$SELECT(X'[":":":X",X'["X":"X",1:"")
+23 ;for Verify only
IF $GET(DIUTIL)="VERIFY FIELDS"
SET VAL="`"_VAL
End DoDot:1
+24 ;Check WP Title
IF $EXTRACT(DIR(0))="W"
SET $PIECE(DIR(0),"^",1)="F"
+25 IF $EXTRACT(DIR(0))="Y"
IF VAL?1.N
SET VAL=$SELECT(VAL=0:"NO",1:"YES")
+26 ;Resolve Date
IF $EXTRACT(DIR(0))="D"
IF $LENGTH($PIECE(DIR(0),"^",2))
Begin DoDot:1
+27 NEW %,X,T1,T2,T3
+28 SET X=$PIECE(DIR(0),"^",2)
SET T1=$PIECE(X,":",1)
SET T2=$PIECE(X,":",2)
SET T3=$PIECE(X,":",3)
+29 DO NOW^%DTC
+30 if T1="NOW"
SET T1=%
if T1="DT"
SET T1=X
if T2="NOW"
SET T2=%
if T2="DT"
SET T2=X
+31 SET $PIECE(DIR(0),"^",2)=T1_":"_T2_":"_T3
End DoDot:1
+32 IF $EXTRACT(DIR(0))="W"
SET $PIECE(DIR(0),"^",1)="F"
+33 ;Check with DIR
SET X=VAL
DO ^DIR
IF $GET(DDER)=1
KILL X
+34 ;Execute 3rd Piece
IF $DATA(X)
IF $LENGTH($GET(^XTV(8989.51,PAR,SUB+2)))
XECUTE ^(SUB+2)
+35 ;Fail Validate
IF '$DATA(X)
SET ERR=$$ERR($SELECT(FLD="V":89895005,1:89895013))
QUIT
+36 ;Pass Validate
SET VAL=$PIECE(Y,"^",1)
+37 QUIT
+38 ;
TYPE(DA,FLD) ; function **********************
+1 ; Find value type and return external value
+2 NEW X
SET X=$PIECE($GET(^XTV(8989.51,DA,$SELECT(FLD="I":6,1:1))),"^",1)
+3 QUIT $SELECT(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")
+4 ;
ERR(IEN) ; function
+1 ; Return error number and message in format: nnn^error message
+2 QUIT IEN_"^"_$$EZBLD^DIALOG(IEN)
+3 ;
HELP(FLD) ; procedure
+1 ; Executable Help for both INSTANCE (.03) and VALUE (1) fields
+2 NEW PDEFNOD,PROOT,PDESC,PHELP
+3 ;Get param definition
SET PDEFNOD=$PIECE($GET(^XTV(8989.5,DA,0)),"^",2)
+4 IF 'PDEFNOD
DO EN^DDIOL("Parameter must be entered before the value.")
+5 IF PDEFNOD
Begin DoDot:1
+6 SET PHELP=$PIECE($GET(^XTV(8989.51,PDEFNOD,$SELECT(FLD="I":6,1:1))),"^",3)
+7 IF '$LENGTH(PHELP)
SET PHELP="Enter a "_$$TYPE(PDEFNOD,FLD)_" value."
+8 DO EN^DDIOL(PHELP,"","!?5")
+9 IF X["??"
Begin DoDot:2
+10 DO EN^DDIOL("Parameter Description: ","","!!")
+11 SET PROOT=$$GET1^DIQ(8989.51,PDEFNOD_",",20,"","PDESC")
+12 DO EN^DDIOL(.PDESC)
DO EN^DDIOL($SELECT(FLD="I":"Instance",1:"Value")_" Field Description:","","!!")
End DoDot:2
End DoDot:1
+13 QUIT
OUT(Y,FLD) ; function
+1 ; returns external value (for OUTPUT TRANSFORM of .03, 1)
+2 ; ** D0 tells current record for output transform?
if $DATA(D0)#2'=1
QUIT Y
+3 NEW PAR
SET PAR=$PIECE($GET(^XTV(8989.5,D0,0)),"^",2)
+4 ;Check that PAR has a value
if '$LENGTH(PAR)
QUIT Y
+5 QUIT $$EXT(Y,PAR,FLD)
+6 ;
EXT(X,PAR,FLD) ; function
+1 ; return external value of INSTANCE or VALUE fields
+2 ; X: internal value
+3 ; PAR: parameter IEN
+4 ; FLD: "I" for instance, "V" for value fields, default="V"
+5 NEW TYP,FN
SET FLD=$GET(FLD,"V")
+6 ;Check parameters
if $GET(X)=""
QUIT ""
if $GET(PAR)=""
QUIT ""
+7 SET TYP=$PIECE($GET(^XTV(8989.51,PAR,$SELECT(FLD="I":6,1:1))),"^",1)
+8 IF "NFWMC"[TYP
QUIT X
+9 IF TYP="D"
QUIT $$EXTDATE(X)
+10 IF TYP="S"
QUIT $$EXTSET(X,PAR,FLD)
+11 IF TYP="Y"
QUIT $SELECT(X=1:"YES",1:"NO")
+12 IF TYP="P"
Begin DoDot:1
+13 SET FN=+$PIECE(^XTV(8989.51,PAR,$SELECT(FLD="I":6,1:1)),"^",2)
End DoDot:1
QUIT $$EXTPTR(X,FN)
+14 ;force error, not quitting before here is erroneous condition
QUIT
EXTDATE(Y) ; function
+1 ; return external form of date
+2 ; Y: date in internal FM format
+3 DO DD^%DT
+4 QUIT Y
EXTPTR(APTR,FN) ; function
+1 ; return external form of pointer
+2 ; APTR: pointer value
+3 ; FN: pointed to file number
+4 ;not a valid pointer
IF (+APTR'=APTR)!(APTR'>0)
QUIT APTR
+5 NEW REF
SET REF=$GET(^DIC(FN,0,"GL"))
+6 IF $LENGTH(REF)
SET @("REF=$G("_REF_APTR_",0))")
+7 if '$LENGTH(REF)
QUIT APTR
+8 SET APTR=$PIECE(REF,"^",1)
+9 QUIT $$EXTERNAL^DILFD(FN,.01,"",APTR)
EXTSET(X,PAR,FLD) ; function
+1 ; return external form for set of codes
+2 ; X: internal code
+3 ; PAR: parameter IEN
+4 ; FLD: "I" for instance, "V" for value fields, default = "V"
+5 NEW CODES
SET FLD=$GET(FLD,"V")
+6 SET CODES=$PIECE($GET(^XTV(8989.51,PAR,$SELECT(FLD="I":6,1:1))),"^",2)
+7 QUIT $PIECE($PIECE(CODES,X_":",2),";",1)
