source: FOIAVistA/trunk/r/RECORD_TRACKING-RT/RTB.m@ 1757

Last change on this file since 1757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.3 KB
Line 
1RTB ;TROY ISC/MJK-Entity Lookup ; 3/31/87 12:10 PM ; 1/30/03 8:34am
2 ;;2.0;Record Tracking;**29,33**;10/22/91
3IN N RTSEC S Y=-1 Q:'$D(^DIC(195.1,RTA,0)) S RTA0=^(0),RTXZ=X
4 I X=" " G Q:'$D(^DISV($S($D(DUZ)'[0:DUZ,1:0),"RT",RTA)) S X=^(RTA) D SPACE^RTB2 G Q
5 I $S(X'?.ANP:1,X[".":0,X["?":1,1:0) S Y=-1 Q
6 S RTX1=X I $E(X,2)="." D FILE G Q:'$D(RTVP) S RTX=$P(RTX1,".",2,99),RTSTUFF=1 D DIC G Q
7 S I=$O(^DD(190,.01,"V","O",0)) I I,'$O(^(I)) S RTVP=+$O(^(I,0)),RTDIC=+^DD(190,.01,"V",RTVP,0) I $D(^DIC(195.1,RTA,"ENTITY","B",RTDIC)) S RTX=RTX1,RTSTUFF=1 D DIC G Q
8 S RTX=RTX1,RTSTUFF=0 F RTO=0:0 S X=RTX S RTO=$O(^DD(190,.01,"V","O",RTO)) Q:'RTO S RTVP=+$O(^(RTO,0)),RTDIC=+^DD(190,.01,"V",RTVP,0) I $D(^DIC(195.1,RTA,"ENTITY","B",RTDIC)) D DIC Q:Y>0!(X="^")
9Q I X'["^",Y<0 W:'$G(RTSEC) !?3,"No match found." S X=RTXZ
10 S:$P(X,";",2)="DPT(" ^DISV($S($D(DUZ)'[0:DUZ,1:0),"^DPT(")=+X
11 K RTXZ,RTVP,F,RTA0,RTSTUFF,RTDIC,RTX,RTX1,RTF1,RTO Q
12 ;
13DIC S X=RTX,Y=-1,F=RTDIC,DIC=^DIC(F,"0","GL"),RTDIC=$E(DIC,2,99)
14 Q:'$D(^DD(190,.01,"V",RTVP,0)) S RTF1=$P(^(0),"^",2),DIC(0)="IEM"_$S($P(^(0),"^",3)="y":"L",1:"") I $P(^(0),"^",5)="y",$D(^(1)) X ^(1)
15 I 'RTSTUFF,DIC(0)["E" W !,"Searching for a ",RTF1," "
16DIC1 D ^DIC I $E(X)="?" S DIC(0)=DIC(0)_"AQ",DIC("A")="Select "_RTF1_": " G DIC1
17 ;
18 ;RT*2*33
19 I RTDIC="DPT(",Y>0,'$G(DICR) D ^DGSEC I Y<0 S RTSEC=1 K DIC Q
20 ;
21 K DIC I Y<0 S:X="" X=RTX Q
22 ;
23 S RTX1=Y G DICQ:RTSTUFF
24 S Y=+Y_";"_RTDIC D NAME S $P(RTX1,"^",2)=Y
25 S RTRD(0)="S",RTRD(1)="Yes^accept as answer",RTRD(2)="No^reject as answer",RTRD("B")=1,RTRD("A")="Do you want the "_RTF1_" '"_$P(RTX1,"^",2)_"' as your answer? " D SET^RTRD K RTRD I $E(X)'="Y" S Y=-1 Q
26DICQ S Y=RTX1,X=+Y_";"_RTDIC,^DISV($S($D(DUZ)'[0:DUZ,1:0),"RT",RTA)=X S:$S('$D(^DIC(195.4,1,"RAD")):0,1:RTA=+^("RAD")) ^DISV($S($D(DUZ)'[0:DUZ,1:0),"^RADPT(")=+X K RTF1,RTX1 Q
27 ;
28BOR S Y=$S($D(^RTV(195.9,+Y,0)):$P(^(0),"^"),1:"UNKNOWN")
29NAME S Z="^"_$P(Y,";",2) I "^DPT(^SC(^VA(200,^DIC(4,^DIC(42,^"[(Z_"^"),$D(@(Z_+Y_",0)")) S Y=$P(^(0),"^") Q
30 S RTDNAM=Y D DNAM S Y=RTDNAM S:Y["MISSING RECORD" Y="*** MISSING ***" K %,RTDNAM K %,RTDNAM Q
31DNAM S RTDNAM=Y Q:'Y S %=$P(Y,";",2),RTDNAM="^"_%_+Y_",0)" S RTDNAM=$S($D(@RTDNAM)#2:$P(^(0),U,1),1:Y),%=$S($D(@("^"_%_"0)")):$P(^(0),U,2),1:"") Q:%=""
32 I %["P"!(%["S")!(%["D") S C=$P(^DD(+%,.01,0),U,2),Y=RTDNAM D Y^DIQ S RTNAM=Y Q
33 Q
34 ;S:$D(DIY) RTZ("DIY")=DIY S DIY=Y D NAME^DICM2 S Y=DINAME K DINAME S:Y["MISSING RECORD" Y="*** MISSING ***" S:$D(RTZ("DIY")) DIY=RTZ("DIY") K RTZ("DIY") Q
35 ;S DINAME=DIY Q:'DIY S %=$P(DIY,";",2),DINAME="^"_%_+DIY_",0)",DINAME=$S($D(@DINAME)#2:$P(^(0),U,1),1:DIY),%=$S($D(@("^"_%_"0)")):$P(^(0),U,2),1:"") Q:%=""
36 ;I %["P"!(%["S")!(%["D") S C=$P(^DD(+%,.01,0),U,2),%YYY=DIY,%YY=Y,Y=DINAME D Y^DIQ S DINAME=Y,DIY=%YYY,Y=%YY,C="," K %YY,%YYY
37 ;
38ASK K RTESC I '$D(^DIC(195.1,RTA,0)) S Y=-1 Q
39 S Y=$S($D(^DIC(195.1,RTA,3)):^(3),1:"") W !!,$S($P(Y,"^",1)]"":$P(Y,"^",1),1:"Enter Selection: ") R X:DTIME I X["^"!(X="") S X="^",Y=-1,RTESC="" Q
40 I $E(X)="?" D ENTITY^RTB2 K RTY G ASK
41 G IN
42 ;
43FILE K RTVP S X=$P(X,"."),DIC("S")="I $D(^DIC(195.1,RTA,""ENTITY"",""B"",+^(0)))",DIC(0)="IM",DIC="^DD(190,.01,""V""," D ^DIC K DIC I Y<0 S X=RTX1 Q
44 S RTVP=+Y,RTDIC=+$P(Y,"^",2) Q
45 ;
46 ;S T=0 F S T=$O(^RTV(195.9,T)) Q:'T S Y=$P(^(T,0),U) D NAME^RTB W !,Y H:'$L(Y) 2 H:Y["***" 1 H:Y["(" 2
47 Q
48 ;S T=0 F S T=$O(^RT(T)) Q:'T S Y=$P(^(T,0),U) D NAME^RTB W !,Y H:'$L(Y) 2 H:Y["***" 1 H:Y["(" 2
49 Q
Note: See TracBrowser for help on using the repository browser.