DILL ;SFISC/GFT - TURN PRINT FLDS INTO CODE ;01MAR2016
;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
;;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.
;
BEGIN ;NEEDS 'W' FOR SORT SPECIFIER AND 'Y' FOR PULLING THE VARIABLE -- E.G. DIOO1 CREATES WRITE CODE IN 'Y'
;THIS SUBROUTINE WILL RETURN 'Y' AS CODE TO DO THE WRITING OF THE VALUE OF THE FIELD, AND 'DLN' AS THE MAX LENGTH OF THE FIELD VALUE
S:$G(DXSET) DXS=1
V ;
I $G(X)'[U S X=$G(^DD(DILLFILE,DILLFLD,0))
TYPE S V=$P(X,U,2) I V["O"!(V["t") S Y=Y_" "_$$OUTPUT^DIETLIBF(DILLFILE,DILLFLD),DIO=1,D1="",DLN=30,DRJ=0 D SY G J
S DRJ=$F(V,"P")
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" D G SY
.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 ;HERE IS WRITE CODE, INCLUDING DT^DIO2
.S:W[";W" Y=Y_" X ^DD(""DD"") S:Y[""@"" Y=$P(Y,""@"")_"" ""_$P(Y,""@"",2)"
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
FJ I V'["S" S I=+$P(V,"J",2) S:V["F"&I DLN=I S:'DLN DLN=30 G J
D W N D1,D2,D3 S D1=$P(X,U,3)
S D2=$G(DUZ("LANG")) I D2>1,$G(^DD(DILLFILE,DILLFLD,.007,D2,0))[";" S D1=^(0) F D2=1:1:$L(D1,";") S $P(D1,";",D2)=":"_$P(D1,";",D2) ;GRAB TRANSLATED SET VALUES
S I D1]"",W[";W"!'$D(DNP) S D2=$P(D1,";"),D1=$P(D1,";",2,99),D3=$P(D2,":"),D2=$P(D2,":",2) S:$L(D2)>DLN&'$P(W,";L",2)&'$P(W,";R",2) DLN=$L(D2) G S
SET S D1="$$SET^DIQ("_DILLFILE_","_DILLFLD_",Y)" S D1=$S(DRJ:"$J("_D1_","_DLN_")",DLN:"$E("_D1_",1,"_DLN_")",1:D1)
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",$P(X,U,2)'["F" 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 ;HERE IS WRITE CODE
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_")" ;HERE IS WRITE CODE
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
;
;
EN(DILLFILE,DILLFLD,DXSET) ; Entry Point for VEN version
G BEGIN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDILL 3324 printed Apr 09, 2024@21:50:54 Page 2
DILL ;SFISC/GFT - TURN PRINT FLDS INTO CODE ;01MAR2016
+1 ;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
+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 ;
BEGIN ;NEEDS 'W' FOR SORT SPECIFIER AND 'Y' FOR PULLING THE VARIABLE -- E.G. DIOO1 CREATES WRITE CODE IN 'Y'
+1 ;THIS SUBROUTINE WILL RETURN 'Y' AS CODE TO DO THE WRITING OF THE VALUE OF THE FIELD, AND 'DLN' AS THE MAX LENGTH OF THE FIELD VALUE
+2 if $GET(DXSET)
SET DXS=1
V ;
+1 IF $GET(X)'[U
SET X=$GET(^DD(DILLFILE,DILLFLD,0))
TYPE SET V=$PIECE(X,U,2)
IF V["O"!(V["t")
SET Y=Y_" "_$$OUTPUT^DIETLIBF(DILLFILE,DILLFLD)
SET DIO=1
SET D1=""
SET DLN=30
SET DRJ=0
DO SY
GOTO J
+1 SET DRJ=$FIND(V,"P")
+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
SET Y=Y_" S Y=$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
SET Y=$PIECE(Y," S Y=$S(Y="""":Y,$D(^")_" S C=$P(^DD("_DP_","_+W_",0),U,2) D Y^DIQ:Y S C="","""
+1 IF V["D"
Begin DoDot:1
+2 SET DLN=$PIECE($PIECE(X,"%DT=""",2),"""",1)
SET DLN=$SELECT(DLN["S":21,DLN["T":18,1:11)
DO W
+3 ;HERE IS WRITE CODE, INCLUDING DT^DIO2
SET D1=" D DT"
if DLN>11&DRJ
SET D1=" W ?("_DLN_"-$S(Y#1:18,1:11)+$X)"_D1
+4 if W[";W"
SET Y=Y_" X ^DD(""DD"") S:Y[""@"" Y=$P(Y,""@"")_"" ""_$P(Y,""@"",2)"
End DoDot:1
GOTO SY
+5 IF $PIECE(X,"X>",2)
SET DLN=$LENGTH(+$PIECE(X,"X>",2))+3
SET DRJ=1
GOTO J
+6 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
FJ IF V'["S"
SET I=+$PIECE(V,"J",2)
if V["F"&I
SET DLN=I
if 'DLN
SET DLN=30
GOTO J
+1 DO W
NEW D1,D2,D3
SET D1=$PIECE(X,U,3)
+2 ;GRAB TRANSLATED SET VALUES
SET D2=$GET(DUZ("LANG"))
IF D2>1
IF $GET(^DD(DILLFILE,DILLFLD,.007,D2,0))[";"
SET D1=^(0)
FOR D2=1:1:$LENGTH(D1,";")
SET $PIECE(D1,";",D2)=":"_$PIECE(D1,";",D2)
S IF D1]""
IF W[";W"!'$DATA(DNP)
SET D2=$PIECE(D1,";")
SET D1=$PIECE(D1,";",2,99)
SET D3=$PIECE(D2,":")
SET D2=$PIECE(D2,":",2)
if $LENGTH(D2)>DLN&'$PIECE(W,";L",2)&'$PIECE(W,";R",2)
SET DLN=$LENGTH(D2)
GOTO S
SET SET D1="$$SET^DIQ("_DILLFILE_","_DILLFLD_",Y)"
SET D1=$SELECT(DRJ:"$J("_D1_","_DLN_")",DLN:"$E("_D1_",1,"_DLN_")",1:D1)
+1 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 ;
+2 ;
+3 ;
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"
IF $PIECE(X,U,2)'["F"
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)
+4 ;
J ;HERE IS WRITE CODE
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 ;HERE IS WRITE CODE
SET Y=$SELECT(DXS:",$"_V_Y,1:Y_" W"_D2_" $"_V_DXS)_","_D3_")"
+5 IF $PIECE(X,U,2)["C"
IF $LENGTH(Y)<225
SET Y=Y_" K Y("_DP_","_+W_")"
+6 IF $GET(DDXP)=4
SET Y=$$DJTOPY^DDXP4(Y)
K KILL D2,D3
QUIT
+1 ;
+2 ;
EN(DILLFILE,DILLFLD,DXSET) ; Entry Point for VEN version
+1 GOTO BEGIN
