- DDSVALM ;SFISC/MKO-PUT FOR MULTIPLES (SELECT PROMPT) ;10:45 AM 9 Sep 1994
- ;;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.
- ;
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDSVALM 2228 printed Feb 19, 2025@00:09:54 Page 2
- DDSVALM ;SFISC/MKO-PUT FOR MULTIPLES (SELECT PROMPT) ;10:45 AM 9 Sep 1994
- +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 ;
- 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