XTIDTRM ;BPFO/JRP - API set for VUID-Term/Concepts in VistA ;05/16/2008
;;7.3;TOOLKIT;**111**;Apr 25, 1995;Build 2
; Per VHA Directive 2004-038, this routine should not be modified.
; IA #5078 governs the APIs in this routine
; IA #5067 allows this routine to check and traverse ^DD(.
;
SETRPLC(FILE,IEN,RPLCMNT) ; Set replacement term
N NEXTFILE,NEXTROOT,XTFDA,XTMSG
I RPLCMNT="" S RPLCMNT="@"
S NEXTFILE=$$PTR2FILE(FILE)
I 'NEXTFILE Q 0
I NEXTFILE=FILE,IEN=RPLCMNT Q 0 ; Don't store ptr to self
S NEXTROOT=$$ROOT^DILFD(NEXTFILE,"",1)
I NEXTROOT="" Q 0
I RPLCMNT'="@",'$D(@NEXTROOT@(RPLCMNT)) Q 0
S XTFDA(FILE,IEN_",",99.97)=RPLCMNT
D FILE^DIE("","XTFDA","XTMSG")
I $D(XTMSG) Q 0
Q 1
;
GETRPLC(FILE,IEN) ; Get replacement term
N NEXTIEN,NEXTFILE
S NEXTFILE=$$PTR2FILE(FILE)
I 'NEXTFILE Q IEN_";"_FILE
S NEXTIEN=$$PTR2IEN(FILE,IEN)
I 'NEXTIEN Q IEN_";"_FILE
Q NEXTIEN_";"_NEXTFILE
;
RPLCMNT(FILE,IEN) ; Follow pointer trail until it ends
N NEXTIEN,NEXTFILE
S NEXTFILE=$$PTR2FILE(FILE)
I 'NEXTFILE Q IEN_";"_FILE
S NEXTIEN=$$PTR2IEN(FILE,IEN)
I 'NEXTIEN Q IEN_";"_FILE
I NEXTFILE=FILE,NEXTIEN=IEN Q IEN_";"_FILE ; Trail leads back to self
Q $$RPLCMNT(NEXTFILE,NEXTIEN)
;
RPLCVALS(FILE,IEN,FIELD,FLAGS,OUTARR) ; Return inherited values for entry
N RPLCMNT,XTMSG
S RPLCMNT=$$RPLCMNT(FILE,IEN)
I RPLCMNT="" Q ""
D GETS^DIQ(+$P(RPLCMNT,";",2),+RPLCMNT_",",FIELD,FLAGS,OUTARR,"XTMSG")
I $D(XTMSG) K @OUTARR
Q RPLCMNT
;
RPLCTRL(FILE,IEN,DRCTN,OUTARR) ; Return replacement trail for entry
N NEXTIEN,NEXTFILE,RPLCMNT,TERMREF,SCRAP,NEXTROOT
S DRCTN=$S($G(DRCTN)="":"F",DRCTN="*":"FB",1:DRCTN)
S TERMREF=IEN_";"_FILE
I DRCTN["F" D
. S NEXTFILE=$$PTR2FILE(FILE)
. I 'NEXTFILE D Q
. . S @OUTARR@("BY",TERMREF)=""
. S NEXTIEN=$$PTR2IEN(FILE,IEN)
. I 'NEXTIEN D Q
. . S @OUTARR@("BY",TERMREF)=""
. S RPLCMNT=NEXTIEN_";"_NEXTFILE
. Q:$D(@OUTARR@("BY",TERMREF))
. S @OUTARR@("BY",TERMREF)=RPLCMNT
. S @OUTARR@("FOR",RPLCMNT,TERMREF)=""
. S SCRAP=$$RPLCTRL(NEXTFILE,NEXTIEN,DRCTN,OUTARR)
I DRCTN["B" D
. S NEXTFILE=""
. F S NEXTFILE=$O(^DD(FILE,0,"PT",NEXTFILE)) Q:'NEXTFILE D
. . Q:'$D(^DD(FILE,0,"PT",NEXTFILE,99.97))
. . S NEXTROOT=$$ROOT^DILFD(NEXTFILE,"",1)
. . Q:NEXTROOT=""
. . S NEXTIEN=""
. . F S NEXTIEN=$O(@NEXTROOT@("AREPLACETERM",IEN,NEXTIEN)) Q:'NEXTIEN D
. . . S RPLCMNT=NEXTIEN_";"_NEXTFILE
. . . Q:$D(@OUTARR@("BY",RPLCMNT))
. . . S @OUTARR@("BY",RPLCMNT)=TERMREF
. . . S @OUTARR@("FOR",TERMREF,RPLCMNT)=""
. . . S SCRAP=$$RPLCTRL(NEXTFILE,NEXTIEN,DRCTN,OUTARR)
Q $$RPLCMNT(FILE,IEN)
;
RPLCLST(FILE,IEN,DRCTN,STATDATE,STATHST,OUTARR) ; Return replacement list for entry
N NEXTIEN,NEXTFILE,RPLCMNT,TERMREF,SCRAP,NEXTROOT,COUNTER
S DRCTN=$S($G(DRCTN)="":"F",DRCTN="*":"FB",1:DRCTN)
S STATDATE=$S($G(STATDATE)="":$$NOW^XLFDT(),1:STATDATE)
S STATHST=+$G(STATHST)
S TERMREF=IEN_";"_FILE
I DRCTN["F" D
. S NEXTFILE=$$PTR2FILE(FILE)
. I 'NEXTFILE D Q
. . S SCRAP=$$GETSTAT^XTID(FILE,.01,IEN_",",STATDATE)
. . S COUNTER=1+$O(@OUTARR@("INDEX"),-1)
. . S @OUTARR@(COUNTER)=TERMREF_U_$P(SCRAP,U,1)
. . S @OUTARR@("INDEX",TERMREF)=COUNTER
. . D STATHIST(FILE,IEN,$NAME(@OUTARR@(COUNTER)))
. S NEXTIEN=$$PTR2IEN(FILE,IEN)
. I 'NEXTIEN D Q
. . S SCRAP=$$GETSTAT^XTID(FILE,.01,IEN_",",STATDATE)
. . S COUNTER=1+$O(@OUTARR@("INDEX"),-1)
. . S @OUTARR@(COUNTER)=TERMREF_U_$P(SCRAP,U,1)
. . S @OUTARR@("INDEX",TERMREF)=COUNTER
. . D STATHIST(FILE,IEN,$NAME(@OUTARR@(COUNTER)))
. S RPLCMNT=NEXTIEN_";"_NEXTFILE
. Q:$D(@OUTARR@("INDEX",TERMREF))
. S SCRAP=$$GETSTAT^XTID(FILE,.01,IEN_",",STATDATE)
. S COUNTER=1+$O(@OUTARR@("INDEX"),-1)
. S @OUTARR@(COUNTER)=TERMREF_U_$P(SCRAP,U,1)
. S @OUTARR@("INDEX",TERMREF)=COUNTER
. D STATHIST(FILE,IEN,$NAME(@OUTARR@(COUNTER)))
. S SCRAP=$$RPLCLST(NEXTFILE,NEXTIEN,DRCTN,STATDATE,STATHST,OUTARR)
I DRCTN["B" D
. S NEXTFILE=""
. F S NEXTFILE=$O(^DD(FILE,0,"PT",NEXTFILE)) Q:'NEXTFILE D
. . Q:'$D(^DD(FILE,0,"PT",NEXTFILE,99.97))
. . S NEXTROOT=$$ROOT^DILFD(NEXTFILE,"",1)
. . Q:NEXTROOT=""
. . S NEXTIEN=""
. . F S NEXTIEN=$O(@NEXTROOT@("AREPLACETERM",IEN,NEXTIEN)) Q:'NEXTIEN D
. . . S RPLCMNT=NEXTIEN_";"_NEXTFILE
. . . Q:$D(@OUTARR@("INDEX",RPLCMNT))
. . . S SCRAP=$$GETSTAT^XTID(NEXTFILE,.01,NEXTIEN_",",STATDATE)
. . . S COUNTER=1+$O(@OUTARR@("INDEX"),-1)
. . . S @OUTARR@(COUNTER)=RPLCMNT_U_$P(SCRAP,U,1)
. . . S @OUTARR@("INDEX",RPLCMNT)=COUNTER
. . . D STATHIST(NEXTFILE,NEXTIEN,$NAME(@OUTARR@(COUNTER)))
. . . S SCRAP=$$RPLCLST(NEXTFILE,NEXTIEN,DRCTN,STATDATE,STATHST,OUTARR)
Q $$RPLCMNT(FILE,IEN)
;
STATHIST(FILE,IEN,OUTARR) ; Return status history for entry
N SUBFILE,XTHIST,XTMSG,ID,STATDATE
S SUBFILE=$$SUBFILE(FILE,99.991)
Q:'SUBFILE
D LIST^DIC(SUBFILE,","_IEN_",",".01;.02","I","*","","","","","","XTHIST","XTMSG")
I $D(XTMSG) Q 0
S ID=0
F S ID=$O(XTHIST("DILIST","ID",ID)) Q:'ID D
. S STATDATE=$G(XTHIST("DILIST","ID",ID,.01))
. Q:'STATDATE
. S @OUTARR@(STATDATE)=$G(XTHIST("DILIST","ID",ID,.02))
Q
;
PTR2FILE(FILE) ; Return file number that field points to
N OTHER,XTMSG
S OTHER=$$GET1^DID(FILE,99.97,"","SPECIFIER","","XTMSG")
I $D(XTMSG) Q 0
Q +$P(OTHER,"P",2)
;
PTR2IEN(FILE,PTR) ; Return entry that field points to
N VALUE,XTMSG
S VALUE=$$GET1^DIQ(FILE,PTR_",",99.97,"I","","XTMSG")
I $D(XTMSG) Q 0
Q VALUE
;
SUBFILE(FILE,FIELD) ; Return subfile number for a multiple
N VALUE,XTMSG
S VALUE=$$GET1^DID(FILE,FIELD,"","SPECIFIER","","XTMSG")
I $D(XTMSG) Q 0
Q +VALUE
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXTIDTRM 5615 printed Apr 09, 2024@21:41:15 Page 2
XTIDTRM ;BPFO/JRP - API set for VUID-Term/Concepts in VistA ;05/16/2008
+1 ;;7.3;TOOLKIT;**111**;Apr 25, 1995;Build 2
+2 ; Per VHA Directive 2004-038, this routine should not be modified.
+3 ; IA #5078 governs the APIs in this routine
+4 ; IA #5067 allows this routine to check and traverse ^DD(.
+5 ;
SETRPLC(FILE,IEN,RPLCMNT) ; Set replacement term
+1 NEW NEXTFILE,NEXTROOT,XTFDA,XTMSG
+2 IF RPLCMNT=""
SET RPLCMNT="@"
+3 SET NEXTFILE=$$PTR2FILE(FILE)
+4 IF 'NEXTFILE
QUIT 0
+5 ; Don't store ptr to self
IF NEXTFILE=FILE
IF IEN=RPLCMNT
QUIT 0
+6 SET NEXTROOT=$$ROOT^DILFD(NEXTFILE,"",1)
+7 IF NEXTROOT=""
QUIT 0
+8 IF RPLCMNT'="@"
IF '$DATA(@NEXTROOT@(RPLCMNT))
QUIT 0
+9 SET XTFDA(FILE,IEN_",",99.97)=RPLCMNT
+10 DO FILE^DIE("","XTFDA","XTMSG")
+11 IF $DATA(XTMSG)
QUIT 0
+12 QUIT 1
+13 ;
GETRPLC(FILE,IEN) ; Get replacement term
+1 NEW NEXTIEN,NEXTFILE
+2 SET NEXTFILE=$$PTR2FILE(FILE)
+3 IF 'NEXTFILE
QUIT IEN_";"_FILE
+4 SET NEXTIEN=$$PTR2IEN(FILE,IEN)
+5 IF 'NEXTIEN
QUIT IEN_";"_FILE
+6 QUIT NEXTIEN_";"_NEXTFILE
+7 ;
RPLCMNT(FILE,IEN) ; Follow pointer trail until it ends
+1 NEW NEXTIEN,NEXTFILE
+2 SET NEXTFILE=$$PTR2FILE(FILE)
+3 IF 'NEXTFILE
QUIT IEN_";"_FILE
+4 SET NEXTIEN=$$PTR2IEN(FILE,IEN)
+5 IF 'NEXTIEN
QUIT IEN_";"_FILE
+6 ; Trail leads back to self
IF NEXTFILE=FILE
IF NEXTIEN=IEN
QUIT IEN_";"_FILE
+7 QUIT $$RPLCMNT(NEXTFILE,NEXTIEN)
+8 ;
RPLCVALS(FILE,IEN,FIELD,FLAGS,OUTARR) ; Return inherited values for entry
+1 NEW RPLCMNT,XTMSG
+2 SET RPLCMNT=$$RPLCMNT(FILE,IEN)
+3 IF RPLCMNT=""
QUIT ""
+4 DO GETS^DIQ(+$PIECE(RPLCMNT,";",2),+RPLCMNT_",",FIELD,FLAGS,OUTARR,"XTMSG")
+5 IF $DATA(XTMSG)
KILL @OUTARR
+6 QUIT RPLCMNT
+7 ;
RPLCTRL(FILE,IEN,DRCTN,OUTARR) ; Return replacement trail for entry
+1 NEW NEXTIEN,NEXTFILE,RPLCMNT,TERMREF,SCRAP,NEXTROOT
+2 SET DRCTN=$SELECT($GET(DRCTN)="":"F",DRCTN="*":"FB",1:DRCTN)
+3 SET TERMREF=IEN_";"_FILE
+4 IF DRCTN["F"
Begin DoDot:1
+5 SET NEXTFILE=$$PTR2FILE(FILE)
+6 IF 'NEXTFILE
Begin DoDot:2
+7 SET @OUTARR@("BY",TERMREF)=""
End DoDot:2
QUIT
+8 SET NEXTIEN=$$PTR2IEN(FILE,IEN)
+9 IF 'NEXTIEN
Begin DoDot:2
+10 SET @OUTARR@("BY",TERMREF)=""
End DoDot:2
QUIT
+11 SET RPLCMNT=NEXTIEN_";"_NEXTFILE
+12 if $DATA(@OUTARR@("BY",TERMREF))
QUIT
+13 SET @OUTARR@("BY",TERMREF)=RPLCMNT
+14 SET @OUTARR@("FOR",RPLCMNT,TERMREF)=""
+15 SET SCRAP=$$RPLCTRL(NEXTFILE,NEXTIEN,DRCTN,OUTARR)
End DoDot:1
+16 IF DRCTN["B"
Begin DoDot:1
+17 SET NEXTFILE=""
+18 FOR
SET NEXTFILE=$ORDER(^DD(FILE,0,"PT",NEXTFILE))
if 'NEXTFILE
QUIT
Begin DoDot:2
+19 if '$DATA(^DD(FILE,0,"PT",NEXTFILE,99.97))
QUIT
+20 SET NEXTROOT=$$ROOT^DILFD(NEXTFILE,"",1)
+21 if NEXTROOT=""
QUIT
+22 SET NEXTIEN=""
+23 FOR
SET NEXTIEN=$ORDER(@NEXTROOT@("AREPLACETERM",IEN,NEXTIEN))
if 'NEXTIEN
QUIT
Begin DoDot:3
+24 SET RPLCMNT=NEXTIEN_";"_NEXTFILE
+25 if $DATA(@OUTARR@("BY",RPLCMNT))
QUIT
+26 SET @OUTARR@("BY",RPLCMNT)=TERMREF
+27 SET @OUTARR@("FOR",TERMREF,RPLCMNT)=""
+28 SET SCRAP=$$RPLCTRL(NEXTFILE,NEXTIEN,DRCTN,OUTARR)
End DoDot:3
End DoDot:2
End DoDot:1
+29 QUIT $$RPLCMNT(FILE,IEN)
+30 ;
RPLCLST(FILE,IEN,DRCTN,STATDATE,STATHST,OUTARR) ; Return replacement list for entry
+1 NEW NEXTIEN,NEXTFILE,RPLCMNT,TERMREF,SCRAP,NEXTROOT,COUNTER
+2 SET DRCTN=$SELECT($GET(DRCTN)="":"F",DRCTN="*":"FB",1:DRCTN)
+3 SET STATDATE=$SELECT($GET(STATDATE)="":$$NOW^XLFDT(),1:STATDATE)
+4 SET STATHST=+$GET(STATHST)
+5 SET TERMREF=IEN_";"_FILE
+6 IF DRCTN["F"
Begin DoDot:1
+7 SET NEXTFILE=$$PTR2FILE(FILE)
+8 IF 'NEXTFILE
Begin DoDot:2
+9 SET SCRAP=$$GETSTAT^XTID(FILE,.01,IEN_",",STATDATE)
+10 SET COUNTER=1+$ORDER(@OUTARR@("INDEX"),-1)
+11 SET @OUTARR@(COUNTER)=TERMREF_U_$PIECE(SCRAP,U,1)
+12 SET @OUTARR@("INDEX",TERMREF)=COUNTER
+13 DO STATHIST(FILE,IEN,$NAME(@OUTARR@(COUNTER)))
End DoDot:2
QUIT
+14 SET NEXTIEN=$$PTR2IEN(FILE,IEN)
+15 IF 'NEXTIEN
Begin DoDot:2
+16 SET SCRAP=$$GETSTAT^XTID(FILE,.01,IEN_",",STATDATE)
+17 SET COUNTER=1+$ORDER(@OUTARR@("INDEX"),-1)
+18 SET @OUTARR@(COUNTER)=TERMREF_U_$PIECE(SCRAP,U,1)
+19 SET @OUTARR@("INDEX",TERMREF)=COUNTER
+20 DO STATHIST(FILE,IEN,$NAME(@OUTARR@(COUNTER)))
End DoDot:2
QUIT
+21 SET RPLCMNT=NEXTIEN_";"_NEXTFILE
+22 if $DATA(@OUTARR@("INDEX",TERMREF))
QUIT
+23 SET SCRAP=$$GETSTAT^XTID(FILE,.01,IEN_",",STATDATE)
+24 SET COUNTER=1+$ORDER(@OUTARR@("INDEX"),-1)
+25 SET @OUTARR@(COUNTER)=TERMREF_U_$PIECE(SCRAP,U,1)
+26 SET @OUTARR@("INDEX",TERMREF)=COUNTER
+27 DO STATHIST(FILE,IEN,$NAME(@OUTARR@(COUNTER)))
+28 SET SCRAP=$$RPLCLST(NEXTFILE,NEXTIEN,DRCTN,STATDATE,STATHST,OUTARR)
End DoDot:1
+29 IF DRCTN["B"
Begin DoDot:1
+30 SET NEXTFILE=""
+31 FOR
SET NEXTFILE=$ORDER(^DD(FILE,0,"PT",NEXTFILE))
if 'NEXTFILE
QUIT
Begin DoDot:2
+32 if '$DATA(^DD(FILE,0,"PT",NEXTFILE,99.97))
QUIT
+33 SET NEXTROOT=$$ROOT^DILFD(NEXTFILE,"",1)
+34 if NEXTROOT=""
QUIT
+35 SET NEXTIEN=""
+36 FOR
SET NEXTIEN=$ORDER(@NEXTROOT@("AREPLACETERM",IEN,NEXTIEN))
if 'NEXTIEN
QUIT
Begin DoDot:3
+37 SET RPLCMNT=NEXTIEN_";"_NEXTFILE
+38 if $DATA(@OUTARR@("INDEX",RPLCMNT))
QUIT
+39 SET SCRAP=$$GETSTAT^XTID(NEXTFILE,.01,NEXTIEN_",",STATDATE)
+40 SET COUNTER=1+$ORDER(@OUTARR@("INDEX"),-1)
+41 SET @OUTARR@(COUNTER)=RPLCMNT_U_$PIECE(SCRAP,U,1)
+42 SET @OUTARR@("INDEX",RPLCMNT)=COUNTER
+43 DO STATHIST(NEXTFILE,NEXTIEN,$NAME(@OUTARR@(COUNTER)))
+44 SET SCRAP=$$RPLCLST(NEXTFILE,NEXTIEN,DRCTN,STATDATE,STATHST,OUTARR)
End DoDot:3
End DoDot:2
End DoDot:1
+45 QUIT $$RPLCMNT(FILE,IEN)
+46 ;
STATHIST(FILE,IEN,OUTARR) ; Return status history for entry
+1 NEW SUBFILE,XTHIST,XTMSG,ID,STATDATE
+2 SET SUBFILE=$$SUBFILE(FILE,99.991)
+3 if 'SUBFILE
QUIT
+4 DO LIST^DIC(SUBFILE,","_IEN_",",".01;.02","I","*","","","","","","XTHIST","XTMSG")
+5 IF $DATA(XTMSG)
QUIT 0
+6 SET ID=0
+7 FOR
SET ID=$ORDER(XTHIST("DILIST","ID",ID))
if 'ID
QUIT
Begin DoDot:1
+8 SET STATDATE=$GET(XTHIST("DILIST","ID",ID,.01))
+9 if 'STATDATE
QUIT
+10 SET @OUTARR@(STATDATE)=$GET(XTHIST("DILIST","ID",ID,.02))
End DoDot:1
+11 QUIT
+12 ;
PTR2FILE(FILE) ; Return file number that field points to
+1 NEW OTHER,XTMSG
+2 SET OTHER=$$GET1^DID(FILE,99.97,"","SPECIFIER","","XTMSG")
+3 IF $DATA(XTMSG)
QUIT 0
+4 QUIT +$PIECE(OTHER,"P",2)
+5 ;
PTR2IEN(FILE,PTR) ; Return entry that field points to
+1 NEW VALUE,XTMSG
+2 SET VALUE=$$GET1^DIQ(FILE,PTR_",",99.97,"I","","XTMSG")
+3 IF $DATA(XTMSG)
QUIT 0
+4 QUIT VALUE
+5 ;
SUBFILE(FILE,FIELD) ; Return subfile number for a multiple
+1 NEW VALUE,XTMSG
+2 SET VALUE=$$GET1^DID(FILE,FIELD,"","SPECIFIER","","XTMSG")
+3 IF $DATA(XTMSG)
QUIT 0
+4 QUIT +VALUE
