ADEDCLK ;IHS/HQW/MJL - DICTIONARY ENTRY LOOK-UP UTILITY [ 03/24/1999 8:35 AM ]
;;6.0;ADE;;APRIL 1999
;IHS/HMW RENAMESPACED FROM AUDICLK
N ADEDRNT1,ADEDNT,ADEG,ADEGLL,ADELKH,ADESUB,ADEDNTT,ADEGG,ADELK,ADEDRENT,ADEGGG,ADEPC
L1 N ADEPCC,ADEGL,ADEDENT,ADENEW G END:'$D(DR)!'$D(DIC)!'$D(DA) S ADELK("I")=1,DIC(1)=DIC,DR(1)=DR G END:+DR<.01!(+DIC<1)!(+DA<1)
I $D(^DD(DIC,DR,0)) S ADEG=^DD(DIC,DR,0) G COMP:$P(ADEG,"^",2)["C" I +$P(ADEG,"^",2)>0 S ADELKERR=5 G END
L2 I '$D(^DD(DIC(ADELK("I")),DR(ADELK("I")),0)) S ADELKERR=3 G END
S ADESUB=$P(^DD(DIC(ADELK("I")),DR(ADELK("I")),0),"^",4),ADEPC(ADELK("I"))=$P(ADESUB,";",2),ADESUB(ADELK("I"))=$P(ADESUB,";",1) I '$D(^DD(DIC(ADELK("I")),0,"UP")) G L4
L3 S ADELKERR=4 S:$D(ADEDRNT1) ADEDRENT=0 G END:'$D(ADEDRENT) G END:ADEDRENT'="0"&(+ADEDRENT<0) G END:ADEDRENT\1'=ADEDRENT S:ADEDRENT=0 ADENEW="" K ADELKERR
S ADELK("I")=ADELK("I")+1,DIC(ADELK("I"))=^DD(DIC(ADELK("I")-1),0,"UP"),DR(ADELK("I"))=0,DR(ADELK("I"))=$O(^DD(DIC(ADELK("I")),"SB",DIC(ADELK("I")-1),DR(ADELK("I")))) G L2
L4 S ADEGL=^DIC(DIC(ADELK("I")),0,"GL")_DA,ADEGL(1)=ADEGL_",0)" I '$D(@ADEGL(1)) S ADELKERR=1 G END
I ADELK("I")=1 K:$D(ADEDRENT) ADEDRENT G L5
F ADELK("J")=ADELK("I"):-1:2 S ADEGL=ADEGL_","_ADESUB(ADELK("J")) S:ADELK("J")>2 ADEGL=ADEGL_",1"
L5 S ADEPCC=ADEPC(1) I '$D(ADEDRENT) S ADEDRENT="" G L6
L5A S ADEGL(0)=ADEGL_",0)" I '$D(@ADEGL(0)) S ADELKERR=6,ADEGL=ADEGL_",1,0)" G END
L5B S ADEDENT=$P(@ADEGL(0),"^",4) S:ADEDENT="" ADEDENT=0 I ADEDENT=0!(ADEDRENT>ADEDENT) S ADELKERR=2 G END
L5BB I $D(ADEDRNT1) D DNT4 G L5E:ADEDNT'="" S ADELKERR=2 G END
L5C I ADEDRENT>0 D DNT2 S ADEDRENT=ADEDNT G L5E:ADEDNTT>0 S ADELKERR=2 G END
L5D S ADEGL(0)=ADEGL_",0)" D DNT
L5E S ADEDRENT=","_ADEDRENT
L6 S ADEGL=ADEGL_ADEDRENT_","_ADESUB(1)_")" I ADEGL[",," S ADELKERR=2,ADENEW="" G END
I '$D(@ADEGL) S ADELKERR=2,ADENEW="" G END
L6A S (ADELKPRN,ADELKDAT)=$P(@ADEGL,"^",ADEPC(1)) G END:ADELKPRN=""
L7 S ADEGG=$P(ADEG,"^",2),ADELK("H")=$P(ADEG,"^",3) G SET:ADEGG["S",DATE:ADEGG["D",PTR:ADEGG["P",TRX:$D(^DD(DIC(1),DR(1),2))
END K ADEDRENT,ADEDRNT1,D0,ADEDNT,ADEDNTT,ADELK,ADELKH,ADEGG,ADEGGG,ADEGLL,ADESUB,ADEPC,ADEDENT,ADEG,ADEGL
S:'$D(ADELKPRN)&'$D(ADELKERR) ADELKERR=0
Q
DNT S ADEDNT=0
DNT1 S ADEGLL=ADEGL_",DNT)",ADEDNT=$O(@ADEGLL) Q:ADEDNT'=+ADEDNT S ADEDRENT=ADEDNT G DNT1
DNT2 S (ADEDNT,ADEDNTT)=0
DNT3 S ADEGLL=ADEGL_",DNT)",ADEDNT=$O(@ADEGLL) Q:ADEDNT="" S ADEDNTT=ADEDNTT+1 Q:ADEDNTT=ADEDRENT G DNT3
DNT4 S ADEDNT=0
DNT5 S ADEGLL=ADEGL_",DNT)",ADEDNT=$O(@ADEGLL) Q:ADEDNT="" S:ADEDNT=ADEDRNT1 ADEDRENT=ADEDNT Q:ADEDRENT=ADEDNT G DNT5
SET F ADELK("I")=1:1 S ADEGGG=$P(ADELK("H"),";",ADELK("I")) G END:ADEGGG="" S:$P(ADEGGG,":",1)=ADELKDAT ADELKPRN=$P(ADEGGG,":",2)
G END
DATE S Y=ADELKDAT X ^DD("DD") S ADELKPRN=Y G END
PTR S ADEGGG="^"_ADELK("H")_ADELKDAT_",0)" I '$D(@ADEGGG) S ADELKERR=7 G END
S ADELKPRN=$P(@ADEGGG,"^",1) G END
COMP S ADELKH=$E($P(ADEG,";",2),3,999),D0=DA X ADELKH S ADELKPRN=X G END
TRX S Y=ADELKDAT X ^DD(DIC(1),DR(1),2) S ADELKPRN=Y G END
ADEDCLK ;IHS/HQW/MJL - DICTIONARY ENTRY LOOK-UP UTILITY [ 03/24/1999 8:35 AM ]
+1 ;;6.0;ADE;;APRIL 1999
+2 ;IHS/HMW RENAMESPACED FROM AUDICLK
+3 NEW ADEDRNT1,ADEDNT,ADEG,ADEGLL,ADELKH,ADESUB,ADEDNTT,ADEGG,ADELK,ADEDRENT,ADEGGG,ADEPC
L1 NEW ADEPCC,ADEGL,ADEDENT,ADENEW
IF '$DATA(DR)!'$DATA(DIC)!'$DATA(DA)
GOTO END
SET ADELK("I")=1
SET DIC(1)=DIC
SET DR(1)=DR
IF +DR<.01!(+DIC<1)!(+DA<1)
GOTO END
+1 IF $DATA(^DD(DIC,DR,0))
SET ADEG=^DD(DIC,DR,0)
IF $PIECE(ADEG,"^",2)["C"
GOTO COMP
IF +$PIECE(ADEG,"^",2)>0
SET ADELKERR=5
GOTO END
L2 IF '$DATA(^DD(DIC(ADELK("I")),DR(ADELK("I")),0))
SET ADELKERR=3
GOTO END
+1 SET ADESUB=$PIECE(^DD(DIC(ADELK("I")),DR(ADELK("I")),0),"^",4)
SET ADEPC(ADELK("I"))=$PIECE(ADESUB,";",2)
SET ADESUB(ADELK("I"))=$PIECE(ADESUB,";",1)
IF '$DATA(^DD(DIC(ADELK("I")),0,"UP"))
GOTO L4
L3 SET ADELKERR=4
IF $DATA(ADEDRNT1)
SET ADEDRENT=0
IF '$DATA(ADEDRENT)
GOTO END
IF ADEDRENT'="0"&(+ADEDRENT<0)
GOTO END
IF ADEDRENT\1'=ADEDRENT
GOTO END
IF ADEDRENT=0
SET ADENEW=""
KILL ADELKERR
+1 SET ADELK("I")=ADELK("I")+1
SET DIC(ADELK("I"))=^DD(DIC(ADELK("I")-1),0,"UP")
SET DR(ADELK("I"))=0
SET DR(ADELK("I"))=$ORDER(^DD(DIC(ADELK("I")),"SB",DIC(ADELK("I")-1),DR(ADELK("I"))))
GOTO L2
L4 SET ADEGL=^DIC(DIC(ADELK("I")),0,"GL")_DA
SET ADEGL(1)=ADEGL_",0)"
IF '$DATA(@ADEGL(1))
SET ADELKERR=1
GOTO END
+1 IF ADELK("I")=1
IF $DATA(ADEDRENT)
KILL ADEDRENT
GOTO L5
+2 FOR ADELK("J")=ADELK("I"):-1:2
SET ADEGL=ADEGL_","_ADESUB(ADELK("J"))
IF ADELK("J")>2
SET ADEGL=ADEGL_",1"
L5 SET ADEPCC=ADEPC(1)
IF '$DATA(ADEDRENT)
SET ADEDRENT=""
GOTO L6
L5A SET ADEGL(0)=ADEGL_",0)"
IF '$DATA(@ADEGL(0))
SET ADELKERR=6
SET ADEGL=ADEGL_",1,0)"
GOTO END
L5B SET ADEDENT=$PIECE(@ADEGL(0),"^",4)
IF ADEDENT=""
SET ADEDENT=0
IF ADEDENT=0!(ADEDRENT>ADEDENT)
SET ADELKERR=2
GOTO END
L5BB IF $DATA(ADEDRNT1)
DO DNT4
IF ADEDNT'=""
GOTO L5E
SET ADELKERR=2
GOTO END
L5C IF ADEDRENT>0
DO DNT2
SET ADEDRENT=ADEDNT
IF ADEDNTT>0
GOTO L5E
SET ADELKERR=2
GOTO END
L5D SET ADEGL(0)=ADEGL_",0)"
DO DNT
L5E SET ADEDRENT=","_ADEDRENT
L6 SET ADEGL=ADEGL_ADEDRENT_","_ADESUB(1)_")"
IF ADEGL[",,"
SET ADELKERR=2
SET ADENEW=""
GOTO END
+1 IF '$DATA(@ADEGL)
SET ADELKERR=2
SET ADENEW=""
GOTO END
L6A SET (ADELKPRN,ADELKDAT)=$PIECE(@ADEGL,"^",ADEPC(1))
IF ADELKPRN=""
GOTO END
L7 SET ADEGG=$PIECE(ADEG,"^",2)
SET ADELK("H")=$PIECE(ADEG,"^",3)
IF ADEGG["S"
GOTO SET
IF ADEGG["D"
GOTO DATE
IF ADEGG["P"
GOTO PTR
IF $DATA(^DD(DIC(1),DR(1),2))
GOTO TRX
END KILL ADEDRENT,ADEDRNT1,D0,ADEDNT,ADEDNTT,ADELK,ADELKH,ADEGG,ADEGGG,ADEGLL,ADESUB,ADEPC,ADEDENT,ADEG,ADEGL
+1 IF '$DATA(ADELKPRN)&'$DATA(ADELKERR)
SET ADELKERR=0
+2 QUIT
DNT SET ADEDNT=0
DNT1 SET ADEGLL=ADEGL_",DNT)"
SET ADEDNT=$ORDER(@ADEGLL)
IF ADEDNT'=+ADEDNT
QUIT
SET ADEDRENT=ADEDNT
GOTO DNT1
DNT2 SET (ADEDNT,ADEDNTT)=0
DNT3 SET ADEGLL=ADEGL_",DNT)"
SET ADEDNT=$ORDER(@ADEGLL)
IF ADEDNT=""
QUIT
SET ADEDNTT=ADEDNTT+1
IF ADEDNTT=ADEDRENT
QUIT
GOTO DNT3
DNT4 SET ADEDNT=0
DNT5 SET ADEGLL=ADEGL_",DNT)"
SET ADEDNT=$ORDER(@ADEGLL)
IF ADEDNT=""
QUIT
IF ADEDNT=ADEDRNT1
SET ADEDRENT=ADEDNT
IF ADEDRENT=ADEDNT
QUIT
GOTO DNT5
SET FOR ADELK("I")=1:1
SET ADEGGG=$PIECE(ADELK("H"),";",ADELK("I"))
IF ADEGGG=""
GOTO END
IF $PIECE(ADEGGG,"
SET ADELKPRN=$PIECE(ADEGGG,":",2)
+1 GOTO END
DATE SET Y=ADELKDAT
XECUTE ^DD("DD")
SET ADELKPRN=Y
GOTO END
PTR SET ADEGGG="^"_ADELK("H")_ADELKDAT_",0)"
IF '$DATA(@ADEGGG)
SET ADELKERR=7
GOTO END
+1 SET ADELKPRN=$PIECE(@ADEGGG,"^",1)
GOTO END
COMP SET ADELKH=$EXTRACT($PIECE(ADEG,";",2),3,999)
SET D0=DA
XECUTE ADELKH
SET ADELKPRN=X
GOTO END
TRX SET Y=ADELKDAT
XECUTE ^DD(DIC(1),DR(1),2)
SET ADELKPRN=Y
GOTO END
