DICL ;SEA/TOAD,SF/TKW-VA FileMan: Lookup: Lister ;28APR2012
;;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.
;
;
LIST(DIFILE,DIFIEN,DIFIELDS,DIFLAGS,DINUMBER,DIFROM,DIPART,DINDEX,DISCREEN,DIWRITE,DILIST,DIMSGA,DIC) ;
; ENTRY POINT--return a list of entries from a file
; (Note: DIC parameter only passed if called from ^DICQ)
;
IN ; Entry point from LIST^DIC
I '$D(DIQUIET) N DIQUIET S DIQUIET=1
I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
N DICLERR S DICLERR=$G(DIERR) K DIERR
;
INPUT ; Validate input parameters
N DIERN,DIPE,DIDENT
S DIFLAGS=$G(DIFLAGS)
I DIFLAGS["I",DIFLAGS'["Q" S DIFLAGS=DIFLAGS_"Q"
S DIFIELDS=$G(DIFIELDS)
I DIFIELDS'["-IX" D
. N DID S DID=";"_DIFIELDS_";"
. I (DID["@"!(DIFLAGS["I")),DID'[";IX;",DID'[";IXE",DID'[";IXIE" Q
. S DIDENT(-5)=1 Q
S DINUMBER=$G(DINUMBER) I DINUMBER="" S DINUMBER="*"
I '$D(DIPART(1)) S DIPART(1)=$G(DIPART)
I '$D(DIFROM(1)) S DIFROM(1)=$G(DIFROM)
I $O(DIFROM(1)) D
. N E S E=9999 F S E=$O(DIFROM(E),-1) Q:'E Q:DIFROM(E)]""
. I E N I F I=1:1:E I DIFROM(I)="" D BLD^DIALOG(202,"FROM values"),OUT Q
. Q
S DIFROM("IEN")=$G(DIFROM("IEN"))
S DINDEX("WAY")=1 I DIFLAGS["B" S DINDEX("WAY")=-1
S DINDEX=$G(DINDEX)
I '$D(DISCREEN("S")) S DISCREEN("S")=$G(DISCREEN) D:DISCREEN("S")]""
.;N X S X=DISCREEN D ^DIM I '$D(X) D BLD^DIALOG(202,"SCREEN") ;**GFT CHECK FOR GOOD MUMPS CODE
S DIWRITE=$G(DIWRITE)
;
OUTPUT ; Establish output file name, starting output subscript no.
I $G(DILIST)="" S DILIST="^TMP(""DILIST"",$J)"
E I DIFLAGS'["h" D I $G(DIERR) D OUT Q
. I DILIST'?.1"^"1U.7UN.ANP,DILIST'?.1"^%".7UN.ANP D Q
. . D BLD^DIALOG(202,"target array")
. S DILIST=$NA(@DILIST@("DILIST"))
. Q
K @DILIST
S DILIST("ORDER")=$S(DINDEX("WAY")=1:0,1:DINUMBER+1)
I DINUMBER="*",DINDEX("WAY")=-1 D
. S DINDEX("WAY")=1,DINDEX("WAY","REVERSE")=1
. S DILIST("ORDER")=0
. Q
;
FILE ; Validate file number and IENS.
I DIFLAGS'["h" D FILE^DICUF(.DIFILE,.DIFIEN,DIFLAGS)
I $G(DIERR) S DIFROM="",DIFROM("IEN")="" D OUT Q
D SCREEN^DICUF(DIFLAGS,.DIFILE,.DISCREEN)
;
CHECKS ;
I $TR(DIFLAGS,"BIKMPQSUfhuXE")'="" S DIERN=301,DIPE(1)=DIFLAGS D ERROUT Q ;GFT: "X" and "E" added
S DIFLAGS=DIFLAGS_3
I DINUMBER'="*",DINUMBER<1!(DINUMBER\1'=DINUMBER) D Q
. S DIERN=202,DIPE(1)="Number" D ERROUT
;
IXANDID ; Gather information about index and field data to be returned.
N DIOUT S DIOUT=0
IXNAME ; Set default index name if null.
N DIGFT,DIGFTEMP
I DIFLAGS["X" D DICL^DICLGFT G BADQ ;NOTE: A CROSS-REF MUST BE 1U.UN (IX^DICE); AN INDEX MUST BE 1A.AN
I DINDEX'="#",DINDEX'?1U.UNP S DINDEX=$$DINDEX(DIFILE,DIFLAGS)
D INDEX^DICUIX(.DIFILE,DIFLAGS,.DINDEX,.DIFROM,.DIPART,DINUMBER,.DISCREEN,DILIST,.DIOUT)
BADQ I DIOUT!($G(DIERR)) D KTMPIX^DICL1 Q
I $D(DISCREEN("V")) D VPDATA^DICUF(.DINDEX,.DISCREEN)
I $O(DIFROM(DINDEX("#")+1))!(DINDEX'="#"&($O(DIPART(DINDEX("#"))))) D BLD^DIALOG(202,"Index"),KTMPIX^DICL1 Q
D IDENTS^DICU1(DIFLAGS,.DIFILE,DIFIELDS,DIWRITE,.DIDENT,.DINDEX)
I $G(DIERR) D KTMPIX^DICL1 Q
;
BRANCH ; Continue on to actual search.
D PREP^DICL1
I $G(DIGFTEMP)["^" K @DIGFTEMP ;**
Q
;
DINDEX(DIFILE,DIFLAGS) ; Set DINDEX to index name for KEY. Also called at top of ^DIC & by DICF & DICF2
N I,X S X=""
I $G(DIFLAGS)["K" D
. S I=$O(^DD("KEY","AP",DIFILE,"P",0)) Q:'I
. S X=$P($G(^DD("IX",+$P($G(^DD("KEY",I,0)),U,4),0)),U,2) Q
Q:X?1U.UNP X
Q "B"
;
ERROUT D BLD^DIALOG(DIERN,.DIPE,.DIPE),OUT Q
;
OUT I DICLERR'=""!$G(DIERR) D
. S DIERR=$G(DIERR)+DICLERR_U_($P($G(DIERR),U,2)+$P(DICLERR,U,2))
I $G(DIMSGA)'="" D CALLOUT^DIEFU(DIMSGA)
Q
;
; Possible messages returned
; 202 The input parameter that identifies the |1
; 301 The passed flag(s) '|1|' are unknown or in
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICL 4030 printed Dec 13, 2024@02:46:08 Page 2
DICL ;SEA/TOAD,SF/TKW-VA FileMan: Lookup: Lister ;28APR2012
+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 ;
+7 ;
LIST(DIFILE,DIFIEN,DIFIELDS,DIFLAGS,DINUMBER,DIFROM,DIPART,DINDEX,DISCREEN,DIWRITE,DILIST,DIMSGA,DIC) ;
+1 ; ENTRY POINT--return a list of entries from a file
+2 ; (Note: DIC parameter only passed if called from ^DICQ)
+3 ;
IN ; Entry point from LIST^DIC
+1 IF '$DATA(DIQUIET)
NEW DIQUIET
SET DIQUIET=1
+2 IF '$DATA(DIFM)
NEW DIFM
SET DIFM=1
DO INIZE^DIEFU
+3 NEW DICLERR
SET DICLERR=$GET(DIERR)
KILL DIERR
+4 ;
INPUT ; Validate input parameters
+1 NEW DIERN,DIPE,DIDENT
+2 SET DIFLAGS=$GET(DIFLAGS)
+3 IF DIFLAGS["I"
IF DIFLAGS'["Q"
SET DIFLAGS=DIFLAGS_"Q"
+4 SET DIFIELDS=$GET(DIFIELDS)
+5 IF DIFIELDS'["-IX"
Begin DoDot:1
+6 NEW DID
SET DID=";"_DIFIELDS_";"
+7 IF (DID["@"!(DIFLAGS["I"))
IF DID'[";IX;"
IF DID'[";IXE"
IF DID'[";IXIE"
QUIT
+8 SET DIDENT(-5)=1
QUIT
End DoDot:1
+9 SET DINUMBER=$GET(DINUMBER)
IF DINUMBER=""
SET DINUMBER="*"
+10 IF '$DATA(DIPART(1))
SET DIPART(1)=$GET(DIPART)
+11 IF '$DATA(DIFROM(1))
SET DIFROM(1)=$GET(DIFROM)
+12 IF $ORDER(DIFROM(1))
Begin DoDot:1
+13 NEW E
SET E=9999
FOR
SET E=$ORDER(DIFROM(E),-1)
if 'E
QUIT
if DIFROM(E)]""
QUIT
+14 IF E
NEW I
FOR I=1:1:E
IF DIFROM(I)=""
DO BLD^DIALOG(202,"FROM values")
DO OUT
QUIT
+15 QUIT
End DoDot:1
+16 SET DIFROM("IEN")=$GET(DIFROM("IEN"))
+17 SET DINDEX("WAY")=1
IF DIFLAGS["B"
SET DINDEX("WAY")=-1
+18 SET DINDEX=$GET(DINDEX)
+19 IF '$DATA(DISCREEN("S"))
SET DISCREEN("S")=$GET(DISCREEN)
if DISCREEN("S")]""
Begin DoDot:1
+20 ;N X S X=DISCREEN D ^DIM I '$D(X) D BLD^DIALOG(202,"SCREEN") ;**GFT CHECK FOR GOOD MUMPS CODE
End DoDot:1
+21 SET DIWRITE=$GET(DIWRITE)
+22 ;
OUTPUT ; Establish output file name, starting output subscript no.
+1 IF $GET(DILIST)=""
SET DILIST="^TMP(""DILIST"",$J)"
+2 IF '$TEST
IF DIFLAGS'["h"
Begin DoDot:1
+3 IF DILIST'?.1"^"1U.7UN.ANP
IF DILIST'?.1"^%".7UN.ANP
Begin DoDot:2
+4 DO BLD^DIALOG(202,"target array")
End DoDot:2
QUIT
+5 SET DILIST=$NAME(@DILIST@("DILIST"))
+6 QUIT
End DoDot:1
IF $GET(DIERR)
DO OUT
QUIT
+7 KILL @DILIST
+8 SET DILIST("ORDER")=$SELECT(DINDEX("WAY")=1:0,1:DINUMBER+1)
+9 IF DINUMBER="*"
IF DINDEX("WAY")=-1
Begin DoDot:1
+10 SET DINDEX("WAY")=1
SET DINDEX("WAY","REVERSE")=1
+11 SET DILIST("ORDER")=0
+12 QUIT
End DoDot:1
+13 ;
FILE ; Validate file number and IENS.
+1 IF DIFLAGS'["h"
DO FILE^DICUF(.DIFILE,.DIFIEN,DIFLAGS)
+2 IF $GET(DIERR)
SET DIFROM=""
SET DIFROM("IEN")=""
DO OUT
QUIT
+3 DO SCREEN^DICUF(DIFLAGS,.DIFILE,.DISCREEN)
+4 ;
CHECKS ;
+1 ;GFT: "X" and "E" added
IF $TRANSLATE(DIFLAGS,"BIKMPQSUfhuXE")'=""
SET DIERN=301
SET DIPE(1)=DIFLAGS
DO ERROUT
QUIT
+2 SET DIFLAGS=DIFLAGS_3
+3 IF DINUMBER'="*"
IF DINUMBER<1!(DINUMBER\1'=DINUMBER)
Begin DoDot:1
+4 SET DIERN=202
SET DIPE(1)="Number"
DO ERROUT
End DoDot:1
QUIT
+5 ;
IXANDID ; Gather information about index and field data to be returned.
+1 NEW DIOUT
SET DIOUT=0
IXNAME ; Set default index name if null.
+1 NEW DIGFT,DIGFTEMP
+2 ;NOTE: A CROSS-REF MUST BE 1U.UN (IX^DICE); AN INDEX MUST BE 1A.AN
IF DIFLAGS["X"
DO DICL^DICLGFT
GOTO BADQ
+3 IF DINDEX'="#"
IF DINDEX'?1U.UNP
SET DINDEX=$$DINDEX(DIFILE,DIFLAGS)
+4 DO INDEX^DICUIX(.DIFILE,DIFLAGS,.DINDEX,.DIFROM,.DIPART,DINUMBER,.DISCREEN,DILIST,.DIOUT)
BADQ IF DIOUT!($GET(DIERR))
DO KTMPIX^DICL1
QUIT
+1 IF $DATA(DISCREEN("V"))
DO VPDATA^DICUF(.DINDEX,.DISCREEN)
+2 IF $ORDER(DIFROM(DINDEX("#")+1))!(DINDEX'="#"&($ORDER(DIPART(DINDEX("#")))))
DO BLD^DIALOG(202,"Index")
DO KTMPIX^DICL1
QUIT
+3 DO IDENTS^DICU1(DIFLAGS,.DIFILE,DIFIELDS,DIWRITE,.DIDENT,.DINDEX)
+4 IF $GET(DIERR)
DO KTMPIX^DICL1
QUIT
+5 ;
BRANCH ; Continue on to actual search.
+1 DO PREP^DICL1
+2 ;**
IF $GET(DIGFTEMP)["^"
KILL @DIGFTEMP
+3 QUIT
+4 ;
DINDEX(DIFILE,DIFLAGS) ; Set DINDEX to index name for KEY. Also called at top of ^DIC & by DICF & DICF2
+1 NEW I,X
SET X=""
+2 IF $GET(DIFLAGS)["K"
Begin DoDot:1
+3 SET I=$ORDER(^DD("KEY","AP",DIFILE,"P",0))
if 'I
QUIT
+4 SET X=$PIECE($GET(^DD("IX",+$PIECE($GET(^DD("KEY",I,0)),U,4),0)),U,2)
QUIT
End DoDot:1
+5 if X?1U.UNP
QUIT X
+6 QUIT "B"
+7 ;
ERROUT DO BLD^DIALOG(DIERN,.DIPE,.DIPE)
DO OUT
QUIT
+1 ;
OUT IF DICLERR'=""!$GET(DIERR)
Begin DoDot:1
+1 SET DIERR=$GET(DIERR)+DICLERR_U_($PIECE($GET(DIERR),U,2)+$PIECE(DICLERR,U,2))
End DoDot:1
+2 IF $GET(DIMSGA)'=""
DO CALLOUT^DIEFU(DIMSGA)
+3 QUIT
+4 ;
+5 ; Possible messages returned
+6 ; 202 The input parameter that identifies the |1
+7 ; 301 The passed flag(s) '|1|' are unknown or in
+8 ;
