- DIO1 ;SFISC/GFT,TKW-BUILD P-ARRAY (OR LINES IN COMPILED SORT) WHICH CREATES SORTED DATA ;20MAR2005
- ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
- ;;Per VA Directive 6402, this routine should not be modified.
- ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- ;;Licensed under the terms of the Apache License, Version 2.0.
- ;
- F DJ=0:1:7 F DX=-1:0 S DX=$O(Y(DJ,DX)) Q:DX="" F DPR=-1:0 S DPR=$O(Y(DJ,DX,DPR)) D Q:DPR=""
- .I DPR="" D:$D(DIBTPGM) SETU("Q") Q
- .S X=0
- A .F S X=$O(Y(DJ,DX,DPR,X)) Q:X="" D
- B ..N DL,DIF,W,DICOND,Z,%,BACKWARD
- ..S DL=Y(DJ,DX,DPR,X),W="DISX("_DL_")",DICOND="=""""",D2="" I $P(DPP(DL),U,4)["-" S BACKWARD="-"
- ..I 'X,DL>$G(DPP(0)) S:'$D(DPP(DL,"CM")) W=$G(BACKWARD)_"D"_V(DX),DICOND="<0"
- ..I X S Z=$P($P(^DD(DX,+X,0),U,4),";",2) S:$E(Z)="E" DICOND="?."" """
- ..S Z="" S:$C(63,122)=$P($G(DPP(DL,"F")),U) Z=1 S:$P($G(DPP(DL,"T")),U)="@" Z=Z+2 ;From NULL:Z=1 To NULL:Z=2 Both:Z=3
- ..S DIF=$S($D(BACKWARD):BACKWARD,$P(DPP(DL),U,10)=2:"+",1:"")_$S($D(DE(DL)):"$E("_W_",1,"_DE(DL)_")",1:W) ;DE array was set in ^DIOS
- ..I Z S DIF="$S("_W_"'"_DICOND_":"_DIF_",1:"" EMPTY"")"
- ..S J(DL)=W
- ..I Z=3 S J(DL)=""" """ K DIF ;if just looking for NULLs
- ..I $P(DPP(DL),U,4)["'" S J(DL)=1 K DIF ;if Sort Value doesn't matter
- ..S P(DX)=$S($D(P(DX)):P(DX)_" ",1:"")
- ..S Y=$S(W?1"DISX(".E:"S "_W_"="""" ",1:"")_DPP(DL,"GET")
- ..S DICOND=$G(DPP(DL,"QCON")) I DL=DJK&$D(DPP(DL,"IX"))!(DICOND="") S DICOND="I "_W_"]"""""
- SORTVAL ..I $D(DIF),DIF'=W S DICOND=DICOND_" S DISX("_DL_")="_DIF
- ..S Y=Y_" ",DIF="" D S Y=DICOND,DIF="I " D
- ...I $D(DIBTPGM) D SETU(Y) D:DIF]"" SETU("Q:'$T") Q
- ...I DPP>2!($L(P(DX))+$L(Y)>125) S Z=$O(P(DX,""),-1)+1,P(DX,Z)=Y,P(DX)=P(DX)_"X P("_DX_","_Z_") "_DIF Q
- ...S P(DX)=P(DX)_Y
- BX ..S Y=DX Q
- UTILITY K W S W="",Z=" S:$T ^UTILITY($J,0" F X=1:1:DPP S Z=Z_","_$G(J(X),1)
- SUB F V=1:1:DPP I V=DPP&(W="")!(DPP(V)-DP) S F=",",Y=DP,%=1,X=0 D S W=W_Z_F_")="""""
- U .S:$D(D(Y)) X=X_D(Y) S %=%+1,Y=$P(Z(V),",",%),D=Y="",F=$S(F'=",":F_",D"_X,D:",D"_X,1:",D"_X_","_V) I 'D S X=V(Y) G U
- .I $L(W)+$L(Z)+$L(F)+$L(DX(DPQ))+$S(V(DPQ):38,1:0)>237 D
- ..I '$D(DIBTPGM) S DIOVFL(V)=$E(W,2,999),W=" X DIOVFL("_V_")" Q
- ..S %=W,(%(1),%(2))="OV",W=" D OV"_DICOV D SETU^DIOS
- DX F X=-1:0 S X=$O(DX(X)),DX=X Q:X="" D
- .N A,B S A=""
- .I $D(DIBTPGM) S B=+$O(^TMP("DIBTC",$J,X,0)),A=$G(^(B))
- .S:A="" A=DX(X)
- .S:X=DPQ A=A_W_$P(",DJ=DJ+1",U,$D(DIS)>9)
- .I V(X) S F="",%(0)=DX,%=DCC S:$D(DXIX(DX)) F=DXIX(DX) D:F="" GREF^DIOU(.V,.%,.F) S A=A_" "_"S D"_V(X)_"=$O("_F_")) Q:D"_V(X)_"'>0"
- .S DX(X)=A Q:'$D(DIBTPGM)
- .S:B ^TMP("DIBTC",$J,X,B)=A S DX(X)="D "_$P(A," ")
- 0 S DX(0)=DX(DP),DX=0,DPQ=0 K:DP DX(DP)
- ;
- 2 K D,%,I D 2^DIO D I $G(DIERR) G IXK^DIO
- .I $G(DIERR),$D(^UTILITY($J,0))>0 D CLEAN^DILF
- K DIOVFL,P,V,Y,D0,D1,D2,D3 K:'$D(DIB) DIS S:$D(DIBTPGM) DIBTPGM=""
- DIOO1 S V="I $D(^UTILITY($J,0" K DPP(0,"F"),DPP(0,"T") F X=1:1:DPP K DPP(X,"F"),DPP(X,"T") S V=V_",DIOO"_(DPP-X+1)
- F X=-1:0 S X=$O(DX(X)) Q:X="" I $D(DX(X,U)) S DSC(X)=V_DX(X,U)_$S($D(DSC(X)):" "_DSC(X),1:"")
- K DX S DX=^UTILITY($J,"DX"),DJ=^("F"),%=$O(^("DX",-1)) S:%="" %=-1 F %=%:0 S DX(%)=^(%),%=$O(^(%)) I %="" G GO^DIO
- ;
- SETU(%) Q:%="" N A
- S A=$G(DICP(DX)) I A S A="P"_A
- S ^TMP("DIBTC",$J,"P",DICNT)=A_" "_%
- K DICP(DX) S DICNT=DICNT+1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIO1 3371 printed Mar 13, 2025@21:57:17 Page 2
- DIO1 ;SFISC/GFT,TKW-BUILD P-ARRAY (OR LINES IN COMPILED SORT) WHICH CREATES SORTED DATA ;20MAR2005
- +1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- +4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- +5 ;;Licensed under the terms of the Apache License, Version 2.0.
- +6 ;
- +7 FOR DJ=0:1:7
- FOR DX=-1:0
- SET DX=$ORDER(Y(DJ,DX))
- if DX=""
- QUIT
- FOR DPR=-1:0
- SET DPR=$ORDER(Y(DJ,DX,DPR))
- Begin DoDot:1
- +8 IF DPR=""
- if $DATA(DIBTPGM)
- DO SETU("Q")
- QUIT
- +9 SET X=0
- A FOR
- SET X=$ORDER(Y(DJ,DX,DPR,X))
- if X=""
- QUIT
- Begin DoDot:2
- B NEW DL,DIF,W,DICOND,Z,%,BACKWARD
- +1 SET DL=Y(DJ,DX,DPR,X)
- SET W="DISX("_DL_")"
- SET DICOND="="""""
- SET D2=""
- IF $PIECE(DPP(DL),U,4)["-"
- SET BACKWARD="-"
- +2 IF 'X
- IF DL>$GET(DPP(0))
- if '$DATA(DPP(DL,"CM"))
- SET W=$GET(BACKWARD)_"D"_V(DX)
- SET DICOND="<0"
- +3 IF X
- SET Z=$PIECE($PIECE(^DD(DX,+X,0),U,4),";",2)
- if $EXTRACT(Z)="E"
- SET DICOND="?."" """
- +4 ;From NULL:Z=1 To NULL:Z=2 Both:Z=3
- SET Z=""
- if $CHAR(63,122)=$PIECE($GET(DPP(DL,"F")),U)
- SET Z=1
- if $PIECE($GET(DPP(DL,"T")),U)="@"
- SET Z=Z+2
- +5 ;DE array was set in ^DIOS
- SET DIF=$SELECT($DATA(BACKWARD):BACKWARD,$PIECE(DPP(DL),U,10)=2:"+",1:"")_$SELECT($DATA(DE(DL)):"$E("_W_",1,"_DE(DL)_")",1:W)
- +6 IF Z
- SET DIF="$S("_W_"'"_DICOND_":"_DIF_",1:"" EMPTY"")"
- +7 SET J(DL)=W
- +8 ;if just looking for NULLs
- IF Z=3
- SET J(DL)=""" """
- KILL DIF
- +9 ;if Sort Value doesn't matter
- IF $PIECE(DPP(DL),U,4)["'"
- SET J(DL)=1
- KILL DIF
- +10 SET P(DX)=$SELECT($DATA(P(DX)):P(DX)_" ",1:"")
- +11 SET Y=$SELECT(W?1"DISX(".E:"S "_W_"="""" ",1:"")_DPP(DL,"GET")
- +12 SET DICOND=$GET(DPP(DL,"QCON"))
- IF DL=DJK&$DATA(DPP(DL,"IX"))!(DICOND="")
- SET DICOND="I "_W_"]"""""
- SORTVAL IF $DATA(DIF)
- IF DIF'=W
- SET DICOND=DICOND_" S DISX("_DL_")="_DIF
- +1 SET Y=Y_" "
- SET DIF=""
- Begin DoDot:3
- +2 IF $DATA(DIBTPGM)
- DO SETU(Y)
- if DIF]""
- DO SETU("Q:'$T")
- QUIT
- +3 IF DPP>2!($LENGTH(P(DX))+$LENGTH(Y)>125)
- SET Z=$ORDER(P(DX,""),-1)+1
- SET P(DX,Z)=Y
- SET P(DX)=P(DX)_"X P("_DX_","_Z_") "_DIF
- QUIT
- +4 SET P(DX)=P(DX)_Y
- End DoDot:3
- SET Y=DICOND
- SET DIF="I "
- Begin DoDot:3
- End DoDot:3
- BX SET Y=DX
- QUIT
- End DoDot:2
- End DoDot:1
- if DPR=""
- QUIT
- UTILITY KILL W
- SET W=""
- SET Z=" S:$T ^UTILITY($J,0"
- FOR X=1:1:DPP
- SET Z=Z_","_$GET(J(X),1)
- SUB FOR V=1:1:DPP
- IF V=DPP&(W="")!(DPP(V)-DP)
- SET F=","
- SET Y=DP
- SET %=1
- SET X=0
- Begin DoDot:1
- U if $DATA(D(Y))
- SET X=X_D(Y)
- SET %=%+1
- SET Y=$PIECE(Z(V),",",%)
- SET D=Y=""
- SET F=$SELECT(F'=",":F_",D"_X,D:",D"_X,1:",D"_X_","_V)
- IF 'D
- SET X=V(Y)
- GOTO U
- +1 IF $LENGTH(W)+$LENGTH(Z)+$LENGTH(F)+$LENGTH(DX(DPQ))+$SELECT(V(DPQ):38,1:0)>237
- Begin DoDot:2
- +2 IF '$DATA(DIBTPGM)
- SET DIOVFL(V)=$EXTRACT(W,2,999)
- SET W=" X DIOVFL("_V_")"
- QUIT
- +3 SET %=W
- SET (%(1),%(2))="OV"
- SET W=" D OV"_DICOV
- DO SETU^DIOS
- End DoDot:2
- End DoDot:1
- SET W=W_Z_F_")="""""
- DX FOR X=-1:0
- SET X=$ORDER(DX(X))
- SET DX=X
- if X=""
- QUIT
- Begin DoDot:1
- +1 NEW A,B
- SET A=""
- +2 IF $DATA(DIBTPGM)
- SET B=+$ORDER(^TMP("DIBTC",$JOB,X,0))
- SET A=$GET(^(B))
- +3 if A=""
- SET A=DX(X)
- +4 if X=DPQ
- SET A=A_W_$PIECE(",DJ=DJ+1",U,$DATA(DIS)>9)
- +5 IF V(X)
- SET F=""
- SET %(0)=DX
- SET %=DCC
- if $DATA(DXIX(DX))
- SET F=DXIX(DX)
- if F=""
- DO GREF^DIOU(.V,.%,.F)
- SET A=A_" "_"S D"_V(X)_"=$O("_F_")) Q:D"_V(X)_"'>0"
- +6 SET DX(X)=A
- if '$DATA(DIBTPGM)
- QUIT
- +7 if B
- SET ^TMP("DIBTC",$JOB,X,B)=A
- SET DX(X)="D "_$PIECE(A," ")
- End DoDot:1
- 0 SET DX(0)=DX(DP)
- SET DX=0
- SET DPQ=0
- if DP
- KILL DX(DP)
- +1 ;
- 2 KILL D,%,I
- DO 2^DIO
- Begin DoDot:1
- +1 IF $GET(DIERR)
- IF $DATA(^UTILITY($JOB,0))>0
- DO CLEAN^DILF
- End DoDot:1
- IF $GET(DIERR)
- GOTO IXK^DIO
- +2 KILL DIOVFL,P,V,Y,D0,D1,D2,D3
- if '$DATA(DIB)
- KILL DIS
- if $DATA(DIBTPGM)
- SET DIBTPGM=""
- DIOO1 SET V="I $D(^UTILITY($J,0"
- KILL DPP(0,"F"),DPP(0,"T")
- FOR X=1:1:DPP
- KILL DPP(X,"F"),DPP(X,"T")
- SET V=V_",DIOO"_(DPP-X+1)
- +1 FOR X=-1:0
- SET X=$ORDER(DX(X))
- if X=""
- QUIT
- IF $DATA(DX(X,U))
- SET DSC(X)=V_DX(X,U)_$SELECT($DATA(DSC(X)):" "_DSC(X),1:"")
- +2 KILL DX
- SET DX=^UTILITY($JOB,"DX")
- SET DJ=^("F")
- SET %=$ORDER(^("DX",-1))
- if %=""
- SET %=-1
- FOR %=%:0
- SET DX(%)=^(%)
- SET %=$ORDER(^(%))
- IF %=""
- GOTO GO^DIO
- +3 ;
- SETU(%) if %=""
- QUIT
- NEW A
- +1 SET A=$GET(DICP(DX))
- IF A
- SET A="P"_A
- +2 SET ^TMP("DIBTC",$JOB,"P",DICNT)=A_" "_%
- +3 KILL DICP(DX)
- SET DICNT=DICNT+1
- +4 QUIT
