DIC0 ;SFISC/TKW-Lookup routine utilities called by DIC ;16JAN2011
;;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.
;
D ; Reset back to starting index for lookup.
S D=DINDEX("START") K DINDEX S (DINDEX,DINDEX("START"))=D,DINDEX("WAY")=1
S:$D(DID(1)) DID(1)=2
N DIFLAGS S DIFLAGS="4l"_$P("M^",U,DIC(0)["M")
D INDEX^DICUIX(.DIFILEI,DIFLAGS,.DINDEX,"",.DIVAL)
Q
;
SETVAL ; If custom lookup routine (like MTLU) comes in to entry point after ASK, we need to set up the lookup values.
K DIVAL,DIALLVAL D CHKVAL
I DIVAL(0) D CHKVAL1(DINDEX("#"),.DIVAL,DIC(0),DIC(0),.DIALLVAL)
Q
;
INIT ; Initialize variables at all entry points in ^DIC.
I $D(DIFILEI)[0 D GETFILE(.DIC,.DIFILEI,.DIENS) Q:DIFILEI=""
I '$D(@(DIC_"0)")),'$D(DIC("P")),$E(DIC,1,6)'="^DOPT(" S DIC("P")=$$GETP^DIC0(DIFILEI) I DIC("P")="" S Y=-1 D Q^DIC2 Q
I $G(DO)="" K DO D GETFA^DIC1(.DIC,.DO)
S (DINDEX,DINDEX("START"))=D,DINDEX("WAY")=1
D INDEX^DICUIX(.DIFILEI,"4l",.DINDEX,"",.DIVAL)
I DIC(0)["V" S DIASKOK=1
S Y=-1 I DIC(0)["Z" K Y(0)
Q
;
CHKVAL ; Check lookup values input by user.
N I I $G(X)="" S X=$G(X(1))
S DIVAL(0)=0,DIVAL(1)=X F I=2:1:DINDEX("#") S DIVAL(I)=$G(X(I))
N J,DIOUT S DIOUT=0
F I=1:1:DINDEX("#") S J=$G(DIVAL(I)) I J]"" D Q:DIOUT
. I DINDEX("#")>1 S X(I)=J
. I J["^" S (DUOUT,DIOUT)=1,DIVAL(0)=0 Q
. I J?1."?" K DIVAL S DIVAL(0)=0,X=$E(J,1,2),DIOUT=1 Q
. S DIVAL(0)=DIVAL(0)+1 Q
Q
;
CHKVAL1(DIXNO,DIVAL,DIFLAGS,DIC0,DIALLVAL) ; Check for errors with values, flags,index.
N DIERROR,I S DIALLVAL=1 D
. I '$D(DIC0),DIFLAGS'["l" D Q:$G(DIERROR)
. . S I=$O(DIVAL(99999),-1) I I>DIXNO S DIERROR=8093 Q
. . S:DIXNO>1&(DIFLAGS["M") DIERROR=8095 Q
. F I=1:1:DIXNO S DIVAL(I)=$G(DIVAL(I)) D:DIVAL(I)=""
. . I DIFLAGS["X",DIFLAGS'["l" S DIERROR=8094 Q
. . S DIALLVAL=0 Q
. Q
I $D(DIERROR) D
. I '$D(DIC0) D ERR^DICF4(DIERROR) Q
. K DIVAL S DIVAL(0)=0 Q:DIC0'["E" W $C(7),!,$$EZBLD^DIALOG(DIERROR) Q
Q
;
CHKVAL2(DIXNO,DIVAL,DIC0,DDS) ; Check lookup values for control characters or too long.
N I,J,DIER S DIER=""
F I=1:1:DIXNO S J=$G(DIVAL(I)) D:J]"" Q:DIER
. I J'?.ANP S DIER=204 Q
. I J?1.N.1".".N,($L($P(J,"."))>25!($L($P(J,".",2))>25)) S DIER=208 Q
. I ($L(J)-255)>0 S DIER=209
. Q
Q:'DIER
D:DIC0["Q"
. W $C(7) Q:DIC(0)'["E"
. I '$D(DDS) W !,$$EZBLD^DIALOG(DIER) Q
. N DDH S DDH=1,DDH(1,"T")=" ** "_$$EZBLD^DIALOG(DIER)
. S DDC=7,DDD=1 D LIST^DDSU
. Q
K DIVAL S DIVAL(0)=0
Q
;
KILL2 K DIVAL,DIALLVAL
KILL1 K DIFILEI,DINDEX,DIMAXLEN,DIENS Q
;
GETFILE(DIC,DIFILE,DIENS) ; Return file number, global references, IEN string and KEY fields data.
S DIFILE="" I $G(DIC)="" Q
I +$P(DIC,"E")'=DIC N DIDIC M DIDIC=DIC N DIC S DIDIC=$$CREF^DILF(DIDIC),DIDIC=$NA(@DIDIC),DIDIC=$$OREF^DILF(DIDIC) M DIC=DIDIC K DIDIC
N DA
I +$P(DIC,"E")=DIC D
. S DIFILE=DIC,DIC=$G(^DIC(DIC,0,"GL")) Q:DIC]""
. S DIC=DIFILE,DIFILE="" Q
E D
. S DIFILE=$G(@(DIC_"0)")) I DIFILE]"" S DIFILE=+$P(DIFILE,U,2) Q
. S DIFILE=+$G(DIC("P")) Q:DIFILE
. ;I DIC["^DD(",'$D(@(DIC_"0)")) S DIFILE="" Q
. S DIFILE=$$FILENUM^DILIBF(DIC) Q
Q:DIFILE=""
S DIENS=","
I DIC(0)'["p" D SETIEN(DIC,DIFILE,.DIENS) Q:DIFILE=""
S DIFILE(DIFILE,"O")=DIC
S DIFILE(DIFILE)=$$CREF^DILF(DIC)
N I S I=$O(^DD("KEY","AP",DIFILE,"P",0)) Q:'I
S DIFILE(DIFILE,"KEY","IEN")=DIENS
N F,X F F=0:0 S F=$O(^DD("KEY",I,2,F)) Q:'F S X=$G(^(F,0)) D
. S DIFILE(DIFILE,"KEY",+$P(X,U,2),+$P(X,U,3),+X)="" Q
Q
;
SETIEN(DIC,DIFILE,DIENS) ; Set DIENS from global root
N F,G,I,J,K,DIDA
S F=$$FNO^DILIBF(DIFILE) I F="" S DIFILE="" Q
S G=$G(^DIC(F,0,"GL")) I G="" S DIFILE="" Q
S F=$P(DIC,G,2)
S K=0 F I=1:2 S J=$P(F,",",I) Q:J="" S K=K+1,J(K)=J
S DIDA="" F J=1:1:K S DIDA(K+1-J)=J(J)
S DIENS=$$IENS^DILF(.DIDA) Q
;
GETP(DISUB) ; Return DIC("P") for a subfile DIFILE.
N DIFILE S DIFILE=$G(^DD(DISUB,0,"UP")) Q:'DIFILE ""
N DIFIELD S DIFIELD=$O(^DD(DIFILE,"SB",DISUB,0)) Q:'DIFIELD ""
Q $P($G(^DD(DIFILE,DIFIELD,0)),U,2)
;
DSPH ; Display name of indexed fields when DIC(0)["T" (called from DIC1 & DIC2)
Q:$G(DS(0,"HDRDSP",DIFILEI)) S DS(0,"HDRDSP",DIFILEI)=1
W ! N I S I=($G(DICR))*2 W:I ?I
W " Lookup: "
I $G(DICR) S I=$G(@(DIC_"0)")) I I]"" W $P(I,U)_" "
F I=1:1:DINDEX("#") W DINDEX(I,"PROMPT")_$P(", ^",U,I<DINDEX("#"))
Q
;
; Error messages:
; 204 The input value contains control character
; 349 String too long by |1| character(s)!
; 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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIC0 4870 printed Dec 13, 2024@02:45:17 Page 2
DIC0 ;SFISC/TKW-Lookup routine utilities called by DIC ;16JAN2011
+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 ;
D ; Reset back to starting index for lookup.
+1 SET D=DINDEX("START")
KILL DINDEX
SET (DINDEX,DINDEX("START"))=D
SET DINDEX("WAY")=1
+2 if $DATA(DID(1))
SET DID(1)=2
+3 NEW DIFLAGS
SET DIFLAGS="4l"_$PIECE("M^",U,DIC(0)["M")
+4 DO INDEX^DICUIX(.DIFILEI,DIFLAGS,.DINDEX,"",.DIVAL)
+5 QUIT
+6 ;
SETVAL ; If custom lookup routine (like MTLU) comes in to entry point after ASK, we need to set up the lookup values.
+1 KILL DIVAL,DIALLVAL
DO CHKVAL
+2 IF DIVAL(0)
DO CHKVAL1(DINDEX("#"),.DIVAL,DIC(0),DIC(0),.DIALLVAL)
+3 QUIT
+4 ;
INIT ; Initialize variables at all entry points in ^DIC.
+1 IF $DATA(DIFILEI)[0
DO GETFILE(.DIC,.DIFILEI,.DIENS)
if DIFILEI=""
QUIT
+2 IF '$DATA(@(DIC_"0)"))
IF '$DATA(DIC("P"))
IF $EXTRACT(DIC,1,6)'="^DOPT("
SET DIC("P")=$$GETP^DIC0(DIFILEI)
IF DIC("P")=""
SET Y=-1
DO Q^DIC2
QUIT
+3 IF $GET(DO)=""
KILL DO
DO GETFA^DIC1(.DIC,.DO)
+4 SET (DINDEX,DINDEX("START"))=D
SET DINDEX("WAY")=1
+5 DO INDEX^DICUIX(.DIFILEI,"4l",.DINDEX,"",.DIVAL)
+6 IF DIC(0)["V"
SET DIASKOK=1
+7 SET Y=-1
IF DIC(0)["Z"
KILL Y(0)
+8 QUIT
+9 ;
CHKVAL ; Check lookup values input by user.
+1 NEW I
IF $GET(X)=""
SET X=$GET(X(1))
+2 SET DIVAL(0)=0
SET DIVAL(1)=X
FOR I=2:1:DINDEX("#")
SET DIVAL(I)=$GET(X(I))
+3 NEW J,DIOUT
SET DIOUT=0
+4 FOR I=1:1:DINDEX("#")
SET J=$GET(DIVAL(I))
IF J]""
Begin DoDot:1
+5 IF DINDEX("#")>1
SET X(I)=J
+6 IF J["^"
SET (DUOUT,DIOUT)=1
SET DIVAL(0)=0
QUIT
+7 IF J?1."?"
KILL DIVAL
SET DIVAL(0)=0
SET X=$EXTRACT(J,1,2)
SET DIOUT=1
QUIT
+8 SET DIVAL(0)=DIVAL(0)+1
QUIT
End DoDot:1
if DIOUT
QUIT
+9 QUIT
+10 ;
CHKVAL1(DIXNO,DIVAL,DIFLAGS,DIC0,DIALLVAL) ; Check for errors with values, flags,index.
+1 NEW DIERROR,I
SET DIALLVAL=1
Begin DoDot:1
+2 IF '$DATA(DIC0)
IF DIFLAGS'["l"
Begin DoDot:2
+3 SET I=$ORDER(DIVAL(99999),-1)
IF I>DIXNO
SET DIERROR=8093
QUIT
+4 if DIXNO>1&(DIFLAGS["M")
SET DIERROR=8095
QUIT
End DoDot:2
if $GET(DIERROR)
QUIT
+5 FOR I=1:1:DIXNO
SET DIVAL(I)=$GET(DIVAL(I))
if DIVAL(I)=""
Begin DoDot:2
+6 IF DIFLAGS["X"
IF DIFLAGS'["l"
SET DIERROR=8094
QUIT
+7 SET DIALLVAL=0
QUIT
End DoDot:2
+8 QUIT
End DoDot:1
+9 IF $DATA(DIERROR)
Begin DoDot:1
+10 IF '$DATA(DIC0)
DO ERR^DICF4(DIERROR)
QUIT
+11 KILL DIVAL
SET DIVAL(0)=0
if DIC0'["E"
QUIT
WRITE $CHAR(7),!,$$EZBLD^DIALOG(DIERROR)
QUIT
End DoDot:1
+12 QUIT
+13 ;
CHKVAL2(DIXNO,DIVAL,DIC0,DDS) ; Check lookup values for control characters or too long.
+1 NEW I,J,DIER
SET DIER=""
+2 FOR I=1:1:DIXNO
SET J=$GET(DIVAL(I))
if J]""
Begin DoDot:1
+3 IF J'?.ANP
SET DIER=204
QUIT
+4 IF J?1.N.1".".N
IF ($LENGTH($PIECE(J,"."))>25!($LENGTH($PIECE(J,".",2))>25))
SET DIER=208
QUIT
+5 IF ($LENGTH(J)-255)>0
SET DIER=209
+6 QUIT
End DoDot:1
if DIER
QUIT
+7 if 'DIER
QUIT
+8 if DIC0["Q"
Begin DoDot:1
+9 WRITE $CHAR(7)
if DIC(0)'["E"
QUIT
+10 IF '$DATA(DDS)
WRITE !,$$EZBLD^DIALOG(DIER)
QUIT
+11 NEW DDH
SET DDH=1
SET DDH(1,"T")=" ** "_$$EZBLD^DIALOG(DIER)
+12 SET DDC=7
SET DDD=1
DO LIST^DDSU
+13 QUIT
End DoDot:1
+14 KILL DIVAL
SET DIVAL(0)=0
+15 QUIT
+16 ;
KILL2 KILL DIVAL,DIALLVAL
KILL1 KILL DIFILEI,DINDEX,DIMAXLEN,DIENS
QUIT
+1 ;
GETFILE(DIC,DIFILE,DIENS) ; Return file number, global references, IEN string and KEY fields data.
+1 SET DIFILE=""
IF $GET(DIC)=""
QUIT
+2 IF +$PIECE(DIC,"E")'=DIC
NEW DIDIC
MERGE DIDIC=DIC
NEW DIC
SET DIDIC=$$CREF^DILF(DIDIC)
SET DIDIC=$NAME(@DIDIC)
SET DIDIC=$$OREF^DILF(DIDIC)
MERGE DIC=DIDIC
KILL DIDIC
+3 NEW DA
+4 IF +$PIECE(DIC,"E")=DIC
Begin DoDot:1
+5 SET DIFILE=DIC
SET DIC=$GET(^DIC(DIC,0,"GL"))
if DIC]""
QUIT
+6 SET DIC=DIFILE
SET DIFILE=""
QUIT
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 SET DIFILE=$GET(@(DIC_"0)"))
IF DIFILE]""
SET DIFILE=+$PIECE(DIFILE,U,2)
QUIT
+9 SET DIFILE=+$GET(DIC("P"))
if DIFILE
QUIT
+10 ;I DIC["^DD(",'$D(@(DIC_"0)")) S DIFILE="" Q
+11 SET DIFILE=$$FILENUM^DILIBF(DIC)
QUIT
End DoDot:1
+12 if DIFILE=""
QUIT
+13 SET DIENS=","
+14 IF DIC(0)'["p"
DO SETIEN(DIC,DIFILE,.DIENS)
if DIFILE=""
QUIT
+15 SET DIFILE(DIFILE,"O")=DIC
+16 SET DIFILE(DIFILE)=$$CREF^DILF(DIC)
+17 NEW I
SET I=$ORDER(^DD("KEY","AP",DIFILE,"P",0))
if 'I
QUIT
+18 SET DIFILE(DIFILE,"KEY","IEN")=DIENS
+19 NEW F,X
FOR F=0:0
SET F=$ORDER(^DD("KEY",I,2,F))
if 'F
QUIT
SET X=$GET(^(F,0))
Begin DoDot:1
+20 SET DIFILE(DIFILE,"KEY",+$PIECE(X,U,2),+$PIECE(X,U,3),+X)=""
QUIT
End DoDot:1
+21 QUIT
+22 ;
SETIEN(DIC,DIFILE,DIENS) ; Set DIENS from global root
+1 NEW F,G,I,J,K,DIDA
+2 SET F=$$FNO^DILIBF(DIFILE)
IF F=""
SET DIFILE=""
QUIT
+3 SET G=$GET(^DIC(F,0,"GL"))
IF G=""
SET DIFILE=""
QUIT
+4 SET F=$PIECE(DIC,G,2)
+5 SET K=0
FOR I=1:2
SET J=$PIECE(F,",",I)
if J=""
QUIT
SET K=K+1
SET J(K)=J
+6 SET DIDA=""
FOR J=1:1:K
SET DIDA(K+1-J)=J(J)
+7 SET DIENS=$$IENS^DILF(.DIDA)
QUIT
+8 ;
GETP(DISUB) ; Return DIC("P") for a subfile DIFILE.
+1 NEW DIFILE
SET DIFILE=$GET(^DD(DISUB,0,"UP"))
if 'DIFILE
QUIT ""
+2 NEW DIFIELD
SET DIFIELD=$ORDER(^DD(DIFILE,"SB",DISUB,0))
if 'DIFIELD
QUIT ""
+3 QUIT $PIECE($GET(^DD(DIFILE,DIFIELD,0)),U,2)
+4 ;
DSPH ; Display name of indexed fields when DIC(0)["T" (called from DIC1 & DIC2)
+1 if $GET(DS(0,"HDRDSP",DIFILEI))
QUIT
SET DS(0,"HDRDSP",DIFILEI)=1
+2 WRITE !
NEW I
SET I=($GET(DICR))*2
if I
WRITE ?I
+3 WRITE " Lookup: "
+4 IF $GET(DICR)
SET I=$GET(@(DIC_"0)"))
IF I]""
WRITE $PIECE(I,U)_" "
+5 FOR I=1:1:DINDEX("#")
WRITE DINDEX(I,"PROMPT")_$PIECE(", ^",U,I<DINDEX("#"))
+6 QUIT
+7 ;
+8 ; Error messages:
+9 ; 204 The input value contains control character
+10 ; 349 String too long by |1| character(s)!
+11 ; 8093 Too many lookup values for this index.
+12 ; 8094 Not enough lookup values provided for an e
+13 ; 8095 Only one compound index allowed on a looku
+14 ;
