- 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 ""