AUPNFMLK ; IHS/CMI/LAB - DICTIONARY ENTRY LOOK-UP UTILITY (FILE MANAGER COMPATIBLE) ;
;;99.1;IHS DICTIONARIES (PATIENT);;MAR 09, 1999
L1 S:$D(D0) LKD0=D0 S:$D(X) LKX=X S:$D(Y)#2 LKY=Y K LKPCC,LKPRINT,LKDATA,LKERR,LKGL,LKDENT,LKNEW G END:'$D(LKDR)!'$D(LKDIC)!'$D(LKDA) S LK("I")=1,LKDIC(1)=LKDIC,LKDR(1)=LKDR G END:+LKDR<.01!(+LKDIC<1)!(+LKDA<1)
S:$D(^DD(LKDIC,LKDR,0)) LKG=^DD(LKDIC,LKDR,0) G COMP:$P(LKG,"^",2)["C" I +$P(LKG,"^",2)>0 S LKERR=5 G END
L2 I '$D(^DD(LKDIC(LK("I")),LKDR(LK("I")),0)) S LKERR=3 G END
S LKSUB=$P(^DD(LKDIC(LK("I")),LKDR(LK("I")),0),"^",4),LKPC(LK("I"))=$P(LKSUB,";",2),LKSUB(LK("I"))=$P(LKSUB,";",1) I '$D(^DD(LKDIC(LK("I")),0,"UP")) G L4
L3 S LKERR=4 S:$D(LKDRENT1) LKDRENT=0 G END:'$D(LKDRENT) G END:LKDRENT'="0"&(+LKDRENT<0) G END:LKDRENT\1'=LKDRENT S:LKDRENT=0 LKNEW="" K LKERR
S LK("I")=LK("I")+1,LKDIC(LK("I"))=^DD(LKDIC(LK("I")-1),0,"UP"),LKDR(LK("I"))=0,LKDR(LK("I"))=$O(^DD(LKDIC(LK("I")),"SB",LKDIC(LK("I")-1),LKDR(LK("I")))) G L2
L4 S LKGL=^DIC(LKDIC(LK("I")),0,"GL")_LKDA,LKGL(1)=LKGL_",0)" I '$D(@LKGL(1)) S LKERR=1 G END
I LK("I")=1 K:$D(LKDRENT) LKDRENT G L5
F LK("J")=LK("I"):-1:2 S LKGL=LKGL_","_LKSUB(LK("J")) S:LK("J")>2 LKGL=LKGL_",1"
L5 S LKPCC=LKPC(1) I '$D(LKDRENT) S LKDRENT="" G L6
L5A S LKGL(0)=LKGL_",0)" I '$D(@LKGL(0)) S LKERR=6,LKGL=LKGL_",1,0)" G END
L5B S LKDENT=$P(@LKGL(0),"^",4) S:LKDENT="" LKDENT=0 I LKDENT=0!(LKDRENT>LKDENT) S LKERR=2 G END
L5BB I $D(LKDRENT1) D DNT4 G L5E:LKDNT'="" S LKERR=2 G END
L5C I LKDRENT>0 D DNT2 S LKDRENT=LKDNT G L5E:LKDNTT>0 S LKERR=2 G END
L5D S LKGL(0)=LKGL_",0)" D DNT
L5E S LKDRENT=","_LKDRENT
L6 S LKGL=LKGL_LKDRENT_","_LKSUB(1)_")" I LKGL[",," S LKERR=2,LKNEW="" G END
I '$D(@LKGL) S LKERR=2,LKNEW="" G END
L6A S (LKPRINT,LKDATA)=$P(@LKGL,"^",LKPC(1)) G END:LKPRINT=""
L7 S LKGG=$P(LKG,"^",2),LK("H")=$P(LKG,"^",3) G SET:LKGG["S",DATE:LKGG["D",PTR:LKGG["P",COMP:LKGG["C",TRX:$D(^DD(LKDIC(1),LKDR(1),2))
END S:$D(LKD0) D0=LKD0 S:$D(LKX) X=LKX S:$D(LKY) Y=LKY K LKDIC,LKNEW,LKD0,LKX,LKY,LKDRENT,LKDRENT1,LKDNT,LKDNTT,LK,LKH,LKGG,LKGGG,LKGLL,LKSUB,LKPC,LKDR,LKDA S:'$D(LKPRINT)&'$D(LKERR) LKERR=0 Q
DNT S LKDNT=0
DNT1 S LKGLL=LKGL_",LKDNT)",LKDNT=$O(@LKGLL) Q:LKDNT="" S LKDRENT=LKDNT G DNT1
DNT2 S (LKDNT,LKDNTT)=0
DNT3 S LKGLL=LKGL_",LKDNT)",LKDNT=$O(@LKGLL) Q:LKDNT="" S LKDNTT=LKDNTT+1 Q:LKDNTT=LKDRENT G DNT3
DNT4 S LKDNT=0
DNT5 S LKGLL=LKGL_",LKDNT)",LKDNT=$O(@LKGLL) Q:LKDNT="" S:LKDNT=LKDRENT1 LKDRENT=LKDNT Q:LKDRENT=LKDNT G DNT5
SET F LK("I")=1:1 S LKGGG=$P(LK("H"),";",LK("I")) G END:LKGGG="" S:$P(LKGGG,":",1)=LKDATA LKPRINT=$P(LKGGG,":",2)
G END
DATE S Y=LKDATA X ^DD("DD") S LKPRINT=Y G END
PTR S LKGGG="^"_LK("H")_LKDATA_",0)" I '$D(@LKGGG) S LKERR=7 G END
S LKPRINT=$P(@LKGGG,"^",1) G END
COMP S LKH=$E($P(LKG,";",2),3,999),D0=LKDA X LKH S LKPRINT=X G END
TRX S Y=LKDATA X ^DD(LKDIC(1),LKDR(1),2) S LKPRINT=X G END
AUPNFMLK ; IHS/CMI/LAB - DICTIONARY ENTRY LOOK-UP UTILITY (FILE MANAGER COMPATIBLE) ;
+1 ;;99.1;IHS DICTIONARIES (PATIENT);;MAR 09, 1999
L1 IF $DATA(D0)
SET LKD0=D0
IF $DATA(X)
SET LKX=X
IF $DATA(Y)#2
SET LKY=Y
KILL LKPCC,LKPRINT,LKDATA,LKERR,LKGL,LKDENT,LKNEW
IF '$DATA(LKDR)!'$DATA(LKDIC)!'$DATA(LKDA)
GOTO END
SET LK("I")=1
SET LKDIC(1)=LKDIC
SET LKDR(1)=LKDR
IF +LKDR<.01!(+LKDIC<1)!(+LKDA<1)
GOTO END
+1 IF $DATA(^DD(LKDIC,LKDR,0))
SET LKG=^DD(LKDIC,LKDR,0)
IF $PIECE(LKG,"^",2)["C"
GOTO COMP
IF +$PIECE(LKG,"^",2)>0
SET LKERR=5
GOTO END
L2 IF '$DATA(^DD(LKDIC(LK("I")),LKDR(LK("I")),0))
SET LKERR=3
GOTO END
+1 SET LKSUB=$PIECE(^DD(LKDIC(LK("I")),LKDR(LK("I")),0),"^",4)
SET LKPC(LK("I"))=$PIECE(LKSUB,";",2)
SET LKSUB(LK("I"))=$PIECE(LKSUB,";",1)
IF '$DATA(^DD(LKDIC(LK("I")),0,"UP"))
GOTO L4
L3 SET LKERR=4
IF $DATA(LKDRENT1)
SET LKDRENT=0
IF '$DATA(LKDRENT)
GOTO END
IF LKDRENT'="0"&(+LKDRENT<0)
GOTO END
IF LKDRENT\1'=LKDRENT
GOTO END
IF LKDRENT=0
SET LKNEW=""
KILL LKERR
+1 SET LK("I")=LK("I")+1
SET LKDIC(LK("I"))=^DD(LKDIC(LK("I")-1),0,"UP")
SET LKDR(LK("I"))=0
SET LKDR(LK("I"))=$ORDER(^DD(LKDIC(LK("I")),"SB",LKDIC(LK("I")-1),LKDR(LK("I"))))
GOTO L2
L4 SET LKGL=^DIC(LKDIC(LK("I")),0,"GL")_LKDA
SET LKGL(1)=LKGL_",0)"
IF '$DATA(@LKGL(1))
SET LKERR=1
GOTO END
+1 IF LK("I")=1
IF $DATA(LKDRENT)
KILL LKDRENT
GOTO L5
+2 FOR LK("J")=LK("I"):-1:2
SET LKGL=LKGL_","_LKSUB(LK("J"))
IF LK("J")>2
SET LKGL=LKGL_",1"
L5 SET LKPCC=LKPC(1)
IF '$DATA(LKDRENT)
SET LKDRENT=""
GOTO L6
L5A SET LKGL(0)=LKGL_",0)"
IF '$DATA(@LKGL(0))
SET LKERR=6
SET LKGL=LKGL_",1,0)"
GOTO END
L5B SET LKDENT=$PIECE(@LKGL(0),"^",4)
IF LKDENT=""
SET LKDENT=0
IF LKDENT=0!(LKDRENT>LKDENT)
SET LKERR=2
GOTO END
L5BB IF $DATA(LKDRENT1)
DO DNT4
IF LKDNT'=""
GOTO L5E
SET LKERR=2
GOTO END
L5C IF LKDRENT>0
DO DNT2
SET LKDRENT=LKDNT
IF LKDNTT>0
GOTO L5E
SET LKERR=2
GOTO END
L5D SET LKGL(0)=LKGL_",0)"
DO DNT
L5E SET LKDRENT=","_LKDRENT
L6 SET LKGL=LKGL_LKDRENT_","_LKSUB(1)_")"
IF LKGL[",,"
SET LKERR=2
SET LKNEW=""
GOTO END
+1 IF '$DATA(@LKGL)
SET LKERR=2
SET LKNEW=""
GOTO END
L6A SET (LKPRINT,LKDATA)=$PIECE(@LKGL,"^",LKPC(1))
IF LKPRINT=""
GOTO END
L7 SET LKGG=$PIECE(LKG,"^",2)
SET LK("H")=$PIECE(LKG,"^",3)
IF LKGG["S"
GOTO SET
IF LKGG["D"
GOTO DATE
IF LKGG["P"
GOTO PTR
IF LKGG["C"
GOTO COMP
IF $DATA(^DD(LKDIC(1),LKDR(1),2))
GOTO TRX
END IF $DATA(LKD0)
SET D0=LKD0
IF $DATA(LKX)
SET X=LKX
IF $DATA(LKY)
SET Y=LKY
KILL LKDIC,LKNEW,LKD0,LKX,LKY,LKDRENT,LKDRENT1,LKDNT,LKDNTT,LK,LKH,LKGG,LKGGG,LKGLL,LKSUB,LKPC,LKDR,LKDA
IF '$DATA(LKPRINT)&'$DATA(LKERR)
SET LKERR=0
QUIT
DNT SET LKDNT=0
DNT1 SET LKGLL=LKGL_",LKDNT)"
SET LKDNT=$ORDER(@LKGLL)
IF LKDNT=""
QUIT
SET LKDRENT=LKDNT
GOTO DNT1
DNT2 SET (LKDNT,LKDNTT)=0
DNT3 SET LKGLL=LKGL_",LKDNT)"
SET LKDNT=$ORDER(@LKGLL)
IF LKDNT=""
QUIT
SET LKDNTT=LKDNTT+1
IF LKDNTT=LKDRENT
QUIT
GOTO DNT3
DNT4 SET LKDNT=0
DNT5 SET LKGLL=LKGL_",LKDNT)"
SET LKDNT=$ORDER(@LKGLL)
IF LKDNT=""
QUIT
IF LKDNT=LKDRENT1
SET LKDRENT=LKDNT
IF LKDRENT=LKDNT
QUIT
GOTO DNT5
SET FOR LK("I")=1:1
SET LKGGG=$PIECE(LK("H"),";",LK("I"))
IF LKGGG=""
GOTO END
IF $PIECE(LKGGG,"
SET LKPRINT=$PIECE(LKGGG,":",2)
+1 GOTO END
DATE SET Y=LKDATA
XECUTE ^DD("DD")
SET LKPRINT=Y
GOTO END
PTR SET LKGGG="^"_LK("H")_LKDATA_",0)"
IF '$DATA(@LKGGG)
SET LKERR=7
GOTO END
+1 SET LKPRINT=$PIECE(@LKGGG,"^",1)
GOTO END
COMP SET LKH=$EXTRACT($PIECE(LKG,";",2),3,999)
SET D0=LKDA
XECUTE LKH
SET LKPRINT=X
GOTO END
TRX SET Y=LKDATA
XECUTE ^DD(LKDIC(1),LKDR(1),2)
SET LKPRINT=X
GOTO END
