DIETLIB ;SFISC/MKO,O-OIFO/GFT - LIBRARY OF APIs FOR USER DEFINED DATA TYPES ;04MAR2016
;;22.2;VA FileMan;**2,5**;Jan 05, 2016;Build 28
;;Per VA Directive 6402, this routine should not be modified.
;
;*************************************************************
;
;THESE CALLS DEAL WITH NODE 41 IN FILE .81, 'FIELD DEFINED BY THIS TYPE'
;
AFDEF(FILE,FIELD) ; --'SET' CROSS-REFERENCE ON SPECIFIER
N T,FF,I
S T=+$P($P($G(^DD(FILE,FIELD,0)),U,2),"t",2) Q:'T!'$D(^DI(.81,T,0)) ;GET THE EXTENDED TYPE
S I=$O(^DI(.81,T,41,"A"),-1)+1,FF=FILE_","_FIELD
I '$D(^DI(.81,"AFDEF",T,FF)) S ^(FF,I)="",^DI(.81,T,41,0)="^.81215^"_I_U_I,^(I,0)=FF ;ADD FIELD TO LIST OF DATATYPES FOR IT
S $P(^DD(FILE,FIELD,0),U,5,99)="",$P(^(0),U,3)="" K ^(12) ;DELETE INPUT TRANSFORM, POINTER,SCREEN EXPLANATION FOR A FIELD THAT IS NOW 'EXTENDED'
Q
;
AFDEFDEL(FILE,FIELD) ;'KILL' CROSS-REFERENCE ON SPECIFIER
N T,FF,I,Z
S T=+$P($P($G(^DD(FILE,FIELD,0)),U,2),"t",2) Q:'T!'$D(^DI(.81,T,0))
S FF=FILE_","_FIELD
F I=0:0 S I=$O(^DI(.81,"AFDEF",T,FF,I)) Q:'I I $G(^DI(.81,T,41,I,0))=FF K ^(0) S Z=$G(^DI(.81,T,41,0)),^(0)="^.81215^"_$O(^("A"),-1)_"^"_($P(Z,U,4)-1)
K ^DI(.81,"AFDEF",T,FF)
Q
;
;
DELETEQ ;CANNOT DELETE A DATA TYPE IN USE
IF DA<100 Q
IF $D(^DI(.81,"AFDEF",DA))
IF W !?3,"SORRY! DATA TYPES IN USE CANNOT BE DELETED!!",!
QUIT
;
;
CLEANDEF ; POST-INSTALL CAN CALL THIS TO MAKE SURE THAT 'FIELD DEFINED BY THIS TYPE' DOES NOT HAVE EXTRA MULTIPLES
N TY,I,FI,FL
F TY=0:0 S TY=$O(^DI(.81,TY)) Q:'TY F I=0:0 S I=$O(^DI(.81,TY,41,I)) Q:'I I $D(^(I,0)) S Z=^(0) D
.S FI=+Z,FL=+$P(Z,",",2) I $D(^DD(FI,FL,0)),$P($P(^(0),"^",2),"t",2)=TY Q
.K ^DI(.81,"AFDEF",TY,Z,I),^DI(.81,TY,41,I)
Q
;
;
;
;
;****************************************************************
;called from DICATTUD & DIRUD
PARSE(DDTSTR,DDTVALS) ;Parse DDTSTR, replacing |abbr| with DDTVALS(abbr)
;Two consecutive |s are replaced with a single |
;|#FILE#| is replaced with DDTVALS("#FILE#")
;|#FIELD#| is replaced with DDTVALS("#FIELD#")
Q:$G(DDTSTR)="" ""
Q:DDTSTR'["|" DDTSTR
;
N I,J,DDTABBR,DDTVAL,L,DDTWIND
;
S I=1 F D Q:'I
. ;Find the next |
. S I=$F(DDTSTR,"|",I) Q:'I
. ;
. ;Replace || with |
. I $E(DDTSTR,I)="|" S $E(DDTSTR,I-1,I)="|" Q
. ;
. ;Find the next |, get the abbreviation and the property value
. S J=$F(DDTSTR,"|",I) I 'J S I=0 Q
. S DDTWIND=$E(DDTSTR,I,J-2)
. S L=+$P(DDTWIND,",",2),DDTABBR=$P(DDTWIND,",")
. S DDTVAL=$G(DDTVALS(DDTABBR))
. S:L DDTVAL=$$QT(DDTVAL,L)
. ;
. ;Replace |abbr| with the value, update I
. S $E(DDTSTR,I-1,J-1)=DDTVAL
. S I=J+$L(DDTVAL)-$L(DDTWIND)-2
Q DDTSTR
;
QT(X,L) ;Return X with one quote replaced with 2 quotes.Repeat the process L times}
N I,J,K
Q:$G(L)=0 X
S:'$G(L) L=1
;
F I=1:1:L D
. S Y=""
. S J=1,K=1 F S K=$F(X,"""",J) Q:'K D
.. S Y=Y_$E(X,J,K-1)_""""
.. S J=K
. S X=Y_$E(X,J,999)
Q X
;
;
;
XCODE(DDTCODE,DDTVALS) ;Execute DDTCODE, return value of X Called by DICATTUD,DIRUD
N X
Q:$G(DDTCODE)="" ""
;
S DDTCODE=$$PARSE(DDTCODE,.DDTVALS)
X DDTCODE
Q $G(X)
;
XCODEM(DDTCODE,DDTVALS,DDTOUT) ;Execute DDTCODE,
; Return values in DDTOUT array
;In:
; DDTCODE = code to execute (may contain |s); sets X or X array
; DDTVALS(abbrev) = array of property values
;Out:
; .DDTOUT = X array set by DDTCODE
;
N X K DDTOUT
Q:$G(DDTCODE)="" ""
;
S DDTCODE=$$PARSE(DDTCODE,.DDTVALS)
X DDTCODE
K DDTOUT M DDTOUT=X
Q
;
;*************************************************************
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIETLIB 3590 printed Sep 23, 2025@20:23:26 Page 2
DIETLIB ;SFISC/MKO,O-OIFO/GFT - LIBRARY OF APIs FOR USER DEFINED DATA TYPES ;04MAR2016
+1 ;;22.2;VA FileMan;**2,5**;Jan 05, 2016;Build 28
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;*************************************************************
+5 ;
+6 ;THESE CALLS DEAL WITH NODE 41 IN FILE .81, 'FIELD DEFINED BY THIS TYPE'
+7 ;
AFDEF(FILE,FIELD) ; --'SET' CROSS-REFERENCE ON SPECIFIER
+1 NEW T,FF,I
+2 ;GET THE EXTENDED TYPE
SET T=+$PIECE($PIECE($GET(^DD(FILE,FIELD,0)),U,2),"t",2)
if 'T!'$DATA(^DI(.81,T,0))
QUIT
+3 SET I=$ORDER(^DI(.81,T,41,"A"),-1)+1
SET FF=FILE_","_FIELD
+4 ;ADD FIELD TO LIST OF DATATYPES FOR IT
IF '$DATA(^DI(.81,"AFDEF",T,FF))
SET ^(FF,I)=""
SET ^DI(.81,T,41,0)="^.81215^"_I_U_I
SET ^(I,0)=FF
+5 ;DELETE INPUT TRANSFORM, POINTER,SCREEN EXPLANATION FOR A FIELD THAT IS NOW 'EXTENDED'
SET $PIECE(^DD(FILE,FIELD,0),U,5,99)=""
SET $PIECE(^(0),U,3)=""
KILL ^(12)
+6 QUIT
+7 ;
AFDEFDEL(FILE,FIELD) ;'KILL' CROSS-REFERENCE ON SPECIFIER
+1 NEW T,FF,I,Z
+2 SET T=+$PIECE($PIECE($GET(^DD(FILE,FIELD,0)),U,2),"t",2)
if 'T!'$DATA(^DI(.81,T,0))
QUIT
+3 SET FF=FILE_","_FIELD
+4 FOR I=0:0
SET I=$ORDER(^DI(.81,"AFDEF",T,FF,I))
if 'I
QUIT
IF $GET(^DI(.81,T,41,I,0))=FF
KILL ^(0)
SET Z=$GET(^DI(.81,T,41,0))
SET ^(0)="^.81215^"_$ORDER(^("A"),-1)_"^"_($PIECE(Z,U,4)-1)
+5 KILL ^DI(.81,"AFDEF",T,FF)
+6 QUIT
+7 ;
+8 ;
DELETEQ ;CANNOT DELETE A DATA TYPE IN USE
+1 IF DA<100
QUIT
+2 IF $DATA(^DI(.81,"AFDEF",DA))
+3 IF $TEST
WRITE !?3,"SORRY! DATA TYPES IN USE CANNOT BE DELETED!!",!
+4 QUIT
+5 ;
+6 ;
CLEANDEF ; POST-INSTALL CAN CALL THIS TO MAKE SURE THAT 'FIELD DEFINED BY THIS TYPE' DOES NOT HAVE EXTRA MULTIPLES
+1 NEW TY,I,FI,FL
+2 FOR TY=0:0
SET TY=$ORDER(^DI(.81,TY))
if 'TY
QUIT
FOR I=0:0
SET I=$ORDER(^DI(.81,TY,41,I))
if 'I
QUIT
IF $DATA(^(I,0))
SET Z=^(0)
Begin DoDot:1
+3 SET FI=+Z
SET FL=+$PIECE(Z,",",2)
IF $DATA(^DD(FI,FL,0))
IF $PIECE($PIECE(^(0),"^",2),"t",2)=TY
QUIT
+4 KILL ^DI(.81,"AFDEF",TY,Z,I),^DI(.81,TY,41,I)
End DoDot:1
+5 QUIT
+6 ;
+7 ;
+8 ;
+9 ;
+10 ;****************************************************************
+11 ;called from DICATTUD & DIRUD
PARSE(DDTSTR,DDTVALS) ;Parse DDTSTR, replacing |abbr| with DDTVALS(abbr)
+1 ;Two consecutive |s are replaced with a single |
+2 ;|#FILE#| is replaced with DDTVALS("#FILE#")
+3 ;|#FIELD#| is replaced with DDTVALS("#FIELD#")
+4 if $GET(DDTSTR)=""
QUIT ""
+5 if DDTSTR'["|"
QUIT DDTSTR
+6 ;
+7 NEW I,J,DDTABBR,DDTVAL,L,DDTWIND
+8 ;
+9 SET I=1
FOR
Begin DoDot:1
+10 ;Find the next |
+11 SET I=$FIND(DDTSTR,"|",I)
if 'I
QUIT
+12 ;
+13 ;Replace || with |
+14 IF $EXTRACT(DDTSTR,I)="|"
SET $EXTRACT(DDTSTR,I-1,I)="|"
QUIT
+15 ;
+16 ;Find the next |, get the abbreviation and the property value
+17 SET J=$FIND(DDTSTR,"|",I)
IF 'J
SET I=0
QUIT
+18 SET DDTWIND=$EXTRACT(DDTSTR,I,J-2)
+19 SET L=+$PIECE(DDTWIND,",",2)
SET DDTABBR=$PIECE(DDTWIND,",")
+20 SET DDTVAL=$GET(DDTVALS(DDTABBR))
+21 if L
SET DDTVAL=$$QT(DDTVAL,L)
+22 ;
+23 ;Replace |abbr| with the value, update I
+24 SET $EXTRACT(DDTSTR,I-1,J-1)=DDTVAL
+25 SET I=J+$LENGTH(DDTVAL)-$LENGTH(DDTWIND)-2
End DoDot:1
if 'I
QUIT
+26 QUIT DDTSTR
+27 ;
QT(X,L) ;Return X with one quote replaced with 2 quotes.Repeat the process L times}
+1 NEW I,J,K
+2 if $GET(L)=0
QUIT X
+3 if '$GET(L)
SET L=1
+4 ;
+5 FOR I=1:1:L
Begin DoDot:1
+6 SET Y=""
+7 SET J=1
SET K=1
FOR
SET K=$FIND(X,"""",J)
if 'K
QUIT
Begin DoDot:2
+8 SET Y=Y_$EXTRACT(X,J,K-1)_""""
+9 SET J=K
End DoDot:2
+10 SET X=Y_$EXTRACT(X,J,999)
End DoDot:1
+11 QUIT X
+12 ;
+13 ;
+14 ;
XCODE(DDTCODE,DDTVALS) ;Execute DDTCODE, return value of X Called by DICATTUD,DIRUD
+1 NEW X
+2 if $GET(DDTCODE)=""
QUIT ""
+3 ;
+4 SET DDTCODE=$$PARSE(DDTCODE,.DDTVALS)
+5 XECUTE DDTCODE
+6 QUIT $GET(X)
+7 ;
XCODEM(DDTCODE,DDTVALS,DDTOUT) ;Execute DDTCODE,
+1 ; Return values in DDTOUT array
+2 ;In:
+3 ; DDTCODE = code to execute (may contain |s); sets X or X array
+4 ; DDTVALS(abbrev) = array of property values
+5 ;Out:
+6 ; .DDTOUT = X array set by DDTCODE
+7 ;
+8 NEW X
KILL DDTOUT
+9 if $GET(DDTCODE)=""
QUIT ""
+10 ;
+11 SET DDTCODE=$$PARSE(DDTCODE,.DDTVALS)
+12 XECUTE DDTCODE
+13 KILL DDTOUT
MERGE DDTOUT=X
+14 QUIT
+15 ;
+16 ;*************************************************************
+17 ;
