- 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
