- XTIDCTX ;OAKCIOFO/JLG - TERM/CONCEPT CONTEXT directories ;04/20/2005 15:12
- ;;7.3;TOOLKIT;**93**;Apr 25, 1995
- ; Reference to global "^DD" supported by IA #4634
- Q
- ; encapsulates the location (directory) of term/concept
- ; references based on FILE/FIELD.
- ; It eventually encapsulates the retrieval of
- ; specific term/concept references (TERM defined in XTIDTERM) based
- ; on the internal reference (IREF).
- ; There are two current implementations: one for terms defined
- ; as "set of codes"; the other defined in VistA files that have
- ; been updated to contain VUID-related data in their DD.
- ; CTX and TERM are passed by reference in all the subroutines
- ;
- CONTEXT(TFILE,TFIELD,CTX) ; determine and create context impl
- ; returns new CTX array
- ; CTX("TYPE")=<"SET" or "TABLE" or "ROOT">
- ; CTX("TERM FILE#")=<TFILE or "">
- ; CTX("TERM FIELD#")=<TFIELD or "">
- ; CTX("SOURCE FILE#")=<8985.1 or TFILE or "">
- ; CTX("TERMSTATUS SUBFILE#")=
- ; <subfile for the multi-valued field
- ; 99.991, EFFECTIVE DATE/TIME or "">
- N TTYPE
- Q:$D(CTX)
- S TFILE=$G(TFILE),TFIELD=$G(TFIELD)
- S TTYPE=$$GETTYPE(TFILE,TFIELD)
- Q:TTYPE=""
- I TTYPE="SET" D CONTEXT^XTIDSET(TFILE,TFIELD,.CTX) Q
- I TTYPE="TABLE" D CONTEXT^XTIDTBL(TFILE,.01,.CTX) Q
- I TTYPE="ROOT" D ROOTCTX(.CTX) Q
- Q
- ;
- VALIDREF(CTX,TIREF) ; validate IREF
- ; validate internal reference against given CTX
- N VALID S VALID=1
- Q:'$D(CTX) 'VALID
- I CTX("TYPE")="SET" D Q VALID
- . S VALID=$$VALIDREF^XTIDSET(.CTX,$G(TIREF))
- ;
- I CTX("TYPE")="TABLE" D Q VALID
- . S VALID=$$VALIDREF^XTIDTBL(.CTX,$G(TIREF))
- ;
- Q 'VALID
- FINDTERM(CTX,TIREF,TERM) ; find term
- ; find the single term reference for given term IREF
- ; return TERM data as new TERM array
- ; IREF is unique within a given CTX, except for "RO0T" context
- ; on success, attach CTX to TERM array
- Q:'$D(CTX)!($D(TERM))
- I CTX("TYPE")="SET" D FINDTERM^XTIDSET(.CTX,$G(TIREF),.TERM)
- I CTX("TYPE")="TABLE" D FINDTERM^XTIDTBL(.CTX,$G(TIREF),.TERM)
- ; don't find term reference for "ROOT" type, where IREF is not unique
- ; on success, attach CTX to TERM
- I $D(TERM) M TERM("CTX")=CTX
- Q
- ;
- NEWTERM(CTX,TIREF,VUID) ; create a new term reference with given VUID
- ; only for "set of codes"
- ; on success (term entry), new TERM array is returned
- ; create a new entry in the Kernel (8985.1) file only (set of codes)
- N SUCCESS
- S TIREF=$G(TIREF),VUID=+$G(VUID)
- Q:'$D(CTX)!('VUID) 0
- ; create new term reference entry only for "set of codes"
- Q:CTX("TYPE")'="SET" 0
- Q $$NEWTERM^XTIDSET(.CTX,TIREF,VUID)
- ;
- GETTERM(CTX,FILE,IENS,TERM) ; get term
- ; return TERM data as new TERM array
- ; called from CTX implementations only
- ; subroutine might be moved to XTIDTERM
- ; D GETS^DIQ(FILE,IENS,FIELD,FLAGS,TARGET_ROOT,MSG_ROOT)
- N DIERR,MSG
- S FILE=+$G(FILE),IENS=$G(IENS)
- ; ensure only CTX implementations use this for callback
- Q:'$D(CTX)!($D(TERM))!('FILE)!(IENS']"")
- D GETS^DIQ(FILE,IENS,"**","IR","TERM","MSG")
- Q:$D(MSG("DIERR"))
- Q
- ;
- SRCHTRMS(CTX,VUID,XTCARR,MASTER) ; search term reference entries
- ; search term reference entries based on VUID and its context
- S VUID=$G(VUID),XTCARR=$G(XTCARR),MASTER=+$G(MASTER)
- ; CTX must be defined
- Q:'$D(CTX)!(XTCARR']"")!('VUID)
- I CTX("TYPE")="SET" D SRCHTRMS^XTIDSET(.CTX,VUID,XTCARR,MASTER) Q
- I CTX("TYPE")="TABLE" D SRCHTRMS^XTIDTBL(.CTX,VUID,XTCARR,MASTER) Q
- I CTX("TYPE")="ROOT" D Q
- . ; each CTX implementation should contribute to XTCARR array
- . N FL
- . ; search "set of codes" first
- . ; temporarily set context info
- . S CTX("TYPE")="SET"
- . S CTX("SOURCE FILE#")=8985.1
- . D SRCHTRMS^XTIDSET(.CTX,VUID,XTCARR,MASTER)
- . ; search all "table" files
- . ; temporarily set context info
- . S CTX("TYPE")="TABLE"
- . S FL=0
- . F S FL=$O(^DIC(FL)) Q:'FL D
- . . Q:'$D(^DD(FL,99.991))
- . . Q:FL=8985.1
- . . S CTX("SOURCE FILE#")=FL
- . . S CTX("TERM FILE#")=FL
- . . S CTX("TERM FIELD#")=.01
- . . D SRCHTRMS^XTIDTBL(.CTX,VUID,XTCARR,MASTER)
- . ;
- . ; reset context info
- . S CTX("TYPE")="ROOT"
- . S CTX("SOURCE FILE#")=""
- . S CTX("TERM FILE#")=""
- . S CTX("TERM FIELD#")=""
- ;
- Q
- ;
- ADDTARRY(XTC2ARR,FILE,FIELD,IREF,VALUE) ;
- ; adds element and value to XTC2ARR array (by name)
- ; called by CTX implementations of SRCHTRMS()
- ; increased count
- N COUNT
- S COUNT=$G(@XTC2ARR)
- S @XTC2ARR@(+$G(FILE),+$G(FIELD),$G(IREF))=$G(VALUE)
- S @XTC2ARR=COUNT+1
- Q
- ;
- GETTYPE(FILE,FIELD) ; determine type of context
- ; based on FILE and FIELD combination
- ; D FIELD^DID(FILE,FIELD,FLAGS,ATTRIBUTES,TARGET_ROOT,MSG_ROOT)
- N DIERR,ATTR,MSG,TYPE
- S FILE=+$G(FILE),FIELD=$G(FIELD)
- S TYPE=""
- ; file may be empty in GETIREF^XTID use-case
- I 'FILE S TYPE="ROOT" Q TYPE
- ; determine if "table" type, by checking VUID DD
- I FIELD=""!(FIELD=.01) D
- . N VFIELD
- . S VFIELD=99.99 ; test existence of VUID field
- . D FIELD^DID(FILE,VFIELD,"","LABEL","ATTR","MSG")
- . ;Q:$D(MSG("DIERR")) ; INVALID type returned
- . I $G(ATTR("LABEL"))="VUID" S TYPE="TABLE"
- ;
- Q:TYPE'="" TYPE
- ; determine if FIELD is a SET OF CODES
- ; D FIELD^DID(FILE,FIELD,"","TYPE","ATTR","MSG")
- ; Q:$D(MSG("DIERR")) TYPE
- ; I $G(ATTR("TYPE"))="SET" S TYPE="SET" Q TYPE
- ; DS requested to assume "SET"
- S TYPE="SET"
- Q TYPE
- ;
- ROOTCTX(CTX) ; set up Context for "ROOT" type
- ; called from CONTEXT^XTIDCTX(TFILE,TFIELD,CTX)
- ; called only when TFILE is not defined
- S CTX("TYPE")="ROOT"
- S CTX("TERM FILE#")=""
- S CTX("TERM FIELD#")=""
- ; the default source file
- S CTX("SOURCE FILE#")=""
- ; TERMSTATUS 99.991, EFFECTIVE DATE/TIME subfile
- S CTX("TERMSTATUS SUBFILE#")=""
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXTIDCTX 5658 printed Jan 18, 2025@03:42:14 Page 2
- XTIDCTX ;OAKCIOFO/JLG - TERM/CONCEPT CONTEXT directories ;04/20/2005 15:12
- +1 ;;7.3;TOOLKIT;**93**;Apr 25, 1995
- +2 ; Reference to global "^DD" supported by IA #4634
- +3 QUIT
- +4 ; encapsulates the location (directory) of term/concept
- +5 ; references based on FILE/FIELD.
- +6 ; It eventually encapsulates the retrieval of
- +7 ; specific term/concept references (TERM defined in XTIDTERM) based
- +8 ; on the internal reference (IREF).
- +9 ; There are two current implementations: one for terms defined
- +10 ; as "set of codes"; the other defined in VistA files that have
- +11 ; been updated to contain VUID-related data in their DD.
- +12 ; CTX and TERM are passed by reference in all the subroutines
- +13 ;
- CONTEXT(TFILE,TFIELD,CTX) ; determine and create context impl
- +1 ; returns new CTX array
- +2 ; CTX("TYPE")=<"SET" or "TABLE" or "ROOT">
- +3 ; CTX("TERM FILE#")=<TFILE or "">
- +4 ; CTX("TERM FIELD#")=<TFIELD or "">
- +5 ; CTX("SOURCE FILE#")=<8985.1 or TFILE or "">
- +6 ; CTX("TERMSTATUS SUBFILE#")=
- +7 ; <subfile for the multi-valued field
- +8 ; 99.991, EFFECTIVE DATE/TIME or "">
- +9 NEW TTYPE
- +10 if $DATA(CTX)
- QUIT
- +11 SET TFILE=$GET(TFILE)
- SET TFIELD=$GET(TFIELD)
- +12 SET TTYPE=$$GETTYPE(TFILE,TFIELD)
- +13 if TTYPE=""
- QUIT
- +14 IF TTYPE="SET"
- DO CONTEXT^XTIDSET(TFILE,TFIELD,.CTX)
- QUIT
- +15 IF TTYPE="TABLE"
- DO CONTEXT^XTIDTBL(TFILE,.01,.CTX)
- QUIT
- +16 IF TTYPE="ROOT"
- DO ROOTCTX(.CTX)
- QUIT
- +17 QUIT
- +18 ;
- VALIDREF(CTX,TIREF) ; validate IREF
- +1 ; validate internal reference against given CTX
- +2 NEW VALID
- SET VALID=1
- +3 if '$DATA(CTX)
- QUIT 'VALID
- +4 IF CTX("TYPE")="SET"
- Begin DoDot:1
- +5 SET VALID=$$VALIDREF^XTIDSET(.CTX,$GET(TIREF))
- End DoDot:1
- QUIT VALID
- +6 ;
- +7 IF CTX("TYPE")="TABLE"
- Begin DoDot:1
- +8 SET VALID=$$VALIDREF^XTIDTBL(.CTX,$GET(TIREF))
- End DoDot:1
- QUIT VALID
- +9 ;
- +10 QUIT 'VALID
- FINDTERM(CTX,TIREF,TERM) ; find term
- +1 ; find the single term reference for given term IREF
- +2 ; return TERM data as new TERM array
- +3 ; IREF is unique within a given CTX, except for "RO0T" context
- +4 ; on success, attach CTX to TERM array
- +5 if '$DATA(CTX)!($DATA(TERM))
- QUIT
- +6 IF CTX("TYPE")="SET"
- DO FINDTERM^XTIDSET(.CTX,$GET(TIREF),.TERM)
- +7 IF CTX("TYPE")="TABLE"
- DO FINDTERM^XTIDTBL(.CTX,$GET(TIREF),.TERM)
- +8 ; don't find term reference for "ROOT" type, where IREF is not unique
- +9 ; on success, attach CTX to TERM
- +10 IF $DATA(TERM)
- MERGE TERM("CTX")=CTX
- +11 QUIT
- +12 ;
- NEWTERM(CTX,TIREF,VUID) ; create a new term reference with given VUID
- +1 ; only for "set of codes"
- +2 ; on success (term entry), new TERM array is returned
- +3 ; create a new entry in the Kernel (8985.1) file only (set of codes)
- +4 NEW SUCCESS
- +5 SET TIREF=$GET(TIREF)
- SET VUID=+$GET(VUID)
- +6 if '$DATA(CTX)!('VUID)
- QUIT 0
- +7 ; create new term reference entry only for "set of codes"
- +8 if CTX("TYPE")'="SET"
- QUIT 0
- +9 QUIT $$NEWTERM^XTIDSET(.CTX,TIREF,VUID)
- +10 ;
- GETTERM(CTX,FILE,IENS,TERM) ; get term
- +1 ; return TERM data as new TERM array
- +2 ; called from CTX implementations only
- +3 ; subroutine might be moved to XTIDTERM
- +4 ; D GETS^DIQ(FILE,IENS,FIELD,FLAGS,TARGET_ROOT,MSG_ROOT)
- +5 NEW DIERR,MSG
- +6 SET FILE=+$GET(FILE)
- SET IENS=$GET(IENS)
- +7 ; ensure only CTX implementations use this for callback
- +8 if '$DATA(CTX)!($DATA(TERM))!('FILE)!(IENS']"")
- QUIT
- +9 DO GETS^DIQ(FILE,IENS,"**","IR","TERM","MSG")
- +10 if $DATA(MSG("DIERR"))
- QUIT
- +11 QUIT
- +12 ;
- SRCHTRMS(CTX,VUID,XTCARR,MASTER) ; search term reference entries
- +1 ; search term reference entries based on VUID and its context
- +2 SET VUID=$GET(VUID)
- SET XTCARR=$GET(XTCARR)
- SET MASTER=+$GET(MASTER)
- +3 ; CTX must be defined
- +4 if '$DATA(CTX)!(XTCARR']"")!('VUID)
- QUIT
- +5 IF CTX("TYPE")="SET"
- DO SRCHTRMS^XTIDSET(.CTX,VUID,XTCARR,MASTER)
- QUIT
- +6 IF CTX("TYPE")="TABLE"
- DO SRCHTRMS^XTIDTBL(.CTX,VUID,XTCARR,MASTER)
- QUIT
- +7 IF CTX("TYPE")="ROOT"
- Begin DoDot:1
- +8 ; each CTX implementation should contribute to XTCARR array
- +9 NEW FL
- +10 ; search "set of codes" first
- +11 ; temporarily set context info
- +12 SET CTX("TYPE")="SET"
- +13 SET CTX("SOURCE FILE#")=8985.1
- +14 DO SRCHTRMS^XTIDSET(.CTX,VUID,XTCARR,MASTER)
- +15 ; search all "table" files
- +16 ; temporarily set context info
- +17 SET CTX("TYPE")="TABLE"
- +18 SET FL=0
- +19 FOR
- SET FL=$ORDER(^DIC(FL))
- if 'FL
- QUIT
- Begin DoDot:2
- +20 if '$DATA(^DD(FL,99.991))
- QUIT
- +21 if FL=8985.1
- QUIT
- +22 SET CTX("SOURCE FILE#")=FL
- +23 SET CTX("TERM FILE#")=FL
- +24 SET CTX("TERM FIELD#")=.01
- +25 DO SRCHTRMS^XTIDTBL(.CTX,VUID,XTCARR,MASTER)
- End DoDot:2
- +26 ;
- +27 ; reset context info
- +28 SET CTX("TYPE")="ROOT"
- +29 SET CTX("SOURCE FILE#")=""
- +30 SET CTX("TERM FILE#")=""
- +31 SET CTX("TERM FIELD#")=""
- End DoDot:1
- QUIT
- +32 ;
- +33 QUIT
- +34 ;
- ADDTARRY(XTC2ARR,FILE,FIELD,IREF,VALUE) ;
- +1 ; adds element and value to XTC2ARR array (by name)
- +2 ; called by CTX implementations of SRCHTRMS()
- +3 ; increased count
- +4 NEW COUNT
- +5 SET COUNT=$GET(@XTC2ARR)
- +6 SET @XTC2ARR@(+$GET(FILE),+$GET(FIELD),$GET(IREF))=$GET(VALUE)
- +7 SET @XTC2ARR=COUNT+1
- +8 QUIT
- +9 ;
- GETTYPE(FILE,FIELD) ; determine type of context
- +1 ; based on FILE and FIELD combination
- +2 ; D FIELD^DID(FILE,FIELD,FLAGS,ATTRIBUTES,TARGET_ROOT,MSG_ROOT)
- +3 NEW DIERR,ATTR,MSG,TYPE
- +4 SET FILE=+$GET(FILE)
- SET FIELD=$GET(FIELD)
- +5 SET TYPE=""
- +6 ; file may be empty in GETIREF^XTID use-case
- +7 IF 'FILE
- SET TYPE="ROOT"
- QUIT TYPE
- +8 ; determine if "table" type, by checking VUID DD
- +9 IF FIELD=""!(FIELD=.01)
- Begin DoDot:1
- +10 NEW VFIELD
- +11 ; test existence of VUID field
- SET VFIELD=99.99
- +12 DO FIELD^DID(FILE,VFIELD,"","LABEL","ATTR","MSG")
- +13 ;Q:$D(MSG("DIERR")) ; INVALID type returned
- +14 IF $GET(ATTR("LABEL"))="VUID"
- SET TYPE="TABLE"
- End DoDot:1
- +15 ;
- +16 if TYPE'=""
- QUIT TYPE
- +17 ; determine if FIELD is a SET OF CODES
- +18 ; D FIELD^DID(FILE,FIELD,"","TYPE","ATTR","MSG")
- +19 ; Q:$D(MSG("DIERR")) TYPE
- +20 ; I $G(ATTR("TYPE"))="SET" S TYPE="SET" Q TYPE
- +21 ; DS requested to assume "SET"
- +22 SET TYPE="SET"
- +23 QUIT TYPE
- +24 ;
- ROOTCTX(CTX) ; set up Context for "ROOT" type
- +1 ; called from CONTEXT^XTIDCTX(TFILE,TFIELD,CTX)
- +2 ; called only when TFILE is not defined
- +3 SET CTX("TYPE")="ROOT"
- +4 SET CTX("TERM FILE#")=""
- +5 SET CTX("TERM FIELD#")=""
- +6 ; the default source file
- +7 SET CTX("SOURCE FILE#")=""
- +8 ; TERMSTATUS 99.991, EFFECTIVE DATE/TIME subfile
- +9 SET CTX("TERMSTATUS SUBFILE#")=""
- +10 QUIT
- +11 ;