DICF ;SEA/TOAD,SF/TKW-VA FileMan: Finder, Part 1 (Main) ;20APR2010
;;22.0;VA FileMan;**20,31,165**;Mar 30, 1999;Build 34
;Per VHA Directive 2004-038, this routine should not be modified.
FIND(DIFILE,DIFIEN,DIFIELDS,DIFLAGS,DIVALUE,DINUMBER,DIFORCE,DISCREEN,DIWRITE,DILIST,DIMSGA,DINDEX,DIC,DIY,DIYX) ;
; ENTRY POINT--silent selecter
;
FINDX ; branch in from FIND^DIC
I '$D(DIQUIET),$G(DIC(0))'["E" N DIQUIET S DIQUIET=1
I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
N DICLERR S DICLERR=$G(DIERR) K DIERR
N DIEN,DIFAIL
M DIEN=DIVALUE N DIVALUE M DIVALUE=DIEN K DIEN
N DIDENT S DIDENT(-1)=+$G(DILIST("C"))
;
INPUT ; Verify correctness of input parameters
S DIFLAGS=$G(DIFLAGS)
I DIFLAGS'["l" N DINDEX S DINDEX("WAY")=1
S DIFAIL=0 D I DIFAIL D CLOSE Q
I0 . ; flags
. I DIFLAGS["p" S DIFLAGS=DIFLAGS_"f"
. I DIFLAGS'["p" D Q:DIFAIL
. . I $G(DIFIELDS)["IX",DIFIELDS'["-IX" D
. . . N D S D=";"_DIFIELDS_";" I D'[";IX;",D'[";IXE",D'[";IXIE" Q
. . . S DIDENT(-5)=1 Q
. . S DIFLAGS=DIFLAGS_4
. . I DIFLAGS["O",DIFLAGS["X" S DIFLAGS=$TR(DIFLAGS,"O")
. . S DIFLAGS=DIFLAGS_"t"
I1 . . ; value
. . I DIFLAGS'["l" N DIERRM D I DIFAIL D ERR^DICF4(202,"","","",DIERRM) Q
. . . S DIERRM="Lookup values"
. . . I $G(DIVALUE(1))="" S DIVALUE(1)=$G(DIVALUE)
. . . N I,DIEND S DIFAIL=1,DIEND=$O(DIVALUE(999999),-1)
. . . F I=1:1:DIEND S DIVALUE(I)=$G(DIVALUE(I)) I DIVALUE(I)]"" S DIFAIL=$$BADVAL(DIVALUE(I)) Q:DIFAIL
. . . Q
. . Q
I2 . ; target_root
. S DILIST=$G(DILIST)
. I DILIST'="",DIFLAGS'["l" D
. . I DIFLAGS'["p" K @DILIST
. . I DIFLAGS'["f" S DILIST=$NA(@DILIST@("DILIST"))
. . Q
. I DILIST="" S DILIST="^TMP(""DILIST"",$J)" K @DILIST
I3 . ; file and screens
. D:DIFLAGS'["v"&(DIFLAGS'["l") FILE^DICUF(.DIFILE,.DIFIEN,DIFLAGS)
. I $G(DIERR) S DIFAIL=1 Q
. D SCREEN^DICUF(DIFLAGS,.DIFILE,.DISCREEN)
. D DA^DILF(DIFIEN,.DIEN)
I4 . ; fields
. S DIFIELDS=$G(DIFIELDS)
I5 . ; flags again
. I DIFLAGS'["p",DIFLAGS'["l" D Q:DIFAIL
. . I $TR(DIFLAGS,"ABCKMOPQSUXfglpqtv4")'="" S DIFAIL=1 D Q
. . . D ERR^DICF4(301,"","","",$TR(DIFLAGS,"fglpqtv4")) Q
. . Q
I6 . ; determine starting index.
. I DIFLAGS'["l" D Q:DIFAIL
. . S DIFORCE=$G(DIFORCE),DIFORCE(1)=1
. . I "*"[DIFORCE D
. . . I DIFLAGS["M" S DIFORCE=0,DIFORCE(0)="*" Q
. . . S DIFORCE(0)=$$DINDEX^DICL(DIFILE,DIFLAGS),DIFORCE=1 Q
. . E D I DIFAIL D ERR^DICF4(202,"","","","Indexes") Q
. . . I $P(DIFORCE,U)="" S DIFAIL=1 Q
. . . S DIFORCE(0)=DIFORCE,DIFORCE=1
. . . I $P(DIFORCE(0),U,2)]"",DIFLAGS'["M" S DIFLAGS=DIFLAGS_"M"
. . . Q
. . I DIFORCE S DINDEX=$P(DIFORCE(0),U) Q
. . S DINDEX=$$DINDEX^DICL(DIFILE,DIFLAGS) Q
I7 . ; rest
. I DIFLAGS'["p",DIFLAGS'["l" D Q:DIFAIL
. . S DINUMBER=$S($G(DINUMBER):DINUMBER,1:"*")
. . I DINUMBER'="*" D Q:DIFAIL
. . . I DINUMBER\1=DINUMBER,DINUMBER>0 Q
. . . S DIFAIL=1 D ERR^DICF4(202,"","","","Number")
. . . Q
. . Q
. S DIWRITE=$G(DIWRITE)
. Q
I8 I DIFLAGS["P" S DIDENT(-3)=""
S DIDENT(-1,"JUST LOOKING")=0,DIDENT(-1,"MAX")=DINUMBER,DIDENT(-1,"MORE?")=0
N DIOUT S DIOUT=0
;
HOOK75 ;
N DIHOOK75
S DIHOOK75=$G(^DD(DIFILE,.01,7.5))
I DIHOOK75'="",DIVALUE(1)]"",DIVALUE(1)'?."?",'$O(DIVALUE(1)),DIFLAGS'["l" D I DIOUT D CLOSE Q
.N DIC D ;I DIFLAGS["p" N DIC D
. . S DIC=DIFILE,DIC(0)=$TR(DIFLAGS,"2^fglpqtv4") Q
. N %,D,X,Y,Y1
. S X=DIVALUE(1),D=DINDEX
. M Y=DIEN S Y="",Y1=DIFIEN
. X DIHOOK75 I '$D(X)!$G(DIERR) S DIOUT=1 D:$G(DIERR) Q
. . S %=$$EZBLD^DIALOG(8090) ;Pre-lookup transform (7.5 node)
. . D ERR^DICF4(120,DIFILE,"",.01,%)
. S DIVALUE(1)=X,DIOUT=$$BADVAL(DIVALUE(1)) Q:DIOUT
. I $G(DIC("S"))'="" S DISCREEN("S")=DIC("S") ;DIHOOK MAY HAVE SET THIS
. I $G(DIC("V"))'="" S (DISCREEN("V"),DISCREEN("V",1))=DIC("V") ;...OR THIS
;
LOOKUP ;
I DIFLAGS'["l" D I DIOUT!($G(DIERR)) D CLOSE Q
. D INDEX^DICUIX(.DIFILE,DIFLAGS,.DINDEX,"",.DIVALUE,DINUMBER,.DISCREEN,DILIST,.DIOUT) Q
I '$D(DINDEX("MAXSUB")) D
. S DINDEX("MAXSUB")=$P($G(^DD("OS",+$G(^DD("OS")),0)),U,7)
. I DINDEX("MAXSUB") S DINDEX("MAXSUB")=DINDEX("MAXSUB")-13 Q
. S DINDEX("MAXSUB")=50 Q
I $D(DISCREEN("V")) D VPDATA^DICUF(.DINDEX,.DISCREEN)
I (DINDEX'="#")!($O(DIVALUE(1))) D CHKVAL1^DIC0(DINDEX("#"),.DIVALUE,DIFLAGS) I $G(DIERR) D CLOSE Q
I DIFLAGS'["f" D I $G(DIERR) D CLOSE Q
. D IDENTS^DICU1(DIFLAGS,.DIFILE,DIFIELDS,DIWRITE,.DIDENT,.DINDEX)
. Q
I DIFLAGS'["p",DIFLAGS'["l" D I DIOUT!($G(DIERR)) D CLOSE Q
. N I F I=2:1:DINDEX("#") Q:$G(DIVALUE(I))]""
. Q:$G(DIVALUE(I))]""
. D SPECIAL^DICF1(.DIFILE,.DIEN,DIFIEN,DIFLAGS,DIVALUE(1),.DINDEX,.DISCREEN,.DIDENT,.DIOUT,.DILIST)
. Q
I DIFLAGS["t" D XFORM^DICF1(.DIFLAGS,.DIVALUE,.DISCREEN,.DINDEX)
I DINDEX("#")>1,DIVALUE(1)="" N S M S=DISCREEN N DISCREEN M DISCREEN=S K S D
. I DIFIELDS["IX",DIFIELDS'["-IX" Q
. N DISAVMAX S DISAVMAX=DINDEX("MAXSUB")
. D ALTIDX^DICF0(.DINDEX,.DIFILE,.DIVALUE,.DISCREEN,DINUMBER)
. S DINDEX("MAXSUB")=DISAVMAX Q
D CHKALL^DICF2(.DIFILE,.DIEN,DIFIEN,.DIFLAGS,.DIVALUE,.DISCREEN,DINUMBER,.DIFORCE,.DINDEX,.DIDENT,.DILIST,.DIC,.DIY,.DIYX)
D CLOSE
Q
;
BADVAL(DIVALUE) ; Check for invalid characters in value
I "^"[DIVALUE Q 1
I DIVALUE'?.ANP D ERR^DICF4(204,"","","",DIVALUE) Q 1
Q 0
CLOSE ;
; cleanup
I $G(DIMSGA)'="" D CALLOUT^DIEFU(DIMSGA)
I DICLERR'=""!$G(DIERR) D
. I DIFLAGS["l",+DIERR=1 Q
. S DIERR=$G(DIERR)+DICLERR_U_($P($G(DIERR),U,2)+$P(DICLERR,U,2))
I $G(DIERR) D Q
. Q:$G(DILIST)="" K @DILIST@("B") Q
I DIFLAGS["p" S @DILIST=DIDENT(-1) Q
Q:DIFLAGS["l"
S @DILIST@(0)=DIDENT(-1)_U_DIDENT(-1,"MAX")_U_DIDENT(-1,"MORE?")_U_$S(DIFLAGS[2:"H",1:"")
I DIFLAGS["P" S @DILIST@(0,"MAP")=$G(DIDENT(-3))
E D SETMAP^DICL1(.DIDENT,DILIST)
K @DILIST@("B")
Q
;
; Error messages:
; 120 The previous error occurred when performin
; 202 The input parameter that identifies the |1
; 204 The input value contains control character
; 301 The passed flag(s) '|1|' are unknown or in
; 8090 Pre-lookup transform (7.5 node)
; 8093 Too many lookup values for this index.
; 8094 Not enough lookup values provided for an e
; 8095 Only one compound index allowed on a looku
;
DICF ;SEA/TOAD,SF/TKW-VA FileMan: Finder, Part 1 (Main) ;20APR2010
+1 ;;22.0;VA FileMan;**20,31,165**;Mar 30, 1999;Build 34
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
FIND(DIFILE,DIFIEN,DIFIELDS,DIFLAGS,DIVALUE,DINUMBER,DIFORCE,DISCREEN,DIWRITE,DILIST,DIMSGA,DINDEX,DIC,DIY,DIYX) ;
+1 ; ENTRY POINT--silent selecter
+2 ;
FINDX ; branch in from FIND^DIC
+1 IF '$DATA(DIQUIET)
IF $GET(DIC(0))'["E"
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 NEW DIEN,DIFAIL
+5 MERGE DIEN=DIVALUE
NEW DIVALUE
MERGE DIVALUE=DIEN
KILL DIEN
+6 NEW DIDENT
SET DIDENT(-1)=+$GET(DILIST("C"))
+7 ;
INPUT ; Verify correctness of input parameters
+1 SET DIFLAGS=$GET(DIFLAGS)
+2 IF DIFLAGS'["l"
NEW DINDEX
SET DINDEX("WAY")=1
+3 SET DIFAIL=0
Begin DoDot:1
I0 ; flags
+1 IF DIFLAGS["p"
SET DIFLAGS=DIFLAGS_"f"
+2 IF DIFLAGS'["p"
Begin DoDot:2
+3 IF $GET(DIFIELDS)["IX"
IF DIFIELDS'["-IX"
Begin DoDot:3
+4 NEW D
SET D=";"_DIFIELDS_";"
IF D'[";IX;"
IF D'[";IXE"
IF D'[";IXIE"
QUIT
+5 SET DIDENT(-5)=1
QUIT
End DoDot:3
+6 SET DIFLAGS=DIFLAGS_4
+7 IF DIFLAGS["O"
IF DIFLAGS["X"
SET DIFLAGS=$TRANSLATE(DIFLAGS,"O")
+8 SET DIFLAGS=DIFLAGS_"t"
I1 ; value
+1 IF DIFLAGS'["l"
NEW DIERRM
Begin DoDot:3
+2 SET DIERRM="Lookup values"
+3 IF $GET(DIVALUE(1))=""
SET DIVALUE(1)=$GET(DIVALUE)
+4 NEW I,DIEND
SET DIFAIL=1
SET DIEND=$ORDER(DIVALUE(999999),-1)
+5 FOR I=1:1:DIEND
SET DIVALUE(I)=$GET(DIVALUE(I))
IF DIVALUE(I)]""
SET DIFAIL=$$BADVAL(DIVALUE(I))
IF DIFAIL
QUIT
+6 QUIT
End DoDot:3
IF DIFAIL
DO ERR^DICF4(202,"","","",DIERRM)
QUIT
+7 QUIT
End DoDot:2
IF DIFAIL
QUIT
I2 ; target_root
+1 SET DILIST=$GET(DILIST)
+2 IF DILIST'=""
IF DIFLAGS'["l"
Begin DoDot:2
+3 IF DIFLAGS'["p"
KILL @DILIST
+4 IF DIFLAGS'["f"
SET DILIST=$NAME(@DILIST@("DILIST"))
+5 QUIT
End DoDot:2
+6 IF DILIST=""
SET DILIST="^TMP(""DILIST"",$J)"
KILL @DILIST
I3 ; file and screens
+1 IF DIFLAGS'["v"&(DIFLAGS'["l")
DO FILE^DICUF(.DIFILE,.DIFIEN,DIFLAGS)
+2 IF $GET(DIERR)
SET DIFAIL=1
QUIT
+3 DO SCREEN^DICUF(DIFLAGS,.DIFILE,.DISCREEN)
+4 DO DA^DILF(DIFIEN,.DIEN)
I4 ; fields
+1 SET DIFIELDS=$GET(DIFIELDS)
I5 ; flags again
+1 IF DIFLAGS'["p"
IF DIFLAGS'["l"
Begin DoDot:2
+2 IF $TRANSLATE(DIFLAGS,"ABCKMOPQSUXfglpqtv4")'=""
SET DIFAIL=1
Begin DoDot:3
+3 DO ERR^DICF4(301,"","","",$TRANSLATE(DIFLAGS,"fglpqtv4"))
QUIT
End DoDot:3
QUIT
+4 QUIT
End DoDot:2
IF DIFAIL
QUIT
I6 ; determine starting index.
+1 IF DIFLAGS'["l"
Begin DoDot:2
+2 SET DIFORCE=$GET(DIFORCE)
SET DIFORCE(1)=1
+3 IF "*"[DIFORCE
Begin DoDot:3
+4 IF DIFLAGS["M"
SET DIFORCE=0
SET DIFORCE(0)="*"
QUIT
+5 SET DIFORCE(0)=$$DINDEX^DICL(DIFILE,DIFLAGS)
SET DIFORCE=1
QUIT
End DoDot:3
+6 IF '$TEST
Begin DoDot:3
+7 IF $PIECE(DIFORCE,U)=""
SET DIFAIL=1
QUIT
+8 SET DIFORCE(0)=DIFORCE
SET DIFORCE=1
+9 IF $PIECE(DIFORCE(0),U,2)]""
IF DIFLAGS'["M"
SET DIFLAGS=DIFLAGS_"M"
+10 QUIT
End DoDot:3
IF DIFAIL
DO ERR^DICF4(202,"","","","Indexes")
QUIT
+11 IF DIFORCE
SET DINDEX=$PIECE(DIFORCE(0),U)
QUIT
+12 SET DINDEX=$$DINDEX^DICL(DIFILE,DIFLAGS)
QUIT
End DoDot:2
IF DIFAIL
QUIT
I7 ; rest
+1 IF DIFLAGS'["p"
IF DIFLAGS'["l"
Begin DoDot:2
+2 SET DINUMBER=$SELECT($GET(DINUMBER):DINUMBER,1:"*")
+3 IF DINUMBER'="*"
Begin DoDot:3
+4 IF DINUMBER\1=DINUMBER
IF DINUMBER>0
QUIT
+5 SET DIFAIL=1
DO ERR^DICF4(202,"","","","Number")
+6 QUIT
End DoDot:3
IF DIFAIL
QUIT
+7 QUIT
End DoDot:2
IF DIFAIL
QUIT
+8 SET DIWRITE=$GET(DIWRITE)
+9 QUIT
End DoDot:1
IF DIFAIL
DO CLOSE
QUIT
I8 IF DIFLAGS["P"
SET DIDENT(-3)=""
+1 SET DIDENT(-1,"JUST LOOKING")=0
SET DIDENT(-1,"MAX")=DINUMBER
SET DIDENT(-1,"MORE?")=0
+2 NEW DIOUT
SET DIOUT=0
+3 ;
HOOK75 ;
+1 NEW DIHOOK75
+2 SET DIHOOK75=$GET(^DD(DIFILE,.01,7.5))
+3 IF DIHOOK75'=""
IF DIVALUE(1)]""
IF DIVALUE(1)'?."?"
IF '$ORDER(DIVALUE(1))
IF DIFLAGS'["l"
Begin DoDot:1
+4 ;I DIFLAGS["p" N DIC D
NEW DIC
Begin DoDot:2
+5 SET DIC=DIFILE
SET DIC(0)=$TRANSLATE(DIFLAGS,"2^fglpqtv4")
QUIT
End DoDot:2
+6 NEW %,D,X,Y,Y1
+7 SET X=DIVALUE(1)
SET D=DINDEX
+8 MERGE Y=DIEN
SET Y=""
SET Y1=DIFIEN
+9 XECUTE DIHOOK75
IF '$DATA(X)!$GET(DIERR)
SET DIOUT=1
IF $GET(DIERR)
Begin DoDot:2
+10 ;Pre-lookup transform (7.5 node)
SET %=$$EZBLD^DIALOG(8090)
+11 DO ERR^DICF4(120,DIFILE,"",.01,%)
End DoDot:2
QUIT
+12 SET DIVALUE(1)=X
SET DIOUT=$$BADVAL(DIVALUE(1))
IF DIOUT
QUIT
+13 ;DIHOOK MAY HAVE SET THIS
IF $GET(DIC("S"))'=""
SET DISCREEN("S")=DIC("S")
+14 ;...OR THIS
IF $GET(DIC("V"))'=""
SET (DISCREEN("V"),DISCREEN("V",1))=DIC("V")
End DoDot:1
IF DIOUT
DO CLOSE
QUIT
+15 ;
LOOKUP ;
+1 IF DIFLAGS'["l"
Begin DoDot:1
+2 DO INDEX^DICUIX(.DIFILE,DIFLAGS,.DINDEX,"",.DIVALUE,DINUMBER,.DISCREEN,DILIST,.DIOUT)
QUIT
End DoDot:1
IF DIOUT!($GET(DIERR))
DO CLOSE
QUIT
+3 IF '$DATA(DINDEX("MAXSUB"))
Begin DoDot:1
+4 SET DINDEX("MAXSUB")=$PIECE($GET(^DD("OS",+$GET(^DD("OS")),0)),U,7)
+5 IF DINDEX("MAXSUB")
SET DINDEX("MAXSUB")=DINDEX("MAXSUB")-13
QUIT
+6 SET DINDEX("MAXSUB")=50
QUIT
End DoDot:1
+7 IF $DATA(DISCREEN("V"))
DO VPDATA^DICUF(.DINDEX,.DISCREEN)
+8 IF (DINDEX'="#")!($ORDER(DIVALUE(1)))
DO CHKVAL1^DIC0(DINDEX("#"),.DIVALUE,DIFLAGS)
IF $GET(DIERR)
DO CLOSE
QUIT
+9 IF DIFLAGS'["f"
Begin DoDot:1
+10 DO IDENTS^DICU1(DIFLAGS,.DIFILE,DIFIELDS,DIWRITE,.DIDENT,.DINDEX)
+11 QUIT
End DoDot:1
IF $GET(DIERR)
DO CLOSE
QUIT
+12 IF DIFLAGS'["p"
IF DIFLAGS'["l"
Begin DoDot:1
+13 NEW I
FOR I=2:1:DINDEX("#")
IF $GET(DIVALUE(I))]""
QUIT
+14 IF $GET(DIVALUE(I))]""
QUIT
+15 DO SPECIAL^DICF1(.DIFILE,.DIEN,DIFIEN,DIFLAGS,DIVALUE(1),.DINDEX,.DISCREEN,.DIDENT,.DIOUT,.DILIST)
+16 QUIT
End DoDot:1
IF DIOUT!($GET(DIERR))
DO CLOSE
QUIT
+17 IF DIFLAGS["t"
DO XFORM^DICF1(.DIFLAGS,.DIVALUE,.DISCREEN,.DINDEX)
+18 IF DINDEX("#")>1
IF DIVALUE(1)=""
NEW S
MERGE S=DISCREEN
NEW DISCREEN
MERGE DISCREEN=S
KILL S
Begin DoDot:1
+19 IF DIFIELDS["IX"
IF DIFIELDS'["-IX"
QUIT
+20 NEW DISAVMAX
SET DISAVMAX=DINDEX("MAXSUB")
+21 DO ALTIDX^DICF0(.DINDEX,.DIFILE,.DIVALUE,.DISCREEN,DINUMBER)
+22 SET DINDEX("MAXSUB")=DISAVMAX
QUIT
End DoDot:1
+23 DO CHKALL^DICF2(.DIFILE,.DIEN,DIFIEN,.DIFLAGS,.DIVALUE,.DISCREEN,DINUMBER,.DIFORCE,.DINDEX,.DIDENT,.DILIST,.DIC,.DIY,.DIYX)
+24 DO CLOSE
+25 QUIT
+26 ;
BADVAL(DIVALUE) ; Check for invalid characters in value
+1 IF "^"[DIVALUE
QUIT 1
+2 IF DIVALUE'?.ANP
DO ERR^DICF4(204,"","","",DIVALUE)
QUIT 1
+3 QUIT 0
CLOSE ;
+1 ; cleanup
+2 IF $GET(DIMSGA)'=""
DO CALLOUT^DIEFU(DIMSGA)
+3 IF DICLERR'=""!$GET(DIERR)
Begin DoDot:1
+4 IF DIFLAGS["l"
IF +DIERR=1
QUIT
+5 SET DIERR=$GET(DIERR)+DICLERR_U_($PIECE($GET(DIERR),U,2)+$PIECE(DICLERR,U,2))
End DoDot:1
+6 IF $GET(DIERR)
Begin DoDot:1
+7 IF $GET(DILIST)=""
QUIT
KILL @DILIST@("B")
QUIT
End DoDot:1
QUIT
+8 IF DIFLAGS["p"
SET @DILIST=DIDENT(-1)
QUIT
+9 IF DIFLAGS["l"
QUIT
+10 SET @DILIST@(0)=DIDENT(-1)_U_DIDENT(-1,"MAX")_U_DIDENT(-1,"MORE?")_U_$SELECT(DIFLAGS[2:"H",1:"")
+11 IF DIFLAGS["P"
SET @DILIST@(0,"MAP")=$GET(DIDENT(-3))
+12 IF '$TEST
DO SETMAP^DICL1(.DIDENT,DILIST)
+13 KILL @DILIST@("B")
+14 QUIT
+15 ;
+16 ; Error messages:
+17 ; 120 The previous error occurred when performin
+18 ; 202 The input parameter that identifies the |1
+19 ; 204 The input value contains control character
+20 ; 301 The passed flag(s) '|1|' are unknown or in
+21 ; 8090 Pre-lookup transform (7.5 node)
+22 ; 8093 Too many lookup values for this index.
+23 ; 8094 Not enough lookup values provided for an e
+24 ; 8095 Only one compound index allowed on a looku
+25 ;
