- DICATTUD ;SFISC/MKO - USER DEFINED DATA TYPES ;24JUN2017
- ;;22.2;VA FileMan;**2,5,13**;Jan 05, 2016;Build 4
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- BEGIN D EN(A,DA,N,O) I $G(DTOUT) K DTOUT G CHECK^DICATT ;Come from DICATT (roll-and-scroll mode)
- G ^DICATT1
- ;
- ;
- ;
- SCREENMN ;Come from DICATTD (ScreenMan mode)
- N L,M,C,Z,DIZ,DIALLVAL,DIVAL,DTOUT,IOTM,IOBT
- D D CLRMSG^DDS ;Set the scrolling region in the command area
- .N X S IOTM=19,IOBM=$G(IOSL,24)-1,X="IOSTBM" D ENDR^%ZISS I $G(IOSTBM)]"" W @IOSTBM
- D EN(DICATTA,DICATTF,X,DICATT4]"")
- I $G(IOSTBM)]"" S IOTM=1,IOBM=$G(IOSL,24) W @IOSTBM
- I $G(DTOUT) QUIT
- S DICATT2N=$P(DIZ,U),DICATT3N="" I $$ESTORE^DICATT1(DICATT2N) D UNED^DDSUTL(20.5,"DICATT",1,2) ;don't allow 'MULTIPLE'
- S DICATT5N=C,DICATTLN=L
- S DICATTMN="" D PUT^DDSVALF(98,"DICATT",1,DICATTMN) ;HERE IS THE HELP-PROMPT, NULLED OUT FOR NOW
- QUIT
- ;
- ;
- ;
- ;
- ;
- ;In: N = data type number
- ; O = 0 : if new field
- ; A = file #
- ; DA = field #
- ;
- ;Out: DICATTPM array (to be merged into ^DD(file#,field#)
- ; e.g., DICATTPM(101,4,0)="4^", DICATTPM(101,4,31)="DPT(" says that POINTER property is "DPT("
- ; L = Maximum internal length
- ; M = Help text
- ; M(2) = 1 : user changed a default on an old field
- ; C = Old input transform (5-99)
- ; DIZ,Z = dataTypeAbbrev_t#, where # is the data type number
- ;
- ;Variables used:
- ; DIVAL = obtained property value
- ; DIVALS(abbrev) = array of property values (already obtained)
- ; DIVALS("DIDEF") = default property value presented to user
- ; DICHANGE = 1 : if user changed a default value (set in PROP)
- ;
- EN(A,DA,N,O) ;
- K DICATTPM,M(2),DTOUT
- N DIMETH,DIORD,DIPROP,DIVALS,DICHANGE,DDS
- M DICATTPM(101)=^DD(A,DA,101),DICATTPM(201)=^DD(A,DA,201) ;GRAB THE EXISTING VALUES OF THE PROPERTIES AND METHODS
- ;
- ;Loop through properties in Data Type file, by ORDER, and get values
- S DIORD=""
- F S DIORD=$O(^DI(.81,N,101,"AC",DIORD)) Q:'DIORD!$D(DUOUT)!$D(DTOUT) D
- .S DIPROP=$O(^DI(.81,N,101,"AC",DIORD,"")) Q:'DIPROP D PROPMETH("P",N,DIPROP,.DIVALS)
- ;If user ^-d or timed out, go back to delete field and reprompt
- I $D(DUOUT)!$D(DTOUT) K DUOUT,DICATTPM S DTOUT=1 Q
- ;Loop through methods in Data Type file
- S DIMETH=0
- I DUZ(0)="@" F S DIMETH=$O(^DI(.81,N,201,DIMETH)) Q:'DIMETH D:$G(^(DIMETH,31))="" PROPMETH("M",N,DIMETH,.DIVALS)
- DONE ;
- ;Set L and M
- K M
- S L=$$PROP4TYP^DIETLIBF("INTERNAL LENGTH",N) S:'L L=30 ;$G(DIVALS("MAXL"),30)
- ;S:$G(DIVALS("HELP"))]"" M=DIVALS("HELP")
- ;I $G(DICHANGE),O S M(2)=1
- ;
- ;Put input transform in C; don't need to store in ^DD(file#,field#,201)
- ;Set Z and DIZ
- S C="Q" ;$G(DICAT201(1,1),"Q") K DICAT201(1)
- S Z=$$GET1^DIQ(.81,N,"INTERNAL REPRESENTATION") S:Z="" Z="F"
- S (DIZ,Z)=Z_"t"_N_U
- QUIT
- ;
- ;
- ;
- PROPMETH(PROPMETH,N,DIPROP,DIVALS) ;For DATA TYPE N, get a PROPERTY (PROPMETH="P") or METHOD
- N DIPROMPT,DIVAL,DIEXEC,DIDD,DIGL
- K DIVALS("DIDEF")
- S DIDD=$S(PROPMETH="M":.87,1:.86),DIGL=$S(PROPMETH="M":201,1:101) ;CHANGED FROM '102'
- ;If there's an Executable Default, get value
- I $G(^DI(.81,N,DIGL,DIPROP,31.2))'?."^" D
- . S DIEXEC=1
- . S DIVAL=$G(^DD(A,DA,DIGL,DIPROP,2)) ;DIGL WILL BE 201, NOT 102
- . ;I 'O!$G(DICHANGE),^DI(.81,N,101,DIPROP,31.2)["|" S DIVAL=$$PARSE^DIETLIB(^(31.2),.DIVALS)
- . S DIVALS("DIDEF")=DIVAL
- ;
- ;Otherwise, get regular default
- E S (DIVAL,DIVALS("DIDEF"))=$$GETDEF(N,DIPROP,.DIVALS)
- ;
- ;Should user be prompted for value?
- S DIPROMPT=$G(^DI(.81,N,DIGL,DIPROP,31))="" ;PROMPT IF THERE IS NO VALUE
- I $G(^DI(.81,N,DIGL,DIPROP,10))'?."^" X $$PARSE^DIETLIB(^(10)) S DIPROMPT=$T
- ;
- ;If so, prompt for DIVAL
- I DIPROMPT D
- . ;If there's Get Code, execute it
- . I $G(^DI(DIDD,DIPROP,51))'?."^" D
- .. D XCODEM^DIETLIB(^DI(DIDD,DIPROP,51),.DIVALS,.DIVAL)
- .. S:$D(DIVAL)[0 DUOUT=1
- . ;
- . ;Otherwise, use ^DIR to get value of property
- . E S DIVAL=$$DIR(DIPROP,.DIVALS)
- . Q:$D(DUOUT)!$D(DTOUT)
- . S:DIVAL'=DIVALS("DIDEF") DICHANGE=1
- ;
- Q:$D(DUOUT)!$D(DTOUT)
- D SAVE(DIPROP,.DIVAL,.DIVALS,.DIGL,$G(DIEXEC))
- Q
- ;
- DIR(DIPROP,DIVALS) ;Do a ^DIR read to get value for property or method
- N I,J,X,Y,DIR,DIRUT,DIROUT
- ;
- ;Get DIR(0) from the PROPERTY or METHOD, (convert |abbr| to values)
- S DIR(0)=$$PARSE^DIETLIB($G(^DI(DIDD,DIPROP,42)),.DIVALS)
- Q:DIR(0)="" ""
- A ;Put Prompt into DIR("A")
- S I=0
- S J=1,DIR("A",1)=$P($G(^DI(DIDD,DIPROP,0)),U)
- F S I=$O(^DI(DIDD,DIPROP,43,I)) Q:'I D:$D(^(I,0))#2
- . S J=J+1
- . S DIR("A",J)=^DI(DIDD,DIPROP,43,I,0)
- I J S DIR("A")=DIR("A",J) K DIR("A",J)
- H ;Put Help into DIR("?")
- S (I,J)=0
- I $G(^DI(DIDD,DIPROP,11))]"" S J=1,DIR("?",1)=^(11)
- F S I=$O(^DI(DIDD,DIPROP,44,I)) Q:'I D:$D(^(I,0))#2
- . S J=J+1
- . S DIR("?",J)=^DI(DIDD,DIPROP,44,I,0)
- I J S DIR("?")=DIR("?",J) K DIR("?",J)
- B ;Put default into DIR("B")
- S I=$G(DICATTPM(DIGL,DIPROP,31)) ;get the current VALUE
- I I="" S I=$G(DIVALS("DIDEF")) ;or get the DEFAULT from node 33 of the PROPERTY for this DATA TYPE
- I I]"" D S DIR("B")=I
- .I DIGL=101 D
- ..N T S T=+$G(^DI(.86,DIPROP,41)) ;get the TYPE
- ..I T=1 S I=$$DATE^DIUTL(I)
- ..I T=3 S I=$P($P($P(DIR(0),U,2),I_":",2),";")
- ;S:$G(DIVALS("DIDEF"))]"" DIR("B")=DIVALS("DIDEF")
- S:$G(^DI(DIDD,DIPROP,45))]"" DIR("S")=^(45)
- S:$G(^DI(DIDD,DIPROP,46))]"" DIR("T")=^(46)
- D ^DIR
- Q Y
- ;
- ;
- SAVE(DIPROP,DIVAL,DIVALS,DICAT101,DIEXEC) ;Save the value of the property
- ; in DIVALS(abbr) and DICAT101
- ;DIVAL is the value of the property
- ;DIEXEC = 1 : if value is an executable
- ;
- ;Returns:
- ; DIVALS(abbr)= array property values
- ; DICATTPM(DIGL,prop#,0)=prop#^abbrev
- ; DICATTPM(DIGL,prop#,31)=value
- ; or 2)=executable value
- ; DICATTPM(DIGL,prop#,3,n,0) = descendent node n of DIVAL
- ;
- N DIABBR
- ;
- ;Set the DIVALS array
- S DIABBR=$P(^DI(DIDD,DIPROP,0),U,2)
- S:DIABBR]"" DIVALS(DIABBR)=DIVAL
- ;
- ;Set the DICATTPM array
- I DIVAL]"" D
- .N I,Z S Z=0 F I=1:1 S Z=$O(DICATTPM(DIGL,Z)) Q:'Z
- .S DICATTPM(DIGL,0)="^."_DIGL_"01P^"_DIPROP_"^"_I ;remember that DIGL=101 or 201
- . S DICATTPM(DIGL,DIPROP,0)=DIPROP_U_DIABBR
- . S DICATTPM(DIGL,DIPROP,31+$G(DIEXEC))=DIVAL
- . I $D(DIVAL)>9 S I="" F S I=$O(DIVAL(I)) Q:I="" D
- .. I $D(DIVAL(I))#2 S DICATTPM(DIGL,DIPROP,3,I,0)=DIVAL(I)
- .. E I $D(DIVAL(I,0))#2 S DICATTPM(DIGL,DIPROP,3,I,0)=DIVAL(I,0)
- .. E Q
- ;
- ;Execute the post action
- ;X:$G(^DI(.81,N,101,DIPROP,61))'?."^" $$PARSE^DIETLIB(^(61))
- Q
- ;
- ;
- GETDEF(N,DIPROP,DIVALS) ;Get defaults for a property.
- ;May come from the ^DD or the data type file.
- N DIDEF
- ;
- ;Get value from ^DD
- S DIDEF=$S(DIPROP=3:$G(^DD(A,DA,3)),1:$G(^DD(A,DA,101,DIPROP,31)))
- ;
- ;For existing fields, return default from ^DD(file#,field#)
- ;if the user hasn't changed any property values
- I O,'$G(DICHANGE) Q DIDEF
- ;
- ;Otherwise, look at default from Data Type file.
- ;For existing fields where default contains no |abbr|,
- ;return value from DD.
- ;
- ;Default
- S DIDEF=$G(^DI(.81,N,101,DIPROP,33))
- ;Q:$G(^DI(.81,N,101,DIPROP,31))]"" $S(^(31)'["|"&O:DIDEF,1:$$PARSE^DIETLIB(^(31),.DIVALS))
- ;
- ;Build Default
- ;Q:$G(^DI(.81,N,101,DIPROP,31.1))]"" $S(^(31.1)'["|"&O:DIDEF,1:$$XCODE^DIETLIB(^(31.1),.DIVALS)) ;NOT THERE ANY MORE
- ;
- Q DIDEF
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICATTUD 7266 printed Mar 13, 2025@21:50:35 Page 2
- DICATTUD ;SFISC/MKO - USER DEFINED DATA TYPES ;24JUN2017
- +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 ;
- BEGIN ;Come from DICATT (roll-and-scroll mode)
- DO EN(A,DA,N,O)
- IF $GET(DTOUT)
- KILL DTOUT
- GOTO CHECK^DICATT
- +1 GOTO ^DICATT1
- +2 ;
- +3 ;
- +4 ;
- SCREENMN ;Come from DICATTD (ScreenMan mode)
- +1 NEW L,M,C,Z,DIZ,DIALLVAL,DIVAL,DTOUT,IOTM,IOBT
- +2 ;Set the scrolling region in the command area
- Begin DoDot:1
- +3 NEW X
- SET IOTM=19
- SET IOBM=$GET(IOSL,24)-1
- SET X="IOSTBM"
- DO ENDR^%ZISS
- IF $GET(IOSTBM)]""
- WRITE @IOSTBM
- End DoDot:1
- DO CLRMSG^DDS
- +4 DO EN(DICATTA,DICATTF,X,DICATT4]"")
- +5 IF $GET(IOSTBM)]""
- SET IOTM=1
- SET IOBM=$GET(IOSL,24)
- WRITE @IOSTBM
- +6 IF $GET(DTOUT)
- QUIT
- +7 ;don't allow 'MULTIPLE'
- SET DICATT2N=$PIECE(DIZ,U)
- SET DICATT3N=""
- IF $$ESTORE^DICATT1(DICATT2N)
- DO UNED^DDSUTL(20.5,"DICATT",1,2)
- +8 SET DICATT5N=C
- SET DICATTLN=L
- +9 ;HERE IS THE HELP-PROMPT, NULLED OUT FOR NOW
- SET DICATTMN=""
- DO PUT^DDSVALF(98,"DICATT",1,DICATTMN)
- +10 QUIT
- +11 ;
- +12 ;
- +13 ;
- +14 ;
- +15 ;
- +16 ;In: N = data type number
- +17 ; O = 0 : if new field
- +18 ; A = file #
- +19 ; DA = field #
- +20 ;
- +21 ;Out: DICATTPM array (to be merged into ^DD(file#,field#)
- +22 ; e.g., DICATTPM(101,4,0)="4^", DICATTPM(101,4,31)="DPT(" says that POINTER property is "DPT("
- +23 ; L = Maximum internal length
- +24 ; M = Help text
- +25 ; M(2) = 1 : user changed a default on an old field
- +26 ; C = Old input transform (5-99)
- +27 ; DIZ,Z = dataTypeAbbrev_t#, where # is the data type number
- +28 ;
- +29 ;Variables used:
- +30 ; DIVAL = obtained property value
- +31 ; DIVALS(abbrev) = array of property values (already obtained)
- +32 ; DIVALS("DIDEF") = default property value presented to user
- +33 ; DICHANGE = 1 : if user changed a default value (set in PROP)
- +34 ;
- EN(A,DA,N,O) ;
- +1 KILL DICATTPM,M(2),DTOUT
- +2 NEW DIMETH,DIORD,DIPROP,DIVALS,DICHANGE,DDS
- +3 ;GRAB THE EXISTING VALUES OF THE PROPERTIES AND METHODS
- MERGE DICATTPM(101)=^DD(A,DA,101),DICATTPM(201)=^DD(A,DA,201)
- +4 ;
- +5 ;Loop through properties in Data Type file, by ORDER, and get values
- +6 SET DIORD=""
- +7 FOR
- SET DIORD=$ORDER(^DI(.81,N,101,"AC",DIORD))
- if 'DIORD!$DATA(DUOUT)!$DATA(DTOUT)
- QUIT
- Begin DoDot:1
- +8 SET DIPROP=$ORDER(^DI(.81,N,101,"AC",DIORD,""))
- if 'DIPROP
- QUIT
- DO PROPMETH("P",N,DIPROP,.DIVALS)
- End DoDot:1
- +9 ;If user ^-d or timed out, go back to delete field and reprompt
- +10 IF $DATA(DUOUT)!$DATA(DTOUT)
- KILL DUOUT,DICATTPM
- SET DTOUT=1
- QUIT
- +11 ;Loop through methods in Data Type file
- +12 SET DIMETH=0
- +13 IF DUZ(0)="@"
- FOR
- SET DIMETH=$ORDER(^DI(.81,N,201,DIMETH))
- if 'DIMETH
- QUIT
- if $GET(^(DIMETH,31))=""
- DO PROPMETH("M",N,DIMETH,.DIVALS)
- DONE ;
- +1 ;Set L and M
- +2 KILL M
- +3 ;$G(DIVALS("MAXL"),30)
- SET L=$$PROP4TYP^DIETLIBF("INTERNAL LENGTH",N)
- if 'L
- SET L=30
- +4 ;S:$G(DIVALS("HELP"))]"" M=DIVALS("HELP")
- +5 ;I $G(DICHANGE),O S M(2)=1
- +6 ;
- +7 ;Put input transform in C; don't need to store in ^DD(file#,field#,201)
- +8 ;Set Z and DIZ
- +9 ;$G(DICAT201(1,1),"Q") K DICAT201(1)
- SET C="Q"
- +10 SET Z=$$GET1^DIQ(.81,N,"INTERNAL REPRESENTATION")
- if Z=""
- SET Z="F"
- +11 SET (DIZ,Z)=Z_"t"_N_U
- +12 QUIT
- +13 ;
- +14 ;
- +15 ;
- PROPMETH(PROPMETH,N,DIPROP,DIVALS) ;For DATA TYPE N, get a PROPERTY (PROPMETH="P") or METHOD
- +1 NEW DIPROMPT,DIVAL,DIEXEC,DIDD,DIGL
- +2 KILL DIVALS("DIDEF")
- +3 ;CHANGED FROM '102'
- SET DIDD=$SELECT(PROPMETH="M":.87,1:.86)
- SET DIGL=$SELECT(PROPMETH="M":201,1:101)
- +4 ;If there's an Executable Default, get value
- +5 IF $GET(^DI(.81,N,DIGL,DIPROP,31.2))'?."^"
- Begin DoDot:1
- +6 SET DIEXEC=1
- +7 ;DIGL WILL BE 201, NOT 102
- SET DIVAL=$GET(^DD(A,DA,DIGL,DIPROP,2))
- +8 ;I 'O!$G(DICHANGE),^DI(.81,N,101,DIPROP,31.2)["|" S DIVAL=$$PARSE^DIETLIB(^(31.2),.DIVALS)
- +9 SET DIVALS("DIDEF")=DIVAL
- End DoDot:1
- +10 ;
- +11 ;Otherwise, get regular default
- +12 IF '$TEST
- SET (DIVAL,DIVALS("DIDEF"))=$$GETDEF(N,DIPROP,.DIVALS)
- +13 ;
- +14 ;Should user be prompted for value?
- +15 ;PROMPT IF THERE IS NO VALUE
- SET DIPROMPT=$GET(^DI(.81,N,DIGL,DIPROP,31))=""
- +16 IF $GET(^DI(.81,N,DIGL,DIPROP,10))'?."^"
- XECUTE $$PARSE^DIETLIB(^(10))
- SET DIPROMPT=$TEST
- +17 ;
- +18 ;If so, prompt for DIVAL
- +19 IF DIPROMPT
- Begin DoDot:1
- +20 ;If there's Get Code, execute it
- +21 IF $GET(^DI(DIDD,DIPROP,51))'?."^"
- Begin DoDot:2
- +22 DO XCODEM^DIETLIB(^DI(DIDD,DIPROP,51),.DIVALS,.DIVAL)
- +23 if $DATA(DIVAL)[0
- SET DUOUT=1
- End DoDot:2
- +24 ;
- +25 ;Otherwise, use ^DIR to get value of property
- +26 IF '$TEST
- SET DIVAL=$$DIR(DIPROP,.DIVALS)
- +27 if $DATA(DUOUT)!$DATA(DTOUT)
- QUIT
- +28 if DIVAL'=DIVALS("DIDEF")
- SET DICHANGE=1
- End DoDot:1
- +29 ;
- +30 if $DATA(DUOUT)!$DATA(DTOUT)
- QUIT
- +31 DO SAVE(DIPROP,.DIVAL,.DIVALS,.DIGL,$GET(DIEXEC))
- +32 QUIT
- +33 ;
- DIR(DIPROP,DIVALS) ;Do a ^DIR read to get value for property or method
- +1 NEW I,J,X,Y,DIR,DIRUT,DIROUT
- +2 ;
- +3 ;Get DIR(0) from the PROPERTY or METHOD, (convert |abbr| to values)
- +4 SET DIR(0)=$$PARSE^DIETLIB($GET(^DI(DIDD,DIPROP,42)),.DIVALS)
- +5 if DIR(0)=""
- QUIT ""
- A ;Put Prompt into DIR("A")
- +1 SET I=0
- +2 SET J=1
- SET DIR("A",1)=$PIECE($GET(^DI(DIDD,DIPROP,0)),U)
- +3 FOR
- SET I=$ORDER(^DI(DIDD,DIPROP,43,I))
- if 'I
- QUIT
- if $DATA(^(I,0))#2
- Begin DoDot:1
- +4 SET J=J+1
- +5 SET DIR("A",J)=^DI(DIDD,DIPROP,43,I,0)
- End DoDot:1
- +6 IF J
- SET DIR("A")=DIR("A",J)
- KILL DIR("A",J)
- H ;Put Help into DIR("?")
- +1 SET (I,J)=0
- +2 IF $GET(^DI(DIDD,DIPROP,11))]""
- SET J=1
- SET DIR("?",1)=^(11)
- +3 FOR
- SET I=$ORDER(^DI(DIDD,DIPROP,44,I))
- if 'I
- QUIT
- if $DATA(^(I,0))#2
- Begin DoDot:1
- +4 SET J=J+1
- +5 SET DIR("?",J)=^DI(DIDD,DIPROP,44,I,0)
- End DoDot:1
- +6 IF J
- SET DIR("?")=DIR("?",J)
- KILL DIR("?",J)
- B ;Put default into DIR("B")
- +1 ;get the current VALUE
- SET I=$GET(DICATTPM(DIGL,DIPROP,31))
- +2 ;or get the DEFAULT from node 33 of the PROPERTY for this DATA TYPE
- IF I=""
- SET I=$GET(DIVALS("DIDEF"))
- +3 IF I]""
- Begin DoDot:1
- +4 IF DIGL=101
- Begin DoDot:2
- +5 ;get the TYPE
- NEW T
- SET T=+$GET(^DI(.86,DIPROP,41))
- +6 IF T=1
- SET I=$$DATE^DIUTL(I)
- +7 IF T=3
- SET I=$PIECE($PIECE($PIECE(DIR(0),U,2),I_":",2),";")
- End DoDot:2
- End DoDot:1
- SET DIR("B")=I
- +8 ;S:$G(DIVALS("DIDEF"))]"" DIR("B")=DIVALS("DIDEF")
- +9 if $GET(^DI(DIDD,DIPROP,45))]""
- SET DIR("S")=^(45)
- +10 if $GET(^DI(DIDD,DIPROP,46))]""
- SET DIR("T")=^(46)
- +11 DO ^DIR
- +12 QUIT Y
- +13 ;
- +14 ;
- SAVE(DIPROP,DIVAL,DIVALS,DICAT101,DIEXEC) ;Save the value of the property
- +1 ; in DIVALS(abbr) and DICAT101
- +2 ;DIVAL is the value of the property
- +3 ;DIEXEC = 1 : if value is an executable
- +4 ;
- +5 ;Returns:
- +6 ; DIVALS(abbr)= array property values
- +7 ; DICATTPM(DIGL,prop#,0)=prop#^abbrev
- +8 ; DICATTPM(DIGL,prop#,31)=value
- +9 ; or 2)=executable value
- +10 ; DICATTPM(DIGL,prop#,3,n,0) = descendent node n of DIVAL
- +11 ;
- +12 NEW DIABBR
- +13 ;
- +14 ;Set the DIVALS array
- +15 SET DIABBR=$PIECE(^DI(DIDD,DIPROP,0),U,2)
- +16 if DIABBR]""
- SET DIVALS(DIABBR)=DIVAL
- +17 ;
- +18 ;Set the DICATTPM array
- +19 IF DIVAL]""
- Begin DoDot:1
- +20 NEW I,Z
- SET Z=0
- FOR I=1:1
- SET Z=$ORDER(DICATTPM(DIGL,Z))
- if 'Z
- QUIT
- +21 ;remember that DIGL=101 or 201
- SET DICATTPM(DIGL,0)="^."_DIGL_"01P^"_DIPROP_"^"_I
- +22 SET DICATTPM(DIGL,DIPROP,0)=DIPROP_U_DIABBR
- +23 SET DICATTPM(DIGL,DIPROP,31+$GET(DIEXEC))=DIVAL
- +24 IF $DATA(DIVAL)>9
- SET I=""
- FOR
- SET I=$ORDER(DIVAL(I))
- if I=""
- QUIT
- Begin DoDot:2
- +25 IF $DATA(DIVAL(I))#2
- SET DICATTPM(DIGL,DIPROP,3,I,0)=DIVAL(I)
- +26 IF '$TEST
- IF $DATA(DIVAL(I,0))#2
- SET DICATTPM(DIGL,DIPROP,3,I,0)=DIVAL(I,0)
- +27 IF '$TEST
- QUIT
- End DoDot:2
- End DoDot:1
- +28 ;
- +29 ;Execute the post action
- +30 ;X:$G(^DI(.81,N,101,DIPROP,61))'?."^" $$PARSE^DIETLIB(^(61))
- +31 QUIT
- +32 ;
- +33 ;
- GETDEF(N,DIPROP,DIVALS) ;Get defaults for a property.
- +1 ;May come from the ^DD or the data type file.
- +2 NEW DIDEF
- +3 ;
- +4 ;Get value from ^DD
- +5 SET DIDEF=$SELECT(DIPROP=3:$GET(^DD(A,DA,3)),1:$GET(^DD(A,DA,101,DIPROP,31)))
- +6 ;
- +7 ;For existing fields, return default from ^DD(file#,field#)
- +8 ;if the user hasn't changed any property values
- +9 IF O
- IF '$GET(DICHANGE)
- QUIT DIDEF
- +10 ;
- +11 ;Otherwise, look at default from Data Type file.
- +12 ;For existing fields where default contains no |abbr|,
- +13 ;return value from DD.
- +14 ;
- +15 ;Default
- +16 SET DIDEF=$GET(^DI(.81,N,101,DIPROP,33))
- +17 ;Q:$G(^DI(.81,N,101,DIPROP,31))]"" $S(^(31)'["|"&O:DIDEF,1:$$PARSE^DIETLIB(^(31),.DIVALS))
- +18 ;
- +19 ;Build Default
- +20 ;Q:$G(^DI(.81,N,101,DIPROP,31.1))]"" $S(^(31.1)'["|"&O:DIDEF,1:$$XCODE^DIETLIB(^(31.1),.DIVALS)) ;NOT THERE ANY MORE
- +21 ;
- +22 QUIT DIDEF
