DIP ;SFISC/XAK,TKW-GET SORT SPECS ;11:10 AM 17 May 2002 [ 12/09/2003 4:16 PM ]
;;22.0;VA FileMan;**2,64,97,1002**;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
K %ZIS,BY,FLDS,DX,DIS,DISV,DHIT,DTOUT,DIFF D ^DICRW G Q:$D(DTOUT),EN:$D(DIC)
Q K DIJ,DIOEND,DIOBEG,DISTOP,DISTXT,DI,DICS,DJ,BY,A,DICSS,ZTSK,FR,TO,FLDS,DHD,DHIT,DIS,PG,DCOPIES,L,DISUPNO,DIPCRIT,DCC,DNP
K %,%H,%I,%X,%Y,%DT,B,D0,DD,DIAC,DIFILE,DM,DP,DQ S I=$G(X) K X S:I]"" X=I
D CLEAN^DIEFU
QQ K DIPR,DIBT,DIBT1,DIBT2,DIBTOLD,DIEDT,DIQ,DIWF,DIPZ,DIL,DXS,DALL,DSC,DCL,DPP,DPQ,DIC,DU,DQI,DY,DITYP,DINS,DIPT,DISX
K S,DC,DL,DV,DE,DA,DK,DIFF,Y,R,C,D,I,J,Q,M,P,N,Q S:$D(DID) M=U Q
;
INIT S DIQUIET=1 Q:$D(ZTQUEUED) I L!('$D(FLDS)#2)!($D(DIASKHD))!($G(IOP)="") K DIQUIET Q
I $G(BY)="" K:$G(BY(0))="" DIQUIET Q
N I,X F I=1:1 Q:'$G(DIQUIET) S X=$P(BY,",",I) Q:X="" K:X="@" DIQUIET D:$G(DIQUIET)
. I $D(FR)#2 K:$P(FR,",",I)="?" DIQUIET I '$D(TO)#2 K DIQUIET Q
. I $D(TO)#2 K:$P(TO,",",I)="?"!('$D(FR)#2) DIQUIET Q
. I '$D(FR(I))#2!($G(FR(I))="?") K DIQUIET Q
. I '$D(TO(I))#2!($G(TO(I))="?") K DIQUIET
. Q
Q
;
EN S L=1 N DIERR
EN1 ;
S:DIC DIC=$G(^DIC(DIC,0,"GL")) G Q:DIC=""
I "^DIA(^DDA("[$E(DIC,1,5),'$G(DIA) S DIA=+$P(DIC,"(",2) G Q:'DIA
S:$D(L)[0 L=0 N DIFM S DIFM=+L N DIFMSTOP D CLEAN^DIEFU I '$D(DIQUIET) N DIQUIET D INIT
S DJ=1,U="^",(DCC,DI)=DIC,DNP="" D QQ I '$D(DISYS) N DISYS D OS^DII
I $G(BY)="@" S %=$G(BY(0)),DNP=BY K BY S:%]"" BY(0)=% K %
S:'$D(DTIME) DTIME=300
I ;
G Q:'$D(@(DI_"0)")) S S=+$P(^(0),U,2)
S Q="""",C=",",DC=0,DIJ=0,DE=$S(L=0!L!(L="]"):"SORT",1:L),DIL(S)=U
I $D(BY(0)) D EN^DIP10 G Q:'$D(BY(0)) I $G(BY)="" S DPP=DPP(0) G N^DIP1
LEVELS F DJ=DJ:1 D DJ Q:$G(X)=""!($D(DTOUT))!($D(DUOUT))!'$D(DJ) G FTEM^DIP1:X?1"[".E
I $D(DUOUT)!($D(DTOUT))!('$D(DJ)) G Q
G DUP^DIP1
DJ K DPP(DJ),DL,DV,I,J S I(0)=DI,(DL,J(0))=S,(N,DU)=0,Y=.01
;I DJ>1 S DIPR=$S($D(DIPR):DIPR,$G(DPP(0))]"":"BY(0)",1:$P(DPP(DJ-1),U,3)),DV=$J("",DJ*2-2)_"WITHIN "_DIPR_", "_DE_" BY" D L^DIP0 K DIPR G Q:$D(DTOUT)!($D(DUOUT)) Q:X="@"
I DJ>1!($G(DPP(0))=0) D G Q:$D(DTOUT)!($D(DUOUT)) Q:X="@" G:$D(DIPP) ADD:X?1"^"1.E G D:X]"" Q
. S DIPR=$S($D(DIPR):DIPR,$G(DPP(0))]"":"BY(0)",1:$P(DPP(DJ-1),U,3))
. S DV=$J("",DJ*2-2)_"WITHIN "_DIPR_", "_DE_" BY"
. D L^DIP0 K DIPR Q
;I DJ>1 G:$D(DIPP) ADD:X?1"^"1.E G D:X]"" Q
S P=$P(^DD(DL,.01,0),U,1,2) D:'$D(DIPP) XR:$P(P,U,2)'["P"&($P(P,U,2)'["V") I 'DU S Y=S,DV(1)=$S($D(^DD(DL,.001,0)):$P(^(0),U),1:"NUMBER")
D1 S DPP(DJ)=$S($D(DIPP(DIJ)):DIPP(DIJ),1:Y_U_DU_U_DV(1)_U)
S DV=DE_" BY" D L^DIP0 G Q:$D(DTOUT)!($D(DUOUT)) I X="" D DJ^DIP1 Q
G:$D(DIPP) ADD:X?1"^"1.E Q:X="@"
D K DPP(DJ,"IX"),DPP(DJ,"PTRIX") S R=U,P=DNP I X="]" S DXS=1,DJ=DJ-1 Q
Y I X'="NUMBER" D ^DIC K DUOUT G Q:$D(DTOUT)!(X=U) G G:Y>0,TEM^DIP11:X?1"[".E&'$D(DIPP)&($G(DIEDT)'=1),B:X=""
I $G(DUZ(0))="@",X="BY(0)",DJ=1,'$D(DIPP),DL=S D G:$G(DTOUT)!($G(DIROUT)) Q G:Y=1 DJ S X="",DPP=DPP(0) Q
. N X D ENBY0^DIP100 I $G(BY(0))="" S Y=1 Q
. S DIR(0)="Y",DIR("A")="Enter additional sort fields",DIR("B")="NO",DIR("?")="Enter YES if you wish to sort by fields in addition to BY(0)." D ^DIR K DIR
. W ! Q
STRIP D G:'$D(D) Y S X=$RE(X) D S X=$RE(X) G:'$D(D) Y ;from beginning, then end
.F D="]","-","#","+","!","@","'" I $E(X)=D S P=P_D,X=$E(X,2,999) S:D="]" DXS=1 K D Q
I X[";" S R=X,X=$P(X,";"),R=U_$P(R,X,2,9) G Y
S D="NUMBER",Y=0_U_D I $P(D,X)="" W $P(D,X,2) G S
G ^DIP0
;
BB S DPP(DJ,"F")=0,DPP(DJ,"T")=1,P=P_$S(P["@":"B",1:"@B"),R=R_$S(R'[";L1":";L1",1:"") K DATE Q
G S X=$P(Y(0),U,2),D=$P($P(Y(0),U,4),";") G NM:'X
S N=N+1,DPP(DJ,DL)=D,DIL(+X)=DL,I(N)=$S(+D=D:D,1:Q_D_Q),(DL,J(N))=+X,Y=.01_U_$P(^DD(DL,.01,0),U) I $D(DIPP(DIJ))#2 S %=$P(DIPP(DIJ),U,3),$P(DIPP(DIJ),U,3)=$S($D(DIPP(DIJ,DL)):DIPP(DIJ,DL),1:%)
I $O(^DD(DL,0))>0!$S($D(BY):BY?1U.E1" ".E,1:0) S DV=$J("",DJ*2-2)_$P(^(0),U) D L^DIP0 G Q:$D(DTOUT)!($D(DUOUT)) Q:X="@" G Y
NM D BB:X["B" I X["P"!(X["V") S P=P_Q_+Y,I=$P(Y,U,2),DPP(DJ)=DL_U_Y_U_P D DPQ^DIP1 S X="#"_$P(P,Q,$L(P,Q)),DPP=I G C^DIP0
I +Y=.001 S Y=0_U_$P(Y,U,2),R=R_U_U_X
S ;
S X=DL_U_+Y,DPP(DJ)=DL_U_Y_U_P_R I P'["-",R'[";TXT",$P(Y,U,3)="" D XR
D DJ^DIP1 S:X'=U X=1 Q
B W $C(7),"??" Q:$D(DIJS) G DJ
;
XR I $P($G(DPP(DJ)),U,3)="NUMBER",+DPP(DJ)=S,$P(DPP(DJ),U,2)=0 S DPP(DJ,"IX")=DI_DI_U_1 Q
I 'Y S Y=+$P($P(DPP(DJ),U,4),"""",2) Q:'Y D
. N P,X,Z S Z=+$P($P(^DD(+DPP(DJ),Y,0),U,2),"P",2) G:'Z XER
. D DTYP^DIOU(Z,.01,.P) G:P>4 XER S P=$P($G(^DD(Z,.01,0)),U,2) I P["O",P'[D G XER
. F P=0:0 S P=$O(^DD(Z,.01,1,P)) Q:'P I +^(P,0)=Z,$P(^(0),U,2,9)="B" Q
. I 'P S P=$O(^DD("IX","BB",Z,"B",0)) I P S P=$$IDXOK(P,Z,Z,.01)
. G:'P XER S P=$G(^DIC(Z,0,"GL")) G:P="" XER
. S DPP(DJ,"PTRIX")=P_Q_"B"_Q_C Q
XER . S Y="" Q
S P=$P($G(^DD(DL,+Y,0)),U,2) D
. I P["O",P'["D" Q
. I P?.E1"NJ"1.N1",2".E,$P($G(^DD(DL,+Y,0)),U,5,99)["""$""" Q
. F P=0:0 S P=$O(^DD(DL,+Y,1,P)) Q:P'>0 I +^(P,0)=S S X=$P(^(0),U,2,9) I X?1A.AN S DPP(DJ,"IX")=DI_Q_X_Q_C_DI_U_2,Y=+$O(^DD(S,0,"IX",X,-1)),DU=+$O(^(Y,-1)),DV(1)=$P(^DD(Y,DU,0),U) Q
. Q:P
. N DIOUT S DIOUT=0
. F S P=$O(^DD("IX","F",DL,+Y,P)) Q:'P S X=$P($G(^DD("IX",P,0)),U,2) I X]"" D Q:DIOUT
. . Q:'$$IDXOK(P,S,DL,+Y)
. . S DPP(DJ,"IX")=DI_Q_X_Q_C_DI_U_2
. . S DU=+Y,Y=DL,DV(1)=$P(^DD(DL,DU,0),U),DIOUT=1 Q
. Q
I $D(DPP(DJ,"PTRIX")),'$D(DPP(DJ,"IX")) K DPP(DJ,"PTRIX")
Q
;
IDXOK(DIEN,DIFILE,DISUB,DIFIELD) ;
N X S X=$G(^DD("IX",DIEN,0))
Q:$P(X,U,14)'["S" 0
Q:+X'=DIFILE 0
N J S J=$O(^DD("IX",DIEN,11.1,0)) Q:'J 0
I $O(^DD("IX",DIEN,11.1,J)) Q 0
S X=$G(^DD("IX",DIEN,11.1,J,0))
I ('$P(X,U,6))!($P(X,U,3)'=DISUB)!($P(X,U,4)'=DIFIELD) Q 0
I $D(^DD("IX",DIEN,11.1,J,1.5))!($D(^(2))) Q 0
Q 1
;
ADD S X=$E(X,2,99),DIJS=DIJ,DIJ=0 D D I $G(X)=U!($D(DTOUT)) K DIJS Q
S:$D(X) DJ=DJ+1 S DIJ=DIJS K DIJS G DJ
DIP ;SFISC/XAK,TKW-GET SORT SPECS ;11:10 AM 17 May 2002 [ 12/09/2003 4:16 PM ]
+1 ;;22.0;VA FileMan;**2,64,97,1002**;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 KILL %ZIS,BY,FLDS,DX,DIS,DISV,DHIT,DTOUT,DIFF
DO ^DICRW
IF $DATA(DTOUT)
GOTO Q
IF $DATA(DIC)
GOTO EN
Q KILL DIJ,DIOEND,DIOBEG,DISTOP,DISTXT,DI,DICS,DJ,BY,A,DICSS,ZTSK,FR,TO,FLDS,DHD,DHIT,DIS,PG,DCOPIES,L,DISUPNO,DIPCRIT,DCC,DNP
+1 KILL %,%H,%I,%X,%Y,%DT,B,D0,DD,DIAC,DIFILE,DM,DP,DQ
SET I=$GET(X)
KILL X
IF I]""
SET X=I
+2 DO CLEAN^DIEFU
QQ KILL DIPR,DIBT,DIBT1,DIBT2,DIBTOLD,DIEDT,DIQ,DIWF,DIPZ,DIL,DXS,DALL,DSC,DCL,DPP,DPQ,DIC,DU,DQI,DY,DITYP,DINS,DIPT,DISX
+1 KILL S,DC,DL,DV,DE,DA,DK,DIFF,Y,R,C,D,I,J,Q,M,P,N,Q
IF $DATA(DID)
SET M=U
QUIT
+2 ;
INIT SET DIQUIET=1
IF $DATA(ZTQUEUED)
QUIT
IF L!('$DATA(FLDS)#2)!($DATA(DIASKHD))!($GET(IOP)="")
KILL DIQUIET
QUIT
+1 IF $GET(BY)=""
IF $GET(BY(0))=""
KILL DIQUIET
QUIT
+2 NEW I,X
FOR I=1:1
IF '$GET(DIQUIET)
QUIT
SET X=$PIECE(BY,",",I)
IF X=""
QUIT
IF X="@"
KILL DIQUIET
IF $GET(DIQUIET)
Begin DoDot:1
+3 IF $DATA(FR)#2
IF $PIECE(FR,",",I)="?"
KILL DIQUIET
IF '$DATA(TO)#2
KILL DIQUIET
QUIT
+4 IF $DATA(TO)#2
IF $PIECE(TO,",",I)="?"!('$DATA(FR)#2)
KILL DIQUIET
QUIT
+5 IF '$DATA(FR(I))#2!($GET(FR(I))="?")
KILL DIQUIET
QUIT
+6 IF '$DATA(TO(I))#2!($GET(TO(I))="?")
KILL DIQUIET
+7 QUIT
End DoDot:1
+8 QUIT
+9 ;
EN SET L=1
NEW DIERR
EN1 ;
+1 IF DIC
SET DIC=$GET(^DIC(DIC,0,"GL"))
IF DIC=""
GOTO Q
+2 IF "^DIA(^DDA("[$EXTRACT(DIC,1,5)
IF '$GET(DIA)
SET DIA=+$PIECE(DIC,"(",2)
IF 'DIA
GOTO Q
+3 IF $DATA(L)[0
SET L=0
NEW DIFM
SET DIFM=+L
NEW DIFMSTOP
DO CLEAN^DIEFU
IF '$DATA(DIQUIET)
NEW DIQUIET
DO INIT
+4 SET DJ=1
SET U="^"
SET (DCC,DI)=DIC
SET DNP=""
DO QQ
IF '$DATA(DISYS)
NEW DISYS
DO OS^DII
+5 IF $GET(BY)="@"
SET %=$GET(BY(0))
SET DNP=BY
KILL BY
IF %]""
SET BY(0)=%
KILL %
+6 IF '$DATA(DTIME)
SET DTIME=300
I ;
+1 IF '$DATA(@(DI_"0)"))
GOTO Q
SET S=+$PIECE(^(0),U,2)
+2 SET Q=""""
SET C=","
SET DC=0
SET DIJ=0
SET DE=$SELECT(L=0!L!(L="]"):"SORT",1:L)
SET DIL(S)=U
+3 IF $DATA(BY(0))
DO EN^DIP10
IF '$DATA(BY(0))
GOTO Q
IF $GET(BY)=""
SET DPP=DPP(0)
GOTO N^DIP1
LEVELS FOR DJ=DJ:1
DO DJ
IF $GET(X)=""!($DATA(DTOUT))!($DATA(DUOUT))!'$DATA(DJ)
QUIT
IF X?1"[".E
GOTO FTEM^DIP1
+1 IF $DATA(DUOUT)!($DATA(DTOUT))!('$DATA(DJ))
GOTO Q
+2 GOTO DUP^DIP1
DJ KILL DPP(DJ),DL,DV,I,J
SET I(0)=DI
SET (DL,J(0))=S
SET (N,DU)=0
SET Y=.01
+1 ;I DIP_source.html#xD">DIP_source.html#xDIP_source.html#xD">D">DIP_source.html#xD">DJ>1 DIP_source.html#xD">DIP_source.html#xDIP_source.html#xD">D">DIP_source.html#xD">DIP_source.html#xS">S DIP_source.html#xD">DIP_source.html#xDIP_source.html#xD">D">DIP_source.html#xD">DIPR=$DIP_source.html#xD">DIP_source.html#xDIP_source.html#xD">D">DIP_source.html#xD">DIP_source.html#xS">S($DIP_source.html#xD">DIP_source.html#xDIP_source.html#xD">D">DIP_source.html#xD">D(DIP_source.html#xD">DIP_source.html#xDIP_source.html#xD">D">DIP_source.html#xD">DIPR):DIP_source.html#xD">DIP_source.html#xDIP_source.html#xD">D">DIP_source.html#xD">DIPR,$DIP_source.html#xD">DIP_source.html#xG">G(DIP_source.html#xD">DIP_source.html#xDIP_source.html#xD">D">DIP_source.html#xD">DPP(0))]"":"BY(0)",1:$P(DIP_source.html#xD">DIP_source.html#xDIP_source.html#xD">D">DIP_source.html#xD">DPP(DIP_source.html#xD">DIP_source.html#xDIP_source.html#xD">D">DIP_source.html#xD">DJ-1),U,3)),DIP_source.html#xD">DIP_source.html#xDIP_source.html#xD">D">DIP_source.html#xD">DV=$J("",DIP_source.html#xD">DIP_source.html#xDIP_source.html#xD">D">DIP_source.html#xD">DJ*2-2)_"WITHIN "_DIP_source.html#xD">DIP_source.html#xDIP_source.html#xD">D">DIP_source.html#xD">DIPR_", "_DIP_source.html#xD">DIP_source.html#xDIP_source.html#xD">D">DIP_source.html#xD">DE_" BY" DIP_source.html#xD">DIP_source.html#xDIP_source.html#xD">D">DIP_source.html#xD">D L^DIP_source.html#xD">DIP_source.html#xDIP_source.html#xD">D">DIP_source.html#xD">DIP0 K DIP_source.html#xD">DIP_source.html#xDIP_source.html#xD">D">DIP_source.html#xD">DIPR DIP_source.html#xD">DIP_source.html#xG">G Q:$DIP_source.html#xD">DIP_source.html#xDIP_source.html#xD">D">DIP_source.html#xD">D(DIP_source.html#xD">DIP_source.html#xDIP_source.html#xD">D">DIP_source.html#xD">DTOUT)!($DIP_source.html#xD">DIP_source.html#xDIP_source.html#xD">D">DIP_source.html#xD">D(DIP_source.html#xD">DIP_source.html#xDIP_source.html#xD">D">DIP_source.html#xD">DUOUT)) Q:X="@"
+2 IF DJ>1!($GET(DPP(0))=0)
Begin DoDot:1
+3 SET DIPR=$SELECT($DATA(DIPR):DIPR,$GET(DPP(0))]"":"BY(0)",1:$PIECE(DPP(DJ-1),U,3))
+4 SET DV=$JUSTIFY("",DJ*2-2)_"WITHIN "_DIPR_", "_DE_" BY"
+5 DO L^DIP0
KILL DIPR
QUIT
End DoDot:1
IF $DATA(DTOUT)!($DATA(DUOUT))
GOTO Q
IF X="@"
QUIT
IF $DATA(DIPP)
IF X?1"^"1.E
GOTO ADD
IF X]""
GOTO D
QUIT
+6 ;I DJ>1 G:$D(DIPP) ADD:X?1"^"1.E G D:X]"" Q
+7 SET P=$PIECE(^DD(DL,.01,0),U,1,2)
IF '$DATA(DIPP)
IF $PIECE(P,U,2)'["P"&($PIECE(P,U,2)'["V")
DO XR
IF 'DU
SET Y=S
SET DV(1)=$SELECT($DATA(^DD(DL,.001,0)):$PIECE(^(0),U),1:"NUMBER")
D1 SET DPP(DJ)=$SELECT($DATA(DIPP(DIJ)):DIPP(DIJ),1:Y_U_DU_U_DV(1)_U)
+1 SET DV=DE_" BY"
DO L^DIP0
IF $DATA(DTOUT)!($DATA(DUOUT))
GOTO Q
IF X=""
DO DJ^DIP1
QUIT
+2 IF $DATA(DIPP)
IF X?1"^"1.E
GOTO ADD
IF X="@"
QUIT
D KILL DPP(DJ,"IX"),DPP(DJ,"PTRIX")
SET R=U
SET P=DNP
IF X="]"
SET DXS=1
SET DJ=DJ-1
QUIT
Y IF X'="NUMBER"
DO ^DIC
KILL DUOUT
IF $DATA(DTOUT)!(X=U)
GOTO Q
IF Y>0
GOTO G
IF X?1"[".E&'$DATA(DIPP)&($GET(DIEDT)'=1)
GOTO TEM^DIP11
IF X=""
GOTO B
+1 IF $GET(DUZ(0))="@"
IF X="BY(0)"
IF DJ=1
IF '$DATA(DIPP)
IF DL=S
Begin DoDot:1
+2 NEW X
DO ENBY0^DIP100
IF $GET(BY(0))=""
SET Y=1
QUIT
+3 SET DIR(0)="Y"
SET DIR("A")="Enter additional sort fields"
SET DIR("B")="NO"
SET DIR("?")="Enter YES if you wish to sort by fields in addition to BY(0)."
DO ^DIR
KILL DIR
+4 WRITE !
QUIT
End DoDot:1
IF $GET(DTOUT)!($GET(DIROUT))
GOTO Q
IF Y=1
GOTO DJ
SET X=""
SET DPP=DPP(0)
QUIT
STRIP ;from beginning, then end
Begin DoDot:1
+1 FOR D="]","-","#","+","!","@","'"
IF $EXTRACT(X)=D
SET P=P_D
SET X=$EXTRACT(X,2,999)
IF D="]"
SET DXS=1
KILL D
QUIT
End DoDot:1
IF '$DATA(D)
GOTO Y
SET X=$REVERSE(X)
Begin DoDot:1
End DoDot:1
SET X=$REVERSE(X)
IF '$DATA(D)
GOTO Y
+2 IF X[";"
SET R=X
SET X=$PIECE(X,";")
SET R=U_$PIECE(R,X,2,9)
GOTO Y
+3 SET D="NUMBER"
SET Y=0_U_D
IF $PIECE(D,X)=""
WRITE $PIECE(D,X,2)
GOTO S
+4 GOTO ^DIP0
+5 ;
BB SET DPP(DJ,"F")=0
SET DPP(DJ,"T")=1
SET P=P_$SELECT(P["@":"B",1:"@B")
SET R=R_$SELECT(R'[";L1":";L1",1:"")
KILL DATE
QUIT
G SET X=$PIECE(Y(0),U,2)
SET D=$PIECE($PIECE(Y(0),U,4),";")
IF 'X
GOTO NM
+1 SET N=N+1
SET DPP(DJ,DL)=D
SET DIL(+X)=DL
SET I(N)=$SELECT(+D=D:D,1:Q_D_Q)
SET (DL,J(N))=+X
SET Y=.01_U_$PIECE(^DD(DL,.01,0),U)
IF $DATA(DIPP(DIJ))#2
SET %=$PIECE(DIPP(DIJ),U,3)
SET $PIECE(DIPP(DIJ),U,3)=$SELECT($DATA(DIPP(DIJ,DL)):DIPP(DIJ,DL),1:%)
+2 IF $ORDER(^DD(DL,0))>0!$SELECT($DATA(BY):BY?1U.E1" ".E,1:0)
SET DV=$JUSTIFY("",DJ*2-2)_$PIECE(^(0),U)
DO L^DIP0
IF $DATA(DTOUT)!($DATA(DUOUT))
GOTO Q
IF X="@"
QUIT
GOTO Y
NM IF X["B"
DO BB
IF X["P"!(X["V")
SET P=P_Q_+Y
SET I=$PIECE(Y,U,2)
SET DPP(DJ)=DL_U_Y_U_P
DO DPQ^DIP1
SET X="#"_$PIECE(P,Q,$LENGTH(P,Q))
SET DPP=I
GOTO C^DIP0
+1 IF +Y=.001
SET Y=0_U_$PIECE(Y,U,2)
SET R=R_U_U_X
S ;
+1 SET X=DL_U_+Y
SET DPP(DJ)=DL_U_Y_U_P_R
IF P'["-"
IF R'[";TXT"
IF $PIECE(Y,U,3)=""
DO XR
+2 DO DJ^DIP1
IF X'=U
SET X=1
QUIT
B WRITE $CHAR(7),"??"
IF $DATA(DIJS)
QUIT
GOTO DJ
+1 ;
XR IF $PIECE($GET(DPP(DJ)),U,3)="NUMBER"
IF +DPP(DJ)=S
IF $PIECE(DPP(DJ),U,2)=0
SET DPP(DJ,"IX")=DI_DI_U_1
QUIT
+1 IF 'Y
SET Y=+$PIECE($PIECE(DPP(DJ),U,4),"""",2)
IF 'Y
QUIT
Begin DoDot:1
+2 NEW P,X,Z
SET Z=+$PIECE($PIECE(^DD(+DPP(DJ),Y,0),U,2),"P",2)
IF 'Z
GOTO XER
+3 DO DTYP^DIOU(Z,.01,.P)
IF P>4
GOTO XER
SET P=$PIECE($GET(^DD(Z,.01,0)),U,2)
IF P["O"
IF P'[D
GOTO XER
+4 FOR P=0:0
SET P=$ORDER(^DD(Z,.01,1,P))
IF 'P
QUIT
IF +^(P,0)=Z
IF $PIECE(^(0),U,2,9)="B"
QUIT
+5 IF 'P
SET P=$ORDER(^DD("IX","BB",Z,"B",0))
IF P
SET P=$$IDXOK(P,Z,Z,.01)
+6 IF 'P
GOTO XER
SET P=$GET(^DIC(Z,0,"GL"))
IF P=""
GOTO XER
+7 SET DPP(DJ,"PTRIX")=P_Q_"B"_Q_C
QUIT
XER SET Y=""
QUIT
End DoDot:1
+1 SET P=$PIECE($GET(^DD(DL,+Y,0)),U,2)
Begin DoDot:1
+2 IF P["O"
IF P'["D"
QUIT
+3 IF P?.E1"NJ"1.N1",2".E
IF $PIECE($GET(^DD(DL,+Y,0)),U,5,99)["""$"""
QUIT
+4 FOR P=0:0
SET P=$ORDER(^DD(DL,+Y,1,P))
IF P'>0
QUIT
IF +^(P,0)=S
SET X=$PIECE(^(0),U,2,9)
IF X?1A.AN
SET DPP(DJ,"IX")=DI_Q_X_Q_C_DI_U_2
SET Y=+$ORDER(^DD(S,0,"IX",X,-1))
SET DU=+$ORDER(^(Y,-1))
SET DV(1)=$PIECE(^DD(Y,DU,0),U)
QUIT
+5 IF P
QUIT
+6 NEW DIOUT
SET DIOUT=0
+7 FOR
SET P=$ORDER(^DD("IX","F",DL,+Y,P))
IF 'P
QUIT
SET X=$PIECE($GET(^DD("IX",P,0)),U,2)
IF X]""
Begin DoDot:2
+8 IF '$$IDXOK(P,S,DL,+Y)
QUIT
+9 SET DPP(DJ,"IX")=DI_Q_X_Q_C_DI_U_2
+10 SET DU=+Y
SET Y=DL
SET DV(1)=$PIECE(^DD(DL,DU,0),U)
SET DIOUT=1
QUIT
End DoDot:2
IF DIOUT
QUIT
+11 QUIT
End DoDot:1
+12 IF $DATA(DPP(DJ,"PTRIX"))
IF '$DATA(DPP(DJ,"IX"))
KILL DPP(DJ,"PTRIX")
+13 QUIT
+14 ;
IDXOK(DIEN,DIFILE,DISUB,DIFIELD) ;
+1 NEW X
SET X=$GET(^DD("IX",DIEN,0))
+2 IF $PIECE(X,U,14)'["S"
QUIT 0
+3 IF +X'=DIFILE
QUIT 0
+4 NEW J
SET J=$ORDER(^DD("IX",DIEN,11.1,0))
IF 'J
QUIT 0
+5 IF $ORDER(^DD("IX",DIEN,11.1,J))
QUIT 0
+6 SET X=$GET(^DD("IX",DIEN,11.1,J,0))
+7 IF ('$PIECE(X,U,6))!($PIECE(X,U,3)'=DISUB)!($PIECE(X,U,4)'=DIFIELD)
QUIT 0
+8 IF $DATA(^DD("IX",DIEN,11.1,J,1.5))!($DATA(^(2)))
QUIT 0
+9 QUIT 1
+10 ;
ADD SET X=$EXTRACT(X,2,99)
SET DIJS=DIJ
SET DIJ=0
DO D
IF $GET(X)=U!($DATA(DTOUT))
KILL DIJS
QUIT
+1 IF $DATA(X)
SET DJ=DJ+1
SET DIJ=DIJS
KILL DIJS
GOTO DJ
