- 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 Feb 19, 2025@00:15:37 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
