- 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 Jan 18, 2025@03:41:22 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)