DIC ;SFISC/XAK,TKW,SEA/TOAD-VA FileMan: Lookup, Part 1 ;2:48 PM 11 Jun 2013
;;22.0;VA FileMan;**4,17,20,78,164,170**;Mar 30, 1999;Build 12
;Per VHA Directive 2004-038, this routine should not be modified.
N %,D,DF,DIFILEI,DIENS,DINDEX,DS,DIASKOK K DO S U="^",DIC(0)=$G(DIC(0))
D GETFILE^DIC0(.DIC,.DIFILEI,.DIENS) I DIFILEI="" S Y=-1 Q
S %=$P("K^",U,DIC(0)["K"),(D,DINDEX,DINDEX("START"))=$$DINDEX^DICL(DIFILEI,%)
K %
EN I $G(DIFILEI)=""!('$D(DINDEX)#2) N DIFILEI,DIENS,DINDEX,DIASKOK,%
K DO,DICR,DIROUT,DTOUT,DUOUT S U="^"
D INIT^DIC0 I DIFILEI="" S Y=-1 D Q^DIC2 Q
S DIC(0)=$G(DIC(0)) D
. I DIC(0)["T" K ^TMP($J,"DICSEEN") S ^TMP($J,"DICSEEN",DIFILEI)=""
. I $D(ZTQUEUED),$E($G(IOST),1,2)'="C-" S DIC(0)=$TR(DIC(0),"AEQ")
. I DIC(0)["X",DIC(0)["O" S DIC(0)=$TR(DIC(0),"O")
. S:DINDEX("#")>1 DIC(0)=$TR(DIC(0),"M") Q
N DIPGM S DIPGM=$$PGM^DIC2(.DIC,$G(DF),DIFILEI)
I DIPGM]"" D KILL1^DIC0 K DIC("W") S DIPGM(0)=1 G @DIPGM
ASK I $G(DIFILEI)=""!('$D(DINDEX)#2) N DIFILEI,DIENS,DINDEX,DIASKOK,% D INIT^DIC0 I DIFILEI="" S Y=-1 D Q^DIC2 Q
I '$D(DIVAL) N DIVAL,DIALLVAL
K DIVAL,DIALLVAL S DIVAL(0)=0,Y=-1,DIALLVAL=1
I DIC(0)["A" K X W ! D ^DIC1 I $G(DTOUT) D Q^DIC2 Q
I DIC(0)'["A" D CHKVAL^DIC0,CHKVAL2^DIC0(DINDEX("#"),.DIVAL,DIC(0),.DDS)
A1 I DIVAL(0) D
. D CHKVAL1^DIC0(DINDEX("#"),.DIVAL,DIC(0),DIC(0),.DIALLVAL) Q:'DIVAL(0)
. I $D(DIADD),X]"",X'["""" S (X,DIVAL(1))=""""_X_"""" S:DINDEX("#")>1 X(1)=X
. N DUOUT K DINDEX S (DINDEX,DINDEX("START"))=D,DINDEX("WAY")=1
. D INDEX^DICUIX(.DIFILEI,"4l",.DINDEX,"",.DIVAL) Q
X ;
I $G(DIFILEI)=""!('$D(DINDEX)#2) K DUOUT,DTOUT N DIFILEI,DIENS,DINDEX,DIASKOK,% N:'$D(DIVAL(0)) DIVAL,DIALLVAL D I DIFILEI="" S Y=-1 D Q^DIC2 Q
. D INIT^DIC0 Q:$D(DIVAL(0))!(DIFILEI="")
. D SETVAL^DIC0 Q
I DIVAL(0),$D(^DD(DIFILEI,.01,7.5)) X ^(7.5) D NODE75^DIC5 I $G(X)="" G:DIC(0)["A" ASK D Q^DIC2 Q
N DIPGM S DIPGM=$S(DIVAL(0)'>1:$$PGM^DIC2(.DIC,$G(DF),DIFILEI),1:"")
I DIPGM]"" D KILL2^DIC0 S DIPGM(0)=2 G @DIPGM
RTN I $G(DIFILEI)=""!('$D(DINDEX)#2) N DIFILEI,DIENS,DINDEX,DIASKOK,% N:'$D(DIVAL(0)) DIVAL,DIALLVAL D I DIFILEI="" S Y=-1 D Q^DIC2 Q
. D INIT^DIC0 Q:$D(DIVAL(0))!(DIFILEI="")
. D SETVAL^DIC0 Q
I X?1."?" D Q:$G(DTOUT) G:DIC(0)["A" ASK Q
. D DSPHLP^DICQ(.DIC,.DIFILEI,.DINDEX,X)
. S Y=-1 Q
I DIVAL(0)=0!($G(DUOUT)) S Y=-1 D Q^DIC2 Q
D:'$D(DO) GETFA^DIC1(.DIC,.DO)
I X?1"`".NP S Y=-1 D BYIEN1^DIC5 Q:Y>0 I '$$TRYADD^DIC11(.DIC,DIFILEI) D DING G:DIC(0)["A" ASK D Q^DIC2 Q
I DIVAL(0)=1,+$P(X,"E")=X,X>0 S Y=-1 N DISKIPIX D BYIEN2^DIC5 Q:Y>0
I X=" ",$L(DIC)<29,$D(^DISV(DUZ,DIC))#2 S Y=+^(DIC) D SPACEBAR^DIC5 Q:Y>0 D DING G:DIC(0)["A" ASK D Q^DIC2 Q
F ; Start regular lookup
N DD,DS,DIX,DIY,DIYX,DIDONE,DISAVDS,%Y,%H,DISYS
I $G(DIFILEI)=""!('$D(DINDEX)#2) N DIFILEI,DIENS,DINDEX,DIASKOK,% N:'$D(DIVAL(0)) DIVAL,DIALLVAL D
. D INIT^DIC0 Q:$D(DIVAL(0))
. D SETVAL^DIC0 Q
F1 S (DD,DS,DS(0),DS("DD"))=0
D SEARCH^DIC3
I $G(DTOUT)!(Y'<0) D Q^DIC2 Q
I $P(DS(0),U,2)="?",(DIC(0)_$G(DICR(1,0)))'["A" D K,INDEX^DICUIX(.DIFILEI,"4l",.DINDEX,"",.DIVAL) G F1 ;**170
I +DS(0)=2 S X=$P(DS(0),U,2) D K D G A1
. K DIVAL,DIALLVAL S DIVAL(0)=0,Y=-1,DIALLVAL=1
. D CHKVAL^DIC0,CHKVAL2^DIC0(DINDEX("#"),.DIVAL,DIC(0),.DDS)
. Q
D D K I Y<0,DIC(0)["A" D D^DIC0 W:DIC(0)["E" ! K:$D(DIROUT) DIROUT G ASK
. Q:$G(DIROUT)
. I DS(0),$P(DS(0),U,2)="" S:DIC(0)["Y"&($O(Y(0))) Y=0 D DING Q
. Q:'($D(DS)#2)
. I (DS(0)=0!($P(DS(0),U,2)="U")),DS("DD")=DS,(DO(2)["O"!($G(DIASKOK))!(DIC(0)["T")),DO(2)'["A",DO(2)'["P",DO(2)'["V",DO(2)'["D",DO(2)'["S",DIC(0)["L" D L^DICM
. Q
D Q^DIC2 Q
;
K K DD,DS,DIX,DIY,DIYX,DIDONE,DISAVDS
I '$G(DICR),DIC(0)["T" K ^TMP($J,"DICSEEN") S ^TMP($J,"DICSEEN",DIFILEI)=""
Q
;
DING Q:DIC(0)'["Q"!(DIC(0)'["E")
W:'$D(DUOUT) $C(7)_$S('$D(DDS):" ??",1:"") Q
;
;
IX N DINDEX,DF
S (DF,DINDEX,DINDEX("START"))=D
G EN
;
A K DIY,DIYX,DS I DIC(0)["A" D D^DIC0 Q
NO S Y=-1 D Q^DIC2 Q
;
; DBS Entry points
LIST(DIFILE,DIFIEN,DIFIELDS,DIFLAGS,DINUMBER,DIFROM,DIPART,DINDEX,DISCREEN,DIWRITE,DILIST,DIMSGA) ;
;ENTRY POINT--return a list of entries from a file (SEA/TOAD)
G IN^DICL
;
FIND1(DIFILE,DIFIEN,DIFLAGS,DIVALUE,DIFORCE,DISCREEN,DIMSGA) ;SEA/TOAD
;ENTRY POINT--find a single entry in the file
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
N DIERN,DIFIND,DIPE,DITARGET
N DIVALS M DIVALS=DIVALUE I $G(DIVALS)="" S DIVALS=$G(DIVALUE(1))
D FIND^DICF($G(DIFILE),$G(DIFIEN),"",$G(DIFLAGS)_"f",.DIVALUE,1,$G(DIFORCE),.DISCREEN,"","DITARGET")
I $D(DIERR) S DIFIND=""
E I $P($G(DITARGET(0)),U,3) K DITARGET S DIFIND="" D
. I $O(DIVALS(1)) N I F I=1:0 S I=$O(DIVALS(I)) Q:'I D:DIVALS(I)]"" Q:'I
. . I ($L(DIVALS)+$L(DIVALS(I)))>100 S DIVALS=DIVALS_"...",I="" Q
. . S DIVALS=DIVALS_$P(", ^",U,DIVALS]"")_DIVALS(I) Q
. D ERR^DICF4(299,$G(DIFILE),$G(DIFIEN),"",DIVALS)
. Q
E S DIFIND=+$G(DITARGET(1))
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 DIFIND
;
FIND(DIFILE,DIFIEN,DIFIELDS,DIFLAGS,DIVALUE,DINUMBER,DIFORCE,DISCREEN,DIWRITE,DILIST,DIMSGA) ;SEA/TOAD
;ENTRY POINT--in a file find entries that match a value
G FINDX^DICF
;
; Error messages:
; 299 More than one entry matches the value(s) '|1|'
; 120 The previous error occurred when performing
; 8090 Pre-lookup transform (7.5 node)
;
DIC ;SFISC/XAK,TKW,SEA/TOAD-VA FileMan: Lookup, Part 1 ;2:48 PM 11 Jun 2013
+1 ;;22.0;VA FileMan;**4,17,20,78,164,170**;Mar 30, 1999;Build 12
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 NEW %,D,DF,DIFILEI,DIENS,DINDEX,DS,DIASKOK
KILL DO
SET U="^"
SET DIC(0)=$GET(DIC(0))
+4 DO GETFILE^DIC0(.DIC,.DIFILEI,.DIENS)
IF DIFILEI=""
SET Y=-1
QUIT
+5 SET %=$PIECE("K^",U,DIC(0)["K")
SET (D,DINDEX,DINDEX("START"))=$$DINDEX^DICL(DIFILEI,%)
+6 KILL %
EN IF $GET(DIFILEI)=""!('$DATA(DINDEX)#2)
NEW DIFILEI,DIENS,DINDEX,DIASKOK,%
+1 KILL DO,DICR,DIROUT,DTOUT,DUOUT
SET U="^"
+2 DO INIT^DIC0
IF DIFILEI=""
SET Y=-1
DO Q^DIC2
QUIT
+3 SET DIC(0)=$GET(DIC(0))
Begin DoDot:1
+4 IF DIC(0)["T"
KILL ^TMP($JOB,"DICSEEN")
SET ^TMP($JOB,"DICSEEN",DIFILEI)=""
+5 IF $DATA(ZTQUEUED)
IF $EXTRACT($GET(IOST),1,2)'="C-"
SET DIC(0)=$TRANSLATE(DIC(0),"AEQ")
+6 IF DIC(0)["X"
IF DIC(0)["O"
SET DIC(0)=$TRANSLATE(DIC(0),"O")
+7 IF DINDEX("#")>1
SET DIC(0)=$TRANSLATE(DIC(0),"M")
QUIT
End DoDot:1
+8 NEW DIPGM
SET DIPGM=$$PGM^DIC2(.DIC,$GET(DF),DIFILEI)
+9 IF DIPGM]""
DO KILL1^DIC0
KILL DIC("W")
SET DIPGM(0)=1
GOTO @DIPGM
ASK IF $GET(DIFILEI)=""!('$DATA(DINDEX)#2)
NEW DIFILEI,DIENS,DINDEX,DIASKOK,%
DO INIT^DIC0
IF DIFILEI=""
SET Y=-1
DO Q^DIC2
QUIT
+1 IF '$DATA(DIVAL)
NEW DIVAL,DIALLVAL
+2 KILL DIVAL,DIALLVAL
SET DIVAL(0)=0
SET Y=-1
SET DIALLVAL=1
+3 IF DIC(0)["A"
KILL X
WRITE !
DO ^DIC1
IF $GET(DTOUT)
DO Q^DIC2
QUIT
+4 IF DIC(0)'["A"
DO CHKVAL^DIC0
DO CHKVAL2^DIC0(DINDEX("#"),.DIVAL,DIC(0),.DDS)
A1 IF DIVAL(0)
Begin DoDot:1
+1 DO CHKVAL1^DIC0(DINDEX("#"),.DIVAL,DIC(0),DIC(0),.DIALLVAL)
IF 'DIVAL(0)
QUIT
+2 IF $DATA(DIADD)
IF X]""
IF X'[""""
SET (X,DIVAL(1))=""""_X_""""
IF DINDEX("#")>1
SET X(1)=X
+3 NEW DUOUT
KILL DINDEX
SET (DINDEX,DINDEX("START"))=D
SET DINDEX("WAY")=1
+4 DO INDEX^DICUIX(.DIFILEI,"4l",.DINDEX,"",.DIVAL)
QUIT
End DoDot:1
X ;
+1 IF $GET(DIFILEI)=""!('$DATA(DINDEX)#2)
KILL DUOUT,DTOUT
NEW DIFILEI,DIENS,DINDEX,DIASKOK,%
IF '$DATA(DIVAL(0))
NEW DIVAL,DIALLVAL
Begin DoDot:1
+2 DO INIT^DIC0
IF $DATA(DIVAL(0))!(DIFILEI="")
QUIT
+3 DO SETVAL^DIC0
QUIT
End DoDot:1
IF DIFILEI=""
SET Y=-1
DO Q^DIC2
QUIT
+4 IF DIVAL(0)
IF $DATA(^DD(DIFILEI,.01,7.5))
XECUTE ^(7.5)
DO NODE75^DIC5
IF $GET(X)=""
IF DIC(0)["A"
GOTO ASK
DO Q^DIC2
QUIT
+5 NEW DIPGM
SET DIPGM=$SELECT(DIVAL(0)'>1:$$PGM^DIC2(.DIC,$GET(DF),DIFILEI),1:"")
+6 IF DIPGM]""
DO KILL2^DIC0
SET DIPGM(0)=2
GOTO @DIPGM
RTN IF $GET(DIFILEI)=""!('$DATA(DINDEX)#2)
NEW DIFILEI,DIENS,DINDEX,DIASKOK,%
IF '$DATA(DIVAL(0))
NEW DIVAL,DIALLVAL
Begin DoDot:1
+1 DO INIT^DIC0
IF $DATA(DIVAL(0))!(DIFILEI="")
QUIT
+2 DO SETVAL^DIC0
QUIT
End DoDot:1
IF DIFILEI=""
SET Y=-1
DO Q^DIC2
QUIT
+3 IF X?1."?"
Begin DoDot:1
+4 DO DSPHLP^DICQ(.DIC,.DIFILEI,.DINDEX,X)
+5 SET Y=-1
QUIT
End DoDot:1
IF $GET(DTOUT)
QUIT
IF DIC(0)["A"
GOTO ASK
QUIT
+6 IF DIVAL(0)=0!($GET(DUOUT))
SET Y=-1
DO Q^DIC2
QUIT
+7 IF '$DATA(DO)
DO GETFA^DIC1(.DIC,.DO)
+8 IF X?1"`".NP
SET Y=-1
DO BYIEN1^DIC5
IF Y>0
QUIT
IF '$$TRYADD^DIC11(.DIC,DIFILEI)
DO DING
IF DIC(0)["A"
GOTO ASK
DO Q^DIC2
QUIT
+9 IF DIVAL(0)=1
IF +$PIECE(X,"E")=X
IF X>0
SET Y=-1
NEW DISKIPIX
DO BYIEN2^DIC5
IF Y>0
QUIT
+10 IF X=" "
IF $LENGTH(DIC)<29
IF $DATA(^DISV(DUZ,DIC))#2
SET Y=+^(DIC)
DO SPACEBAR^DIC5
IF Y>0
QUIT
DO DING
IF DIC(0)["A"
GOTO ASK
DO Q^DIC2
QUIT
F ; Start regular lookup
+1 NEW DD,DS,DIX,DIY,DIYX,DIDONE,DISAVDS,%Y,%H,DISYS
+2 IF $GET(DIFILEI)=""!('$DATA(DINDEX)#2)
NEW DIFILEI,DIENS,DINDEX,DIASKOK,%
IF '$DATA(DIVAL(0))
NEW DIVAL,DIALLVAL
Begin DoDot:1
+3 DO INIT^DIC0
IF $DATA(DIVAL(0))
QUIT
+4 DO SETVAL^DIC0
QUIT
End DoDot:1
F1 SET (DD,DS,DS(0),DS("DD"))=0
+1 DO SEARCH^DIC3
+2 IF $GET(DTOUT)!(Y'<0)
DO Q^DIC2
QUIT
+3 ;**170
IF $PIECE(DS(0),U,2)="?"
IF (DIC(0)_$GET(DICR(1,0)))'["A"
DO K
DO INDEX^DICUIX(.DIFILEI,"4l",.DINDEX,"",.DIVAL)
GOTO F1
+4 IF +DS(0)=2
SET X=$PIECE(DS(0),U,2)
DO K
Begin DoDot:1
+5 KILL DIVAL,DIALLVAL
SET DIVAL(0)=0
SET Y=-1
SET DIALLVAL=1
+6 DO CHKVAL^DIC0
DO CHKVAL2^DIC0(DINDEX("#"),.DIVAL,DIC(0),.DDS)
+7 QUIT
End DoDot:1
GOTO A1
+8 Begin DoDot:1
+9 IF $GET(DIROUT)
QUIT
+10 IF DS(0)
IF $PIECE(DS(0),U,2)=""
IF DIC(0)["Y"&($ORDER(Y(0)))
SET Y=0
DO DING
QUIT
+11 IF '($DATA(DS)#2)
QUIT
+12 IF (DS(0)=0!($PIECE(DS(0),U,2)="U"))
IF DS("DD")=DS
IF (DO(2)["O"!($GET(DIASKOK))!(DIC(0)["T"))
IF DO(2)'["A"
IF DO(2)'["P"
IF DO(2)'["V"
IF DO(2)'["D"
IF DO(2)'["S"
IF DIC(0)["L"
DO L^DICM
+13 QUIT
End DoDot:1
DO K
IF Y<0
IF DIC(0)["A"
DO D^DIC0
IF DIC(0)["E"
WRITE !
IF $DATA(DIROUT)
KILL DIROUT
GOTO ASK
+14 DO Q^DIC2
QUIT
+15 ;
K KILL DD,DS,DIX,DIY,DIYX,DIDONE,DISAVDS
+1 IF '$GET(DICR)
IF DIC(0)["T"
KILL ^TMP($JOB,"DICSEEN")
SET ^TMP($JOB,"DICSEEN",DIFILEI)=""
+2 QUIT
+3 ;
DING IF DIC(0)'["Q"!(DIC(0)'["E")
QUIT
+1 IF '$DATA(DUOUT)
WRITE $CHAR(7)_$SELECT('$DATA(DDS):" ??",1:"")
QUIT
+2 ;
+3 ;
IX NEW DINDEX,DF
+1 SET (DF,DINDEX,DINDEX("START"))=D
+2 GOTO EN
+3 ;
A KILL DIY,DIYX,DS
IF DIC(0)["A"
DO D^DIC0
QUIT
NO SET Y=-1
DO Q^DIC2
QUIT
+1 ;
+2 ; DBS Entry points
LIST(DIFILE,DIFIEN,DIFIELDS,DIFLAGS,DINUMBER,DIFROM,DIPART,DINDEX,DISCREEN,DIWRITE,DILIST,DIMSGA) ;
+1 ;ENTRY POINT--return a list of entries from a file (SEA/TOAD)
+2 GOTO IN^DICL
+3 ;
FIND1(DIFILE,DIFIEN,DIFLAGS,DIVALUE,DIFORCE,DISCREEN,DIMSGA) ;SEA/TOAD
+1 ;ENTRY POINT--find a single entry in the file
+2 IF '$DATA(DIQUIET)
NEW DIQUIET
SET DIQUIET=1
+3 IF '$DATA(DIFM)
NEW DIFM
SET DIFM=1
DO INIZE^DIEFU
+4 NEW DICLERR
SET DICLERR=$GET(DIERR)
KILL DIERR
+5 NEW DIERN,DIFIND,DIPE,DITARGET
+6 NEW DIVALS
MERGE DIVALS=DIVALUE
IF $GET(DIVALS)=""
SET DIVALS=$GET(DIVALUE(1))
+7 DO FIND^DICF($GET(DIFILE),$GET(DIFIEN),"",$GET(DIFLAGS)_"f",.DIVALUE,1,$GET(DIFORCE),.DISCREEN,"","DITARGET")
+8 IF $DATA(DIERR)
SET DIFIND=""
+9 IF '$TEST
IF $PIECE($GET(DITARGET(0)),U,3)
KILL DITARGET
SET DIFIND=""
Begin DoDot:1
+10 IF $ORDER(DIVALS(1))
NEW I
FOR I=1:0
SET I=$ORDER(DIVALS(I))
IF 'I
QUIT
IF DIVALS(I)]""
Begin DoDot:2
+11 IF ($LENGTH(DIVALS)+$LENGTH(DIVALS(I)))>100
SET DIVALS=DIVALS_"..."
SET I=""
QUIT
+12 SET DIVALS=DIVALS_$PIECE(", ^",U,DIVALS]"")_DIVALS(I)
QUIT
End DoDot:2
IF 'I
QUIT
+13 DO ERR^DICF4(299,$GET(DIFILE),$GET(DIFIEN),"",DIVALS)
+14 QUIT
End DoDot:1
+15 IF '$TEST
SET DIFIND=+$GET(DITARGET(1))
+16 IF DICLERR'=""!$GET(DIERR)
Begin DoDot:1
+17 SET DIERR=$GET(DIERR)+DICLERR_U_($PIECE($GET(DIERR),U,2)+$PIECE(DICLERR,U,2))
End DoDot:1
+18 IF $GET(DIMSGA)'=""
DO CALLOUT^DIEFU(DIMSGA)
+19 QUIT DIFIND
+20 ;
FIND(DIFILE,DIFIEN,DIFIELDS,DIFLAGS,DIVALUE,DINUMBER,DIFORCE,DISCREEN,DIWRITE,DILIST,DIMSGA) ;SEA/TOAD
+1 ;ENTRY POINT--in a file find entries that match a value
+2 GOTO FINDX^DICF
+3 ;
+4 ; Error messages:
+5 ; 299 More than one entry matches the value(s) '|1|'
+6 ; 120 The previous error occurred when performing
+7 ; 8090 Pre-lookup transform (7.5 node)
+8 ;
