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 Apr 09, 2024@21:46:03 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
