DICL1 ;SEA/TOAD,SF/TKW-VA FileMan: Lookup: Lister, Part 2 ;10/15/98 14:19
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
PREP ; set up subfile's DA array under DIEN, init how many found,
; set max, and init array of last entries returned.
;
N DIEN D DA^DILF(DIFIEN,.DIEN)
N DISUB,DIVAL,X,Y
S DIDENT(-1)=0
S DIDENT(-1,"MAX")=DINUMBER
S DIDENT(-1,"JUST LOOKING")=0
F DISUB=1:1:DINDEX("#")+1 S DIDENT(-1,"LAST",DISUB)=""
S (DIDENT(-1,"LAST"),DIDENT(-1,"LAST","IEN"))=""
;
PTR ; if 1st indexed field is a pointer or var.ptr., and we're not doing
; a quick list, we build info for the
; pointer chain(s) to the end file(s) and do the search.
;
I "VP"[DINDEX(1,"TYPE"),DIFLAGS'["Q",'$D(DINDEX("ROOTCNG",1)) D
. D POINT^DICL10(.DIFILE,.DIFLAGS,.DINDEX,.DIDENT,.DIEN,DIFIEN,.DISCREEN,.DILIST)
. Q
;
GETLIST ; build the output list when first subscript not a ptr. or var.ptr.
;
E D
. I $D(DINDEX("ROOTCNG",1)) D BLDTMP^DICLIX1(.DINDEX,.DISCREEN,DIFLAGS,.DIDENT)
. D WALK^DICLIX(DIFLAGS,.DINDEX,.DIDENT,.DIFILE,.DIEN,.DIFIEN,.DISCREEN,.DILIST,"","",.DIC)
;
DSPHLP ; If we're displaying entries for online ^DIC help, display the rest
;
I DIFLAGS["h",$O(DICQ(0)) D
. K DTOUT,DUOUT S DICQ(0,"MAP")=DIDENT(-3)
. D DSP^DICQ1(.DINDEX,.DICQ,.DIC,.DIFILE)
. I $G(DTOUT)!($G(DUOUT)) S (DINDEX("DONE"),DIDONE)=1 Q
. S DIDENT(-1)=0
. Q
;
KTMPIX ; if we've built temporary indexes, we delete them:
D KILLB(.DIFILE)
N DISUB S DISUB=$O(DINDEX("ROOTCNG","")) I DISUB K @DINDEX(DISUB,"ROOT")
;
FINAL ; cleanup after search.
;
I $G(DIERR) K @DILIST D OUT^DICL Q
;
; set the output list header node and map node, output FROM values
; for last entries returned.
;
I '$D(DIDENT(-1)) S DIDENT(-1)=0,DIDENT(-1,"MAX")=DINUMBER
N DIHEADER S DIHEADER=DIDENT(-1)_U_DIDENT(-1,"MAX")_U_+$G(DIDENT(-1,"MORE?"))
S @DILIST@(0)=DIHEADER_U_$S(DIFLAGS[2:"H",1:"")
I DIFLAGS["P",$G(DIDENT(-3))]"" S @DILIST@(0,"MAP")=DIDENT(-3)
E D SETMAP(.DIDENT,DILIST)
N I S I=0 F S I=$O(DIDENT(-1,"LAST",I)) Q:'I D
. K DIDENT(-1,"LAST",I,"I")
. Q:$G(DIDENT(-1,"MORE?"))
. I I=1 S (DIDENT(-1,"LAST"),DIDENT(-1,"LAST","IEN"))=""
. S DIDENT(-1,"LAST",I)=""
. Q
K DIFROM M DIFROM=DIDENT(-1,"LAST")
;
; Move arrays to output and QUIT.
D OUT^DICL
Q
;
KILLB(DIFILE) ; Kill temporary "B" index on current file DIFILE or pointed-to files.
N DIROOT I $D(DIFILE(DIFILE,"NO B")) S DIROOT=DIFILE(DIFILE,"NO B")_")" K @DIROOT
Q:'$O(DIFILE("STACK",0))
N I,J,K
F I=0:0 S I=$O(DIFILE("STACK",I)) Q:'I F J=0:0 S J=$O(DIFILE("STACK",I,J)) Q:'J F K=0:0 S K=$O(DIFILE("STACK",I,J,K)) Q:'K I $D(DIFILE(K,"NO B")) D
. S DIROOT=DIFILE(K,"NO B")_")"
. K @DIROOT Q
Q
;
SETMAP(DIDENT,DILIST) ; Set map node for unpacked format
N I,J,K,DIMAP,DITMP S (DIMAP,I)=""
F S I=$O(DIDENT(-3,I)) Q:I="" S DITMP="" D D SETM2
. I I S J="" F S J=$O(DIDENT(-3,I,J)) Q:J="" D
. . I J?1.N.1"I" D
. . . N K S K="FID("_I_")"_$P("I^",U,J["I")
. . . K:$D(DIDENT(-3,I,K)) DIDENT(-3,I,K) Q
. . S DITMP=DITMP_J_"^" Q
. Q:I'=0
. F J=0:0 S J=$O(DIDENT(-3,0,J)) Q:'J S K="" F D Q:K=""
. . S K=$O(DIDENT(-3,0,J,K)) S:K]"" DITMP=DITMP_K_"^" Q
Q:DIMAP="" S $E(DIMAP,$L(DIMAP))=""
S @DILIST@(0,"MAP")=DIMAP
Q
;
SETM2 N DILENGTH S DILENGTH=$L(DIMAP) Q:$E(DIMAP,DILENGTH-3,DILENGTH)="..."
I $L(DITMP)+($L(DIMAP))>252 S DIMAP=DIMAP_"..." Q
S DIMAP=DIMAP_DITMP Q
;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICL1 3701 printed Sep 23, 2025@20:22:15 Page 2
DICL1 ;SEA/TOAD,SF/TKW-VA FileMan: Lookup: Lister, Part 2 ;10/15/98 14:19
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
PREP ; set up subfile's DA array under DIEN, init how many found,
+1 ; set max, and init array of last entries returned.
+2 ;
+3 NEW DIEN
DO DA^DILF(DIFIEN,.DIEN)
+4 NEW DISUB,DIVAL,X,Y
+5 SET DIDENT(-1)=0
+6 SET DIDENT(-1,"MAX")=DINUMBER
+7 SET DIDENT(-1,"JUST LOOKING")=0
+8 FOR DISUB=1:1:DINDEX("#")+1
SET DIDENT(-1,"LAST",DISUB)=""
+9 SET (DIDENT(-1,"LAST"),DIDENT(-1,"LAST","IEN"))=""
+10 ;
PTR ; if 1st indexed field is a pointer or var.ptr., and we're not doing
+1 ; a quick list, we build info for the
+2 ; pointer chain(s) to the end file(s) and do the search.
+3 ;
+4 IF "VP"[DINDEX(1,"TYPE")
IF DIFLAGS'["Q"
IF '$DATA(DINDEX("ROOTCNG",1))
Begin DoDot:1
+5 DO POINT^DICL10(.DIFILE,.DIFLAGS,.DINDEX,.DIDENT,.DIEN,DIFIEN,.DISCREEN,.DILIST)
+6 QUIT
End DoDot:1
+7 ;
GETLIST ; build the output list when first subscript not a ptr. or var.ptr.
+1 ;
+2 IF '$TEST
Begin DoDot:1
+3 IF $DATA(DINDEX("ROOTCNG",1))
DO BLDTMP^DICLIX1(.DINDEX,.DISCREEN,DIFLAGS,.DIDENT)
+4 DO WALK^DICLIX(DIFLAGS,.DINDEX,.DIDENT,.DIFILE,.DIEN,.DIFIEN,.DISCREEN,.DILIST,"","",.DIC)
End DoDot:1
+5 ;
DSPHLP ; If we're displaying entries for online ^DIC help, display the rest
+1 ;
+2 IF DIFLAGS["h"
IF $ORDER(DICQ(0))
Begin DoDot:1
+3 KILL DTOUT,DUOUT
SET DICQ(0,"MAP")=DIDENT(-3)
+4 DO DSP^DICQ1(.DINDEX,.DICQ,.DIC,.DIFILE)
+5 IF $GET(DTOUT)!($GET(DUOUT))
SET (DINDEX("DONE"),DIDONE)=1
QUIT
+6 SET DIDENT(-1)=0
+7 QUIT
End DoDot:1
+8 ;
KTMPIX ; if we've built temporary indexes, we delete them:
+1 DO KILLB(.DIFILE)
+2 NEW DISUB
SET DISUB=$ORDER(DINDEX("ROOTCNG",""))
IF DISUB
KILL @DINDEX(DISUB,"ROOT")
+3 ;
FINAL ; cleanup after search.
+1 ;
+2 IF $GET(DIERR)
KILL @DILIST
DO OUT^DICL
QUIT
+3 ;
+4 ; set the output list header node and map node, output FROM values
+5 ; for last entries returned.
+6 ;
+7 IF '$DATA(DIDENT(-1))
SET DIDENT(-1)=0
SET DIDENT(-1,"MAX")=DINUMBER
+8 NEW DIHEADER
SET DIHEADER=DIDENT(-1)_U_DIDENT(-1,"MAX")_U_+$GET(DIDENT(-1,"MORE?"))
+9 SET @DILIST@(0)=DIHEADER_U_$SELECT(DIFLAGS[2:"H",1:"")
+10 IF DIFLAGS["P"
IF $GET(DIDENT(-3))]""
SET @DILIST@(0,"MAP")=DIDENT(-3)
+11 IF '$TEST
DO SETMAP(.DIDENT,DILIST)
+12 NEW I
SET I=0
FOR
SET I=$ORDER(DIDENT(-1,"LAST",I))
if 'I
QUIT
Begin DoDot:1
+13 KILL DIDENT(-1,"LAST",I,"I")
+14 if $GET(DIDENT(-1,"MORE?"))
QUIT
+15 IF I=1
SET (DIDENT(-1,"LAST"),DIDENT(-1,"LAST","IEN"))=""
+16 SET DIDENT(-1,"LAST",I)=""
+17 QUIT
End DoDot:1
+18 KILL DIFROM
MERGE DIFROM=DIDENT(-1,"LAST")
+19 ;
+20 ; Move arrays to output and QUIT.
+21 DO OUT^DICL
+22 QUIT
+23 ;
KILLB(DIFILE) ; Kill temporary "B" index on current file DIFILE or pointed-to files.
+1 NEW DIROOT
IF $DATA(DIFILE(DIFILE,"NO B"))
SET DIROOT=DIFILE(DIFILE,"NO B")_")"
KILL @DIROOT
+2 if '$ORDER(DIFILE("STACK",0))
QUIT
+3 NEW I,J,K
+4 FOR I=0:0
SET I=$ORDER(DIFILE("STACK",I))
if 'I
QUIT
FOR J=0:0
SET J=$ORDER(DIFILE("STACK",I,J))
if 'J
QUIT
FOR K=0:0
SET K=$ORDER(DIFILE("STACK",I,J,K))
if 'K
QUIT
IF $DATA(DIFILE(K,"NO B"))
Begin DoDot:1
+5 SET DIROOT=DIFILE(K,"NO B")_")"
+6 KILL @DIROOT
QUIT
End DoDot:1
+7 QUIT
+8 ;
SETMAP(DIDENT,DILIST) ; Set map node for unpacked format
+1 NEW I,J,K,DIMAP,DITMP
SET (DIMAP,I)=""
+2 FOR
SET I=$ORDER(DIDENT(-3,I))
if I=""
QUIT
SET DITMP=""
Begin DoDot:1
+3 IF I
SET J=""
FOR
SET J=$ORDER(DIDENT(-3,I,J))
if J=""
QUIT
Begin DoDot:2
+4 IF J?1.N.1"I"
Begin DoDot:3
+5 NEW K
SET K="FID("_I_")"_$PIECE("I^",U,J["I")
+6 if $DATA(DIDENT(-3,I,K))
KILL DIDENT(-3,I,K)
QUIT
End DoDot:3
+7 SET DITMP=DITMP_J_"^"
QUIT
End DoDot:2
+8 if I'=0
QUIT
+9 FOR J=0:0
SET J=$ORDER(DIDENT(-3,0,J))
if 'J
QUIT
SET K=""
FOR
Begin DoDot:2
+10 SET K=$ORDER(DIDENT(-3,0,J,K))
if K]""
SET DITMP=DITMP_K_"^"
QUIT
End DoDot:2
if K=""
QUIT
End DoDot:1
DO SETM2
+11 if DIMAP=""
QUIT
SET $EXTRACT(DIMAP,$LENGTH(DIMAP))=""
+12 SET @DILIST@(0,"MAP")=DIMAP
+13 QUIT
+14 ;
SETM2 NEW DILENGTH
SET DILENGTH=$LENGTH(DIMAP)
if $EXTRACT(DIMAP,DILENGTH-3,DILENGTH)="..."
QUIT
+1 IF $LENGTH(DITMP)+($LENGTH(DIMAP))>252
SET DIMAP=DIMAP_"..."
QUIT
+2 SET DIMAP=DIMAP_DITMP
QUIT
+3 ;
+4 ;
