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