- 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 Feb 19, 2025@00:11:35 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
