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