DILL ;SFISC/GFT-TURN PRINT FLDS INTO CODE ;03:56 PM 5 Dec 2001 [ 12/09/2003 4:32 PM ]
;;22.0;VA FileMan;**25,76,1002**;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
S DXS=1
V ;
S V=$P(X,U,2),DRJ=$F(V,"P") I V["O",$D(^(2)) S Y=Y_" "_^(2),DIO=1,D1="",DLN=30,DRJ=0 D SY G J
G CLC:V["C",D:'DRJ S V=+$E(V,DRJ,99),D1=$P(X,U,3) I 'V S DRJ=0,@("V=$D(^"_D1_"0))") G D:'V S V=+$P(^(0),U,2)
POINTR D Y S Y=Y_" S Y=$S(Y="""":Y,$D(^"_D1_"Y,0))#2:$P(^(0),U),1:Y)" I $D(^DD(V,.01,0)) S X=$P(X,U)_U_$P(^(0),U,2,9) G V
D I V["V" D Y S Y=$P(Y," S Y=$S(Y="""":Y,$D(^")_" S C=$P(^DD("_DP_","_+W_",0),U,2) D Y^DIQ:Y S C="","""
I V["D" S DLN=$P($P(X,"%DT=""",2),"""",1),DLN=$S(DLN["S":21,DLN["T":18,1:11) D W S D1=" D DT" S:DLN>11&DRJ D1=" W ?("_DLN_"-$S(Y#1:18,1:11)+$X)"_D1 S:W[";W" Y=Y_" X ^DD(""DD"") S:Y[""@"" Y=$P(Y,""@"")_"" ""_$P(Y,""@"",2)" G SY
I $P(X,"X>",2) S DLN=$L(+$P(X,"X>",2))+3,DRJ=1 G J
S DLN=+$P(X,"$L(X)>",2) I 'DLN S D1=$P($P(X,U,4),";",2) I D1?1"E"1N.N1","1N.N S DLN=$P(D1,",",2)-D1+1
I V'["S" S:'DLN DLN=30 G J
D W S D1=$P(X,U,3) F V=1:1 Q:'$D(DXS(V))
S I D1]"",W[";W"!'$D(DNP) S D2=$P(D1,";",1),D1=$P(D1,";",2,99),D3=$P(D2,":",1),D2=$P(D2,":",2) S:$L(D2)>DLN&'$P(W,";L",2)&'$P(W,";R",2) DLN=$L(D2) S DXS(V,D3)=$E(D2,1,DLN) G S
D K S D1="$S($D(DXS("_V_",Y)):DXS("_V_",Y),1:Y)" S:DRJ D1="$J("_D1_","_DLN_")" S:W[";W" Y=Y_" S:Y]"""" Y="_D1 S:W'[";W" D1=" W:Y]"""" "_D1
SY D Y S Y=Y_$S($D(DNP):"",1:D1) K D1 Q
;
Y I DXS S Y=" S Y="_Y,DXS="Y"
Q Q
;
W ;
F I=";W",";L" I W[I S DRJ=0 S:$P(W,I,2)?1N.E DLN=+$P(W,I,2),I="" G Q
I $P(X,U,2)["J" S I=$P($P(X,U,2),"J",2),W=W_";R"_$P(I+1,U,I>0) I $P(X,U,2)'["O",I["," S W=W_";D"_+$P(I,",",2)
I W[";R" S DRJ=1 S:$P(W,";R",2) DLN=+$P(W,";R",2)
S I=$P($P(W,";D",2),";",1) S:I]"" DRJ=1,I=","_+I Q
;
CLC ;
S Y=" "_$P(X,U,5,99),DXS="X" I V["D" S Y=Y_" S Y=X" G D
I V["p" S V=$P(V,"p",2),D1=$P($G(^DIC(+V,0,"GL")),U,2) I D1]"" S Y=Y_" S Y=X",DXS="Y" G POINTR ;computed pointer
I V?.E1"J"1N.E,W'[";X",W'[";R",V'["," S W=W_";L"_+$P(V,"J",2)
J D W Q:V["m"!$D(DNP) I '$D(DLN) S Y=Y_" W X" Q
I 'DLN S DLN=$S(V["B":1,W[";L0":0,1:8)
S D2="" I 'DRJ S V="E(",D3="1,"_DLN
E S V="J(",D3=DLN_I I I]"" D Y S D2=":Y]""""" I DXS="X" S D2=":X'?.""*"""
S Y=$S(DXS:",$"_V_Y,1:Y_" W"_D2_" $"_V_DXS)_","_D3_")" I $P(X,U,2)["C",$L(Y)<225 S Y=Y_" K Y("_DP_","_+W_")"
I $G(DDXP)=4 S Y=$$DJTOPY^DDXP4(Y)
K K D2,D3 Q
DILL ;SFISC/GFT-TURN PRINT FLDS INTO CODE ;03:56 PM 5 Dec 2001 [ 12/09/2003 4:32 PM ]
+1 ;;22.0;VA FileMan;**25,76,1002**;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 SET DXS=1
V ;
+1 SET V=$PIECE(X,U,2)
SET DRJ=$FIND(V,"P")
IF V["O"
IF $DATA(^(2))
SET Y=Y_" "_^(2)
SET DIO=1
SET D1=""
SET DLN=30
SET DRJ=0
DO SY
GOTO J
+2 IF V["C"
GOTO CLC
IF 'DRJ
GOTO D
SET V=+$EXTRACT(V,DRJ,99)
SET D1=$PIECE(X,U,3)
IF 'V
SET DRJ=0
SET @("V=$D(^"_D1_"0))")
IF 'V
GOTO D
SET V=+$PIECE(^(0),U,2)
POINTR DO Y
DILL_source.html#xS">SET Y=Y_" DILL_source.html#xS">S Y=$DILL_source.html#xS">S(Y="""":Y,$D(^"_D1_"Y,0))#2:$P(^(0),U),1:Y)"
IF $DATA(^DD(V,.01,0))
SET X=$PIECE(X,U)_U_$PIECE(^(0),U,2,9)
GOTO V
D IF V["V"
DO Y
DILL_source.html#xS">SET Y=$PIECE(Y," DILL_source.html#xS">S Y=$DILL_source.html#xS">S(Y="""":Y,$D(^")_" DILL_source.html#xS">S C=$P(^DD("_DP_","_+W_",0),U,2) D Y^DIQ:Y DILL_source.html#xS">S C="","""
+1 IF V["D"
SET DLN=$PIECE($PIECE(X,"%DT=""",2),"""",1)
SET DLN=$SELECT(DLN["S":21,DLN["T":18,1:11)
DO W
SET D1=" D DT"
IF DLN>11&DRJ
SET D1=" W ?("_DLN_"-$S(Y#1:18,1:11)+$X)"_D1
IF W[";W"
SET Y=Y_" X ^DD(""DD"") S:Y[""@"" Y=$P(Y,""@"")_"" ""_$P(Y,""@"",2)"
GOTO SY
+2 IF $PIECE(X,"X>",2)
SET DLN=$LENGTH(+$PIECE(X,"X>",2))+3
SET DRJ=1
GOTO J
+3 SET DLN=+$PIECE(X,"$L(X)>",2)
IF 'DLN
SET D1=$PIECE($PIECE(X,U,4),";",2)
IF D1?1"E"1N.N1","1N.N
SET DLN=$PIECE(D1,",",2)-D1+1
+4 IF V'["S"
IF 'DLN
SET DLN=30
GOTO J
+5 DO W
SET D1=$PIECE(X,U,3)
FOR V=1:1
IF '$DATA(DXS(V))
QUIT
S IF D1]""
IF W[";W"!'$DATA(DNP)
SET D2=$PIECE(D1,";",1)
SET D1=$PIECE(D1,";",2,99)
SET D3=$PIECE(D2,":",1)
SET D2=$PIECE(D2,":",2)
IF $LENGTH(D2)>DLN&'$PIECE(W,";L",2)&'$PIECE(W,";R",2)
SET DLN=$LENGTH(D2)
SET DXS(V,D3)=$EXTRACT(D2,1,DLN)
GOTO S
+1 DO K
DILL_source.html#xS">SET D1="$DILL_source.html#xS">S($D(DXDILL_source.html#xS">S("_V_",Y)):DXDILL_source.html#xS">S("_V_",Y),1:Y)"
IF DRJ
SET D1="$J("_D1_","_DLN_")"
IF W[";W"
SET Y=Y_" S:Y]"""" Y="_D1
IF W'[";W"
SET D1=" W:Y]"""" "_D1
SY DO Y
SET Y=Y_$SELECT($DATA(DNP):"",1:D1)
KILL D1
QUIT
+1 ;
Y IF DXS
SET Y=" S Y="_Y
SET DXS="Y"
Q QUIT
+1 ;
W ;
+1 FOR I=";W",";L"
IF W[I
SET DRJ=0
IF $PIECE(W,I,2)?1N.E
SET DLN=+$PIECE(W,I,2)
SET I=""
GOTO Q
+2 IF $PIECE(X,U,2)["J"
SET I=$PIECE($PIECE(X,U,2),"J",2)
SET W=W_";R"_$PIECE(I+1,U,I>0)
IF $PIECE(X,U,2)'["O"
IF I[","
SET W=W_";D"_+$PIECE(I,",",2)
+3 IF W[";R"
SET DRJ=1
IF $PIECE(W,";R",2)
SET DLN=+$PIECE(W,";R",2)
+4 SET I=$PIECE($PIECE(W,";D",2),";",1)
IF I]""
SET DRJ=1
SET I=","_+I
QUIT
+5 ;
CLC ;
+1 SET Y=" "_$PIECE(X,U,5,99)
SET DXS="X"
IF V["D"
SET Y=Y_" S Y=X"
GOTO D
+2 ;computed pointer
IF V["p"
SET V=$PIECE(V,"p",2)
SET D1=$PIECE($GET(^DIC(+V,0,"GL")),U,2)
IF D1]""
SET Y=Y_" S Y=X"
SET DXS="Y"
GOTO POINTR
+3 IF V?.E1"J"1N.E
IF W'[";X"
IF W'[";R"
IF V'[","
SET W=W_";L"_+$PIECE(V,"J",2)
J DO W
IF V["m"!$DATA(DNP)
QUIT
IF '$DATA(DLN)
SET Y=Y_" W X"
QUIT
+1 IF 'DLN
SET DLN=$SELECT(V["B":1,W[";L0":0,1:8)
+2 SET D2=""
IF 'DRJ
SET V="E("
SET D3="1,"_DLN
+3 IF '$TEST
SET V="J("
SET D3=DLN_I
IF I]""
DO Y
SET D2=":Y]"""""
IF DXS="X"
SET D2=":X'?.""*"""
+4 SET Y=$SELECT(DXS:",$"_V_Y,1:Y_" W"_D2_" $"_V_DXS)_","_D3_")"
IF $PIECE(X,U,2)["C"
IF $LENGTH(Y)<225
SET Y=Y_" K Y("_DP_","_+W_")"
+5 IF $GET(DDXP)=4
SET Y=$$DJTOPY^DDXP4(Y)
K KILL D2,D3
QUIT
