DDSCOMP ;SFISC/MKO-EVALUATE COMPUTED EXPRESSIONS ;8:55 AM 12 Feb 1999
;;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.
;
PARSE(DDP,EXP,BK,NEXP,AR,FDL) ;Parse the computed expression EXP
;Returns:
; NEXP = EXP with {expr} replaced with DDSE(n)
; AR = array when executed sets DDSE(n)
; FDL = list of fields referenced
N I,J,N,ST
;
S NEXP="",(N,AR)=0,ST=1
S I=0 F D Q:'I!$G(DIERR)
. S I=$$FIND^DDSLIB(EXP,"{",I) Q:'I
. S N=N+1
. S NEXP=NEXP_$E(EXP,ST,I-2)_"DDSE("_N_")"
. S ST=$$FIND^DDSLIB(EXP,"}",I)
. D EVAL(DDP,$E(EXP,I,ST-2),BK,N,.AR,.FDL) Q:$G(DIERR)
. S I=ST
Q:$G(DIERR)
S NEXP=$S(EXP?1"=".E:"S Y",1:"")_NEXP_$E(EXP,ST,999)
;
S AR=N
S:$G(FDL)]"" FDL=$E(FDL,1,$L(FDL)-1)
Q
;
EVAL(DDP,EXP,BK,N,AR,FDL) ;Evaluate field expression
;In:
; EXP = computed expr
; N = expr number -- index into DDSE()
;Out:
; AR = array of code that sets DDSE(n)
; FDL = list of fields used in expr
;
N CD
D:EXP?1"FO(".E FO^DDSPTR(DDP,EXP,"","",BK,.CD,.FDL,1)
D:EXP'?1"FO(".E DD^DDSPTR(DDP,EXP,"",.CD,.FDL,1)
Q:$G(DIERR)
;
I CD=1 S AR(N)="N X "_CD(1)_",DDSE("_N_")=X"
E D
. F CD=1:1:CD S AR(N,CD)=CD(CD)
. S AR(N,CD)=AR(N,CD)_",DDSE("_N_")=X"
. S AR(N)="N DDSI,X S DDSE("_N_")="""" F DDSI=1:1:"_CD_" Q:DDSI>1&($G(X)'>0)!'$D(*DDSREFC*,DDSI)) X ^(DDSI)"
Q
;
RPCF(DDSPG) ;Repaint computed fields
;Called from ^DDS01 and ^DDSVALF when value used in
;computed expression changes
N DDSCBK,DDSCDDO
;
S DDSCBK="" F S DDSCBK=$O(@DDSREFS@("COMP",DDP,DDSFLD,DDSPG,DDSCBK)) Q:DDSCBK="" D
. I $P($G(@DDSREFS@(DDSPG,DDSCBK)),U,7)>1 D DB^DDSR(DDSPG,DDSCBK) Q
. N DA,DDSDA
. D GETDA(DDSPG,DDSCBK,.DA)
. S DDSDA=$$DDSDA(.DA)
. S DDSCDDO="" F S DDSCDDO=$O(@DDSREFS@("COMP",DDP,DDSFLD,DDSPG,DDSCBK,DDSCDDO)) Q:DDSCDDO="" D RPCF1
;
Q
;
RPCF1 ;
N DDSC,DDSE,DDSLEN,DDSX
S DDSC=$G(@DDSREFS@(DDSPG,DDSCBK,DDSCDDO,"D")) Q:DDSC=""
S DDSX=$$VAL(DDSCDDO,DDSCBK,DDSDA)
;
S DY=+DDSC,DX=$P(DDSC,U,2),DDSLEN=$P(DDSC,U,3)
I $P(DDSC,U,10) S DDSX=$J("",DDSLEN-$L(DDSX))_$E(DDSX,1,DDSLEN)
E S DDSX=$E(DDSX,1,DDSLEN)_$J("",DDSLEN-$L(DDSX))
X IOXY
W $P(DDGLVID,DDGLDEL)_DDSX_$P(DDGLVID,DDGLDEL,10)
;
N DDP,DDSFLD
S DDP=0,DDSFLD=DDSCDDO_","_DDSBK
D:$D(@DDSREFS@("COMP",DDP,DDSFLD,DDSPG)) RPCF(DDSPG)
;
Q
;
GETDA(P,B,DA) ;Get DA array of block
N I K DA
S DA=$G(@DDSREFT@(P,B)) Q:DA="" Q:'$G(^(B,DA))
F I=2:1:$L(DA,",")-1 S DA(I-1)=$P(DA,",",I)
S DA=+DA
Q
;
VAL(DDSDDO,DDSBK,DDSDA) ;Return value of computed field
N DDSE,DDSX,Y
I $D(DDSDA) N DA D DA(DDSDA,.DA)
S DDSX=0 F S DDSX=$O(@DDSREFS@("COMPE",DDSBK,DDSDDO,DDSX)) Q:DDSX="" X ^(DDSX)
K Y X $G(@DDSREFS@("COMPE",DDSBK,DDSDDO))
Q $G(Y)
;
DA(DDSDA,DA) ;Return DA array based on DDSDA
N I
S DA=$P(DDSDA,",")
F I=2:1:$L(DDSDA,",") S DA(I-1)=$P(DDSDA,",",I)
Q
;
DDSDA(DA) ;Return DDSDA based on DA array
N DDSDA,I
I $G(DA)="" S DDSDA="0,"
E D
. S DDSDA=DA_","
. F I=1:1 Q:$G(DA(I))="" S DDSDA=DDSDA_DA(I)_","
Q DDSDA
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDSCOMP 3286 printed Oct 16, 2024@18:43:49 Page 2
DDSCOMP ;SFISC/MKO-EVALUATE COMPUTED EXPRESSIONS ;8:55 AM 12 Feb 1999
+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 ;
PARSE(DDP,EXP,BK,NEXP,AR,FDL) ;Parse the computed expression EXP
+1 ;Returns:
+2 ; NEXP = EXP with {expr} replaced with DDSE(n)
+3 ; AR = array when executed sets DDSE(n)
+4 ; FDL = list of fields referenced
+5 NEW I,J,N,ST
+6 ;
+7 SET NEXP=""
SET (N,AR)=0
SET ST=1
+8 SET I=0
FOR
Begin DoDot:1
+9 SET I=$$FIND^DDSLIB(EXP,"{",I)
if 'I
QUIT
+10 SET N=N+1
+11 SET NEXP=NEXP_$EXTRACT(EXP,ST,I-2)_"DDSE("_N_")"
+12 SET ST=$$FIND^DDSLIB(EXP,"}",I)
+13 DO EVAL(DDP,$EXTRACT(EXP,I,ST-2),BK,N,.AR,.FDL)
if $GET(DIERR)
QUIT
+14 SET I=ST
End DoDot:1
if 'I!$GET(DIERR)
QUIT
+15 if $GET(DIERR)
QUIT
+16 SET NEXP=$SELECT(EXP?1"=".E:"S Y",1:"")_NEXP_$EXTRACT(EXP,ST,999)
+17 ;
+18 SET AR=N
+19 if $GET(FDL)]""
SET FDL=$EXTRACT(FDL,1,$LENGTH(FDL)-1)
+20 QUIT
+21 ;
EVAL(DDP,EXP,BK,N,AR,FDL) ;Evaluate field expression
+1 ;In:
+2 ; EXP = computed expr
+3 ; N = expr number -- index into DDSE()
+4 ;Out:
+5 ; AR = array of code that sets DDSE(n)
+6 ; FDL = list of fields used in expr
+7 ;
+8 NEW CD
+9 if EXP?1"FO(".E
DO FO^DDSPTR(DDP,EXP,"","",BK,.CD,.FDL,1)
+10 if EXP'?1"FO(".E
DO DD^DDSPTR(DDP,EXP,"",.CD,.FDL,1)
+11 if $GET(DIERR)
QUIT
+12 ;
+13 IF CD=1
SET AR(N)="N X "_CD(1)_",DDSE("_N_")=X"
+14 IF '$TEST
Begin DoDot:1
+15 FOR CD=1:1:CD
SET AR(N,CD)=CD(CD)
+16 SET AR(N,CD)=AR(N,CD)_",DDSE("_N_")=X"
+17 SET AR(N)="N DDSI,X S DDSE("_N_")="""" F DDSI=1:1:"_CD_" Q:DDSI>1&($G(X)'>0)!'$D(*DDSREFC*,DDSI)) X ^(DDSI)"
End DoDot:1
+18 QUIT
+19 ;
RPCF(DDSPG) ;Repaint computed fields
+1 ;Called from ^DDS01 and ^DDSVALF when value used in
+2 ;computed expression changes
+3 NEW DDSCBK,DDSCDDO
+4 ;
+5 SET DDSCBK=""
FOR
SET DDSCBK=$ORDER(@DDSREFS@("COMP",DDP,DDSFLD,DDSPG,DDSCBK))
if DDSCBK=""
QUIT
Begin DoDot:1
+6 IF $PIECE($GET(@DDSREFS@(DDSPG,DDSCBK)),U,7)>1
DO DB^DDSR(DDSPG,DDSCBK)
QUIT
+7 NEW DA,DDSDA
+8 DO GETDA(DDSPG,DDSCBK,.DA)
+9 SET DDSDA=$$DDSDA(.DA)
+10 SET DDSCDDO=""
FOR
SET DDSCDDO=$ORDER(@DDSREFS@("COMP",DDP,DDSFLD,DDSPG,DDSCBK,DDSCDDO))
if DDSCDDO=""
QUIT
DO RPCF1
End DoDot:1
+11 ;
+12 QUIT
+13 ;
RPCF1 ;
+1 NEW DDSC,DDSE,DDSLEN,DDSX
+2 SET DDSC=$GET(@DDSREFS@(DDSPG,DDSCBK,DDSCDDO,"D"))
if DDSC=""
QUIT
+3 SET DDSX=$$VAL(DDSCDDO,DDSCBK,DDSDA)
+4 ;
+5 SET DY=+DDSC
SET DX=$PIECE(DDSC,U,2)
SET DDSLEN=$PIECE(DDSC,U,3)
+6 IF $PIECE(DDSC,U,10)
SET DDSX=$JUSTIFY("",DDSLEN-$LENGTH(DDSX))_$EXTRACT(DDSX,1,DDSLEN)
+7 IF '$TEST
SET DDSX=$EXTRACT(DDSX,1,DDSLEN)_$JUSTIFY("",DDSLEN-$LENGTH(DDSX))
+8 XECUTE IOXY
+9 WRITE $PIECE(DDGLVID,DDGLDEL)_DDSX_$PIECE(DDGLVID,DDGLDEL,10)
+10 ;
+11 NEW DDP,DDSFLD
+12 SET DDP=0
SET DDSFLD=DDSCDDO_","_DDSBK
+13 if $DATA(@DDSREFS@("COMP",DDP,DDSFLD,DDSPG))
DO RPCF(DDSPG)
+14 ;
+15 QUIT
+16 ;
GETDA(P,B,DA) ;Get DA array of block
+1 NEW I
KILL DA
+2 SET DA=$GET(@DDSREFT@(P,B))
if DA=""
QUIT
if '$GET(^(B,DA))
QUIT
+3 FOR I=2:1:$LENGTH(DA,",")-1
SET DA(I-1)=$PIECE(DA,",",I)
+4 SET DA=+DA
+5 QUIT
+6 ;
VAL(DDSDDO,DDSBK,DDSDA) ;Return value of computed field
+1 NEW DDSE,DDSX,Y
+2 IF $DATA(DDSDA)
NEW DA
DO DA(DDSDA,.DA)
+3 SET DDSX=0
FOR
SET DDSX=$ORDER(@DDSREFS@("COMPE",DDSBK,DDSDDO,DDSX))
if DDSX=""
QUIT
XECUTE ^(DDSX)
+4 KILL Y
XECUTE $GET(@DDSREFS@("COMPE",DDSBK,DDSDDO))
+5 QUIT $GET(Y)
+6 ;
DA(DDSDA,DA) ;Return DA array based on DDSDA
+1 NEW I
+2 SET DA=$PIECE(DDSDA,",")
+3 FOR I=2:1:$LENGTH(DDSDA,",")
SET DA(I-1)=$PIECE(DDSDA,",",I)
+4 QUIT
+5 ;
DDSDA(DA) ;Return DDSDA based on DA array
+1 NEW DDSDA,I
+2 IF $GET(DA)=""
SET DDSDA="0,"
+3 IF '$TEST
Begin DoDot:1
+4 SET DDSDA=DA_","
+5 FOR I=1:1
if $GET(DA(I))=""
QUIT
SET DDSDA=DDSDA_DA(I)_","
End DoDot:1
+6 QUIT DDSDA
