DDSZ1 ;SFISC/MKO-GET BLOCK INFO,SCREEN IMAGE ;9:59 AM 15 Jul 1997
;;22.0;VA FileMan;;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
EN(DDSPG,DDSBK,DDP,DDSBY,DDSBX,DDSBO,DDSTP,DDSREP,DDSNDD,DDSPGRP,DDSSCR,DDSNAV,DDSORD,DDSRNAV) ;
;Input:
; DDSREFS = Global ref
;Output:
; DDSSCR
; DDSNAV
; DDSORD
; DDSRNAV
;
N Y
S:$G(DDSTP)="" DDSTP="e"
I DDSTP'="h",$G(DDSBO),$D(DDSORD(DDSBO))[0 D
. S DDSORD(DDSBO)=DDSBK
. S:$G(DDSREP)>1 $P(DDSORD(DDSBO),U,2)=$S($P(DDSREP,U,5)]"":$P($$GETFLD^DDSLIB($P(DDSREP,U,5),"","","","",DDSBK),","),1:"FIRST")
;
S DDSF=0
F S DDSF=$O(^DIST(.404,DDSBK,40,DDSF)) Q:DDSF'=+DDSF D FLD
;
KILL K DDSC1,DDSC2,DDSCAP,DDSCLN,DDSD1,DDSD2,DDSD3
K DDSDDL0,DDSF,DDSFLD,DDSKEY,DDSL0,DDSL01,DDSL2,DDSL4,DDSN
Q
;
FLD ;Set up
; @DDSREFS@(pg,bk,ddo,
; "D") = data $Y^data $X^data $L^field#
; ^xcap $Y^xcap $X^xcap colon^xcap req
; ^1 if computed field^1 if right justified
; "COMPE") = M code that sets X
; "COMPE",1) = array sets DDSE(n)
;
; @DDSREFS@("Ffile#",field#,"L",pg,bk,ddo)=""
;
; DDSSCR(row) = captions on that row
; DDSSCR(row,col) = final columns underlined
; DDSNAV(row,col) = ddo,bk for editable fields
; DDSORD(bo,fo) = ddo for editable fields
;
;Get field properties
S:'$P(^DIST(.404,DDSBK,40,DDSF,0),U,3) $P(^(0),U,3)=3
S DDSL0=$G(^DIST(.404,DDSBK,40,DDSF,0)),DDSL01=$G(^(.1)),DDSFLD=$S($P(DDSL0,U,3)=2:DDSF_","_DDSBK,1:+$G(^(1))),DDSL2=$G(^(2)),DDSL4=$G(^(4))
K:$P(DDSL0,U,3)=3!'$P(DDSL0,U,3) DDSNDD
S DDSDDL0=$G(^DD(DDP,DDSFLD,0)) Q:DDSL0?."^"!(DDSL2?."^")
S DDSKEY=DDSFLD'[","&($D(^DD("KEY","F",DDP,DDSFLD))>1)
S DDSD1=$P($P(DDSL2,U),",")+DDSBY-1
S DDSD2=$P($P(DDSL2,U),",",2)+DDSBX-1
S DDSD3=$P(DDSL2,U,2)
S DDSC1=$P($P(DDSL2,U,3),",")+DDSBY-1
S DDSC2=$P($P(DDSL2,U,3),",",2)+DDSBX-1
S DDSCAP=$TR($P(DDSL0,U,2)," ",$C(0))
S DDSCLN=$S(DDSCAP="":"",$P(DDSL0,U,3)=1:"",$P(DDSL2,U,4):"",1:":")
;
I DDSC1'<0,DDSC2'<0,$L(DDSCAP)>0,DDSCAP'="!M" D
. ;Set CAP xref for ^-jumping
. I DDSTP="e","^2^3^"[(U_$P(DDSL0,U,3)_U)!'$P(DDSL0,U,3) D
.. N C,I,L
.. S I=0 F S I=$O(DDSPGRP(I)) Q:'I Q:U_DDSPGRP(I)_U[(U_DDSPG_U)
.. Q:'I
.. S C=$P(DDSL0,U,2)
.. S:C?1"Select ".E C=$P(C,"Select ",2,999)
.. S C=$E($TR(C,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ"),1,40)
.. S L=$L(DDSREFS)+$L(C)+$L(DDSPGRP(I))+$L(DDSPG)+$L(DDSBK)+$L(DDSF)+30
.. S:L>127 C=$E(C,1,$L(C)-(L-127))
.. S:C]"" @DDSREFS@("CAP",C,DDSPGRP(I),DDSPG,DDSBK,DDSF)=""
. ;
. ;Set DDSSCR
. I DDSC1'<0,DDSC2'<0,$L(DDSCAP)>0,DDSCAP'="!M" D
.. N DDSI,DDSX
.. S DDSX=DDSCAP_DDSCLN
.. F DDSI=1:1:+DDSREP D
... S $E(DDSSCR(DDSC1+DDSI),DDSC2+1,DDSC2+$L(DDSX))=DDSX
... S:$S($P(DDSL4,U)]"":+DDSL4,1:$P(DDSDDL0,U,2)["R")!DDSKEY DDSSCR(DDSC1+DDSI,DDSC2+1)=DDSC2+$L(DDSCAP)
;
;Set "D", "L" nodes, DDSNAV, and DDSORD
I DDSD1'<0,DDSD2'<0,DDSD3>0 D
. S @DDSREFS@(DDSPG,DDSBK,DDSF,"D")=DDSD1_U_DDSD2_U_DDSD3_U_DDSFLD
. S @DDSREFS@("F"_$S(DDSFLD[",":0,1:DDP),DDSFLD,"L",DDSPG,DDSBK,DDSF)=""
I DDSCAP="!M",DDSC1'<0,DDSC2'<0 S $P(@DDSREFS@(DDSPG,DDSBK,DDSF,"D"),U,5,8)=DDSC1_U_DDSC2_U_DDSCLN_U_($P(DDSDDL0,U,2)["R"!+DDSL4!DDSKEY)
S:$P(DDSL4,U,3) $P(@DDSREFS@(DDSPG,DDSBK,DDSF,"D"),U,10)=1
;
;Computed fields
I $P(DDSL0,U,3)=4 D K DDSCOMP,DDSAR,DDSEXP,DDSFD Q
. S DDSCOMP=$G(^DIST(.404,DDSBK,40,DDSF,30)) Q:DDSCOMP?."^"
. D PARSE^DDSCOMP(DDP,DDSCOMP,DDSBK,.DDSEXP,.DDSAR,.DDSFD)
. Q:DDSEXP=""!$G(DIERR)
. S @DDSREFS@("COMPE",DDSBK,DDSF)=DDSEXP
. F DDSAR=1:1:DDSAR D
.. S:DDSAR(DDSAR)["*DDSREFC*" DDSAR(DDSAR)=$P(DDSAR(DDSAR),"*DDSREFC*")_$E(DDSREFS,1,$L(DDSREFS)-1)_",""COMPE"","_DDSBK_","_DDSF_","_DDSAR_$P(DDSAR(DDSAR),"*DDSREFC*",2,999)
.. S @DDSREFS@("COMPE",DDSBK,DDSF,DDSAR)=DDSAR(DDSAR)
.. I $D(DDSAR(DDSAR))>9 N I F I=1:1 Q:$D(DDSAR(DDSAR,I))[0 D
... S @DDSREFS@("COMPE",DDSBK,DDSF,DDSAR,I)=DDSAR(DDSAR,I)
. S $P(@DDSREFS@(DDSPG,DDSBK,DDSF,"D"),U,9)=1
. I $G(DDSFD)]"" F DDSAR=1:1:$L(DDSFD,U) D
.. N F S F=$P(DDSFD,U,DDSAR) Q:F=""
.. S @DDSREFS@("COMP",$P(F,","),$P($P(F,",",2,99),";"),DDSPG,DDSBK,DDSF)=""
;
Q:DDSD1<0!(DDSD2<0)!(DDSD3'>0)!(DDSL2?."^")
Q:$P(DDSDDL0,U,4)=" ; " Q:DDSTP="h" Q:DDSFLD=.001
I '$P(DDSDDL0,U,2),DDSTP'="e" Q
;
S DDSORD(DDSBO,+DDSL0)=DDSF
S DDSNAV(DDSD1,DDSD2)=DDSF_","_DDSBK
S:$P(DDSDDL0,U,2) DDSMUL(DDSBK,DDSF)=""
;
I $G(DDSREP)>1 D
. S $P(DDSNAV(DDSD1,DDSD2),",",3)=DDSBO
. S DDSRNAV(DDSBO,DDSD1)=DDSBK
. S DDSRNAV(DDSBO,DDSD1,DDSD2)=DDSF
. S DDSRNAV(DDSBO,DDSD1-1,DDSD2)=DDSF_",-1"
. S DDSRNAV(DDSBO,DDSD1+1,DDSD2)=DDSF_",+1"
Q
DDSZ1 ;SFISC/MKO-GET BLOCK INFO,SCREEN IMAGE ;9:59 AM 15 Jul 1997
+1 ;;22.0;VA FileMan;;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN(DDSPG,DDSBK,DDP,DDSBY,DDSBX,DDSBO,DDSTP,DDSREP,DDSNDD,DDSPGRP,DDSSCR,DDSNAV,DDSORD,DDSRNAV) ;
+1 ;Input:
+2 ; DDSREFS = Global ref
+3 ;Output:
+4 ; DDSSCR
+5 ; DDSNAV
+6 ; DDSORD
+7 ; DDSRNAV
+8 ;
+9 NEW Y
+10 IF $GET(DDSTP)=""
SET DDSTP="e"
+11 IF DDSTP'="h"
IF $GET(DDSBO)
IF $DATA(DDSORD(DDSBO))[0
Begin DoDot:1
+12 SET DDSORD(DDSBO)=DDSBK
+13 IF $GET(DDSREP)>1
SET $PIECE(DDSORD(DDSBO),U,2)=$SELECT($PIECE(DDSREP,U,5)]"":$PIECE($$GETFLD^DDSLIB($PIECE(DDSREP,U,5),"","","","",DDSBK),","),1:"FIRST")
End DoDot:1
+14 ;
+15 SET DDSF=0
+16 FOR
SET DDSF=$ORDER(^DIST(.404,DDSBK,40,DDSF))
IF DDSF'=+DDSF
QUIT
DO FLD
+17 ;
KILL KILL DDSC1,DDSC2,DDSCAP,DDSCLN,DDSD1,DDSD2,DDSD3
+1 KILL DDSDDL0,DDSF,DDSFLD,DDSKEY,DDSL0,DDSL01,DDSL2,DDSL4,DDSN
+2 QUIT
+3 ;
FLD ;Set up
+1 ; @DDSREFS@(pg,bk,ddo,
+2 ; "D") = data $Y^data $X^data $L^field#
+3 ; ^xcap $Y^xcap $X^xcap colon^xcap req
+4 ; ^1 if computed field^1 if right justified
+5 ; "COMPE") = M code that sets X
+6 ; "COMPE",1) = array sets DDSE(n)
+7 ;
+8 ; @DDSREFS@("Ffile#",field#,"L",pg,bk,ddo)=""
+9 ;
+10 ; DDSSCR(row) = captions on that row
+11 ; DDSSCR(row,col) = final columns underlined
+12 ; DDSNAV(row,col) = ddo,bk for editable fields
+13 ; DDSORD(bo,fo) = ddo for editable fields
+14 ;
+15 ;Get field properties
+16 IF '$PIECE(^DIST(.404,DDSBK,40,DDSF,0),U,3)
SET $PIECE(^(0),U,3)=3
+17 SET DDSL0=$GET(^DIST(.404,DDSBK,40,DDSF,0))
SET DDSL01=$GET(^(.1))
SET DDSFLD=$SELECT($PIECE(DDSL0,U,3)=2:DDSF_","_DDSBK,1:+$GET(^(1)))
SET DDSL2=$GET(^(2))
SET DDSL4=$GET(^(4))
+18 IF $PIECE(DDSL0,U,3)=3!'$PIECE(DDSL0,U,3)
KILL DDSNDD
+19 SET DDSDDL0=$GET(^DD(DDP,DDSFLD,0))
IF DDSL0?."^"!(DDSL2?."^")
QUIT
+20 SET DDSKEY=DDSFLD'[","&($DATA(^DD("KEY","F",DDP,DDSFLD))>1)
+21 SET DDSD1=$PIECE($PIECE(DDSL2,U),",")+DDSBY-1
+22 SET DDSD2=$PIECE($PIECE(DDSL2,U),",",2)+DDSBX-1
+23 SET DDSD3=$PIECE(DDSL2,U,2)
+24 SET DDSC1=$PIECE($PIECE(DDSL2,U,3),",")+DDSBY-1
+25 SET DDSC2=$PIECE($PIECE(DDSL2,U,3),",",2)+DDSBX-1
+26 SET DDSCAP=$TRANSLATE($PIECE(DDSL0,U,2)," ",$CHAR(0))
+27 SET DDSCLN=$SELECT(DDSCAP="":"",$PIECE(DDSL0,U,3)=1:"",$PIECE(DDSL2,U,4):"",1:":")
+28 ;
+29 IF DDSC1'<0
IF DDSC2'<0
IF $LENGTH(DDSCAP)>0
IF DDSCAP'="!M"
Begin DoDot:1
+30 ;Set CAP xref for ^-jumping
+31 IF DDSTP="e"
IF "^2^3^"[(U_$PIECE(DDSL0,U,3)_U)!'$PIECE(DDSL0,U,3)
Begin DoDot:2
+32 NEW C,I,L
+33 SET I=0
FOR
SET I=$ORDER(DDSPGRP(I))
IF 'I
QUIT
IF U_DDSPGRP(I)_U[(U_DDSPG_U)
QUIT
+34 IF 'I
QUIT
+35 SET C=$PIECE(DDSL0,U,2)
+36 IF C?1"Select ".E
SET C=$PIECE(C,"Select ",2,999)
+37 SET C=$EXTRACT($TRANSLATE(C,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ"),1,40)
+38 SET L=$LENGTH(DDSREFS)+$LENGTH(C)+$LENGTH(DDSPGRP(I))+$LENGTH(DDSPG)+$LENGTH(DDSBK)+$LENGTH(DDSF)+30
+39 IF L>127
SET C=$EXTRACT(C,1,$LENGTH(C)-(L-127))
+40 IF C]""
SET @DDSREFS@("CAP",C,DDSPGRP(I),DDSPG,DDSBK,DDSF)=""
End DoDot:2
+41 ;
+42 ;Set DDSSCR
+43 IF DDSC1'<0
IF DDSC2'<0
IF $LENGTH(DDSCAP)>0
IF DDSCAP'="!M"
Begin DoDot:2
+44 NEW DDSI,DDSX
+45 SET DDSX=DDSCAP_DDSCLN
+46 FOR DDSI=1:1:+DDSREP
Begin DoDot:3
+47 SET $EXTRACT(DDSSCR(DDSC1+DDSI),DDSC2+1,DDSC2+$LENGTH(DDSX))=DDSX
+48 IF $SELECT($PIECE(DDSL4,U)]""
SET DDSSCR(DDSC1+DDSI,DDSC2+1)=DDSC2+$LENGTH(DDSCAP)
End DoDot:3
End DoDot:2
End DoDot:1
+49 ;
+50 ;Set "D", "L" nodes, DDSNAV, and DDSORD
+51 IF DDSD1'<0
IF DDSD2'<0
IF DDSD3>0
Begin DoDot:1
+52 SET @DDSREFS@(DDSPG,DDSBK,DDSF,"D")=DDSD1_U_DDSD2_U_DDSD3_U_DDSFLD
+53 SET @DDSREFS@("F"_$SELECT(DDSFLD[",":0,1:DDP),DDSFLD,"L",DDSPG,DDSBK,DDSF)=""
End DoDot:1
+54 IF DDSCAP="!M"
IF DDSC1'<0
IF DDSC2'<0
SET $PIECE(@DDSREFS@(DDSPG,DDSBK,DDSF,"D"),U,5,8)=DDSC1_U_DDSC2_U_DDSCLN_U_($PIECE(DDSDDL0,U,2)["R"!+DDSL4!DDSKEY)
+55 IF $PIECE(DDSL4,U,3)
SET $PIECE(@DDSREFS@(DDSPG,DDSBK,DDSF,"D"),U,10)=1
+56 ;
+57 ;Computed fields
+58 IF $PIECE(DDSL0,U,3)=4
Begin DoDot:1
+59 SET DDSCOMP=$GET(^DIST(.404,DDSBK,40,DDSF,30))
IF DDSCOMP?."^"
QUIT
+60 DO PARSE^DDSCOMP(DDP,DDSCOMP,DDSBK,.DDSEXP,.DDSAR,.DDSFD)
+61 IF DDSEXP=""!$GET(DIERR)
QUIT
+62 SET @DDSREFS@("COMPE",DDSBK,DDSF)=DDSEXP
+63 FOR DDSAR=1:1:DDSAR
Begin DoDot:2
+64 IF DDSAR(DDSAR)["*DDSREFC*"
SET DDSAR(DDSAR)=$PIECE(DDSAR(DDSAR),"*DDSREFC*")_$EXTRACT(DDSREFS,1,$LENGTH(DDSREFS)-1)_",""COMPE"","_DDSBK_","_DDSF_","_DDSAR_$PIECE(DDSAR(DDSAR),"*DDSREFC*",2,999)
+65 SET @DDSREFS@("COMPE",DDSBK,DDSF,DDSAR)=DDSAR(DDSAR)
+66 IF $DATA(DDSAR(DDSAR))>9
NEW I
FOR I=1:1
IF $DATA(DDSAR(DDSAR,I))[0
QUIT
Begin DoDot:3
+67 SET @DDSREFS@("COMPE",DDSBK,DDSF,DDSAR,I)=DDSAR(DDSAR,I)
End DoDot:3
End DoDot:2
+68 SET $PIECE(@DDSREFS@(DDSPG,DDSBK,DDSF,"D"),U,9)=1
+69 IF $GET(DDSFD)]""
FOR DDSAR=1:1:$LENGTH(DDSFD,U)
Begin DoDot:2
+70 NEW F
SET F=$PIECE(DDSFD,U,DDSAR)
IF F=""
QUIT
+71 SET @DDSREFS@("COMP",$PIECE(F,","),$PIECE($PIECE(F,",",2,99),";"),DDSPG,DDSBK,DDSF)=""
End DoDot:2
End DoDot:1
KILL DDSCOMP,DDSAR,DDSEXP,DDSFD
QUIT
+72 ;
+73 IF DDSD1<0!(DDSD2<0)!(DDSD3'>0)!(DDSL2?."^")
QUIT
+74 IF $PIECE(DDSDDL0,U,4)=" ; "
QUIT
IF DDSTP="h"
QUIT
IF DDSFLD=.001
QUIT
+75 IF '$PIECE(DDSDDL0,U,2)
IF DDSTP'="e"
QUIT
+76 ;
+77 SET DDSORD(DDSBO,+DDSL0)=DDSF
+78 SET DDSNAV(DDSD1,DDSD2)=DDSF_","_DDSBK
+79 IF $PIECE(DDSDDL0,U,2)
SET DDSMUL(DDSBK,DDSF)=""
+80 ;
+81 IF $GET(DDSREP)>1
Begin DoDot:1
+82 SET $PIECE(DDSNAV(DDSD1,DDSD2),",",3)=DDSBO
+83 SET DDSRNAV(DDSBO,DDSD1)=DDSBK
+84 SET DDSRNAV(DDSBO,DDSD1,DDSD2)=DDSF
+85 SET DDSRNAV(DDSBO,DDSD1-1,DDSD2)=DDSF_",-1"
+86 SET DDSRNAV(DDSBO,DDSD1+1,DDSD2)=DDSF_",+1"
End DoDot:1
+87 QUIT
