DDSZ1 ;SFISC/MKO-GET BLOCK INFO,SCREEN IMAGE ;20JAN2004
;;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.
;
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")
;
LOOP N DDSHITE S DDSHITE=$$HITE^DDSR(DDSBK),DDSF=0 ;DJW/GFT HEIGHT OF MULTIPLES
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 ;REMEMBER THAT AT LEAST ONE FIELD IS A DATA DICTIONARY
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)
UP .. S C=$E($$UP^DILIBF(C),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
CAPS ... S $E(DDSSCR(DDSI-1*DDSHITE+1+DDSC1),DDSC2+1,DDSC2+$L(DDSX))=DDSX ;GFT
... S:$S($P(DDSL4,U)]"":+DDSL4,1:$P(DDSDDL0,U,2)["R")!DDSKEY DDSSCR(DDSI-1*DDSHITE+1+DDSC1,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
HITE . S DDSRNAV(DDSBO,DDSD1-.4,DDSD2)=DDSF_",-1" ;DJW/GFT??
. S DDSRNAV(DDSBO,DDSD1+.4,DDSD2)=DDSF_",+1"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDSZ1 4986 printed Oct 16, 2024@18:44:15 Page 2
DDSZ1 ;SFISC/MKO-GET BLOCK INFO,SCREEN IMAGE ;20JAN2004
+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 ;
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 ;
LOOP ;DJW/GFT HEIGHT OF MULTIPLES
NEW DDSHITE
SET DDSHITE=$$HITE^DDSR(DDSBK)
SET DDSF=0
+1 FOR
SET DDSF=$ORDER(^DIST(.404,DDSBK,40,DDSF))
if DDSF'=+DDSF
QUIT
DO FLD
+2 ;
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 ;REMEMBER THAT AT LEAST ONE FIELD IS A DATA DICTIONARY
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)
UP SET C=$EXTRACT($$UP^DILIBF(C),1,40)
+1 SET L=$LENGTH(DDSREFS)+$LENGTH(C)+$LENGTH(DDSPGRP(I))+$LENGTH(DDSPG)+$LENGTH(DDSBK)+$LENGTH(DDSF)+30
+2 if L>127
SET C=$EXTRACT(C,1,$LENGTH(C)-(L-127))
+3 if C]""
SET @DDSREFS@("CAP",C,DDSPGRP(I),DDSPG,DDSBK,DDSF)=""
End DoDot:2
+4 ;
+5 ;Set DDSSCR
+6 IF DDSC1'<0
IF DDSC2'<0
IF $LENGTH(DDSCAP)>0
IF DDSCAP'="!M"
Begin DoDot:2
+7 NEW DDSI,DDSX
+8 SET DDSX=DDSCAP_DDSCLN
+9 FOR DDSI=1:1:+DDSREP
Begin DoDot:3
CAPS ;GFT
SET $EXTRACT(DDSSCR(DDSI-1*DDSHITE+1+DDSC1),DDSC2+1,DDSC2+$LENGTH(DDSX))=DDSX
+1 if $SELECT($PIECE(DDSL4,U)]""
SET DDSSCR(DDSI-1*DDSHITE+1+DDSC1,DDSC2+1)=DDSC2+$LENGTH(DDSCAP)
End DoDot:3
End DoDot:2
End DoDot:1
+2 ;
+3 ;Set "D", "L" nodes, DDSNAV, and DDSORD
+4 IF DDSD1'<0
IF DDSD2'<0
IF DDSD3>0
Begin DoDot:1
+5 SET @DDSREFS@(DDSPG,DDSBK,DDSF,"D")=DDSD1_U_DDSD2_U_DDSD3_U_DDSFLD
+6 SET @DDSREFS@("F"_$SELECT(DDSFLD[",":0,1:DDP),DDSFLD,"L",DDSPG,DDSBK,DDSF)=""
End DoDot:1
+7 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)
+8 if $PIECE(DDSL4,U,3)
SET $PIECE(@DDSREFS@(DDSPG,DDSBK,DDSF,"D"),U,10)=1
+9 ;
+10 ;Computed fields
+11 IF $PIECE(DDSL0,U,3)=4
Begin DoDot:1
+12 SET DDSCOMP=$GET(^DIST(.404,DDSBK,40,DDSF,30))
if DDSCOMP?."^"
QUIT
+13 DO PARSE^DDSCOMP(DDP,DDSCOMP,DDSBK,.DDSEXP,.DDSAR,.DDSFD)
+14 if DDSEXP=""!$GET(DIERR)
QUIT
+15 SET @DDSREFS@("COMPE",DDSBK,DDSF)=DDSEXP
+16 FOR DDSAR=1:1:DDSAR
Begin DoDot:2
+17 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)
+18 SET @DDSREFS@("COMPE",DDSBK,DDSF,DDSAR)=DDSAR(DDSAR)
+19 IF $DATA(DDSAR(DDSAR))>9
NEW I
FOR I=1:1
if $DATA(DDSAR(DDSAR,I))[0
QUIT
Begin DoDot:3
+20 SET @DDSREFS@("COMPE",DDSBK,DDSF,DDSAR,I)=DDSAR(DDSAR,I)
End DoDot:3
End DoDot:2
+21 SET $PIECE(@DDSREFS@(DDSPG,DDSBK,DDSF,"D"),U,9)=1
+22 IF $GET(DDSFD)]""
FOR DDSAR=1:1:$LENGTH(DDSFD,U)
Begin DoDot:2
+23 NEW F
SET F=$PIECE(DDSFD,U,DDSAR)
if F=""
QUIT
+24 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
+25 ;
+26 if DDSD1<0!(DDSD2<0)!(DDSD3'>0)!(DDSL2?."^")
QUIT
+27 if $PIECE(DDSDDL0,U,4)=" ; "
QUIT
if DDSTP="h"
QUIT
if DDSFLD=.001
QUIT
+28 IF '$PIECE(DDSDDL0,U,2)
IF DDSTP'="e"
QUIT
+29 ;
+30 SET DDSORD(DDSBO,+DDSL0)=DDSF
+31 SET DDSNAV(DDSD1,DDSD2)=DDSF_","_DDSBK
+32 if $PIECE(DDSDDL0,U,2)
SET DDSMUL(DDSBK,DDSF)=""
+33 ;
+34 IF $GET(DDSREP)>1
Begin DoDot:1
+35 SET $PIECE(DDSNAV(DDSD1,DDSD2),",",3)=DDSBO
+36 SET DDSRNAV(DDSBO,DDSD1)=DDSBK
+37 SET DDSRNAV(DDSBO,DDSD1,DDSD2)=DDSF
HITE ;DJW/GFT??
SET DDSRNAV(DDSBO,DDSD1-.4,DDSD2)=DDSF_",-1"
+1 SET DDSRNAV(DDSBO,DDSD1+.4,DDSD2)=DDSF_",+1"
End DoDot:1
+2 QUIT
