- DIOS ;SFISC/GFT,TKW-BUILD SORT LOGIC ;12:07 PM 5 Aug 1999 [ 04/02/2003 8:25 AM ]
- ;;22.0;VA FileMan;**1001**;APR 1, 2003
- ;;22.0;VA FileMan;**6**;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- D INIT S ^UTILITY($J,"DX")=DX,^("F")="^UTILITY($J,0,"_DCC_U_(DPP+1)
- F X=-1:0 S X=$O(DX(X)) Q:X="" S ^UTILITY($J,"DX",X)=DX(X)
- C K DX F DL=1:1:DPP S DX=+DPP(DL),V(DX,2)=DL,X=DP,(DPQ,DJ)=0,Z(DL)="" D A S X=999-$P($G(DPP(DL,"SER")),U,2),Y(DPQ,DX,X,$E($P(DPP(DL),U,2,3),1,30))=DL
- F DL=1:1:DPP D I D5,DE>0,$D(DE(DL))=1 S DE(DL)=DE(DL)-(DE\D5) S:DE(DL)<4 DE(DL)=4
- .K % S Z=Z(DL)
- U .F %=1:1 S D="",Y=$P(Z,",",%) Q:Y="" D
- ..S %(%)="D"_V(Y) I $D(V(Y,9)) F I=1:1:%-1 S DIOS=$P(Z,",",I),%(I)="$$SUB^DIOS("_DIOS_")"
- ..F I=1:1:% S D=D_","_%(I) I I=1 S D=D_","_DL
- ..S DX(Y,U)=D_"))"
- K DIOS S I=DP G GO
- ;
- SUB(F) ;
- N S,L
- S L="",S=-1
- F S L=$O(J(L)) Q:L="" I J(L)=F,$D(I(L,0)) S S=I(L,0) Q
- Q S
- ;
- A S W=$D(DPP(DL,X)),V(X)=DJ,Z(DL)=Z(DL)_X_C G ^DIOS1:'W
- I W=1 S Z=X,V=DPP(DL,X),DJ=DJ+1,DPQ=DPQ+1,X=$O(DPP(DL,X)) S:X="" X=-1 S:+V'=V V=Q_V_Q S:$S($D(^DD(X,0,"UP")):^("UP")-Z,1:1) X=DX K J(DJ,X) S:J'<DJ&$D(J(DJ)) J=DJ-1 S J(DJ,X)=DL,V(X,1)=V,V(X,0)=Z,I(Z,X)=DL G A
- S W=-1
- O S W=$O(DPP(DL,X,W)) I W="" S X=+V G A
- S V=DPP(DL,X,W),DJ=W#100,V(+V,9,DL)=W,V(+V,8)=U_$P(V,U,2),DPQ=DPQ+1+DJ,I(X,+V)=DL,J=-1,J(DJ,X)=DL G O
- ;
- GO K DISETP,DISAVX S X=I,I="" I $D(V(X,2)) S I=" X P("_X_")" I $D(DIBTPGM) S I=" D P"_DICP,DISETP=1
- I V(X) S W="D"_V(X),I="F "_W_"="_W_":0"_I
- S DX(X)=I,DPQ=X
- S DX=X,I=$O(I(X,X)),F=-1 I I="" D I I="" G DIO1
- . I $D(I)<9 Q:'$D(DIBTPGM) Q:$D(DISAVX(X)) S %=DX(X),%(1)=X,%(2)="DX" D SETU Q
- . S I=$O(I(X,-1)) Q:I]""
- . S I=$O(I(DP,-1)) I I]"" S DX=DP Q
- . S DX=+$O(I(-1)),I=+$O(I(DX,-1))
- . Q
- S P=I(DX,I) K I(DX,I) G COLON:$D(V(I,9)) D MULPATH
- S F="",(DX,%(0))=I,W="D"_V(I),%=DCC S:$D(DXIX(I)) F=DXIX(I) D:F="" GREF^DIOU(.V,.%,.F)
- S DX(X)=DX(X)_" S "_D2_W_"=$O("_$E(F,1,$L(F)-2)_"0))"_DN_$P(")",U,'$D(DIBTPGM))_D1
- I $D(DIBTPGM) S %=DX(X),%(1)=X,%(2)="DX" D SETU
- G GO
- COLON S F=$O(V(I,9,F)) I F="" G GO
- D MULPATH S DX(X)=DX(X)_$E(" S "_D2,1,$S(D2]"":$L(D2)+2,1:0))_DN I '$D(DIBTPGM) S DX(X)=DX(X)_C_F_")"
- S DX(X)=DX(X)_D1
- I $D(DIBTPGM) S %=DX(X),%(1)=X,%(2)="DX" D SETU
- S DN=DPP(F,DX,V(I,9,F)),V=$P(DN,U,4,99)
- I $P(DN,U,3) S V="S DIXX="_I_" "_V
- E S V=V_" S D0=D(0) " D
- .I '$D(DIBTPGM) S V=V_"X DX("_I_")" Q
- .S V=V_"D DX"_DICDX
- .Q
- S DX(I,F)=V I $D(DIBTPGM) S %=V,%(1)=I_","_F,%(2)="DX" D SETU
- G COLON
- ;
- MULPATH S DN=" "_$E("XD",$D(DIBTPGM)+1)_$P(":$T",1,$D(V(X,2)))_" DX" D
- .I $D(DIBTPGM) S DN=DN_DICDX Q
- .S DN=DN_"("_I Q
- S (D1,D2)="" F Z=J+1:1:V(X) S W="D"_Z,D(X)="("_X_C_P_")",%=W_D(X),D2=%_"="_W_C_D2,D1=$S(D1]"":D1_C,1:" S ")_W_"="_%
- F V=0:1 S Y=$S($D(J(V,X)):X,$O(J(V,-1)):$O(J(V,-1)),1:-1) D:$D(D(Y)) Q:V'<V(X)
- . I V<V(X) S DN=" S D"_V_"=D"_V_D(Y)_DN
- . Q:'$D(V(X,9))
- . S:V=0 DN=" N I,DIXX"_DN
- . Q:V<V(X)
- . I $D(V(X,2)) S DN=" S D"_V_"=D"_V_D(Y)_DN
- . Q
- Q
- ;
- SETU ;FILE A LINE TO ^TMP FOR LATER INCLUSION IN ROUTINE
- Q:%="" N A
- I %(2)="DX" S A=$S(DICDX=1:"O",1:"DX"_(DICDX-1)),DISAVX(X)=""
- I %(2)'="DX" S A=%(2)_DICOV,DICOV=DICOV+1
- S %=A_$E(" ",$E(%)'=" ")_%
- S ^TMP("DIBTC",$J,%(1),DICNT)=%,^((DICNT+.001))=" Q"
- S A="DIC"_%(2) S @(A)=@(A)+1,DICNT=DICNT+1
- I %(2)="DX",$D(DISETP) S DICP(X)=DICP,DICP=DICP+1 K DISETP
- Q
- ;
- INIT S:'$D(L) L=1 I $G(IO)=IO(0),L'=0,($G(IOST)=""!($G(IOST)?1"C".E)) D WAIT^DICD
- S I=^DD("OS",DISYS,0),J=$P(I,U,7),DIOS=$S(J:J,1:63),J=$P(I,U,3),DE=$S(J:J,$G(^DD("SUB")):^("SUB"),1:255)
- K I,J,Z S J=99,Q="""",DE=DPP*8-DE+23,D5=0
- Q
- ;
- DIO1 K %,I,J,P G ^DIO1
- DIOS ;SFISC/GFT,TKW-BUILD SORT LOGIC ;12:07 PM 5 Aug 1999 [ 04/02/2003 8:25 AM ]
- +1 ;;22.0;VA FileMan;**1001**;APR 1, 2003
- +2 ;;22.0;VA FileMan;**6**;Mar 30, 1999
- +3 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +4 DO INIT
- SET ^UTILITY($JOB,"DX")=DX
- SET ^("F")="^UTILITY($J,0,"_DCC_U_(DPP+1)
- +5 FOR X=-1:0
- SET X=$ORDER(DX(X))
- IF X=""
- QUIT
- SET ^UTILITY($JOB,"DX",X)=DX(X)
- C KILL DX
- FOR DL=1:1:DPP
- SET DX=+DPP(DL)
- SET V(DX,2)=DL
- SET X=DP
- SET (DPQ,DJ)=0
- SET Z(DL)=""
- DO A
- SET X=999-$PIECE($GET(DPP(DL,"SER")),U,2)
- SET Y(DPQ,DX,X,$EXTRACT($PIECE(DPP(DL),U,2,3),1,30))=DL
- +1 FOR DL=1:1:DPP
- Begin DoDot:1
- +2 KILL %
- SET Z=Z(DL)
- U FOR %=1:1
- SET D=""
- SET Y=$PIECE(Z,",",%)
- IF Y=""
- QUIT
- Begin DoDot:2
- +1 SET %(%)="D"_V(Y)
- IF $DATA(V(Y,9))
- FOR I=1:1:%-1
- SET DIOS=$PIECE(Z,",",I)
- SET %(I)="$$SUB^DIOS("_DIOS_")"
- +2 FOR I=1:1:%
- SET D=D_","_%(I)
- IF I=1
- SET D=D_","_DL
- +3 SET DX(Y,U)=D_"))"
- End DoDot:2
- End DoDot:1
- IF D5
- IF DE>0
- IF $DATA(DE(DL))=1
- SET DE(DL)=DE(DL)-(DE\D5)
- IF DE(DL)<4
- SET DE(DL)=4
- +4 KILL DIOS
- SET I=DP
- GOTO GO
- +5 ;
- SUB(F) ;
- +1 NEW S,L
- +2 SET L=""
- SET S=-1
- +3 FOR
- SET L=$ORDER(J(L))
- IF L=""
- QUIT
- IF J(L)=F
- IF $DATA(I(L,0))
- SET S=I(L,0)
- QUIT
- +4 QUIT S
- +5 ;
- A SET W=$DATA(DPP(DL,X))
- SET V(X)=DJ
- SET Z(DL)=Z(DL)_X_C
- IF 'W
- GOTO ^DIOS1
- +1 IF W=1
- SET Z=X
- SET V=DPP(DL,X)
- SET DJ=DJ+1
- SET DPQ=DPQ+1
- SET X=$ORDER(DPP(DL,X))
- IF X=""
- SET X=-1
- IF +V'=V
- SET V=Q_V_Q
- IF $SELECT($DATA(^DD(X,0,"UP"))
- SET X=DX
- KILL J(DJ,X)
- IF J'<DJ&$DATA(J(DJ))
- SET J=DJ-1
- SET J(DJ,X)=DL
- SET V(X,1)=V
- SET V(X,0)=Z
- SET I(Z,X)=DL
- GOTO A
- +2 SET W=-1
- O SET W=$ORDER(DPP(DL,X,W))
- IF W=""
- SET X=+V
- GOTO A
- +1 SET V=DPP(DL,X,W)
- SET DJ=W#100
- SET V(+V,9,DL)=W
- SET V(+V,8)=U_$PIECE(V,U,2)
- SET DPQ=DPQ+1+DJ
- SET I(X,+V)=DL
- SET J=-1
- SET J(DJ,X)=DL
- GOTO O
- +2 ;
- GO KILL DISETP,DISAVX
- SET X=I
- SET I=""
- IF $DATA(V(X,2))
- SET I=" X P("_X_")"
- IF $DATA(DIBTPGM)
- SET I=" D P"_DICP
- SET DISETP=1
- +1 IF V(X)
- SET W="D"_V(X)
- SET I="F "_W_"="_W_":0"_I
- +2 SET DX(X)=I
- SET DPQ=X
- +3 SET DX=X
- SET I=$ORDER(I(X,X))
- SET F=-1
- IF I=""
- Begin DoDot:1
- +4 IF $DATA(I)<9
- IF '$DATA(DIBTPGM)
- QUIT
- IF $DATA(DISAVX(X))
- QUIT
- SET %=DX(X)
- SET %(1)=X
- SET %(2)="DX"
- DO SETU
- QUIT
- +5 SET I=$ORDER(I(X,-1))
- IF I]""
- QUIT
- +6 SET I=$ORDER(I(DP,-1))
- IF I]""
- SET DX=DP
- QUIT
- +7 SET DX=+$ORDER(I(-1))
- SET I=+$ORDER(I(DX,-1))
- +8 QUIT
- End DoDot:1
- IF I=""
- GOTO DIO1
- +9 SET P=I(DX,I)
- KILL I(DX,I)
- IF $DATA(V(I,9))
- GOTO COLON
- DO MULPATH
- +10 SET F=""
- SET (DX,%(0))=I
- SET W="D"_V(I)
- SET %=DCC
- IF $DATA(DXIX(I))
- SET F=DXIX(I)
- IF F=""
- DO GREF^DIOU(.V,.%,.F)
- +11 SET DX(X)=DX(X)_" S "_D2_W_"=$O("_$EXTRACT(F,1,$LENGTH(F)-2)_"0))"_DN_$PIECE(")",U,'$DATA(DIBTPGM))_D1
- +12 IF $DATA(DIBTPGM)
- SET %=DX(X)
- SET %(1)=X
- SET %(2)="DX"
- DO SETU
- +13 GOTO GO
- COLON SET F=$ORDER(V(I,9,F))
- IF F=""
- GOTO GO
- +1 DO MULPATH
- SET DX(X)=DX(X)_$EXTRACT(" S "_D2,1,$SELECT(D2]"":$LENGTH(D2)+2,1:0))_DN
- IF '$DATA(DIBTPGM)
- SET DX(X)=DX(X)_C_F_")"
- +2 SET DX(X)=DX(X)_D1
- +3 IF $DATA(DIBTPGM)
- SET %=DX(X)
- SET %(1)=X
- SET %(2)="DX"
- DO SETU
- +4 SET DN=DPP(F,DX,V(I,9,F))
- SET V=$PIECE(DN,U,4,99)
- +5 IF $PIECE(DN,U,3)
- SET V="S DIXX="_I_" "_V
- +6 IF '$TEST
- SET V=V_" S D0=D(0) "
- Begin DoDot:1
- +7 IF '$DATA(DIBTPGM)
- SET V=V_"X DX("_I_")"
- QUIT
- +8 SET V=V_"D DX"_DICDX
- +9 QUIT
- End DoDot:1
- +10 SET DX(I,F)=V
- IF $DATA(DIBTPGM)
- SET %=V
- SET %(1)=I_","_F
- SET %(2)="DX"
- DO SETU
- +11 GOTO COLON
- +12 ;
- MULPATH SET DN=" "_$EXTRACT("XD",$DATA(DIBTPGM)+1)_$PIECE(":$T",1,$DATA(V(X,2)))_" DX"
- Begin DoDot:1
- +1 IF $DATA(DIBTPGM)
- SET DN=DN_DICDX
- QUIT
- +2 SET DN=DN_"("_I
- QUIT
- End DoDot:1
- +3 SET (D1,D2)=""
- FOR Z=J+1:1:V(X)
- SET W="D"_Z
- SET D(X)="("_X_C_P_")"
- SET %=W_D(X)
- SET D2=%_"="_W_C_D2
- SET D1=$SELECT(D1]"":D1_C,1:" S ")_W_"="_%
- +4 FOR V=0:1
- SET Y=$SELECT($DATA(J(V,X)):X,$ORDER(J(V,-1)):$ORDER(J(V,-1)),1:-1)
- IF $DATA(D(Y))
- Begin DoDot:1
- +5 IF V<V(X)
- SET DN=" S D"_V_"=D"_V_D(Y)_DN
- +6 IF '$DATA(V(X,9))
- QUIT
- +7 IF V=0
- SET DN=" N I,DIXX"_DN
- +8 IF V<V(X)
- QUIT
- +9 IF $DATA(V(X,2))
- SET DN=" S D"_V_"=D"_V_D(Y)_DN
- +10 QUIT
- End DoDot:1
- IF V'<V(X)
- QUIT
- +11 QUIT
- +12 ;
- SETU ;FILE A LINE TO ^TMP FOR LATER INCLUSION IN ROUTINE
- +1 IF %=""
- QUIT
- NEW A
- +2 IF %(2)="DX"
- SET A=$SELECT(DICDX=1:"O",1:"DX"_(DICDX-1))
- SET DISAVX(X)=""
- +3 IF %(2)'="DX"
- SET A=%(2)_DICOV
- SET DICOV=DICOV+1
- +4 SET %=A_$EXTRACT(" ",$EXTRACT(%)'=" ")_%
- +5 SET ^TMP("DIBTC",$JOB,%(1),DICNT)=%
- SET ^((DICNT+.001))=" Q"
- +6 SET A="DIC"_%(2)
- SET @(A)=@(A)+1
- SET DICNT=DICNT+1
- +7 IF %(2)="DX"
- IF $DATA(DISETP)
- SET DICP(X)=DICP
- SET DICP=DICP+1
- KILL DISETP
- +8 QUIT
- +9 ;
- INIT IF '$DATA(L)
- SET L=1
- IF $GET(IO)=IO(0)
- IF L'=0
- IF ($GET(IOST)=""!($GET(IOST)?1"C".E))
- DO WAIT^DICD
- +1 SET I=^DD("OS",DISYS,0)
- SET J=$PIECE(I,U,7)
- SET DIOS=$SELECT(J:J,1:63)
- SET J=$PIECE(I,U,3)
- SET DE=$SELECT(J:J,$GET(^DD("SUB")):^("SUB"),1:255)
- +2 KILL I,J,Z
- SET J=99
- SET Q=""""
- SET DE=DPP*8-DE+23
- SET D5=0
- +3 QUIT
- +4 ;
- DIO1 KILL %,I,J,P
- GOTO ^DIO1
