RTB ;TROY ISC/MJK-Entity Lookup ; 3/31/87 12:10 PM ; 1/30/03 8:34am
;;2.0;Record Tracking;**29,33**;10/22/91
IN N RTSEC S Y=-1 Q:'$D(^DIC(195.1,RTA,0)) S RTA0=^(0),RTXZ=X
I X=" " G Q:'$D(^DISV($S($D(DUZ)'[0:DUZ,1:0),"RT",RTA)) S X=^(RTA) D SPACE^RTB2 G Q
I $S(X'?.ANP:1,X[".":0,X["?":1,1:0) S Y=-1 Q
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
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
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="^")
Q I X'["^",Y<0 W:'$G(RTSEC) !?3,"No match found." S X=RTXZ
S:$P(X,";",2)="DPT(" ^DISV($S($D(DUZ)'[0:DUZ,1:0),"^DPT(")=+X
K RTXZ,RTVP,F,RTA0,RTSTUFF,RTDIC,RTX,RTX1,RTF1,RTO Q
;
DIC S X=RTX,Y=-1,F=RTDIC,DIC=^DIC(F,"0","GL"),RTDIC=$E(DIC,2,99)
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)
I 'RTSTUFF,DIC(0)["E" W !,"Searching for a ",RTF1," "
DIC1 D ^DIC I $E(X)="?" S DIC(0)=DIC(0)_"AQ",DIC("A")="Select "_RTF1_": " G DIC1
;
;RT*2*33
I RTDIC="DPT(",Y>0,'$G(DICR) D ^DGSEC I Y<0 S RTSEC=1 K DIC Q
;
K DIC I Y<0 S:X="" X=RTX Q
;
S RTX1=Y G DICQ:RTSTUFF
S Y=+Y_";"_RTDIC D NAME S $P(RTX1,"^",2)=Y
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
DICQ 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
;
BOR S Y=$S($D(^RTV(195.9,+Y,0)):$P(^(0),"^"),1:"UNKNOWN")
NAME S Z="^"_$P(Y,";",2) I "^DPT(^SC(^VA(200,^DIC(4,^DIC(42,^"[(Z_"^"),$D(@(Z_+Y_",0)")) S Y=$P(^(0),"^") Q
S RTDNAM=Y D DNAM S Y=RTDNAM S:Y["MISSING RECORD" Y="*** MISSING ***" K %,RTDNAM K %,RTDNAM Q
DNAM 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:%=""
I %["P"!(%["S")!(%["D") S C=$P(^DD(+%,.01,0),U,2),Y=RTDNAM D Y^DIQ S RTNAM=Y Q
Q
;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
;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:%=""
;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
;
ASK K RTESC I '$D(^DIC(195.1,RTA,0)) S Y=-1 Q
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
I $E(X)="?" D ENTITY^RTB2 K RTY G ASK
G IN
;
FILE 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
S RTVP=+Y,RTDIC=+$P(Y,"^",2) Q
;
;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
Q
;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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRTB 3464 printed Apr 09, 2024@21:37:04 Page 2
RTB ;TROY ISC/MJK-Entity Lookup ; 3/31/87 12:10 PM ; 1/30/03 8:34am
+1 ;;2.0;Record Tracking;**29,33**;10/22/91
IN NEW RTSEC
SET Y=-1
if '$DATA(^DIC(195.1,RTA,0))
QUIT
SET RTA0=^(0)
SET RTXZ=X
+1 IF X=" "
if '$DATA(^DISV($SELECT($DATA(DUZ)'[0:DUZ,1:0),"RT",RTA))
GOTO Q
SET X=^(RTA)
DO SPACE^RTB2
GOTO Q
+2 IF $SELECT(X'?.ANP:1,X[".":0,X["?":1,1:0)
SET Y=-1
QUIT
+3 SET RTX1=X
IF $EXTRACT(X,2)="."
DO FILE
if '$DATA(RTVP)
GOTO Q
SET RTX=$PIECE(RTX1,".",2,99)
SET RTSTUFF=1
DO DIC
GOTO Q
+4 SET I=$ORDER(^DD(190,.01,"V","O",0))
IF I
IF '$ORDER(^(I))
SET RTVP=+$ORDER(^(I,0))
SET RTDIC=+^DD(190,.01,"V",RTVP,0)
IF $DATA(^DIC(195.1,RTA,"ENTITY","B",RTDIC))
SET RTX=RTX1
SET RTSTUFF=1
DO DIC
GOTO Q
+5 SET RTX=RTX1
SET RTSTUFF=0
FOR RTO=0:0
SET X=RTX
SET RTO=$ORDER(^DD(190,.01,"V","O",RTO))
if 'RTO
QUIT
SET RTVP=+$ORDER(^(RTO,0))
SET RTDIC=+^DD(190,.01,"V",RTVP,0)
IF $DATA(^DIC(195.1,RTA,"ENTITY","B",RTDIC))
DO DIC
if Y>0!(X="^")
QUIT
Q IF X'["^"
IF Y<0
if '$GET(RTSEC)
WRITE !?3,"No match found."
SET X=RTXZ
+1 if $PIECE(X,";",2)="DPT("
SET ^DISV($SELECT($DATA(DUZ)'[0:DUZ,1:0),"^DPT(")=+X
+2 KILL RTXZ,RTVP,F,RTA0,RTSTUFF,RTDIC,RTX,RTX1,RTF1,RTO
QUIT
+3 ;
DIC SET X=RTX
SET Y=-1
SET F=RTDIC
SET DIC=^DIC(F,"0","GL")
SET RTDIC=$EXTRACT(DIC,2,99)
+1 if '$DATA(^DD(190,.01,"V",RTVP,0))
QUIT
SET RTF1=$PIECE(^(0),"^",2)
SET DIC(0)="IEM"_$SELECT($PIECE(^(0),"^",3)="y":"L",1:"")
IF $PIECE(^(0),"^",5)="y"
IF $DATA(^(1))
XECUTE ^(1)
+2 IF 'RTSTUFF
IF DIC(0)["E"
WRITE !,"Searching for a ",RTF1," "
DIC1 DO ^DIC
IF $EXTRACT(X)="?"
SET DIC(0)=DIC(0)_"AQ"
SET DIC("A")="Select "_RTF1_": "
GOTO DIC1
+1 ;
+2 ;RT*2*33
+3 IF RTDIC="DPT("
IF Y>0
IF '$GET(DICR)
DO ^DGSEC
IF Y<0
SET RTSEC=1
KILL DIC
QUIT
+4 ;
+5 KILL DIC
IF Y<0
if X=""
SET X=RTX
QUIT
+6 ;
+7 SET RTX1=Y
if RTSTUFF
GOTO DICQ
+8 SET Y=+Y_";"_RTDIC
DO NAME
SET $PIECE(RTX1,"^",2)=Y
+9 SET RTRD(0)="S"
SET RTRD(1)="Yes^accept as answer"
SET RTRD(2)="No^reject as answer"
SET RTRD("B")=1
SET RTRD("A")="Do you want the "_RTF1_" '"_$PIECE(RTX1,"^",2)_"' as your answer? "
DO SET^RTRD
KILL RTRD
IF $EXTRACT(X)'="Y"
SET Y=-1
QUIT
DICQ SET Y=RTX1
SET X=+Y_";"_RTDIC
SET ^DISV($SELECT($DATA(DUZ)'[0:DUZ,1:0),"RT",RTA)=X
if $SELECT('$DATA(^DIC(195.4,1,"RAD"))
SET ^DISV($SELECT($DATA(DUZ)'[0:DUZ,1:0),"^RADPT(")=+X
KILL RTF1,RTX1
QUIT
+1 ;
BOR SET Y=$SELECT($DATA(^RTV(195.9,+Y,0)):$PIECE(^(0),"^"),1:"UNKNOWN")
NAME SET Z="^"_$PIECE(Y,";",2)
IF "^DPT(^SC(^VA(200,^DIC(4,^DIC(42,^"[(Z_"^")
IF $DATA(@(Z_+Y_",0)"))
SET Y=$PIECE(^(0),"^")
QUIT
+1 SET RTDNAM=Y
DO DNAM
SET Y=RTDNAM
if Y["MISSING RECORD"
SET Y="*** MISSING ***"
KILL %,RTDNAM
KILL %,RTDNAM
QUIT
DNAM SET RTDNAM=Y
if 'Y
QUIT
SET %=$PIECE(Y,";",2)
SET RTDNAM="^"_%_+Y_",0)"
SET RTDNAM=$SELECT($DATA(@RTDNAM)#2:$PIECE(^(0),U,1),1:Y)
SET %=$SELECT($DATA(@("^"_%_"0)")):$PIECE(^(0),U,2),1:"")
if %=""
QUIT
+1 IF %["P"!(%["S")!(%["D")
SET C=$PIECE(^DD(+%,.01,0),U,2)
SET Y=RTDNAM
DO Y^DIQ
SET RTNAM=Y
QUIT
+2 QUIT
+3 ;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
+4 ;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:%=""
+5 ;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
+6 ;
ASK KILL RTESC
IF '$DATA(^DIC(195.1,RTA,0))
SET Y=-1
QUIT
+1 SET Y=$SELECT($DATA(^DIC(195.1,RTA,3)):^(3),1:"")
WRITE !!,$SELECT($PIECE(Y,"^",1)]"":$PIECE(Y,"^",1),1:"Enter Selection: ")
READ X:DTIME
IF X["^"!(X="")
SET X="^"
SET Y=-1
SET RTESC=""
QUIT
+2 IF $EXTRACT(X)="?"
DO ENTITY^RTB2
KILL RTY
GOTO ASK
+3 GOTO IN
+4 ;
FILE KILL RTVP
SET X=$PIECE(X,".")
SET DIC("S")="I $D(^DIC(195.1,RTA,""ENTITY"",""B"",+^(0)))"
SET DIC(0)="IM"
SET DIC="^DD(190,.01,""V"","
DO ^DIC
KILL DIC
IF Y<0
SET X=RTX1
QUIT
+1 SET RTVP=+Y
SET RTDIC=+$PIECE(Y,"^",2)
QUIT
+2 ;
+3 ;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
+4 QUIT
+5 ;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
+6 QUIT
