- 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 Jan 18, 2025@03:48:18 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 ;