DIS1 ;SFISC/GFT-BUILD DIS-ARRAY ;16 DEC 2013
;;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.
;
K DIS0 I $D(DL)#2 S DIS0=DL
S DL(0)="" W ! G 1:$D(DE)>1!$D(DJ) I DL=1 S DL(0)=DL(1),DL=0 K DL(1)
E F P=2:1 S Y=$P(DL(1),U,P) Q:Y="" S Y=U_Y_U,X=2 D 2
F X=1:1 Q:'$D(DL(X)) F Y=X+1:1 Q:'$D(DL(Y)) I DL(X)=DL(Y)!(DL(Y)?.P) S DL=DL-1 K DL(Y) F P=Y:1:DL S DL(P)=DL(P+1) K DL(P+1)
1 D ENT G ^DIS2:'$D(DIAR),DIS^DIS2
;
ENT S DK(0)=DK,Z="D0," F DQ=0:1:DL K R,M D S X=0,DQ(0)=DQ,R=-1 D MAKE S %=0 F S R=$O(R(R)) Q:R="" I R(R)<2 S DIS(R)=DIS(R)_" K D"
. N I S I="" F S I=$O(DI(I)) Q:'I K DI(I)
. Q
S R=-1 Q
;
2 I X'>DL Q:DL(X)'[Y S X=X+1 G 2
S DL(0)=U_$P(Y,U,2)_DL(0),P=P-1
22 S X=X-1,DQ=$F(DL(X),Y),DL(X)=$E(DL(X),1,DQ-$L(Y))_$E(DL(X),DQ,999) G 22:X>1 Q
;
C S Y=Y_$S(DV="'":" I 'X",1:" I "_$$XFORM("X")_DV) D SD
MAKE S DC=DI,DQ=+DQ,X=X+1,Y=$P(DL(DQ),U,X+1) Q:Y=""
S S=+Y,DN=$E("'",Y["'"),Y=DC(S),D=0,DL=0 I $D(DJ(DQ,S)) S D=$P(DJ(DQ,S),U,2),DL=+DJ(DQ,S) I $D(DI(DL)) S DC=DI(DL)
S DQ=DQ(DL),Z=$P(Z,",",1,D+D+1)_",",DU=$P($P(Y,U),",",DL+1,99),O=DK(DL),DV=DN_$P(Y,U,2) I DV?1"''".E S DV=$E(DV,3,999)
LEV S DL=DL+1,DN=$S($D(DE(+DQ,X,DL)):DE(+DQ,X,DL),1:1)
S:$G(DI(DL-1))]"" DI(DL)=DI(DL-1)
I DU<0 G X:$D(DY(-DU)) S Y=DA(-DU) G C
S N=$P(^DD(O,+DU,0),U,4),DE=$P(N,";",1),Y=$P(N,";",2) I Y="" S Y="D"_D G M
I $P(^(0),U,2)["C" S Y=$P(^(0),U,5,99) G C
S:+DE'=DE DE=""""_DE_""""
S Z=Z_DE,E="$G("_DC_Z_"))" I Y S Y="$P("_E_",U,"_Y_")" G M
I Y'=0 S Y=$E(Y,2,99) S:$P(Y,",",2)=+Y Y=+Y S Y="$E("_E_","_Y_")" G M
F Y=65:1 S M=DQ_$C(Y) Q:'$D(DIS(M))
S D=D+1,Y="S D"_D_"=+$O("_DC_Z_",0)) X DIS("""_M_""") I $T" D SD
I $D(DIAR) S DIAR(DIARF,DQ)="X DIS("""_M_"A"")"
S DQ=M,DIS(DQ)="F X DIS("""_DQ_"A"") X:D"_D_"'>0 ""IF "_(DN=3)_""" Q:"_$E("'",DN>1)_"$T S D"_D_"=$O("_DC_Z_",D"_D_")) Q:D"_D_"'>0"
WP S DQ=DQ_"A",DQ(DL)=DQ I DU'["," S DIS(DQ)="I "_$$XFORM("$G(^(D"_D_",0))")_DV G MAKE
S O=+$P(^(0),U,2),DK(DL)=O,Z=Z_",D"_D_","
N S DU=$P(DU,",",2,99) G LEV
;
M D S Y=Y_DV D SD G MAKE
VARPOINT .I $P(^DD(O,+DU,0),U,2)["V" S Y="N DIERR I "_$$XFORM("$$EXTERNAL^DIDU("_O_","_+DU_","""","_Y_")") Q
OUTX .I $D(^(2)),$P(^(0),U,2)'["D",DV'["=" S M=0,Y="S Y="_Y_" "_$$OVFL(^(2))_" I "_$$XFORM("Y") Q ;**GFT 144
SET .I $D(DIS(U,S)) S Y="S Y="_Y_" I $S(Y="""":"""",$D(DIS(U,"_S_",Y)):DIS(U,"_S_",Y),1:"""")" Q
.S M=Y,Y="I "_$$XFORM(Y)
;
XFORM(Y) I '$D(DIS("XFORM",S)) Q Y
Q $P(DIS("XFORM",S),";")_Y_$P(DIS("XFORM",S),";",2)
;
SD I $D(R(DQ)),R(DQ)>1 S Y="K D "_Y_" S:$T D=1"
I '$D(DIS(DQ)) S DIS(DQ)=Y Q
I $L($G(DL(DQ)))*8+$L(DIS(DQ))+$L(Y)>180 S Y=$$OVFL(Y)_" I $T" I $L(Y)+$L(DIS(DQ))>235 S DIS(DQ)=$$OVFL(DIS(DQ))_" I "
S DIS(DQ)=DIS(DQ)_" "_Y Q
;
OVFL(Y) N I,%
F I=1:1 S %=DQ_"@"_I Q:'$D(DIS(%))
S DIS(%)=Y Q "X DIS("""_%_""")"
;
X S D=DY(-DU),O=+D,DC=U_$P(D,U,2) F %=66:1 S M=DQ_$C(%) Q:'$D(DIS(M))
I $P(D,U,3) S M=DQ_U_$P(D,U,3),Y="S DIXX="""_M_""" "_$P("X ""I 0"" ^I 1 ",U,DN=3+1)_$P(D,U,4,99)_" I $T",R(M)=DN
E S Y=$P(D,U,4,99)_" S D0=D(0) X DIS("""_M_""") S D0=I(0,0) I $T"
D SD S DQ=M,DI(DL)=DC,DK(DL)=+D,DQ(DL)=DQ,D=0,Z="D0," G N
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIS1 3367 printed Dec 13, 2024@02:54 Page 2
DIS1 ;SFISC/GFT-BUILD DIS-ARRAY ;16 DEC 2013
+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 KILL DIS0
IF $DATA(DL)#2
SET DIS0=DL
+8 SET DL(0)=""
WRITE !
if $DATA(DE)>1!$DATA(DJ)
GOTO 1
IF DL=1
SET DL(0)=DL(1)
SET DL=0
KILL DL(1)
+9 IF '$TEST
FOR P=2:1
SET Y=$PIECE(DL(1),U,P)
if Y=""
QUIT
SET Y=U_Y_U
SET X=2
DO 2
+10 FOR X=1:1
if '$DATA(DL(X))
QUIT
FOR Y=X+1:1
if '$DATA(DL(Y))
QUIT
IF DL(X)=DL(Y)!(DL(Y)?.P)
SET DL=DL-1
KILL DL(Y)
FOR P=Y:1:DL
SET DL(P)=DL(P+1)
KILL DL(P+1)
1 DO ENT
if '$DATA(DIAR)
GOTO ^DIS2
GOTO DIS^DIS2
+1 ;
ENT SET DK(0)=DK
SET Z="D0,"
FOR DQ=0:1:DL
KILL R,M
Begin DoDot:1
+1 NEW I
SET I=""
FOR
SET I=$ORDER(DI(I))
if 'I
QUIT
KILL DI(I)
+2 QUIT
End DoDot:1
SET X=0
SET DQ(0)=DQ
SET R=-1
DO MAKE
SET %=0
FOR
SET R=$ORDER(R(R))
if R=""
QUIT
IF R(R)<2
SET DIS(R)=DIS(R)_" K D"
+3 SET R=-1
QUIT
+4 ;
2 IF X'>DL
if DL(X)'[Y
QUIT
SET X=X+1
GOTO 2
+1 SET DL(0)=U_$PIECE(Y,U,2)_DL(0)
SET P=P-1
22 SET X=X-1
SET DQ=$FIND(DL(X),Y)
SET DL(X)=$EXTRACT(DL(X),1,DQ-$LENGTH(Y))_$EXTRACT(DL(X),DQ,999)
if X>1
GOTO 22
QUIT
+1 ;
C SET Y=Y_$SELECT(DV="'":" I 'X",1:" I "_$$XFORM("X")_DV)
DO SD
MAKE SET DC=DI
SET DQ=+DQ
SET X=X+1
SET Y=$PIECE(DL(DQ),U,X+1)
if Y=""
QUIT
+1 SET S=+Y
SET DN=$EXTRACT("'",Y["'")
SET Y=DC(S)
SET D=0
SET DL=0
IF $DATA(DJ(DQ,S))
SET D=$PIECE(DJ(DQ,S),U,2)
SET DL=+DJ(DQ,S)
IF $DATA(DI(DL))
SET DC=DI(DL)
+2 SET DQ=DQ(DL)
SET Z=$PIECE(Z,",",1,D+D+1)_","
SET DU=$PIECE($PIECE(Y,U),",",DL+1,99)
SET O=DK(DL)
SET DV=DN_$PIECE(Y,U,2)
IF DV?1"''".E
SET DV=$EXTRACT(DV,3,999)
LEV SET DL=DL+1
SET DN=$SELECT($DATA(DE(+DQ,X,DL)):DE(+DQ,X,DL),1:1)
+1 if $GET(DI(DL-1))]""
SET DI(DL)=DI(DL-1)
+2 IF DU<0
if $DATA(DY(-DU))
GOTO X
SET Y=DA(-DU)
GOTO C
+3 SET N=$PIECE(^DD(O,+DU,0),U,4)
SET DE=$PIECE(N,";",1)
SET Y=$PIECE(N,";",2)
IF Y=""
SET Y="D"_D
GOTO M
+4 IF $PIECE(^(0),U,2)["C"
SET Y=$PIECE(^(0),U,5,99)
GOTO C
+5 if +DE'=DE
SET DE=""""_DE_""""
+6 SET Z=Z_DE
SET E="$G("_DC_Z_"))"
IF Y
SET Y="$P("_E_",U,"_Y_")"
GOTO M
+7 IF Y'=0
SET Y=$EXTRACT(Y,2,99)
if $PIECE(Y,",",2)=+Y
SET Y=+Y
SET Y="$E("_E_","_Y_")"
GOTO M
+8 FOR Y=65:1
SET M=DQ_$CHAR(Y)
if '$DATA(DIS(M))
QUIT
+9 SET D=D+1
SET Y="S D"_D_"=+$O("_DC_Z_",0)) X DIS("""_M_""") I $T"
DO SD
+10 IF $DATA(DIAR)
SET DIAR(DIARF,DQ)="X DIS("""_M_"A"")"
+11 SET DQ=M
SET DIS(DQ)="F X DIS("""_DQ_"A"") X:D"_D_"'>0 ""IF "_(DN=3)_""" Q:"_$EXTRACT("'",DN>1)_"$T S D"_D_"=$O("_DC_Z_",D"_D_")) Q:D"_D_"'>0"
WP SET DQ=DQ_"A"
SET DQ(DL)=DQ
IF DU'[","
SET DIS(DQ)="I "_$$XFORM("$G(^(D"_D_",0))")_DV
GOTO MAKE
+1 SET O=+$PIECE(^(0),U,2)
SET DK(DL)=O
SET Z=Z_",D"_D_","
N SET DU=$PIECE(DU,",",2,99)
GOTO LEV
+1 ;
M Begin DoDot:1
VARPOINT IF $PIECE(^DD(O,+DU,0),U,2)["V"
SET Y="N DIERR I "_$$XFORM("$$EXTERNAL^DIDU("_O_","_+DU_","""","_Y_")")
QUIT
OUTX ;**GFT 144
IF $DATA(^(2))
IF $PIECE(^(0),U,2)'["D"
IF DV'["="
SET M=0
SET Y="S Y="_Y_" "_$$OVFL(^(2))_" I "_$$XFORM("Y")
QUIT
SET IF $DATA(DIS(U,S))
SET Y="S Y="_Y_" I $S(Y="""":"""",$D(DIS(U,"_S_",Y)):DIS(U,"_S_",Y),1:"""")"
QUIT
+1 SET M=Y
SET Y="I "_$$XFORM(Y)
End DoDot:1
SET Y=Y_DV
DO SD
GOTO MAKE
+2 ;
XFORM(Y) IF '$DATA(DIS("XFORM",S))
QUIT Y
+1 QUIT $PIECE(DIS("XFORM",S),";")_Y_$PIECE(DIS("XFORM",S),";",2)
+2 ;
SD IF $DATA(R(DQ))
IF R(DQ)>1
SET Y="K D "_Y_" S:$T D=1"
+1 IF '$DATA(DIS(DQ))
SET DIS(DQ)=Y
QUIT
+2 IF $LENGTH($GET(DL(DQ)))*8+$LENGTH(DIS(DQ))+$LENGTH(Y)>180
SET Y=$$OVFL(Y)_" I $T"
IF $LENGTH(Y)+$LENGTH(DIS(DQ))>235
SET DIS(DQ)=$$OVFL(DIS(DQ))_" I "
+3 SET DIS(DQ)=DIS(DQ)_" "_Y
QUIT
+4 ;
OVFL(Y) NEW I,%
+1 FOR I=1:1
SET %=DQ_"@"_I
if '$DATA(DIS(%))
QUIT
+2 SET DIS(%)=Y
QUIT "X DIS("""_%_""")"
+3 ;
X SET D=DY(-DU)
SET O=+D
SET DC=U_$PIECE(D,U,2)
FOR %=66:1
SET M=DQ_$CHAR(%)
if '$DATA(DIS(M))
QUIT
+1 IF $PIECE(D,U,3)
SET M=DQ_U_$PIECE(D,U,3)
SET Y="S DIXX="""_M_""" "_$PIECE("X ""I 0"" ^I 1 ",U,DN=3+1)_$PIECE(D,U,4,99)_" I $T"
SET R(M)=DN
+2 IF '$TEST
SET Y=$PIECE(D,U,4,99)_" S D0=D(0) X DIS("""_M_""") S D0=I(0,0) I $T"
+3 DO SD
SET DQ=M
SET DI(DL)=DC
SET DK(DL)=+D
SET DQ(DL)=DQ
SET D=0
SET Z="D0,"
GOTO N
