DDSVALM ;SFISC/MKO-PUT FOR MULTIPLES (SELECT PROMPT) ;10:45 AM 9 Sep 1994
;;22.0;VA FileMan;;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
;
MULT ;Put multiple or wp field
N DDSVDIC,DDSVDV,DDSVND,DDSVPC,DDSVSUB
S DDSVPC=$P(DDSV0,U,4),DDSVND=$P(DDSVPC,";"),DDSVPC=$P(DDSVPC,";",2)
S DDSVSUB=+DDSV02 Q:$D(^DD(DDSVSUB,.01,0))[0
S DDSVDV=DDSVSUB_$P(^DD(DDSVSUB,.01,0),U,2),X=$P(^(0),U,3)
S DDSVDIC=DIE_DA_","""_DDSVND_""","
;
I DDSVDV["W" D PUTWP
I DDSVDV'["W" D PUTMULT
Q
;
PUTMULT ;Put for multiples
N DDSVRN
S DDSVRN=$S(DDSVAL="FIRST":$O(@(DDSVDIC_"0)")),DDSVAL="LAST":$O(@(DDSVDIC_""" "")"),-1),1:+$G(DDSVAL))
;
K Y S Y="",Y(0)=""
I DDSVRN>0,$D(@(DDSVDIC_+DDSVRN_",0)"))#2 S Y(0)=$P(^(0),U) D
. I DDSVDV["O"!(DDSVDV["P")!(DDSVDV["V")!(DDSVDV["D")!(DDSVDV["S") D
.. S Y(0)=$$EXTERNAL^DILFD(DDSVSUB,.01,"",DDSVRN)
. S Y=DDSVRN
;
S:'$D(@DDSREFT@("F"_DDP,DDSVDA,DDSFLD,"M")) ^("M")=1_DDSVDIC_U_DDSVSUB
D UPDATE^DDSVAL(DDP,DDSVDA,.DA,DDSFLD,DDSPG,.Y)
Q
;
PUTWP ;File wp field from @DDSVAL into @DDSREFT
N DDSTMP
S DDSTMP=$NA(@DDSREFT@("F"_DDP,DDSDA))
;
I DDSVAL]"",$D(@DDSVAL) D Q:$G(DIERR)
. D PUTWP^DIEFW($E("A",DDSPARM["A"),DDSVAL,$NA(@DDSTMP@(DDSFLD,"D")))
E K @DDSTMP@(DDSFLD,"D")
;
S:$D(@DDSTMP@(DDSFLD,"M"))[0 ^("M")="0"_DDSVDIC_U_DDSVSUB
S:$D(@DDSTMP@("GL"))[0 ^("GL")=DIE
S (DDSCHG,@DDSTMP@(DDSFLD,"F"))=3
Q
;
GETWP ;Merge wp field into ^TMP, return root in DDSANS
N DDSGL
S DDSGL=DIE_DA_","""_DDSVND_""","
S DDSANS=$NA(^TMP("DDSWP",$J,DDP,DDSDA,DDSFLD))
;
K @DDSANS
M:$D(@(DDSGL_"0)"))#2 @DDSANS=@($E(DDSGL,1,$L(DDSGL)-1)_")")
Q
;
REL(DDP,DA,DDSFLD,DDSPARM) ;Relational syntax
N DDSCD,DDSI,X
D DD^DDSPTR(DDP,DDSFLD,"",.DDSCD,"",DDSPARM["I"+1)
F DDSI=1:1:DDSCD X DDSCD(DDSI)
Q X
;
ERR(DDSVEP) ;Print error messages
Q:'$G(DIERR)
I '$D(DDS) D MSG^DIALOG("BW") Q
N DDSVMSG
S DDSER=DIERR
D BLD^DIALOG(3031,DDSVEP,"","DDSVMSG")
D MSG^DDSMSG(DDSVMSG(1)),ERR^DDSMSG
Q
DDSVALM ;SFISC/MKO-PUT FOR MULTIPLES (SELECT PROMPT) ;10:45 AM 9 Sep 1994
+1 ;;22.0;VA FileMan;;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
MULT ;Put multiple or wp field
+1 NEW DDSVDIC,DDSVDV,DDSVND,DDSVPC,DDSVSUB
+2 SET DDSVPC=$PIECE(DDSV0,U,4)
SET DDSVND=$PIECE(DDSVPC,";")
SET DDSVPC=$PIECE(DDSVPC,";",2)
+3 SET DDSVSUB=+DDSV02
IF $DATA(^DD(DDSVSUB,.01,0))[0
QUIT
+4 SET DDSVDV=DDSVSUB_$PIECE(^DD(DDSVSUB,.01,0),U,2)
SET X=$PIECE(^(0),U,3)
+5 SET DDSVDIC=DIE_DA_","""_DDSVND_""","
+6 ;
+7 IF DDSVDV["W"
DO PUTWP
+8 IF DDSVDV'["W"
DO PUTMULT
+9 QUIT
+10 ;
PUTMULT ;Put for multiples
+1 NEW DDSVRN
+2 SET DDSVRN=$SELECT(DDSVAL="FIRST":$ORDER(@(DDSVDIC_"0)")),DDSVAL="LAST":$ORDER(@(DDSVDIC_""" "")"),-1),1:+$GET(DDSVAL))
+3 ;
+4 KILL Y
SET Y=""
SET Y(0)=""
+5 IF DDSVRN>0
IF $DATA(@(DDSVDIC_+DDSVRN_",0)"))#2
SET Y(0)=$PIECE(^(0),U)
Begin DoDot:1
+6 IF DDSVDV["O"!(DDSVDV["P")!(DDSVDV["V")!(DDSVDV["D")!(DDSVDV["S")
Begin DoDot:2
+7 SET Y(0)=$$EXTERNAL^DILFD(DDSVSUB,.01,"",DDSVRN)
End DoDot:2
+8 SET Y=DDSVRN
End DoDot:1
+9 ;
+10 IF '$DATA(@DDSREFT@("F"_DDP,DDSVDA,DDSFLD,"M"))
SET ^("M")=1_DDSVDIC_U_DDSVSUB
+11 DO UPDATE^DDSVAL(DDP,DDSVDA,.DA,DDSFLD,DDSPG,.Y)
+12 QUIT
+13 ;
PUTWP ;File wp field from @DDSVAL into @DDSREFT
+1 NEW DDSTMP
+2 SET DDSTMP=$NAME(@DDSREFT@("F"_DDP,DDSDA))
+3 ;
+4 IF DDSVAL]""
IF $DATA(@DDSVAL)
Begin DoDot:1
+5 DO PUTWP^DIEFW($EXTRACT("A",DDSPARM["A"),DDSVAL,$NAME(@DDSTMP@(DDSFLD,"D")))
End DoDot:1
IF $GET(DIERR)
QUIT
+6 IF '$TEST
KILL @DDSTMP@(DDSFLD,"D")
+7 ;
+8 IF $DATA(@DDSTMP@(DDSFLD,"M"))[0
SET ^("M")="0"_DDSVDIC_U_DDSVSUB
+9 IF $DATA(@DDSTMP@("GL"))[0
SET ^("GL")=DIE
+10 SET (DDSCHG,@DDSTMP@(DDSFLD,"F"))=3
+11 QUIT
+12 ;
GETWP ;Merge wp field into ^TMP, return root in DDSANS
+1 NEW DDSGL
+2 SET DDSGL=DIE_DA_","""_DDSVND_""","
+3 SET DDSANS=$NAME(^TMP("DDSWP",$JOB,DDP,DDSDA,DDSFLD))
+4 ;
+5 KILL @DDSANS
+6 IF $DATA(@(DDSGL_"0)"))#2
MERGE @DDSANS=@($EXTRACT(DDSGL,1,$LENGTH(DDSGL)-1)_")")
+7 QUIT
+8 ;
REL(DDP,DA,DDSFLD,DDSPARM) ;Relational syntax
+1 NEW DDSCD,DDSI,X
+2 DO DD^DDSPTR(DDP,DDSFLD,"",.DDSCD,"",DDSPARM["I"+1)
+3 FOR DDSI=1:1:DDSCD
XECUTE DDSCD(DDSI)
+4 QUIT X
+5 ;
ERR(DDSVEP) ;Print error messages
+1 IF '$GET(DIERR)
QUIT
+2 IF '$DATA(DDS)
DO MSG^DIALOG("BW")
QUIT
+3 NEW DDSVMSG
+4 SET DDSER=DIERR
+5 DO BLD^DIALOG(3031,DDSVEP,"","DDSVMSG")
+6 DO MSG^DDSMSG(DDSVMSG(1))
DO ERR^DDSMSG
+7 QUIT
