freem_fileman/USER/DIO1.m - view

File: [Coherent Logic Development] / freem_fileman / USER / DIO1.m
Revision 1.1: download - view: text, annotated - select for diffs
Mon Apr 28 14:13:21 2025 UTC (3 months ago) by snw
Branches: MAIN
CVS tags: HEAD

Restructure repository

1: DIO1 ;SFISC/GFT,TKW-BUILD P-ARRAY WHICH CREATES SORTED DATA ;9/1/94 12:41 2: ;;21.0;VA FileMan;;Dec 28, 1994 3: ;Per VHA Directive 10-93-142, this routine should not be modified. 4: 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:DPR="" Q:DPR="" S X=0 D A 5: .Q:'$D(DIBTPGM) I $G(P(DX))]"" S %=P(DX),DISETQ=1 D SETU 6: .Q 7: K W S W="",Z=" S:$T ^UTILITY($J,0" F X=1:1:DPP D I W]"" D OVZ 8: .N % S %=$S($P(DPP(X),U,4)["'":1,1:J(X)) I ($L(Z)+$L(%))'>180 S Z=Z_C_% Q 9: .I %=J(X),J(X)'="DISX("_X_")" S W=W_" S DISX("_X_")="_J(X),%="DISX("_X_")" 10: .S Z=Z_C_% Q 11: F V=1:1:DPP I V=DPP&(W="")!(DPP(V)-DP) S F=C,Y=DP,%=1,X=0 D U D:$L(W)+$L(Z)+$L(F)+$L(DX(DPQ))+$S(V(DPQ):38,1:0)>237 S W=W_Z_F_")=""""" 12: .I '$D(DIBTPGM) S DIOVFL(V)=$E(W,2,999),W=" X DIOVFL("_V_")" Q 13: .S %=W,(%(1),%(2))="OV",W=" D OV"_DICOV D SETU^DIOS 14: .Q 15: F X=-1:0 S X=$O(DX(X)),DX=X Q:X="" D 16: .N A,B S A="" 17: .I $D(DIBTPGM) S B=+$O(^TMP("DIBTC",$J,X,0)),A=$G(^(B)) 18: .S:$E(DX(X),1)=" " DX(X)=$E(DX(X),2,999) 19: .S:A="" A=DX(X) 20: .S:X=DPQ A=A_W_$P(",DJ=DJ+1",U,$D(DIS)>9) 21: .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" 22: .S DX(X)=A Q:'$D(DIBTPGM) 23: .S:B ^TMP("DIBTC",$J,X,B)=A S DX(X)="D "_$P(A," ") 24: .Q 25: S DX(0)=DX(DP),DX=0,DPQ=0 K:DP DX(DP) 26: ; 27: 2 K D,%,I D 2^DIO I $G(DIERR) G IXK^DIO 28: K DIOVFL,P,V,Y,D0,D1,D2,D3 K:'$D(DIB) DIS S:$D(DIBTPGM) DIBTPGM="" 29: 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_$E(",DDDDDDDDDDD",1,DPP+3-X)_0 30: 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:"") 31: K DX S DX=^UTILITY($J,"DX"),DJ=^("F"),%=$O(^("DX",-1)) S:%="" %=-1 F %=%:0 S DX(%)=^(%),%=$O(^(%)) I %="" G GO^DIO 32: ; 33: U S:$D(D(Y)) X=X_D(Y) S %=%+1,Y=$P(Z(V),C,%),D=Y="",F=$S(F'=C:F_",D"_X,D:",D"_X,1:",D"_X_C_V) Q:D S X=V(Y) G U 34: ; 35: A S X=$O(Y(DJ,DX,DPR,X)) Q:X="" D B G A 36: ; 37: B S DL=Y(DJ,DX,DPR,X),W="DISX("_DL_")",DIO="=""""",D2="" 38: I 'X,DL>$G(DPP(0)) S:'$D(DPP(DL,"CM")) W="D"_V(DX),DIO="<0" 39: I X S Z=$P($P(^DD(DX,+X,0),U,4),";",2) S:$E(Z)="E" DIO="?."" """ 40: S Z="" S:$C(63,122)=$P($G(DPP(DL,"F")),U) Z=1 S:$P($G(DPP(DL,"T")),U)="@" Z=Z+2 41: S F=$S($P(DPP(DL),U,4)["-":"999999999-",$P(DPP(DL),U,10)=2:"+",1:"")_$S($D(DE(DL)):"$E("_W_",1,"_DE(DL)_")",1:W) 42: I Z S F="$S("_W_"'"_DIO_":"_F_",1:"" EMPTY"")" I Z>2 S F=""" """ 43: S J(DL)=F 44: S P(DX)=$S($D(P(DX)):P(DX)_" ",1:"") 45: S Y=$S($E(W,1,5)="DISX(":"S "_W_"="""" ",1:"")_DPP(DL,"GET") 46: S DLN=$G(DPP(DL,"QCON")) I DL=DJK&$D(DPP(DL,"IX"))!(DLN="") S DLN="I "_W_"]""""" 47: I $D(DIBTPGM) D G BX 48: .N % I $L(P(DX))+$L(Y)+$L(DLN)>237 S %=$E(P(DX),1,($L(P(DX))-1)) D SETU S P(DX)="I " 49: .S P(DX)=P(DX)_Y_" "_DLN Q 50: I DPP>2!($L(P(DX))+$L(Y)>125) F Z=1:1 I '$D(P(DX,Z)) S P(DX,Z)=Y,P(DX)=P(DX)_"X P("_DX_C_Z_")"_$P(" I ",C,Y[" I ")_" "_DLN Q 51: E S P(DX)=P(DX)_Y_" "_DLN 52: BX S Y=DX Q 53: ; 54: OVZ I '$D(DIBTPGM) S DIOVFL("SX"_X)=$E(W,2,999),Z=" X DIOVFL(""SX"_X_""") "_Z,W="" Q 55: N % I $D(DIBTPGM) S %=W,(%(1),%(2))="OV",Z=" D OV"_DICOV_" "_Z D SETU^DIOS 56: S W="" Q 57: ; 58: SETU Q:%="" N A 59: S A=$G(DICP(DX)) I A S A="P"_A 60: S ^TMP("DIBTC",$J,"P",DICNT)=A_" "_% 61: I $D(DISETQ) S ^((DICNT+.001))=" Q" K DISETQ 62: K DICP(DX) S DICNT=DICNT+1 63: Q