DIC2 ;SF/XAK/TKW-LOOKUP (CONT) ;5/10/00 11:16 [ 04/02/2003 8:25 AM ]
;;22.0;VA FileMan;**1001**;APR 1, 2003
;;22.0;VA FileMan;**4,17,20,31,40**;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
WO ; Display .01 field, Primary KEY values and Identifiers for an entry.
I '$D(DST) N DST
S DST=$G(DST)_" " D WR
I $D(DIC("W")),$D(@(DIC_"Y,0)")) D:$D(DDS)&'$D(DDH("ID")) ID^DICQ1 I '$D(DDS) D
. I $G(DST)]"" W DST," "
. N DISAVEX M DISAVEX=Y N Y M Y=DISAVEX S DISAVEX=X N X S X=DISAVEX K DISAVEX
. I $D(@(DIC_"Y,0)")) X DIC("W")
. K DST Q
Q
WR ; Put .01 field into DST for display
D:'$D(DO) GETFA^DIC1(.DIC,.DO) I '$D(DST) N DST
I (DIC(0)["S"!(DIC(0)["s")),DIVAL(1)'=" " Q:" "[$G(DST)&('$D(DIX("K"))) D S Q
S DST=$G(DST)
I DO(2)["V",DIY?1.N1";"1.E S DST=DST_$$EXT(+DO(2),.01,DIY) D S Q
I DIY?.N.1".".N,(DO(2)["P"!(DO(2)["D")),DIY D D S Q
. I DO(2)["P" S DST=DST_$$EXT(+DO(2),.01,DIY) Q
. N % S %=DIY D DT^DIC1 Q
W1 I '$G(DIYX),DIY]"",((DST'[DIY)!($P(DST,DIY)]"")) S DST=DST_DIY
S ; Put Primary KEY values into DST, display DST if not in ScreenMan
I $D(DIX("K")),DIC(0)'["S" N I,F,% F I=0:0 S I=$O(DIX("K",I)) Q:'I F F=0:0 S F=$O(DIX("K",I,F)) Q:'F D
. I DIY]"",F=.01 Q
. I $G(DIX("F"))[("^"_F_"^") Q
. S %=DIX("K",I,F) Q:%="" I $L(%)+$L(DST)>240 Q
. S DST=DST_$P(" ^",U,DST]"")_% Q
N A1 S A1=Y I '$D(DDS) W DST K DST Q
H ; Display .01 and Primary KEY values if in ScreenMan
I '$D(A1) N A1 S A1="T"
S DDH=$G(DDH)+1,DDH(DDH,A1)=DST K DST Q
;
EXT(DIFILE,DIFIELD,DIVAL,DIF) ; Return external value of field
N DIERR,DISAV S DISAV=$G(DIVAL) I DISAV="" Q DISAV
S DIF=$G(DIF) S:DIF="" DIF="F"
S DIVAL=$$EXTERNAL^DIDU(DIFILE,DIFIELD,DIF,DIVAL,"DIERR")
I $D(DIERR) S DIVAL=DISAV
Q DIVAL
;
PGM(DIC,DF,DIFILE) ; Return special lookup program name
I DIC(0)["I"!($G(DF)]"") Q ""
N DIPGM S DIPGM=$G(^DD(DIFILE,0,"DIC")) Q:DIPGM=""!(DIPGM?1"DI".E) ""
Q U_DIPGM
;
GOT I DIC(0)["E" D
. N:'$D(DST) DST N DDH D WO
. I $D(DDS),$D(DDH)>10 D LIST^DDSU K DDH("ID")
. Q
S Y=Y_"^"_$S(DIY="":X,$G(DIYX):X_DIY,1:DIY)
I DIC(0)["E" D Q:Y<0
. I DO(2)["O"!($G(DIASKOK)) D OK^DIC1 Q
. Q:DIC(0)'["T"
. I $G(DICR) Q:'$G(DICRS)!(DICR'=1) D OK^DIC1 Q
. D OK^DIC1 Q
R D:'$G(DICR) I Y<0 D A^DIC S DS(0)="1^" Q
. D ACT^DICM1 Q:Y<0
. Q:DINDEX("#")'>1!(DINDEX("START")'=DINDEX)
. N I F I=1:1:DINDEX("#") I $D(DIX(I))#2 S X(I)=DIX(I)
. Q
I DIC(0)["Z" S Y(0)=@(DIC_"+Y,0)"),Y(0,0)=$$EXT(DIFILEI,.01,$P(Y(0),U))
ACT I DIC(0)'["F",$D(DUZ)#2 S ^DISV(DUZ,$E(DIC,1,28))=$E(DIC,29,999)_+Y
I $D(@(DIC_"+Y,0)")) D:DIC(0)'["T" Q Q
S Y=-1 D Q S DS(0)="1^" Q
;
Q K DIDA,DID,DISMN,DINUM,DS,DF,DD,DIX,DIY,DIYX,DZ,DO,D,DIAC,DIFILE
I '$G(DICR) K DIC("W"),DIROUT I DIC(0)["T" K ^TMP($J,"DICSEEN")
Q
;
G ; Display index values for a single looked-up entry
I $D(DS(0,"DICRS")),'$D(DICRS) N DICRS S DICRS=1
I $D(DS(0,"DIDA")),'$G(DIDA) N DIDA S DIDA=1
I $D(DIDA),$P(DS(1),U,2,99)]"" N:'$G(DIASKOK) DIASKOK S DIASKOK=1
I DIC(0)["T",DIC(0)["E",'$D(DDS) D DSPH^DIC0 W !
S DIY=1,DIX=X I DIC(0)["E",DIC(0)'["U" D
. I DIC(0)["D" Q:$P(DS(1,"F"),U,2)=.01 N DIENTIRE S DIENTIRE=1
. N D,% S (D,%)=""
. I $G(DIDA),$P(DS(1),U,2,99)]"" S %=" partial match to:"
. I $O(DS(1,0)) D
. . I DINDEX("#")=1,'$G(DIDA) S D=%_$$BLDDSP^DIC1(.DS,1,1,.DIYX,.DIY,$G(DICRS)) Q
. . S D=%_$$BLDDSP^DIC1(.DS,1,"","","",$G(DICRS)) Q
. E I $G(DITRANX) D
. . S D=X_$P(DS(1),U,2,99)_$S($G(DIYX(1)):$G(DIY(1)),1:"")
. . I $G(DINDEX(1,"TRANOUT"))]"" N X S X=D X DINDEX(1,"TRANOUT") S D=$G(X)
. . S:D]"" D=" "_D I $G(DIFINDER)["p",'$D(DDS) W !
. . Q
. E I '$D(DICRS) D
. . I $G(DIDA) S D=$P(DS(1),U,2,99) I D]"" S D=%_" "_$$FMTE^DILIBF(X_D,"1U") W:'$D(DDS) ! Q
. . S D=$P(DS(1),U,2,99)_$S($G(DIYX(1)):$G(DIY(1)),1:"")
. . I $G(DIFINDER)["p" S D=X_D W:'$D(DDS)&(DIC(0)'["T") ! Q
. . I DIC(0)["T"!($G(DIENTIRE)) S D=X_D
. . Q
. S DST=$P(" ^",U,$D(DST)#2)_D
. I '$D(DDS) W DST S DST=""
. Q
C S Y=$G(DIX) M DIX=DS(DIY) S DIX=Y
I $O(DS(1)) K DIX("F")
S Y=+DS(DIY),X=X_$P(DS(DIY),"^",2),DIYX=$G(DIYX(DIY)),DIY=DIY(DIY)
D GOT Q
;
;
DIC2 ;SF/XAK/TKW-LOOKUP (CONT) ;5/10/00 11:16 [ 04/02/2003 8:25 AM ]
+1 ;;22.0;VA FileMan;**1001**;APR 1, 2003
+2 ;;22.0;VA FileMan;**4,17,20,31,40**;Mar 30, 1999
+3 ;Per VHA Directive 10-93-142, this routine should not be modified.
WO ; Display .01 field, Primary KEY values and Identifiers for an entry.
+1 IF '$DATA(DST)
NEW DST
+2 SET DST=$GET(DST)_" "
DO WR
+3 IF $DATA(DIC("W"))
IF $DATA(@(DIC_"Y,0)"))
IF $DATA(DDS)&'$DATA(DDH("ID"))
DO ID^DICQ1
IF '$DATA(DDS)
Begin DoDot:1
+4 IF $GET(DST)]""
WRITE DST," "
+5 NEW DISAVEX
MERGE DISAVEX=Y
NEW Y
MERGE Y=DISAVEX
SET DISAVEX=X
NEW X
SET X=DISAVEX
KILL DISAVEX
+6 IF $DATA(@(DIC_"Y,0)"))
XECUTE DIC("W")
+7 KILL DST
QUIT
End DoDot:1
+8 QUIT
WR ; Put .01 field into DST for display
+1 IF '$DATA(DO)
DO GETFA^DIC1(.DIC,.DO)
IF '$DATA(DST)
NEW DST
+2 IF (DIC(0)["S"!(DIC(0)["s"))
IF DIVAL(1)'=" "
IF " "[$GET(DST)&('$DATA(DIX("K")))
QUIT
DO S
QUIT
+3 SET DST=$GET(DST)
+4 IF DO(2)["V"
IF DIY?1.N1";"1.E
SET DST=DST_$$EXT(+DO(2),.01,DIY)
DO S
QUIT
+5 IF DIY?.N.1".".N
IF (DO(2)["P"!(DO(2)["D"))
IF DIY
Begin DoDot:1
+6 IF DO(2)["P"
SET DST=DST_$$EXT(+DO(2),.01,DIY)
QUIT
+7 NEW %
SET %=DIY
DO DT^DIC1
QUIT
End DoDot:1
DO S
QUIT
W1 IF '$GET(DIYX)
IF DIY]""
IF ((DST'[DIY)!($PIECE(DST,DIY)]""))
SET DST=DST_DIY
S ; Put Primary KEY values into DST, display DST if not in ScreenMan
+1 IF $DATA(DIX("K"))
IF DIC(0)'["S"
NEW I,F,%
FOR I=0:0
SET I=$ORDER(DIX("K",I))
IF 'I
QUIT
FOR F=0:0
SET F=$ORDER(DIX("K",I,F))
IF 'F
QUIT
Begin DoDot:1
+2 IF DIY]""
IF F=.01
QUIT
+3 IF $GET(DIX("F"))[("^"_F_"^")
QUIT
+4 SET %=DIX("K",I,F)
IF %=""
QUIT
IF $LENGTH(%)+$LENGTH(DST)>240
QUIT
+5 SET DST=DST_$PIECE(" ^",U,DST]"")_%
QUIT
End DoDot:1
+6 NEW A1
SET A1=Y
IF '$DATA(DDS)
WRITE DST
KILL DST
QUIT
H ; Display .01 and Primary KEY values if in ScreenMan
+1 IF '$DATA(A1)
NEW A1
SET A1="T"
+2 SET DDH=$GET(DDH)+1
SET DDH(DDH,A1)=DST
KILL DST
QUIT
+3 ;
EXT(DIFILE,DIFIELD,DIVAL,DIF) ; Return external value of field
+1 NEW DIERR,DISAV
SET DISAV=$GET(DIVAL)
IF DISAV=""
QUIT DISAV
+2 SET DIF=$GET(DIF)
IF DIF=""
SET DIF="F"
+3 SET DIVAL=$$EXTERNAL^DIDU(DIFILE,DIFIELD,DIF,DIVAL,"DIERR")
+4 IF $DATA(DIERR)
SET DIVAL=DISAV
+5 QUIT DIVAL
+6 ;
PGM(DIC,DF,DIFILE) ; Return special lookup program name
+1 IF DIC(0)["I"!($GET(DF)]"")
QUIT ""
+2 NEW DIPGM
SET DIPGM=$GET(^DD(DIFILE,0,"DIC"))
IF DIPGM=""!(DIPGM?1"DI".E)
QUIT ""
+3 QUIT U_DIPGM
+4 ;
GOT IF DIC(0)["E"
Begin DoDot:1
+1 IF '$DATA(DST)
NEW DST
NEW DDH
DO WO
+2 IF $DATA(DDS)
IF $DATA(DDH)>10
DO LIST^DDSU
KILL DDH("ID")
+3 QUIT
End DoDot:1
+4 SET Y=Y_"^"_$SELECT(DIY="":X,$GET(DIYX):X_DIY,1:DIY)
+5 IF DIC(0)["E"
Begin DoDot:1
+6 IF DO(2)["O"!($GET(DIASKOK))
DO OK^DIC1
QUIT
+7 IF DIC(0)'["T"
QUIT
+8 IF $GET(DICR)
IF '$GET(DICRS)!(DICR'=1)
QUIT
DO OK^DIC1
QUIT
+9 DO OK^DIC1
QUIT
End DoDot:1
IF Y<0
QUIT
R IF '$GET(DICR)
Begin DoDot:1
+1 DO ACT^DICM1
IF Y<0
QUIT
+2 IF DINDEX("#")'>1!(DINDEX("START")'=DINDEX)
QUIT
+3 NEW I
FOR I=1:1:DINDEX("#")
IF $DATA(DIX(I))#2
SET X(I)=DIX(I)
+4 QUIT
End DoDot:1
IF Y<0
DO A^DIC
SET DS(0)="1^"
QUIT
+5 IF DIC(0)["Z"
SET Y(0)=@(DIC_"+Y,0)")
SET Y(0,0)=$$EXT(DIFILEI,.01,$PIECE(Y(0),U))
ACT IF DIC(0)'["F"
IF $DATA(DUZ)#2
SET ^DISV(DUZ,$EXTRACT(DIC,1,28))=$EXTRACT(DIC,29,999)_+Y
+1 IF $DATA(@(DIC_"+Y,0)"))
IF DIC(0)'["T"
DO Q
QUIT
+2 SET Y=-1
DO Q
SET DS(0)="1^"
QUIT
+3 ;
Q KILL DIDA,DID,DISMN,DINUM,DS,DF,DD,DIX,DIY,DIYX,DZ,DO,D,DIAC,DIFILE
+1 IF '$GET(DICR)
KILL DIC("W"),DIROUT
IF DIC(0)["T"
KILL ^TMP($JOB,"DICSEEN")
+2 QUIT
+3 ;
G ; Display index values for a single looked-up entry
+1 IF $DATA(DS(0,"DICRS"))
IF '$DATA(DICRS)
NEW DICRS
SET DICRS=1
+2 IF $DATA(DS(0,"DIDA"))
IF '$GET(DIDA)
NEW DIDA
SET DIDA=1
+3 IF $DATA(DIDA)
IF $PIECE(DS(1),U,2,99)]""
IF '$GET(DIASKOK)
NEW DIASKOK
SET DIASKOK=1
+4 IF DIC(0)["T"
IF DIC(0)["E"
IF '$DATA(DDS)
DO DSPH^DIC0
WRITE !
+5 SET DIY=1
SET DIX=X
IF DIC(0)["E"
IF DIC(0)'["U"
Begin DoDot:1
+6 IF DIC(0)["D"
IF $PIECE(DS(1,"F"),U,2)=.01
QUIT
NEW DIENTIRE
SET DIENTIRE=1
+7 NEW D,%
SET (D,%)=""
+8 IF $GET(DIDA)
IF $PIECE(DS(1),U,2,99)]""
SET %=" partial match to:"
+9 IF $ORDER(DS(1,0))
Begin DoDot:2
+10 IF DINDEX("#")=1
IF '$GET(DIDA)
SET D=%_$$BLDDSP^DIC1(.DS,1,1,.DIYX,.DIY,$GET(DICRS))
QUIT
+11 SET D=%_$$BLDDSP^DIC1(.DS,1,"","","",$GET(DICRS))
QUIT
End DoDot:2
+12 IF '$TEST
IF $GET(DITRANX)
Begin DoDot:2
+13 SET D=X_$PIECE(DS(1),U,2,99)_$SELECT($GET(DIYX(1)):$GET(DIY(1)),1:"")
+14 IF $GET(DINDEX(1,"TRANOUT"))]""
NEW X
SET X=D
XECUTE DINDEX(1,"TRANOUT")
SET D=$GET(X)
+15 IF D]""
SET D=" "_D
IF $GET(DIFINDER)["p"
IF '$DATA(DDS)
WRITE !
+16 QUIT
End DoDot:2
+17 IF '$TEST
IF '$DATA(DICRS)
Begin DoDot:2
+18 IF $GET(DIDA)
SET D=$PIECE(DS(1),U,2,99)
IF D]""
SET D=%_" "_$$FMTE^DILIBF(X_D,"1U")
IF '$DATA(DDS)
WRITE !
QUIT
+19 SET D=$PIECE(DS(1),U,2,99)_$SELECT($GET(DIYX(1)):$GET(DIY(1)),1:"")
+20 IF $GET(DIFINDER)["p"
SET D=X_D
IF '$DATA(DDS)&(DIC(0)'["T")
WRITE !
QUIT
+21 IF DIC(0)["T"!($GET(DIENTIRE))
SET D=X_D
+22 QUIT
End DoDot:2
+23 SET DST=$PIECE(" ^",U,$DATA(DST)#2)_D
+24 IF '$DATA(DDS)
WRITE DST
SET DST=""
+25 QUIT
End DoDot:1
C SET Y=$GET(DIX)
MERGE DIX=DS(DIY)
SET DIX=Y
+1 IF $ORDER(DS(1))
KILL DIX("F")
+2 SET Y=+DS(DIY)
SET X=X_$PIECE(DS(DIY),"^",2)
SET DIYX=$GET(DIYX(DIY))
SET DIY=DIY(DIY)
+3 DO GOT
QUIT
+4 ;
+5 ;
