- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIC3.m
r613 r623 1 DIC3 ;SFISC/XAK,TKW,SEA/TOAD-VA FileMan: Lookup, Part 1 (called from DIC) ;31JUL2007 2 ;;22.0;VA FileMan;**1,16,4,17,20,28,40,86,70,159**;Mar 30, 1999;Build 8 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 SEARCH ; Begin search through x-refs. 6 I DIC(0)["T",'$G(DICR) N:'$D(DICR(1)) DICR S DICR=0 D:DIC(0)["O" 7 . I DIC(0)'["X" S DIC(0)=DIC(0)_"X" Q 8 . S DIC(0)=$TR(DIC(0),"X") Q 9 I X?1"`".NP D ^DICM Q 10 I $L(X)>100,'$G(DILONGX) D ^DICM Q 11 N DIOK,DIEXACTN K % I $G(DISKIPIX)=D K DISKIPIX G M 12 EXACT ; Find all exact matches to the lookup values 13 S DISAVDS=DS,DIEXACTN=0 14 I $G(DILONGX) G:$L(DICR(DICR,"ORG"))'>DINDEX(1,"LENGTH") M D 15 . S (X,X(1),DIVAL,DIVAL(1))=$E(DICR(DICR,"ORG"),1,DINDEX(1,"LENGTH")) Q 16 I DINDEX("#")>1,($G(DIALLVAL)!($G(DICR))),(DIC(0)["X"!(DIC(0)["O")) D EXACT^DIC4,SET^DIC4 17 I DINDEX("#")'>1 S Y=0,DIX=X F D MOREX Q:Y=-1!(DS(0)) 18 I DS(0) Q:DIC(0)'["T" Q:$P(DS(0),U,2)'="U"!($G(DIROUT)) S DS(0)=0 19 I DIC(0)["T",DIC(0)["E",$G(DUOUT) D ;22*70 20 . ; Set up variables for next index lookup 21 . K DS,DUOUT 22 . S (DS,DS(0),DS("DD"))=0 23 . S X=DIVAL(1) 24 . Q 25 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 26 . I DINDEX("#")'>1,DIEXACTN>1,DINDEX'="B" S Y=-1 Q 27 . S Y=+DS(1),DS("DD")=1 28 . I DINDEX("#")'>1,DIEXACTN'>1 S DIY=1 D C^DIC2 Q 29 . D G^DIC2 Q 30 ; 31 PARTIAL ; Find all partial matches to the lookup values 32 I DIC(0)'["X",DINDEX("#")>1 D PARTIAL^DIC4,SET^DIC4 33 I DIC(0)'["X",DINDEX("#")'>1 F D Q:$G(DIX)=""!(DS(0)) 34 . N DITYP S DITYP=$G(DINDEX(1,"TYPE")) 35 . D 36 . . I DIC(0)["E",(DITYP["F"!(DITYP["S")) Q:DIC(0)["n" 37 . . I $TR(X,"-.")?.N,DO(2)'["D",'$D(DIDA) S DIX=$O(@(DIC_"D,DIX_"" "")"),-1) 38 . . Q 39 . S DIX=$O(@(DIC_"D,DIX)")) 40 . Q:DIX="" 41 . I $P(DIX,X)'="" D Q:DIX="" 42 . . I +$P(X,"E")'=X!(DIC(0)'["E") S DIX="" Q 43 . . I DIC(0)'["n"!(DITYP'["F"&(DITYP'["S")) S DIX="" Q 44 . . D FINDMORE^DICLIX0(1,.DIX,X,.DINDEX) 45 . . S:$P(DIX,X)'="" DIX="" Q 46 . S Y=0 F D MOREX Q:Y=-1!(DS(0)) 47 . Q 48 I DS(0) Q:DIC(0)'["T" Q:$P(DS(0),U,2)'="U"!($G(DIROUT)) S DS(0)=0 49 I DIC(0)["T",DIC(0)["E",$G(DUOUT) D ;22*70 50 . ; Set up variables for next index lookup 51 . K DS,DUOUT 52 . S (DS,DS(0),DS("DD"))=0 53 . S X=DIVAL(1) 54 . Q 55 ; 56 M ; Find the next index. At end, display the rest 57 I DIC(0)["T" D KEEPON^DIC5 I DS(0) Q:$P(DS(0),U,2)'="U"!($G(DIROUT)) 58 I DIC(0)["M" S DIOK=0 F D Q:DIOK 59 . N Y S Y=DINDEX("START") K DINDEX S DINDEX("WAY")=1,DINDEX("START")=Y,DINDEX("#")=1 60 . S (D,DINDEX)=$S($D(DID):$P(DID,U,DID(1)),1:$O(@(DIC_"D)"))) 61 . S:$D(DID) DID(1)=DID(1)+1 62 . I D=""!(D=-1) S D="",DIOK=1 Q 63 . I $D(@(DIC_"D)"))-10 Q 64 . ; Check Index, build index info 65 . D IXCHK^DIC4(.DIFILEI,.DINDEX,.DIOK,.DIALLVAL,.DIVAL,$G(DID)) Q 66 I DIC(0)["M",D]"" G EXACT 67 D:DIC(0)["M" D^DIC0 68 I DS=1 S DS("DD")=1 D G^DIC2 Q 69 I DS D Y^DIC1 Q:DS(0) I DINDEX("#")'>1 D:DO(2)["O"&(DO(2)'["A") L^DICM Q 70 I $G(DILONGX) S X=$E(DICR(DICR,"ORG"),1,30) 71 I DIC(0)["T",'$G(DICR),DIC(0)["O",DIC(0)["X" G SEARCH 72 I DINDEX("#")>1,'$G(DICR) D:DIC(0)["L" D:Y=-1 BAD^DIC1 Q 73 . S Y=-1 I $G(DICR)="" N DICR S DICR=0 74 . I $A(X)=34,X?.E1"""" D N^DICM Q 75 . K DD D L^DICM Q 76 D ^DICM Q 77 ; 78 ; 79 MOREX ; Find more exact matches to lookup value DIX 80 S Y=$O(@(DIC_"D,DIX,Y)")) I 'Y S Y=-1 Q 81 I $D(DIEXACTN)#2 S DIEXACTN=DIEXACTN+1 82 D MN Q:'$T D K Q:$G(DS(0)) 83 I DS>1,DIC(0)'["E",DIC(0)'["Y" K DS S DS=0,DS(0)=1,Y=-1 84 Q 85 ; 86 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 87 D:'$D(DO) GETFA^DIC1(.DIC,.DO) 88 I D="B",'DZ,'($D(@(DIC_"D,DIX,Y)"))#2) D 89 . N I S I=Y F S DZ=$G(^(I)),I=$O(^(I,0)) Q:I="" 90 . Q 91 S DIY="" I '$D(@(DIC_"Y,0)")) X "I 0" Q 92 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 93 D S I D 94 . I DINDEX("FLISTD")["^.01^",DINDEX("#")=1,'DZ,$P(DIY,DIX)="",'$G(DINDEX("OLDSUB")) D Q 95 . . N I S I=$S($G(DILONGX):DICR(DICR,"ORG"),1:DIX) 96 . . S DIY=$P(DIY,I,2,9),DIYX=1 D ADDKEY Q 97 . Q:DIC(0)["Y" 98 . I ($G(DINDEX("#"))>1)!($G(DINDEX("OLDSUB"))) D Q 99 . . D ADDIX^DIC4(.DIFILEI,Y,.DINDEX,.DIX,.DISCREEN) 100 . . D ADDKEY Q 101 . D ADDKEY 102 . I DINDEX("FLISTD")["^.01^",'DZ S DIY="" 103 . Q 104 Q 105 ; 106 S D:'$D(DO) GETFA^DIC1(.DIC,.DO) 107 I $D(@(DIC_"Y,0)")),'$D(^(-9)) S DIY=$P(^(0),U) 108 E S DIY="" Q 109 I '$D(DIC("S")),'$D(DO("SCR")) Q 110 I $G(DINDEX("#"))>1!($G(DINDEX("OLDSUB"))) Q 111 I $G(DILONGX) N DI0NODE,DIVAL D 112 . N % S %=DINDEX(1,"GET") 113 . I %="DIVAL=DINDEX(DISUB)" S DIVAL=X Q 114 . I %["DI0NODE" S DI0NODE=@(DIC_"Y,0)") 115 . N DIFILE S DIFILE=DIFILEI,DIFILE(DIFILE)=DIFILEI(DIFILEI) 116 . N DIEN S DIEN=Y_DIENS 117 . S @% Q 118 N DIAC,DIFILE,DISAVEX,DISAVEY,DISAVED 119 M DISAVEX=X,DISAVEY=Y S DISAVED=D I $D(@(DIC_"Y,0)")) 120 I $D(DIVAL(1)),$D(DIVAL)=10 S DIVAL=DIVAL(1) ;*159 121 I 1 X:$D(DIC("S")) DIC("S") K DIAC,DIFILE D:$D(DIC("S")) SX Q:'$T 122 I $D(DO("SCR")),$D(@(DIC_"Y,0)")) X DO("SCR") D SX Q:'$T 123 I 1 Q 124 ; 125 SX M X=DISAVEX,Y=DISAVEY S D=DISAVED Q 126 ; 127 ADDKEY ; Put KEY values into output array for display 128 S DIX("F")="" I DIC(0)'["U" S DIX("F")=$G(DINDEX("FLISTD")) 129 Q:'$D(DIFILEI(DIFILEI,"KEY")) Q:DIC(0)["S" 130 N DIKX,DII,DIFLD,DIERR,I 131 M DIKX=DIFILEI(DIFILEI,"KEY",DIFILEI) Q:'$D(DIKX) 132 K DIX("K") 133 F I=0:0 S I=$O(DIKX(I)) Q:'I F DIFLD=0:0 S DIFLD=$O(DIKX(I,DIFLD)) Q:'DIFLD D 134 . I DIFLD=.01,$G(DZ)=0 S DIY="" 135 . S DIX("K",I,DIFLD)=$$GET1^DIQ(DIFILEI,Y_DIFILEI(DIFILEI,"KEY","IEN"),DIFLD,"","","DIERR") Q 136 Q 137 ; 138 K ; Put an IEN into the DS array for display 139 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 140 I I'=-1,DIC(0)["T" D 141 . Q:'$D(^TMP($J,"DICSEEN",DIFILEI)) 142 . I $D(^TMP($J,"DICSEEN",DIFILEI,Y)) S I=-1 Q 143 . S ^TMP($J,"DICSEEN",DIFILEI,Y)="" Q 144 I I=-1 S I=DIX K DIX S DIX=I,I=-1 Q 145 I DS-DZ>100 D 146 . N D1,D2 S D2=DZ+19 F D1=DZ:1:D2 K DS(D1),DIY(D1),DIYX(D1) 147 . Q 148 S DS=DS+1 D 149 . S I=DS M DS(DS)=DIX S DS=I,I=DIX K DIX S DIX=I 150 . S DS(DS)=Y_"^"_$P(DIX,X,2,99) Q 151 S DIY(DS)=DIY S:DIY]""&$G(DIYX) DIYX(DS)=1 152 I DS#5-1!(DS=1)!(DIC(0)["Y") Q 153 D Y^DIC1 Q 154 ; 155 ; 1 DIC3 ;SFISC/XAK,TKW,SEA/TOAD-VA FileMan: Lookup, Part 1 (called from DIC) ;7:29 AM 23 Sep 2002 2 ;;22.0;VA FileMan;**1,16,4,17,20,28,40,86,70**;Mar 30, 1999 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; 5 SEARCH ; Begin search through x-refs. 6 I DIC(0)["T",'$G(DICR) N:'$D(DICR(1)) DICR S DICR=0 D:DIC(0)["O" 7 . I DIC(0)'["X" S DIC(0)=DIC(0)_"X" Q 8 . S DIC(0)=$TR(DIC(0),"X") Q 9 I X?1"`".NP D ^DICM Q 10 I $L(X)>100,'$G(DILONGX) D ^DICM Q 11 N DIOK,DIEXACTN K % I $G(DISKIPIX)=D K DISKIPIX G M 12 EXACT ; Find all exact matches to the lookup values 13 S DISAVDS=DS,DIEXACTN=0 14 I $G(DILONGX) G:$L(DICR(DICR,"ORG"))'>DINDEX(1,"LENGTH") M D 15 . S (X,X(1),DIVAL,DIVAL(1))=$E(DICR(DICR,"ORG"),1,DINDEX(1,"LENGTH")) Q 16 I DINDEX("#")>1,($G(DIALLVAL)!($G(DICR))),(DIC(0)["X"!(DIC(0)["O")) D EXACT^DIC4,SET^DIC4 17 I DINDEX("#")'>1 S Y=0,DIX=X F D MOREX Q:Y=-1!(DS(0)) 18 I DS(0) Q:DIC(0)'["T" Q:$P(DS(0),U,2)'="U"!($G(DIROUT)) S DS(0)=0 19 I DIC(0)["T",DIC(0)["E",$G(DUOUT) D ;22*70 20 . ; Set up variables for next index lookup 21 . K DS,DUOUT 22 . S (DS,DS(0),DS("DD"))=0 23 . S X=DIVAL(1) 24 . Q 25 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 26 . I DINDEX("#")'>1,DIEXACTN>1,DINDEX'="B" S Y=-1 Q 27 . S Y=+DS(1),DS("DD")=1 28 . I DINDEX("#")'>1,DIEXACTN'>1 S DIY=1 D C^DIC2 Q 29 . D G^DIC2 Q 30 ; 31 PARTIAL ; Find all partial matches to the lookup values 32 I DIC(0)'["X",DINDEX("#")>1 D PARTIAL^DIC4,SET^DIC4 33 I DIC(0)'["X",DINDEX("#")'>1 F D Q:$G(DIX)=""!(DS(0)) 34 . N DITYP S DITYP=$G(DINDEX(1,"TYPE")) 35 . D 36 . . I DIC(0)["E",(DITYP["F"!(DITYP["S")) Q:DIC(0)["n" 37 . . I $TR(X,"-.")?.N,DO(2)'["D",'$D(DIDA) S DIX=$O(@(DIC_"D,DIX_"" "")"),-1) 38 . . Q 39 . S DIX=$O(@(DIC_"D,DIX)")) 40 . Q:DIX="" 41 . I $P(DIX,X)'="" D Q:DIX="" 42 . . I +$P(X,"E")'=X!(DIC(0)'["E") S DIX="" Q 43 . . I DIC(0)'["n"!(DITYP'["F"&(DITYP'["S")) S DIX="" Q 44 . . D FINDMORE^DICLIX0(1,.DIX,X,.DINDEX) 45 . . S:$P(DIX,X)'="" DIX="" Q 46 . S Y=0 F D MOREX Q:Y=-1!(DS(0)) 47 . Q 48 I DS(0) Q:DIC(0)'["T" Q:$P(DS(0),U,2)'="U"!($G(DIROUT)) S DS(0)=0 49 I DIC(0)["T",DIC(0)["E",$G(DUOUT) D ;22*70 50 . ; Set up variables for next index lookup 51 . K DS,DUOUT 52 . S (DS,DS(0),DS("DD"))=0 53 . S X=DIVAL(1) 54 . Q 55 ; 56 M ; Find the next index. At end, display the rest 57 I DIC(0)["T" D KEEPON^DIC5 I DS(0) Q:$P(DS(0),U,2)'="U"!($G(DIROUT)) 58 I DIC(0)["M" S DIOK=0 F D Q:DIOK 59 . N Y S Y=DINDEX("START") K DINDEX S DINDEX("WAY")=1,DINDEX("START")=Y,DINDEX("#")=1 60 . S (D,DINDEX)=$S($D(DID):$P(DID,U,DID(1)),1:$O(@(DIC_"D)"))) 61 . S:$D(DID) DID(1)=DID(1)+1 62 . I D=""!(D=-1) S D="",DIOK=1 Q 63 . I $D(@(DIC_"D)"))-10 Q 64 . ; Check Index, build index info 65 . D IXCHK^DIC4(.DIFILEI,.DINDEX,.DIOK,.DIALLVAL,.DIVAL,$G(DID)) Q 66 I DIC(0)["M",D]"" G EXACT 67 D:DIC(0)["M" D^DIC0 68 I DS=1 S DS("DD")=1 D G^DIC2 Q 69 I DS D Y^DIC1 Q:DS(0) I DINDEX("#")'>1 D:DO(2)["O"&(DO(2)'["A") L^DICM Q 70 I $G(DILONGX) S X=$E(DICR(DICR,"ORG"),1,30) 71 I DIC(0)["T",'$G(DICR),DIC(0)["O",DIC(0)["X" G SEARCH 72 I DINDEX("#")>1,'$G(DICR) D:DIC(0)["L" D:Y=-1 BAD^DIC1 Q 73 . S Y=-1 I $G(DICR)="" N DICR S DICR=0 74 . I $A(X)=34,X?.E1"""" D N^DICM Q 75 . K DD D L^DICM Q 76 D ^DICM Q 77 ; 78 ; 79 MOREX ; Find more exact matches to lookup value DIX 80 S Y=$O(@(DIC_"D,DIX,Y)")) I 'Y S Y=-1 Q 81 I $D(DIEXACTN)#2 S DIEXACTN=DIEXACTN+1 82 D MN Q:'$T D K Q:$G(DS(0)) 83 I DS>1,DIC(0)'["E",DIC(0)'["Y" K DS S DS=0,DS(0)=1,Y=-1 84 Q 85 ; 86 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 87 D:'$D(DO) GETFA^DIC1(.DIC,.DO) 88 I D="B",'DZ,'($D(@(DIC_"D,DIX,Y)"))#2) D 89 . N I S I=Y F S DZ=$G(^(I)),I=$O(^(I,0)) Q:I="" 90 . Q 91 S DIY="" I '$D(@(DIC_"Y,0)")) X "I 0" Q 92 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 93 D S I D 94 . I DINDEX("FLISTD")["^.01^",DINDEX("#")=1,'DZ,$P(DIY,DIX)="",'$G(DINDEX("OLDSUB")) D Q 95 . . N I S I=$S($G(DILONGX):DICR(DICR,"ORG"),1:DIX) 96 . . S DIY=$P(DIY,I,2,9),DIYX=1 D ADDKEY Q 97 . Q:DIC(0)["Y" 98 . I ($G(DINDEX("#"))>1)!($G(DINDEX("OLDSUB"))) D Q 99 . . D ADDIX^DIC4(.DIFILEI,Y,.DINDEX,.DIX,.DISCREEN) 100 . . D ADDKEY Q 101 . D ADDKEY 102 . I DINDEX("FLISTD")["^.01^",'DZ S DIY="" 103 . Q 104 Q 105 ; 106 S D:'$D(DO) GETFA^DIC1(.DIC,.DO) 107 I $D(@(DIC_"Y,0)")),'$D(^(-9)) S DIY=$P(^(0),U) 108 E S DIY="" Q 109 I '$D(DIC("S")),'$D(DO("SCR")) Q 110 I $G(DINDEX("#"))>1!($G(DINDEX("OLDSUB"))) Q 111 I $G(DILONGX) N DI0NODE,DIVAL D 112 . N % S %=DINDEX(1,"GET") 113 . I %="DIVAL=DINDEX(DISUB)" S DIVAL=X Q 114 . I %["DI0NODE" S DI0NODE=@(DIC_"Y,0)") 115 . N DIFILE S DIFILE=DIFILEI,DIFILE(DIFILE)=DIFILEI(DIFILEI) 116 . N DIEN S DIEN=Y_DIENS 117 . S @% Q 118 N DIAC,DIFILE,DISAVEX,DISAVEY,DISAVED 119 M DISAVEX=X,DISAVEY=Y S DISAVED=D I $D(@(DIC_"Y,0)")) 120 I 1 X:$D(DIC("S")) DIC("S") K DIAC,DIFILE D:$D(DIC("S")) SX Q:'$T 121 I $D(DO("SCR")),$D(@(DIC_"Y,0)")) X DO("SCR") D SX Q:'$T 122 I 1 Q 123 ; 124 SX M X=DISAVEX,Y=DISAVEY S D=DISAVED Q 125 ; 126 ADDKEY ; Put KEY values into output array for display 127 S DIX("F")="" I DIC(0)'["U" S DIX("F")=$G(DINDEX("FLISTD")) 128 Q:'$D(DIFILEI(DIFILEI,"KEY")) Q:DIC(0)["S" 129 N DIKX,DII,DIFLD,DIERR,I 130 M DIKX=DIFILEI(DIFILEI,"KEY",DIFILEI) Q:'$D(DIKX) 131 K DIX("K") 132 F I=0:0 S I=$O(DIKX(I)) Q:'I F DIFLD=0:0 S DIFLD=$O(DIKX(I,DIFLD)) Q:'DIFLD D 133 . I DIFLD=.01,$G(DZ)=0 S DIY="" 134 . S DIX("K",I,DIFLD)=$$GET1^DIQ(DIFILEI,Y_DIFILEI(DIFILEI,"KEY","IEN"),DIFLD,"","","DIERR") Q 135 Q 136 ; 137 K ; Put an IEN into the DS array for display 138 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 139 I I'=-1,DIC(0)["T" D 140 . Q:'$D(^TMP($J,"DICSEEN",DIFILEI)) 141 . I $D(^TMP($J,"DICSEEN",DIFILEI,Y)) S I=-1 Q 142 . S ^TMP($J,"DICSEEN",DIFILEI,Y)="" Q 143 I I=-1 S I=DIX K DIX S DIX=I,I=-1 Q 144 I DS-DZ>100 D 145 . N D1,D2 S D2=DZ+19 F D1=DZ:1:D2 K DS(D1),DIY(D1),DIYX(D1) 146 . Q 147 S DS=DS+1 D 148 . S I=DS M DS(DS)=DIX S DS=I,I=DIX K DIX S DIX=I 149 . S DS(DS)=Y_"^"_$P(DIX,X,2,99) Q 150 S DIY(DS)=DIY S:DIY]""&$G(DIYX) DIYX(DS)=1 151 I DS#5-1!(DS=1)!(DIC(0)["Y") Q 152 D Y^DIC1 Q 153 ; 154 ;
Note:
See TracChangeset
for help on using the changeset viewer.
