DIETLIBF ;SFISC/MKO,GFT - LIBRARY FOR FIELD ATTRIBUTES ;23JUN2017
;;22.2;VA FileMan;**2,5,13**;Jan 05, 2016;Build 4
;;Per VA Directive 6402, this routine should not be modified.
;
;The following functions return, for a given file and field,
;code to do something, such as validate user input, or validate
;the internal form of data. The actual code to perform these
;functions may reside under one of several methods, so a list of
;methods need to be searched.
;
;Input to these methods are:
; DDTFILE = File #
; DDTFIELD = Field #
;
;Returned is:
; Code for method or null
;
VALEXT(DDTFILE,DDTFIELD) ;Return code to validate and transform user input --PERHAPS INTERACTIVELY
Q $$GETMETH(.DDTFILE,.DDTFIELD,$$VALEXTL)
;
VALEXTS(DDTFILE,DDTFIELD) ;Return code to SILENTLY validate and transform user input
;Non-interactive
N D,%
S %=$$GETMETH(.DDTFILE,.DDTFIELD,$$VALEXTSL) I %["+X" S %="K:X?16.N.E X I $D(X) "_% ;DON'T TRY TO "+" A HUGE NUMBER
S D=$F(%,"%DT=""E") I D>0 S %=$E(%,1,D-2)_$E(%,D,9999)
Q "N %T,%DT,C,DIG,DIH,DIU,DIV,DICR,DIQUIET S DIQUIET=1 "_% ;PRESERVE VARIABLES
;
VALINT(DDTFILE,DDTFIELD) ;Return code to validate internal form
Q $$GETMETH(.DDTFILE,.DDTFIELD,$$VALINTL)
;
XHELP(DDTFILE,DDTFIELD) ;Return the executable help of a field
D DIPA(DDTFILE,DDTFIELD) ;I $D(^DI(.81,+$P($P(^DD(DDTFILE,DDTFIELD,0),U,2),"t",2),101,4,0)) S DIPA("POINTER")=$$GETPROP(DDTFILE,DDTFIELD,"POINTER")
Q $$GETMETH(.DDTFILE,.DDTFIELD,$$XHELPL)
;
OUTPUT(DDTFILE,DDTFIELD) ;Return the executable code to output a field's value. No arguments means ^DD(DDTFILE,DDTFIELD,0) is already in naked ref
Q $$GETMETH(.DDTFILE,.DDTFIELD,$$OUTPUTL)
;
;
;
DIPA(DDTFILE,DDTFIELD) ;CREATE DIPA NODES FROM PROPERTIES IN THE FIELD
N T,P,V,N
S T=+$P($P(^DD(DDTFILE,DDTFIELD,0),U,2),"t",2) Q:'T ;ONLY HAPPENS FOR EXTENDED DATA TYPES
F P=0:0 S P=$O(^DD(DDTFILE,DDTFIELD,101,P)) Q:'P S V=$G(^(P,31)) I V]"" S N=$P($G(^DI(.86,P,0)),U) I N]"" S DIPA(N)=V ;E.G., DIPA("POINTER")="DIC(5,"
F P=0:0 S P=$O(^DD(DDTFILE,DDTFIELD,201,P)) Q:'P S V=$G(^(P,31)) I V]"" S N=$P($G(^DI(.87,P,0)),U) I N]"" S DIPA(N)=V ;E.G., DIPA("CODE TO SET POINTER SCREEN")="I 1"
Q
;
;****************************************************************
;The following functions return a string of methods to search
;
VALEXTL() Q "INTERACTIVE VALIDATE AND INPUT TRANSFORM;VALIDATE AND TRANSFORM INPUT;INPUT TRANSFORM"
VALEXTSL() Q "VALIDATE AND TRANSFORM INPUT;INPUT TRANSFORM"
VALINTL() Q "VALIDATE INTERNAL FORM;INPUT TRANSFORM"
XHELPL() Q "INTERACTIVE EXECUTABLE HELP;XECUTABLE HELP"
OUTPUTL() Q "OUTPUT TRANSFORM"
;
;****************************************************************
;
GETMETH(DDTFILE,DDTFIELD,DDTMETL) ;Look for methods in the ;-delimited string
;of method numbers.
;Return the code for the first non-null method found.
;In:
; DDTFILE = file #
; DDTFIELD = field #
; DDTMETL = ;-delimited list of methods to search for
;
N REF,DDTCOD,DDTMET,DDTP,DDTPC,I
Q:" "[$G(DDTMETL) ""
; The use of the naked reference is needed here, regardless of its obscurity. MSC/DKA 2016-03-04
I '$G(DDTFILE)!'$G(DDTFIELD) S REF=$NA(^(0)) ;^DD(DDTFILE,DDTFIELD,0) is already in naked ref -- MAYBE! LET'S NOT USE THIS 'NAKED' TRICK
E S REF=$NA(^DD(DDTFILE,DDTFIELD,0))
Q:REF'?1"^DD(".E ""
F DDTPC=1:1:$L(DDTMETL,";") S DDTMET=$P(DDTMETL,";",DDTPC) D:DDTMET]"" Q:$G(DDTCOD)]""
. S I=+$P($P($G(@REF),U,2),"t",2)
. S DDTP=$O(^DI(.87,"B",DDTMET,""),-1) I DDTP,$P($G(^DI(.81,I,201,DDTP,31)),";")'?."^" S DDTCOD=^(31) ;Q ;FIRST TRY TO GET IT FROM THE DEFINITION IN .81
. I DDTMET="INPUT TRANSFORM" D Q:$D(DDTCOD)
..D DIPA(DDTFILE,DDTFIELD) ;SET UP THE PARAMETERS
..S DDTP=$$PROP4TYP("SET OF CODES",I) I DDTP]"" S DDTCOD="D READSET^DIED(.X,"""_DDTP_""")" Q ;M CODE: D READSET^DIED(.X,$$PROP4TYP^DIETLIBF("SET OF CODES",11)
..I "Q"'[$P($G(@REF),U,5,999) S DDTCOD=$P(^(0),U,5,999) ;from regular field, get the old input transform
. I DDTMET="OUTPUT TRANSFORM",$G(@REF)]"",$G(^(2))'?."^" S DDTCOD=^(2) Q
. I DDTMET="XECUTABLE HELP",$G(@REF)]"",$G(^(4))'?."^" S DDTCOD=^(4) Q
Q $G(DDTCOD)
;
;
%DT(PARAM) ;CREATE CODE TO SET THE %DT VARIABLE FROM PARAMETERS, INCLUDING 'PARAM', WHICH MAY BE "E"
N EARLY
S EARLY="",PARAM=$TR(PARAM,"""")
I $G(DIPA("EARLIEST DATE")) S EARLY=",%DT(0)="_DIPA("EARLIEST DATE")
I $G(DIPA("TIME REQUIRED")) S PARAM=PARAM_"R"
I $G(DIPA("SECONDS ALLOWED")) S PARAM=PARAM_"S"
I $G(DIPA("TIME OF DAY")) S PARAM=PARAM_"T"
I '$G(DIPA("IMPRECISE DATE")) S PARAM=PARAM_"X"
Q "SET %DT="""_PARAM_""""_EARLY
;
DIC ;SET THE DIC VARIABLE FROM PARAMETERS
I $G(DIPA("POINTER"))'["(" S Y=-1 Q
N DIS,DIC,DIFILE,DIBTDH ;DIFILE SHOULD REALLY BE NEWED BY ^DIC ITSELF
X $G(DIPA("CODE TO SET POINTER SCREEN")) ;S DIC("S")
S DIC="^"_DIPA("POINTER"),DIC(0)="M"_$E("L",$G(DIPA("LAYGO"))) I '$D(DIQUIET) S DIC(0)=DIC(0)_"EQ"
D ^DIC
Q
;
;
GETPROP(DDTFILE,DDTFIELD,DDTPROL) ;Look for PROPERTIES in the ;-delimited string
;Return the string for the first non-null property found.
;In:
; DDTFILE = file #
; DDTFIELD = field #
; DDTPROL = ;-delimited list of properties to search for
;
N REF
Q:" "[$G(DDTPROL) ""
I '$G(DDTFILE)!'$G(DDTFIELD) S REF=$NA(^(0)) ;^DD(DDTFILE,DDTFIELD,0) is already in naked ref
E S REF=$NA(^DD(DDTFILE,DDTFIELD,0))
Q:REF'?1"^DD(".E ""
N DDTCOD,DDTP,DDTPC,I,DIP
S I=+$P($P($G(@REF),U,2),"t",2)
F DDTPC=1:1:$L(DDTPROL,";") S DDTP=$P(DDTPROL,";",DDTPC) I DDTP]"" D Q:$G(DDTCOD)]""
.I $D(@REF),$O(^(101,0)) S DIP=$O(^DI(.86,"B",DDTP,""),-1) I DIP,$D(@REF),$G(^(101,DIP,31))]"" S DDTCOD=^(31) Q ;GET PROPERTY FROM THE FIELD ITSELF
.S DDTCOD=$$PROP4TYP(DDTP,I)
Q $G(DDTCOD)
;
PROP4TYP(T,I) ;FOR PROPERTY 'T' IN DATA TYPE 'I', RETURN THE VALUE
S T=$O(^DI(.86,"B",T,""),-1) I T,$G(^DI(.81,I,101,T,31))'?."^" Q ^(31) ;GET IT FROM THE DEFINITION IN .81
Q ""
;
;
METH4TYP(T,I) ;FOR METHOD 'T' IN DATA TYPE 'I', RETURN THE VALUE
S T=$O(^DI(.87,"B",T,""),-1) I T,$G(^DI(.81,I,201,T,31))'?."^" Q ^(31) ;GET IT FROM THE DEFINITION IN .81
Q ""
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIETLIBF 6151 printed Jan 18, 2025@03:48:19 Page 2
DIETLIBF ;SFISC/MKO,GFT - LIBRARY FOR FIELD ATTRIBUTES ;23JUN2017
+1 ;;22.2;VA FileMan;**2,5,13**;Jan 05, 2016;Build 4
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;The following functions return, for a given file and field,
+5 ;code to do something, such as validate user input, or validate
+6 ;the internal form of data. The actual code to perform these
+7 ;functions may reside under one of several methods, so a list of
+8 ;methods need to be searched.
+9 ;
+10 ;Input to these methods are:
+11 ; DDTFILE = File #
+12 ; DDTFIELD = Field #
+13 ;
+14 ;Returned is:
+15 ; Code for method or null
+16 ;
VALEXT(DDTFILE,DDTFIELD) ;Return code to validate and transform user input --PERHAPS INTERACTIVELY
+1 QUIT $$GETMETH(.DDTFILE,.DDTFIELD,$$VALEXTL)
+2 ;
VALEXTS(DDTFILE,DDTFIELD) ;Return code to SILENTLY validate and transform user input
+1 ;Non-interactive
+2 NEW D,%
+3 ;DON'T TRY TO "+" A HUGE NUMBER
SET %=$$GETMETH(.DDTFILE,.DDTFIELD,$$VALEXTSL)
IF %["+X"
SET %="K:X?16.N.E X I $D(X) "_%
+4 SET D=$FIND(%,"%DT=""E")
IF D>0
SET %=$EXTRACT(%,1,D-2)_$EXTRACT(%,D,9999)
+5 ;PRESERVE VARIABLES
QUIT "N %T,%DT,C,DIG,DIH,DIU,DIV,DICR,DIQUIET S DIQUIET=1 "_%
+6 ;
VALINT(DDTFILE,DDTFIELD) ;Return code to validate internal form
+1 QUIT $$GETMETH(.DDTFILE,.DDTFIELD,$$VALINTL)
+2 ;
XHELP(DDTFILE,DDTFIELD) ;Return the executable help of a field
+1 ;I $D(^DI(.81,+$P($P(^DD(DDTFILE,DDTFIELD,0),U,2),"t",2),101,4,0)) S DIPA("POINTER")=$$GETPROP(DDTFILE,DDTFIELD,"POINTER")
DO DIPA(DDTFILE,DDTFIELD)
+2 QUIT $$GETMETH(.DDTFILE,.DDTFIELD,$$XHELPL)
+3 ;
OUTPUT(DDTFILE,DDTFIELD) ;Return the executable code to output a field's value. No arguments means ^DD(DDTFILE,DDTFIELD,0) is already in naked ref
+1 QUIT $$GETMETH(.DDTFILE,.DDTFIELD,$$OUTPUTL)
+2 ;
+3 ;
+4 ;
DIPA(DDTFILE,DDTFIELD) ;CREATE DIPA NODES FROM PROPERTIES IN THE FIELD
+1 NEW T,P,V,N
+2 ;ONLY HAPPENS FOR EXTENDED DATA TYPES
SET T=+$PIECE($PIECE(^DD(DDTFILE,DDTFIELD,0),U,2),"t",2)
if 'T
QUIT
+3 ;E.G., DIPA("POINTER")="DIC(5,"
FOR P=0:0
SET P=$ORDER(^DD(DDTFILE,DDTFIELD,101,P))
if 'P
QUIT
SET V=$GET(^(P,31))
IF V]""
SET N=$PIECE($GET(^DI(.86,P,0)),U)
IF N]""
SET DIPA(N)=V
+4 ;E.G., DIPA("CODE TO SET POINTER SCREEN")="I 1"
FOR P=0:0
SET P=$ORDER(^DD(DDTFILE,DDTFIELD,201,P))
if 'P
QUIT
SET V=$GET(^(P,31))
IF V]""
SET N=$PIECE($GET(^DI(.87,P,0)),U)
IF N]""
SET DIPA(N)=V
+5 QUIT
+6 ;
+7 ;****************************************************************
+8 ;The following functions return a string of methods to search
+9 ;
VALEXTL() QUIT "INTERACTIVE VALIDATE AND INPUT TRANSFORM;VALIDATE AND TRANSFORM INPUT;INPUT TRANSFORM"
VALEXTSL() QUIT "VALIDATE AND TRANSFORM INPUT;INPUT TRANSFORM"
VALINTL() QUIT "VALIDATE INTERNAL FORM;INPUT TRANSFORM"
XHELPL() QUIT "INTERACTIVE EXECUTABLE HELP;XECUTABLE HELP"
OUTPUTL() QUIT "OUTPUT TRANSFORM"
+1 ;
+2 ;****************************************************************
+3 ;
GETMETH(DDTFILE,DDTFIELD,DDTMETL) ;Look for methods in the ;-delimited string
+1 ;of method numbers.
+2 ;Return the code for the first non-null method found.
+3 ;In:
+4 ; DDTFILE = file #
+5 ; DDTFIELD = field #
+6 ; DDTMETL = ;-delimited list of methods to search for
+7 ;
+8 NEW REF,DDTCOD,DDTMET,DDTP,DDTPC,I
+9 if " "[$GET(DDTMETL)
QUIT ""
+10 ; The use of the naked reference is needed here, regardless of its obscurity. MSC/DKA 2016-03-04
+11 ;^DD(DDTFILE,DDTFIELD,0) is already in naked ref -- MAYBE! LET'S NOT USE THIS 'NAKED' TRICK
IF '$GET(DDTFILE)!'$GET(DDTFIELD)
SET REF=$NAME(^(0))
+12 IF '$TEST
SET REF=$NAME(^DD(DDTFILE,DDTFIELD,0))
+13 if REF'?1"^DD(".E
QUIT ""
+14 FOR DDTPC=1:1:$LENGTH(DDTMETL,";")
SET DDTMET=$PIECE(DDTMETL,";",DDTPC)
if DDTMET]""
Begin DoDot:1
+15 SET I=+$PIECE($PIECE($GET(@REF),U,2),"t",2)
+16 ;Q ;FIRST TRY TO GET IT FROM THE DEFINITION IN .81
SET DDTP=$ORDER(^DI(.87,"B",DDTMET,""),-1)
IF DDTP
IF $PIECE($GET(^DI(.81,I,201,DDTP,31)),";")'?."^"
SET DDTCOD=^(31)
+17 IF DDTMET="INPUT TRANSFORM"
Begin DoDot:2
+18 ;SET UP THE PARAMETERS
DO DIPA(DDTFILE,DDTFIELD)
+19 ;M CODE: D READSET^DIED(.X,$$PROP4TYP^DIETLIBF("SET OF CODES",11)
SET DDTP=$$PROP4TYP("SET OF CODES",I)
IF DDTP]""
SET DDTCOD="D READSET^DIED(.X,"""_DDTP_""")"
QUIT
+20 ;from regular field, get the old input transform
IF "Q"'[$PIECE($GET(@REF),U,5,999)
SET DDTCOD=$PIECE(^(0),U,5,999)
End DoDot:2
if $DATA(DDTCOD)
QUIT
+21 IF DDTMET="OUTPUT TRANSFORM"
IF $GET(@REF)]""
IF $GET(^(2))'?."^"
SET DDTCOD=^(2)
QUIT
+22 IF DDTMET="XECUTABLE HELP"
IF $GET(@REF)]""
IF $GET(^(4))'?."^"
SET DDTCOD=^(4)
QUIT
End DoDot:1
if $GET(DDTCOD)]""
QUIT
+23 QUIT $GET(DDTCOD)
+24 ;
+25 ;
%DT(PARAM) ;CREATE CODE TO SET THE %DT VARIABLE FROM PARAMETERS, INCLUDING 'PARAM', WHICH MAY BE "E"
+1 NEW EARLY
+2 SET EARLY=""
SET PARAM=$TRANSLATE(PARAM,"""")
+3 IF $GET(DIPA("EARLIEST DATE"))
SET EARLY=",%DT(0)="_DIPA("EARLIEST DATE")
+4 IF $GET(DIPA("TIME REQUIRED"))
SET PARAM=PARAM_"R"
+5 IF $GET(DIPA("SECONDS ALLOWED"))
SET PARAM=PARAM_"S"
+6 IF $GET(DIPA("TIME OF DAY"))
SET PARAM=PARAM_"T"
+7 IF '$GET(DIPA("IMPRECISE DATE"))
SET PARAM=PARAM_"X"
+8 QUIT "SET %DT="""_PARAM_""""_EARLY
+9 ;
DIC ;SET THE DIC VARIABLE FROM PARAMETERS
+1 IF $GET(DIPA("POINTER"))'["("
SET Y=-1
QUIT
+2 ;DIFILE SHOULD REALLY BE NEWED BY ^DIC ITSELF
NEW DIS,DIC,DIFILE,DIBTDH
+3 ;S DIC("S")
XECUTE $GET(DIPA("CODE TO SET POINTER SCREEN"))
+4 SET DIC="^"_DIPA("POINTER")
SET DIC(0)="M"_$EXTRACT("L",$GET(DIPA("LAYGO")))
IF '$DATA(DIQUIET)
SET DIC(0)=DIC(0)_"EQ"
+5 DO ^DIC
+6 QUIT
+7 ;
+8 ;
GETPROP(DDTFILE,DDTFIELD,DDTPROL) ;Look for PROPERTIES in the ;-delimited string
+1 ;Return the string for the first non-null property found.
+2 ;In:
+3 ; DDTFILE = file #
+4 ; DDTFIELD = field #
+5 ; DDTPROL = ;-delimited list of properties to search for
+6 ;
+7 NEW REF
+8 if " "[$GET(DDTPROL)
QUIT ""
+9 ;^DD(DDTFILE,DDTFIELD,0) is already in naked ref
IF '$GET(DDTFILE)!'$GET(DDTFIELD)
SET REF=$NAME(^(0))
+10 IF '$TEST
SET REF=$NAME(^DD(DDTFILE,DDTFIELD,0))
+11 if REF'?1"^DD(".E
QUIT ""
+12 NEW DDTCOD,DDTP,DDTPC,I,DIP
+13 SET I=+$PIECE($PIECE($GET(@REF),U,2),"t",2)
+14 FOR DDTPC=1:1:$LENGTH(DDTPROL,";")
SET DDTP=$PIECE(DDTPROL,";",DDTPC)
IF DDTP]""
Begin DoDot:1
+15 ;GET PROPERTY FROM THE FIELD ITSELF
IF $DATA(@REF)
IF $ORDER(^(101,0))
SET DIP=$ORDER(^DI(.86,"B",DDTP,""),-1)
IF DIP
IF $DATA(@REF)
IF $GET(^(101,DIP,31))]""
SET DDTCOD=^(31)
QUIT
+16 SET DDTCOD=$$PROP4TYP(DDTP,I)
End DoDot:1
if $GET(DDTCOD)]""
QUIT
+17 QUIT $GET(DDTCOD)
+18 ;
PROP4TYP(T,I) ;FOR PROPERTY 'T' IN DATA TYPE 'I', RETURN THE VALUE
+1 ;GET IT FROM THE DEFINITION IN .81
SET T=$ORDER(^DI(.86,"B",T,""),-1)
IF T
IF $GET(^DI(.81,I,101,T,31))'?."^"
QUIT ^(31)
+2 QUIT ""
+3 ;
+4 ;
METH4TYP(T,I) ;FOR METHOD 'T' IN DATA TYPE 'I', RETURN THE VALUE
+1 ;GET IT FROM THE DEFINITION IN .81
SET T=$ORDER(^DI(.87,"B",T,""),-1)
IF T
IF $GET(^DI(.81,I,201,T,31))'?."^"
QUIT ^(31)
+2 QUIT ""
