DIC3 ;SFISC/XAK,TKW,SEA/TOAD-VA FileMan: Lookup, Part 1 (called from DIC) ;28SEP2010
;;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.
;
SEARCH ; Begin search through x-refs.
I DIC(0)["T",'$G(DICR) N:'$D(DICR(1)) DICR S DICR=0 D:DIC(0)["O"
. I DIC(0)'["X" S DIC(0)=DIC(0)_"X" Q
. S DIC(0)=$TR(DIC(0),"X") Q
I X?1"`".NP D ^DICM Q
I $L(X)>DINDEX(1,"LENGTH"),'$G(DILONGX) D ^DICM Q
N DIOK,DIEXACTN K % I $G(DISKIPIX)=D K DISKIPIX G M
EXACT ; Find all exact matches to the lookup values
S DISAVDS=DS,DIEXACTN=0
I $G(DILONGX) D ;G:$L(DICR(DICR,"ORG"))'>DINDEX(1,"LENGTH") M D ;JUMPED AWAY FROM USING THIS INDEX, EVEN THOUGH IT MIGHT NEVER HAVE BEEN TRIED BEFORE
. S (X,X(1),DIVAL,DIVAL(1))=$E(DICR(DILONGX,"ORG"),1,DINDEX(1,"LENGTH")) ;TRIM LOOKUP VALUE DOWN TO SIZE!
I DINDEX("#")>1,($G(DIALLVAL)!($G(DICR))),(DIC(0)["X"!(DIC(0)["O")) D EXACT^DIC4,SET^DIC4
I DINDEX("#")'>1 S Y=0,DIX=X F D MOREX Q:Y=-1!(DS(0))
I DS(0) Q:DIC(0)'["T" Q:$P(DS(0),U,2)'="U"!($G(DIROUT)) S DS(0)=0
I DIC(0)["T",DIC(0)["E",$G(DUOUT) D ;22*70
. ; Set up variables for next index lookup
. K DS,DUOUT
. S (DS,DS(0),DS("DD"))=0
. S X=DIVAL(1)
. Q
I DISAVDS=0,DS=1,DIC(0)["O"!(DIC(0)'["E"),DIC(0)'["T" D Q:Y>0!($D(DIROUT)) ;Good IEN returned or user bailed out
. I DINDEX("#")'>1,DIEXACTN>1,DINDEX'="B" S Y=-1 Q
. S Y=+DS(1),DS("DD")=1
. I DINDEX("#")'>1,DIEXACTN'>1 S DIY=1 D C^DIC2 Q
. D G^DIC2 Q
;
PARTIAL ; Find all partial matches to the lookup values
I DIC(0)'["X",DINDEX("#")>1 D PARTIAL^DIC4,SET^DIC4
I DIC(0)'["X",DINDEX("#")'>1 F D Q:$G(DIX)=""!(DS(0))
. N DITYP S DITYP=$G(DINDEX(1,"TYPE"))
. D
. . I DIC(0)["E",(DITYP["F"!(DITYP["S")) Q:DIC(0)["n"
. . I $TR(X,"-.")?.N,DO(2)'["D",'$D(DIDA) S DIX=$O(@(DIC_"D,DIX_"" "")"),-1)
. . Q
. S DIX=$O(@(DIC_"D,DIX)"))
. Q:DIX=""
. I $P(DIX,X)'="" D Q:DIX=""
. . I +$P(X,"E")'=X!(DIC(0)'["E") S DIX="" Q
. . I DIC(0)'["n"!(DITYP'["F"&(DITYP'["S")) S DIX="" Q
. . D FINDMORE^DICLIX0(1,.DIX,X,.DINDEX) ;DIC(0)["n" SO WE KEEP LOOKING FOR PARTIAL NUMERIC MATCHES
. . S:$P(DIX,X)'="" DIX="" Q
. S Y=0 F D MOREX Q:Y=-1!(DS(0))
. Q
I DS(0) Q:DIC(0)'["T" Q:$P(DS(0),U,2)'="U"!($G(DIROUT)) S DS(0)=0
I DIC(0)["T",DIC(0)["E",$G(DUOUT) D ;22*70
. ; Set up variables for next index lookup
. K DS,DUOUT
. S (DS,DS(0),DS("DD"))=0
. S X=DIVAL(1)
. Q
;
M ; Find the next index. At end, display the rest
I DIC(0)["T" D KEEPON^DIC5 I DS(0) Q:$P(DS(0),U,2)'="U"!($G(DIROUT))
I DIC(0)["M" S DIOK=0 F D Q:DIOK
. N Y S Y=DINDEX("START") K DINDEX S DINDEX("WAY")=1,DINDEX("START")=Y,DINDEX("#")=1
. S (D,DINDEX)=$S($D(DID):$P(DID,U,DID(1)),1:$O(@(DIC_"D)"))) ;GRAB THE NEXT EXISTING CROSS-REF
. S:$D(DID) DID(1)=DID(1)+1
. I D=""!(D=-1) S D="",DIOK=1 Q
. I $D(@(DIC_"D)"))-10 Q
. ; Check Index, build index info
. D IXCHK^DIC4(.DIFILEI,.DINDEX,.DIOK,.DIALLVAL,.DIVAL,$G(DID)) ;DINDEX=D. Check that it's OK
I DIC(0)["M",D]"" G EXACT
D:DIC(0)["M" D^DIC0
I DS=1 S DS("DD")=1 D G^DIC2 Q
I DS D Y^DIC1 Q:DS(0) I DINDEX("#")'>1 D:DO(2)["O"&(DO(2)'["A") L^DICM Q
I $G(DILONGX) S X=$E(DICR(DILONGX,"ORG"),1,30)
I DIC(0)["T",'$G(DICR),DIC(0)["O",DIC(0)["X" G SEARCH
I DINDEX("#")>1,'$G(DICR) D:DIC(0)["L" D:Y=-1 BAD^DIC1 Q
. S Y=-1 I $G(DICR)="" N DICR S DICR=0
. I $A(X)=34,X?.E1"""" D N^DICM Q
. K DD D L^DICM Q
D ^DICM Q
;
;
MOREX ; Find more exact matches to lookup value DIX
S Y=$O(@(DIC_"D,DIX,Y)")) I 'Y S Y=-1 Q
I $D(DIEXACTN)#2 S DIEXACTN=DIEXACTN+1
D MN Q:'$T D K Q:$G(DS(0))
I DS>1,DIC(0)'["E",DIC(0)'["Y" K DS S DS=0,DS(0)=1,Y=-1
Q
;
MN N DZ S DZ=$S((DIC(0)["D"&(DINDEX="B")):1,$G(DINDEX("#"))>1:0,$G(@(DIC_"D,DIX,Y)")):1,1:0) S DIYX=0
D:'$D(DO) GETFA^DIC1(.DIC,.DO)
I D="B",'DZ,'($D(@(DIC_"D,DIX,Y)"))#2) D
. N I S I=Y F S DZ=$G(^(I)),I=$O(^(I,0)) Q:I=""
. Q
S DIY="" I '$D(@(DIC_"Y,0)")) X "I 0" Q
I D="B",'DZ,'$D(DO("SCR")),$L(DIX)<30,'$D(DIC("S")),'$D(@(DIC_"Y,-9)")),'$G(DINDEX("OLDSUB")) D ADDKEY I 1 Q
D S I D
. I DINDEX("FLISTD")["^.01^",DINDEX("#")=1,'DZ,$P(DIY,DIX)="",'$G(DINDEX("OLDSUB")) D Q
. . N I S I=$S($G(DILONGX):DICR(DILONGX,"ORG"),1:DIX)
. . S DIY=$P(DIY,I,2,9),DIYX=1 D ADDKEY Q
. Q:DIC(0)["Y"
. I ($G(DINDEX("#"))>1)!($G(DINDEX("OLDSUB"))) D Q
. . D ADDIX^DIC4(.DIFILEI,Y,.DINDEX,.DIX,.DISCREEN)
. . D ADDKEY Q
. D ADDKEY
. I DINDEX("FLISTD")["^.01^",'DZ S DIY=""
. Q
Q
;
S D:'$D(DO) GETFA^DIC1(.DIC,.DO)
I $D(@(DIC_"Y,0)")),'$D(^(-9)) S DIY=$P(^(0),U)
E S DIY="" Q
I '$D(DIC("S")),'$D(DO("SCR")) Q
I $G(DINDEX("#"))>1!($G(DINDEX("OLDSUB"))) Q
I $G(DILONGX) N DI0NODE,DIVAL D
. N % S %=DINDEX(1,"GET")
. I %="DIVAL=DINDEX(DISUB)" S DIVAL=X Q
. I %["DI0NODE" S DI0NODE=@(DIC_"Y,0)")
. N DIFILE S DIFILE=DIFILEI,DIFILE(DIFILE)=DIFILEI(DIFILEI)
. N DIEN S DIEN=Y_DIENS
. S @% Q
N DIAC,DIFILE,DISAVEX,DISAVEY,DISAVED
M DISAVEX=X,DISAVEY=Y S DISAVED=D I $D(@(DIC_"Y,0)"))
I $D(DIVAL(1)),$D(DIVAL)=10 S DIVAL=DIVAL(1) ;*159
I 1 X:$D(DIC("S")) DIC("S") K DIAC,DIFILE D:$D(DIC("S")) SX Q:'$T
I $D(DO("SCR")),$D(@(DIC_"Y,0)")) X DO("SCR") D SX Q:'$T
I 1 Q
;
SX M X=DISAVEX,Y=DISAVEY S D=DISAVED Q
;
ADDKEY ; Put KEY values into output array for display
S DIX("F")="" I DIC(0)'["U" S DIX("F")=$G(DINDEX("FLISTD"))
Q:'$D(DIFILEI(DIFILEI,"KEY")) Q:DIC(0)["S"
N DIKX,DII,DIFLD,DIERR,I
M DIKX=DIFILEI(DIFILEI,"KEY",DIFILEI) Q:'$D(DIKX)
K DIX("K")
F I=0:0 S I=$O(DIKX(I)) Q:'I F DIFLD=0:0 S DIFLD=$O(DIKX(I,DIFLD)) Q:'DIFLD D
. I DIFLD=.01,$G(DZ)=0 S DIY=""
. S DIX("K",I,DIFLD)=$$GET1^DIQ(DIFILEI,Y_DIFILEI(DIFILEI,"KEY","IEN"),DIFLD,"","","DIERR") Q
Q
;
K ; Put an IEN into the DS array for display
N DZ,I S DZ=$O(DS(0)) F I=DZ:1:DS I +$G(DS(I))=Y,DIC(0)'["C" S I=-1 Q
I I'=-1,DIC(0)["T" D
. Q:'$D(^TMP($J,"DICSEEN",DIFILEI))
. I $D(^TMP($J,"DICSEEN",DIFILEI,Y)) S I=-1 Q
. S ^TMP($J,"DICSEEN",DIFILEI,Y)="" Q
I I=-1 S I=DIX K DIX S DIX=I,I=-1 Q
I DS-DZ>100 D
. N D1,D2 S D2=DZ+19 F D1=DZ:1:D2 K DS(D1),DIY(D1),DIYX(D1)
. Q
S DS=DS+1 D
. S I=DS M DS(DS)=DIX S DS=I,I=DIX K DIX S DIX=I
. S DS(DS)=Y_"^"_$P(DIX,X,2,99) Q
S DIY(DS)=DIY S:DIY]""&$G(DIYX) DIYX(DS)=1
I DS#5-1!(DS=1)!(DIC(0)["Y") Q
D Y^DIC1 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIC3 6493 printed Nov 22, 2024@17:55:16 Page 2
DIC3 ;SFISC/XAK,TKW,SEA/TOAD-VA FileMan: Lookup, Part 1 (called from DIC) ;28SEP2010
+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 ;
SEARCH ; Begin search through x-refs.
+1 IF DIC(0)["T"
IF '$GET(DICR)
if '$DATA(DICR(1))
NEW DICR
SET DICR=0
if DIC(0)["O"
Begin DoDot:1
+2 IF DIC(0)'["X"
SET DIC(0)=DIC(0)_"X"
QUIT
+3 SET DIC(0)=$TRANSLATE(DIC(0),"X")
QUIT
End DoDot:1
+4 IF X?1"`".NP
DO ^DICM
QUIT
+5 IF $LENGTH(X)>DINDEX(1,"LENGTH")
IF '$GET(DILONGX)
DO ^DICM
QUIT
+6 NEW DIOK,DIEXACTN
KILL %
IF $GET(DISKIPIX)=D
KILL DISKIPIX
GOTO M
EXACT ; Find all exact matches to the lookup values
+1 SET DISAVDS=DS
SET DIEXACTN=0
+2 ;G:$L(DICR(DICR,"ORG"))'>DINDEX(1,"LENGTH") M D ;JUMPED AWAY FROM USING THIS INDEX, EVEN THOUGH IT MIGHT NEVER HAVE BEEN TRIED BEFORE
IF $GET(DILONGX)
Begin DoDot:1
+3 ;TRIM LOOKUP VALUE DOWN TO SIZE!
SET (X,X(1),DIVAL,DIVAL(1))=$EXTRACT(DICR(DILONGX,"ORG"),1,DINDEX(1,"LENGTH"))
End DoDot:1
+4 IF DINDEX("#")>1
IF ($GET(DIALLVAL)!($GET(DICR)))
IF (DIC(0)["X"!(DIC(0)["O"))
DO EXACT^DIC4
DO SET^DIC4
+5 IF DINDEX("#")'>1
SET Y=0
SET DIX=X
FOR
DO MOREX
if Y=-1!(DS(0))
QUIT
+6 IF DS(0)
if DIC(0)'["T"
QUIT
if $PIECE(DS(0),U,2)'="U"!($GET(DIROUT))
QUIT
SET DS(0)=0
+7 ;22*70
IF DIC(0)["T"
IF DIC(0)["E"
IF $GET(DUOUT)
Begin DoDot:1
+8 ; Set up variables for next index lookup
+9 KILL DS,DUOUT
+10 SET (DS,DS(0),DS("DD"))=0
+11 SET X=DIVAL(1)
+12 QUIT
End DoDot:1
+13 ;Good IEN returned or user bailed out
IF DISAVDS=0
IF DS=1
IF DIC(0)["O"!(DIC(0)'["E")
IF DIC(0)'["T"
Begin DoDot:1
+14 IF DINDEX("#")'>1
IF DIEXACTN>1
IF DINDEX'="B"
SET Y=-1
QUIT
+15 SET Y=+DS(1)
SET DS("DD")=1
+16 IF DINDEX("#")'>1
IF DIEXACTN'>1
SET DIY=1
DO C^DIC2
QUIT
+17 DO G^DIC2
QUIT
End DoDot:1
if Y>0!($DATA(DIROUT))
QUIT
+18 ;
PARTIAL ; Find all partial matches to the lookup values
+1 IF DIC(0)'["X"
IF DINDEX("#")>1
DO PARTIAL^DIC4
DO SET^DIC4
+2 IF DIC(0)'["X"
IF DINDEX("#")'>1
FOR
Begin DoDot:1
+3 NEW DITYP
SET DITYP=$GET(DINDEX(1,"TYPE"))
+4 Begin DoDot:2
+5 IF DIC(0)["E"
IF (DITYP["F"!(DITYP["S"))
if DIC(0)["n"
QUIT
+6 IF $TRANSLATE(X,"-.")?.N
IF DO(2)'["D"
IF '$DATA(DIDA)
SET DIX=$ORDER(@(DIC_"D,DIX_"" "")"),-1)
+7 QUIT
End DoDot:2
+8 SET DIX=$ORDER(@(DIC_"D,DIX)"))
+9 if DIX=""
QUIT
+10 IF $PIECE(DIX,X)'=""
Begin DoDot:2
+11 IF +$PIECE(X,"E")'=X!(DIC(0)'["E")
SET DIX=""
QUIT
+12 IF DIC(0)'["n"!(DITYP'["F"&(DITYP'["S"))
SET DIX=""
QUIT
+13 ;DIC(0)["n" SO WE KEEP LOOKING FOR PARTIAL NUMERIC MATCHES
DO FINDMORE^DICLIX0(1,.DIX,X,.DINDEX)
+14 if $PIECE(DIX,X)'=""
SET DIX=""
QUIT
End DoDot:2
if DIX=""
QUIT
+15 SET Y=0
FOR
DO MOREX
if Y=-1!(DS(0))
QUIT
+16 QUIT
End DoDot:1
if $GET(DIX)=""!(DS(0))
QUIT
+17 IF DS(0)
if DIC(0)'["T"
QUIT
if $PIECE(DS(0),U,2)'="U"!($GET(DIROUT))
QUIT
SET DS(0)=0
+18 ;22*70
IF DIC(0)["T"
IF DIC(0)["E"
IF $GET(DUOUT)
Begin DoDot:1
+19 ; Set up variables for next index lookup
+20 KILL DS,DUOUT
+21 SET (DS,DS(0),DS("DD"))=0
+22 SET X=DIVAL(1)
+23 QUIT
End DoDot:1
+24 ;
M ; Find the next index. At end, display the rest
+1 IF DIC(0)["T"
DO KEEPON^DIC5
IF DS(0)
if $PIECE(DS(0),U,2)'="U"!($GET(DIROUT))
QUIT
+2 IF DIC(0)["M"
SET DIOK=0
FOR
Begin DoDot:1
+3 NEW Y
SET Y=DINDEX("START")
KILL DINDEX
SET DINDEX("WAY")=1
SET DINDEX("START")=Y
SET DINDEX("#")=1
+4 ;GRAB THE NEXT EXISTING CROSS-REF
SET (D,DINDEX)=$SELECT($DATA(DID):$PIECE(DID,U,DID(1)),1:$ORDER(@(DIC_"D)")))
+5 if $DATA(DID)
SET DID(1)=DID(1)+1
+6 IF D=""!(D=-1)
SET D=""
SET DIOK=1
QUIT
+7 IF $DATA(@(DIC_"D)"))-10
QUIT
+8 ; Check Index, build index info
+9 ;DINDEX=D. Check that it's OK
DO IXCHK^DIC4(.DIFILEI,.DINDEX,.DIOK,.DIALLVAL,.DIVAL,$GET(DID))
End DoDot:1
if DIOK
QUIT
+10 IF DIC(0)["M"
IF D]""
GOTO EXACT
+11 if DIC(0)["M"
DO D^DIC0
+12 IF DS=1
SET DS("DD")=1
DO G^DIC2
QUIT
+13 IF DS
DO Y^DIC1
if DS(0)
QUIT
IF DINDEX("#")'>1
if DO(2)["O"&(DO(2)'["A")
DO L^DICM
QUIT
+14 IF $GET(DILONGX)
SET X=$EXTRACT(DICR(DILONGX,"ORG"),1,30)
+15 IF DIC(0)["T"
IF '$GET(DICR)
IF DIC(0)["O"
IF DIC(0)["X"
GOTO SEARCH
+16 IF DINDEX("#")>1
IF '$GET(DICR)
if DIC(0)["L"
Begin DoDot:1
+17 SET Y=-1
IF $GET(DICR)=""
NEW DICR
SET DICR=0
+18 IF $ASCII(X)=34
IF X?.E1""""
DO N^DICM
QUIT
+19 KILL DD
DO L^DICM
QUIT
End DoDot:1
if Y=-1
DO BAD^DIC1
QUIT
+20 DO ^DICM
QUIT
+21 ;
+22 ;
MOREX ; Find more exact matches to lookup value DIX
+1 SET Y=$ORDER(@(DIC_"D,DIX,Y)"))
IF 'Y
SET Y=-1
QUIT
+2 IF $DATA(DIEXACTN)#2
SET DIEXACTN=DIEXACTN+1
+3 DO MN
if '$TEST
QUIT
DO K
if $GET(DS(0))
QUIT
+4 IF DS>1
IF DIC(0)'["E"
IF DIC(0)'["Y"
KILL DS
SET DS=0
SET DS(0)=1
SET Y=-1
+5 QUIT
+6 ;
MN NEW DZ
SET DZ=$SELECT((DIC(0)["D"&(DINDEX="B")):1,$GET(DINDEX("#"))>1:0,$GET(@(DIC_"D,DIX,Y)")):1,1:0)
SET DIYX=0
+1 if '$DATA(DO)
DO GETFA^DIC1(.DIC,.DO)
+2 IF D="B"
IF 'DZ
IF '($DATA(@(DIC_"D,DIX,Y)"))#2)
Begin DoDot:1
+3 NEW I
SET I=Y
FOR
SET DZ=$GET(^(I))
SET I=$ORDER(^(I,0))
if I=""
QUIT
+4 QUIT
End DoDot:1
+5 SET DIY=""
IF '$DATA(@(DIC_"Y,0)"))
XECUTE "I 0"
QUIT
+6 IF D="B"
IF 'DZ
IF '$DATA(DO("SCR"))
IF $LENGTH(DIX)<30
IF '$DATA(DIC("S"))
IF '$DATA(@(DIC_"Y,-9)"))
IF '$GET(DINDEX("OLDSUB"))
DO ADDKEY
IF 1
QUIT
+7 DO S
IF $TEST
Begin DoDot:1
+8 IF DINDEX("FLISTD")["^.01^"
IF DINDEX("#")=1
IF 'DZ
IF $PIECE(DIY,DIX)=""
IF '$GET(DINDEX("OLDSUB"))
Begin DoDot:2
+9 NEW I
SET I=$SELECT($GET(DILONGX):DICR(DILONGX,"ORG"),1:DIX)
+10 SET DIY=$PIECE(DIY,I,2,9)
SET DIYX=1
DO ADDKEY
QUIT
End DoDot:2
QUIT
+11 if DIC(0)["Y"
QUIT
+12 IF ($GET(DINDEX("#"))>1)!($GET(DINDEX("OLDSUB")))
Begin DoDot:2
+13 DO ADDIX^DIC4(.DIFILEI,Y,.DINDEX,.DIX,.DISCREEN)
+14 DO ADDKEY
QUIT
End DoDot:2
QUIT
+15 DO ADDKEY
+16 IF DINDEX("FLISTD")["^.01^"
IF 'DZ
SET DIY=""
+17 QUIT
End DoDot:1
+18 QUIT
+19 ;
S if '$DATA(DO)
DO GETFA^DIC1(.DIC,.DO)
+1 IF $DATA(@(DIC_"Y,0)"))
IF '$DATA(^(-9))
SET DIY=$PIECE(^(0),U)
+2 IF '$TEST
SET DIY=""
QUIT
+3 IF '$DATA(DIC("S"))
IF '$DATA(DO("SCR"))
QUIT
+4 IF $GET(DINDEX("#"))>1!($GET(DINDEX("OLDSUB")))
QUIT
+5 IF $GET(DILONGX)
NEW DI0NODE,DIVAL
Begin DoDot:1
+6 NEW %
SET %=DINDEX(1,"GET")
+7 IF %="DIVAL=DINDEX(DISUB)"
SET DIVAL=X
QUIT
+8 IF %["DI0NODE"
SET DI0NODE=@(DIC_"Y,0)")
+9 NEW DIFILE
SET DIFILE=DIFILEI
SET DIFILE(DIFILE)=DIFILEI(DIFILEI)
+10 NEW DIEN
SET DIEN=Y_DIENS
+11 SET @%
QUIT
End DoDot:1
+12 NEW DIAC,DIFILE,DISAVEX,DISAVEY,DISAVED
+13 MERGE DISAVEX=X,DISAVEY=Y
SET DISAVED=D
IF $DATA(@(DIC_"Y,0)"))
+14 ;*159
IF $DATA(DIVAL(1))
IF $DATA(DIVAL)=10
SET DIVAL=DIVAL(1)
+15 IF 1
if $DATA(DIC("S"))
XECUTE DIC("S")
KILL DIAC,DIFILE
if $DATA(DIC("S"))
DO SX
if '$TEST
QUIT
+16 IF $DATA(DO("SCR"))
IF $DATA(@(DIC_"Y,0)"))
XECUTE DO("SCR")
DO SX
if '$TEST
QUIT
+17 IF 1
QUIT
+18 ;
SX MERGE X=DISAVEX,Y=DISAVEY
SET D=DISAVED
QUIT
+1 ;
ADDKEY ; Put KEY values into output array for display
+1 SET DIX("F")=""
IF DIC(0)'["U"
SET DIX("F")=$GET(DINDEX("FLISTD"))
+2 if '$DATA(DIFILEI(DIFILEI,"KEY"))
QUIT
if DIC(0)["S"
QUIT
+3 NEW DIKX,DII,DIFLD,DIERR,I
+4 MERGE DIKX=DIFILEI(DIFILEI,"KEY",DIFILEI)
if '$DATA(DIKX)
QUIT
+5 KILL DIX("K")
+6 FOR I=0:0
SET I=$ORDER(DIKX(I))
if 'I
QUIT
FOR DIFLD=0:0
SET DIFLD=$ORDER(DIKX(I,DIFLD))
if 'DIFLD
QUIT
Begin DoDot:1
+7 IF DIFLD=.01
IF $GET(DZ)=0
SET DIY=""
+8 SET DIX("K",I,DIFLD)=$$GET1^DIQ(DIFILEI,Y_DIFILEI(DIFILEI,"KEY","IEN"),DIFLD,"","","DIERR")
QUIT
End DoDot:1
+9 QUIT
+10 ;
K ; Put an IEN into the DS array for display
+1 NEW DZ,I
SET DZ=$ORDER(DS(0))
FOR I=DZ:1:DS
IF +$GET(DS(I))=Y
IF DIC(0)'["C"
SET I=-1
QUIT
+2 IF I'=-1
IF DIC(0)["T"
Begin DoDot:1
+3 if '$DATA(^TMP($JOB,"DICSEEN",DIFILEI))
QUIT
+4 IF $DATA(^TMP($JOB,"DICSEEN",DIFILEI,Y))
SET I=-1
QUIT
+5 SET ^TMP($JOB,"DICSEEN",DIFILEI,Y)=""
QUIT
End DoDot:1
+6 IF I=-1
SET I=DIX
KILL DIX
SET DIX=I
SET I=-1
QUIT
+7 IF DS-DZ>100
Begin DoDot:1
+8 NEW D1,D2
SET D2=DZ+19
FOR D1=DZ:1:D2
KILL DS(D1),DIY(D1),DIYX(D1)
+9 QUIT
End DoDot:1
+10 SET DS=DS+1
Begin DoDot:1
+11 SET I=DS
MERGE DS(DS)=DIX
SET DS=I
SET I=DIX
KILL DIX
SET DIX=I
+12 SET DS(DS)=Y_"^"_$PIECE(DIX,X,2,99)
QUIT
End DoDot:1
+13 SET DIY(DS)=DIY
if DIY]""&$GET(DIYX)
SET DIYX(DS)=1
+14 IF DS#5-1!(DS=1)!(DIC(0)["Y")
QUIT
+15 DO Y^DIC1
QUIT
