ASDZAGE ; IHS/DSD/ENM - DICTIONARY ENTRY LOOK-UP UTILITY [ 03/25/1999 11:48 AM ]
;;5.0;IHS SCHEDULING;; MAR 25, 1999
;Original Routine = AUDICLK called by AGE()^ASDAIU
;IHS-OKLA CITY AREA OFFICE-LMD
L1 K PCC,LKPRINT,LKDATA,LKERR,GL,DENT,NEW G END:'$D(DR)!'$D(DIC)!'$D(DA) S LK("I")=1,DIC(1)=DIC,DR(1)=DR G END:+DR<.01!(+DIC<1)!(+DA<1)
I $D(^DD(DIC,DR,0)) S G=^DD(DIC,DR,0) G COMP:$P(G,"^",2)["C" I +$P(G,"^",2)>0 S LKERR=5 G END
L2 I '$D(^DD(DIC(LK("I")),DR(LK("I")),0)) S LKERR=3 G END
S SUB=$P(^DD(DIC(LK("I")),DR(LK("I")),0),"^",4),PC(LK("I"))=$P(SUB,";",2),SUB(LK("I"))=$P(SUB,";",1) I '$D(^DD(DIC(LK("I")),0,"UP")) G L4
L3 S LKERR=4 S:$D(DRENT1) DRENT=0 G END:'$D(DRENT) G END:DRENT'="0"&(+DRENT<0) G END:DRENT\1'=DRENT S:DRENT=0 NEW="" K LKERR
S LK("I")=LK("I")+1,DIC(LK("I"))=^DD(DIC(LK("I")-1),0,"UP"),DR(LK("I"))=0,DR(LK("I"))=$O(^DD(DIC(LK("I")),"SB",DIC(LK("I")-1),DR(LK("I")))) G L2
L4 S GL=^DIC(DIC(LK("I")),0,"GL")_DA,GL(1)=GL_",0)" I '$D(@GL(1)) S LKERR=1 G END
I LK("I")=1 K:$D(DRENT) DRENT G L5
F LK("J")=LK("I"):-1:2 S GL=GL_","_SUB(LK("J")) S:LK("J")>2 GL=GL_",1"
L5 S PCC=PC(1) I '$D(DRENT) S DRENT="" G L6
L5A S GL(0)=GL_",0)" I '$D(@GL(0)) S LKERR=6,GL=GL_",1,0)" G END
L5B S DENT=$P(@GL(0),"^",4) S:DENT="" DENT=0 I DENT=0!(DRENT>DENT) S LKERR=2 G END
L5BB I $D(DRENT1) D DNT4 G L5E:DNT'="" S LKERR=2 G END
L5C I DRENT>0 D DNT2 S DRENT=DNT G L5E:DNTT>0 S LKERR=2 G END
L5D S GL(0)=GL_",0)" D DNT
L5E S DRENT=","_DRENT
L6 S GL=GL_DRENT_","_SUB(1)_")" I GL[",," S LKERR=2,NEW="" G END
I '$D(@GL) S LKERR=2,NEW="" G END
L6A S (LKPRINT,LKDATA)=$P(@GL,"^",PC(1)) G END:LKPRINT=""
L7 S GG=$P(G,"^",2),LK("H")=$P(G,"^",3) G SET:GG["S",DATE:GG["D",PTR:GG["P",TRX:$D(^DD(DIC(1),DR(1),2))
END K DRENT,DRENT1,D0,DNT,DNTT,LK,LKH,GG,GGG,GLL,SUB,PC S:'$D(LKPRINT)&'$D(LKERR) LKERR=0 Q
DNT S DNT=0
DNT1 S GLL=GL_",DNT)",DNT=$O(@GLL) Q:DNT'=+DNT S DRENT=DNT G DNT1
DNT2 S (DNT,DNTT)=0
DNT3 S GLL=GL_",DNT)",DNT=$O(@GLL) Q:DNT="" S DNTT=DNTT+1 Q:DNTT=DRENT G DNT3
DNT4 S DNT=0
DNT5 S GLL=GL_",DNT)",DNT=$O(@GLL) Q:DNT="" S:DNT=DRENT1 DRENT=DNT Q:DRENT=DNT G DNT5
SET F LK("I")=1:1 S GGG=$P(LK("H"),";",LK("I")) G END:GGG="" S:$P(GGG,":",1)=LKDATA LKPRINT=$P(GGG,":",2)
G END
DATE S Y=LKDATA X ^DD("DD") S LKPRINT=Y G END
PTR S GGG="^"_LK("H")_LKDATA_",0)" I '$D(@GGG) S LKERR=7 G END
S LKPRINT=$P(@GGG,"^",1) G END
COMP S LKH=$E($P(G,";",2),3,999),D0=DA X LKH S LKPRINT=X G END
TRX S Y=LKDATA X ^DD(DIC(1),DR(1),2) S LKPRINT=Y G END
ASDZAGE ; IHS/DSD/ENM - DICTIONARY ENTRY LOOK-UP UTILITY [ 03/25/1999 11:48 AM ]
+1 ;;5.0;IHS SCHEDULING;; MAR 25, 1999
+2 ;Original Routine = AUDICLK called by AGE()^ASDAIU
+3 ;IHS-OKLA CITY AREA OFFICE-LMD
L1 KILL PCC,LKPRINT,LKDATA,LKERR,GL,DENT,NEW
IF '$DATA(DR)!'$DATA(DIC)!'$DATA(DA)
GOTO END
SET LK("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 G=^DD(DIC,DR,0)
IF $PIECE(G,"^",2)["C"
GOTO COMP
IF +$PIECE(G,"^",2)>0
SET LKERR=5
GOTO END
L2 IF '$DATA(^DD(DIC(LK("I")),DR(LK("I")),0))
SET LKERR=3
GOTO END
+1 SET SUB=$PIECE(^DD(DIC(LK("I")),DR(LK("I")),0),"^",4)
SET PC(LK("I"))=$PIECE(SUB,";",2)
SET SUB(LK("I"))=$PIECE(SUB,";",1)
IF '$DATA(^DD(DIC(LK("I")),0,"UP"))
GOTO L4
L3 SET LKERR=4
IF $DATA(DRENT1)
SET DRENT=0
IF '$DATA(DRENT)
GOTO END
IF DRENT'="0"&(+DRENT<0)
GOTO END
IF DRENT\1'=DRENT
GOTO END
IF DRENT=0
SET NEW=""
KILL LKERR
+1 SET LK("I")=LK("I")+1
SET DIC(LK("I"))=^DD(DIC(LK("I")-1),0,"UP")
SET DR(LK("I"))=0
SET DR(LK("I"))=$ORDER(^DD(DIC(LK("I")),"SB",DIC(LK("I")-1),DR(LK("I"))))
GOTO L2
L4 SET GL=^DIC(DIC(LK("I")),0,"GL")_DA
SET GL(1)=GL_",0)"
IF '$DATA(@GL(1))
SET LKERR=1
GOTO END
+1 IF LK("I")=1
IF $DATA(DRENT)
KILL DRENT
GOTO L5
+2 FOR LK("J")=LK("I"):-1:2
SET GL=GL_","_SUB(LK("J"))
IF LK("J")>2
SET GL=GL_",1"
L5 SET PCC=PC(1)
IF '$DATA(DRENT)
SET DRENT=""
GOTO L6
L5A SET GL(0)=GL_",0)"
IF '$DATA(@GL(0))
SET LKERR=6
SET GL=GL_",1,0)"
GOTO END
L5B SET DENT=$PIECE(@GL(0),"^",4)
IF DENT=""
SET DENT=0
IF DENT=0!(DRENT>DENT)
SET LKERR=2
GOTO END
L5BB IF $DATA(DRENT1)
DO DNT4
IF DNT'=""
GOTO L5E
SET LKERR=2
GOTO END
L5C IF DRENT>0
DO DNT2
SET DRENT=DNT
IF DNTT>0
GOTO L5E
SET LKERR=2
GOTO END
L5D SET GL(0)=GL_",0)"
DO DNT
L5E SET DRENT=","_DRENT
L6 SET GL=GL_DRENT_","_SUB(1)_")"
IF GL[",,"
SET LKERR=2
SET NEW=""
GOTO END
+1 IF '$DATA(@GL)
SET LKERR=2
SET NEW=""
GOTO END
L6A SET (LKPRINT,LKDATA)=$PIECE(@GL,"^",PC(1))
IF LKPRINT=""
GOTO END
L7 SET GG=$PIECE(G,"^",2)
SET LK("H")=$PIECE(G,"^",3)
IF GG["S"
GOTO SET
IF GG["D"
GOTO DATE
IF GG["P"
GOTO PTR
IF $DATA(^DD(DIC(1),DR(1),2))
GOTO TRX
END KILL DRENT,DRENT1,D0,DNT,DNTT,LK,LKH,GG,GGG,GLL,SUB,PC
IF '$DATA(LKPRINT)&'$DATA(LKERR)
SET LKERR=0
QUIT
DNT SET DNT=0
DNT1 SET GLL=GL_",DNT)"
SET DNT=$ORDER(@GLL)
IF DNT'=+DNT
QUIT
SET DRENT=DNT
GOTO DNT1
DNT2 SET (DNT,DNTT)=0
DNT3 SET GLL=GL_",DNT)"
SET DNT=$ORDER(@GLL)
IF DNT=""
QUIT
SET DNTT=DNTT+1
IF DNTT=DRENT
QUIT
GOTO DNT3
DNT4 SET DNT=0
DNT5 SET GLL=GL_",DNT)"
SET DNT=$ORDER(@GLL)
IF DNT=""
QUIT
IF DNT=DRENT1
SET DRENT=DNT
IF DRENT=DNT
QUIT
GOTO DNT5
SET FOR LK("I")=1:1
SET GGG=$PIECE(LK("H"),";",LK("I"))
IF GGG=""
GOTO END
IF $PIECE(GGG,"
SET LKPRINT=$PIECE(GGG,":",2)
+1 GOTO END
DATE SET Y=LKDATA
XECUTE ^DD("DD")
SET LKPRINT=Y
GOTO END
PTR SET GGG="^"_LK("H")_LKDATA_",0)"
IF '$DATA(@GGG)
SET LKERR=7
GOTO END
+1 SET LKPRINT=$PIECE(@GGG,"^",1)
GOTO END
COMP SET LKH=$EXTRACT($PIECE(G,";",2),3,999)
SET D0=DA
XECUTE LKH
SET LKPRINT=X
GOTO END
TRX SET Y=LKDATA
XECUTE ^DD(DIC(1),DR(1),2)
SET LKPRINT=Y
GOTO END
