DDSVAL ;SFISC/MKO-GET,PUT FOR DD IELDS ;2OCT2003
;;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.
;
GET(DDSFILE,DA,DDSFLD,DDSER,DDSPARM) ;Get value for file/field
N DDP,DIE,DDSANS,DDSTMP,X
N DDSVDA,DDSVDDL0,DDSVDL,DDSVDV,DDSVND,DDSVPC,DIERR
;
S DDSANS=""
I $G(DDSPARM)'["I",$G(DDSPARM)'["E" S DDSPARM=$G(DDSPARM)_"I"
;
D GDIE() G:$G(DIERR) GETQ G:'$G(DDSVDA) GETQ
;
I DDSFLD[":",$$FIND^DDSLIB(DDSFLD,":") D G GETQ
. S DDSANS=$$REL^DDSVALM(DDP,.DA,DDSFLD,DDSPARM)
;
S DDSFLD=$$FIELD(DDP,DDSFLD) G:$G(DIERR) GETQ
;
S:$D(DDSREFT)#2 DDSTMP=$NA(@DDSREFT@("F"_DDP,DDSVDA,DDSFLD))
I $D(DDS),$D(DDSREFT)#2,$D(@DDSTMP@("D")) D
. I $D(@DDSTMP@("M")),'^("M") D Q
.. S DDSANS=$NA(^TMP("DDSWP",$J,DDP,DDSVDA,DDSFLD))
.. M @DDSANS=@DDSTMP@("D")
. S DDSANS=$G(@DDSTMP@("D")) I DDSPARM["E",$D(^("X"))#2 S DDSANS=^("X")
E D
. D GNDPC Q:$G(DIERR)
. I DDSVPC=0,DDSVDV["W" D GETWP^DDSVALM Q
. S DDSANS=$$GVAL(DIE,DA,DDSVND,DDSVPC)
. I DDSPARM["E" S DDSANS=$$EXTERNAL^DILFD(DDP,DDSFLD,"",DDSANS)
;
GETQ D:$G(DIERR) ERR^DDSVALM("$$GET^DDSVAL")
Q DDSANS
;
PUT(DDSFILE,DA,DDSFLD,DDSVAL,DDSER,DDSPARM) ;Put value for file/field
N DDP,DDSVDA,DDSV0,DDSV02,DDSVDL,DIE
N DIERR
;
S:$D(DDSVAL)[0 DDSVAL=""
I $G(DDSPARM)'["I",$G(DDSPARM)'["E" S DDSPARM=$G(DDSPARM)_"E"
;
D GDIE($D(DDS)#2) G:$G(DIERR) PUTQ G:'$G(DDSVDA) PUTQ
S DDSFLD=$$FIELD(DDP,DDSFLD) G:$G(DIERR) PUTQ
I DDSFLD=.01,"@"[DDSVAL D BLD^DIALOG(3086) G PUTQ
;
S DDSV0=^DD(DDP,DDSFLD,0),DDSV02=$P(DDSV0,U,2)
I +DDSV02 D
. D MULT^DDSVALM
E D VALPUT
;
PUTQ D:$G(DIERR) ERR^DDSVALM("PUT^DDSVAL")
Q
;
VALPUT ;Validate and put
N DDSVY
I DDSPARM["E" D
. D VAL^DIE(DDP,DDSVDA,DDSFLD,"ER",DDSVAL,.DDSVY)
E D
. D AUXVAL^DIEV(DDP,DDSVDA,DDSFLD,"EIR",DDSVAL,.DDSVY,DDSV0,DDSV02)
Q:$G(DIERR)
I DDSVY=DDSVY(0),'$D(@DDSREFT@("F"_DDP,DDSVDA,DDSFLD,"X")) K DDSVY(0)
;
I $D(DDS) D
. S:'$D(@DDSREFT@("F"_DDP,DDSVDA,DDSFLD)) ^("GL")=DIE
. D UPDATE(DDP,DDSVDA,.DA,DDSFLD,DDSPG,.DDSVY)
. S DDSCHG=1
E D
. N DDSFDA
. S DDSFDA(DDP,DDSVDA,DDSFLD)=DDSVY
. D FILE^DIE("","DDSFDA")
Q
;
UPDATE(DDP,DDSVDA,DA,FLD,PG,Y) ;Store value, repaint
N DX,DY,BK,DDO,LEN,EXT,PAGE,RJ,REP,VAL
S (EXT,@DDSREFT@("F"_DDP,DDSVDA,FLD,"D"))=Y,^("F")=3 S:$D(Y(0))#2 (EXT,^("X"))=Y(0)
;
D:FLD=.01
. S PAGE=0 F S PAGE=$O(@DDSREFS@("F"_DDP,FLD,"L",PAGE)) Q:'PAGE D
.. S BK=0 F S BK=$O(@DDSREFS@("F"_DDP,FLD,"L",PAGE,BK)) Q:'BK D
... D:$P($G(@DDSREFS@(PAGE,BK)),U,8)
.... N DDSPTB S DDSPTB=$G(@DDSREFS@(PAGE,BK,"PTB"))
.... D:DDSPTB]"" RPF^DDS7(DDP,DDSPTB,DDSVDA,.DA)
;
S BK=0 F S BK=$O(@DDSREFS@("F"_DDP,FLD,"L",PG,BK)) Q:'BK D
. S DDO=0 F S DDO=$O(@DDSREFS@("F"_DDP,FLD,"L",PG,BK,DDO)) Q:'DDO D
.. S LEN=$G(@DDSREFS@(PG,BK,DDO,"D")) Q:LEN=""
.. S DY=+LEN,DX=$P(LEN,U,2),RJ=$P(LEN,U,10),LEN=$P(LEN,U,3)
.. S REP=$P($G(@DDSREFS@(PG,BK)),U,7)
.. I $G(REP) D Q:DY=""
... N SN,PDA,OFS
... S PDA=$G(@DDSREFT@(PG,BK)) I 'PDA S DY="" Q
... S REP=$P($G(@DDSREFT@(PG,BK,PDA)),U,2,999) I REP="" S DY="" Q
... S SN=$G(@DDSREFT@(PG,BK,PDA,"B",DDSVDA)) I 'SN S DY="" Q
HITE ... N HITE S HITE=$$HITE^DDSR(BK),OFS=SN-$P(REP,U,2)*HITE ;DJW/GFT
... I OFS'<0,$P(REP,U,5)*HITE>OFS S DY=DY+OFS ;GFT OFFSET CAN'T BE OUTSIDE SCROLLING WINDOW
... E S DY=""
.. S VAL=$P(DDGLVID,DDGLDEL)_$E(EXT,1,LEN)_$P(DDGLVID,DDGLDEL,10)
.. X IOXY
.. W $S(RJ:$J("",LEN-$L(EXT))_VAL,1:VAL_$J("",LEN-$L(EXT)))
;
D:$D(@DDSREFS@("PT",DDP,FLD)) RPB^DDS7(DDP,FLD,PG)
D:$D(@DDSREFS@("COMP",DDP,FLD,PG)) RPCF^DDSCOMP(PG)
Q
;
GDIE(DDSVL) ;In:
; DDSFILE = File # or root
; DA = Record array
; DDSVL = Flag to lock record
;Returns:
; DIE = Global root of file
; DDP = File #
; DDSVDL = Level #
; DDSVDA = DA,DA(1),...,
S DDP=$S(DDSFILE=+DDSFILE:DDSFILE,1:+$P($G(@(DDSFILE_"0)")),U,2))
I DDP=0 D BLD^DIALOG(202,"file") Q
D GL^DDS10(DDP,.DA,.DIE,.DDSVDL,.DDSVDA,$G(DDSVL))
Q
;
GNDPC ;In:
; DDP = File #
; DDSFLD = Field #
;Returns:
; DDSVDDL0 = 0 node of DD
; DDSVND = Node where data resides
; DDSVPC = Piece where data resides
; DDSVDV = Field specifications
; X = Pointed to file root or set of codes
I $G(DDSFLD)="" D BLD^DIALOG(202,"field") Q
S DDSVDDL0=$G(^DD(DDP,DDSFLD,0))
I DDSVDDL0?."^" D Q
. N I,E
. S (I("FILE"),E("FILE"))=DDP,I(1)="#"_DDSFLD,E("FIELD")=DDSFLD
. D BLD^DIALOG(501,.I,.E)
;
S DDSVPC=$P(DDSVDDL0,U,4)
S DDSVND=$P(DDSVPC,";"),DDSVPC=$P(DDSVPC,";",2)
S DDSVDV=$P(DDSVDDL0,U,2),X=$P(DDSVDDL0,U,3)
;
N P S P("FILE")=DDP,P("FIELD")=DDSFLD
I DDSVPC=" " D
. D BLD^DIALOG(520,"computed",.P)
I DDSVPC=0 D
. S DDSVDV=+DDSVDV_$P($G(^DD(+DDSVDV,.01,0)),U,2)
. D:DDSVDV'["W" BLD^DIALOG(520,"multiple",.P)
Q
;
GVAL(DIE,DA,ND,PC) ;Get value
N LN,Y
S LN=$G(@(DIE_"DA,ND)"))
I $E(PC)'="E" S Y=$P(LN,U,PC)
E S Y=$E(LN,+$E(PC,2,999),$P(PC,",",2)) S:Y?." " Y=""
Q Y
;
FIELD(DDP,FLD) ;Get field number
N F,P
S:$E(FLD)="""" FLD=$$UQT^DDSLIB($E(FLD,1,$$AFTQ^DDSLIB(FLD)-1))
;
S F=FLD,P("FILE")=DDP
I FLD'=+$P(FLD,"E") D Q:$G(DIERR) ""
. S F=$O(^DD(DDP,"B",FLD,""))
. I F="" S P(1)=FLD D BLD^DIALOG(501,.P)
;
I $D(^DD(DDP,F,0))[0 S P(1)="#"_F D BLD^DIALOG(501,.P) Q ""
Q F
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDSVAL 5531 printed Dec 13, 2024@02:43:37 Page 2
DDSVAL ;SFISC/MKO-GET,PUT FOR DD IELDS ;2OCT2003
+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 ;
GET(DDSFILE,DA,DDSFLD,DDSER,DDSPARM) ;Get value for file/field
+1 NEW DDP,DIE,DDSANS,DDSTMP,X
+2 NEW DDSVDA,DDSVDDL0,DDSVDL,DDSVDV,DDSVND,DDSVPC,DIERR
+3 ;
+4 SET DDSANS=""
+5 IF $GET(DDSPARM)'["I"
IF $GET(DDSPARM)'["E"
SET DDSPARM=$GET(DDSPARM)_"I"
+6 ;
+7 DO GDIE()
if $GET(DIERR)
GOTO GETQ
if '$GET(DDSVDA)
GOTO GETQ
+8 ;
+9 IF DDSFLD[":"
IF $$FIND^DDSLIB(DDSFLD,":")
Begin DoDot:1
+10 SET DDSANS=$$REL^DDSVALM(DDP,.DA,DDSFLD,DDSPARM)
End DoDot:1
GOTO GETQ
+11 ;
+12 SET DDSFLD=$$FIELD(DDP,DDSFLD)
if $GET(DIERR)
GOTO GETQ
+13 ;
+14 if $DATA(DDSREFT)#2
SET DDSTMP=$NAME(@DDSREFT@("F"_DDP,DDSVDA,DDSFLD))
+15 IF $DATA(DDS)
IF $DATA(DDSREFT)#2
IF $DATA(@DDSTMP@("D"))
Begin DoDot:1
+16 IF $DATA(@DDSTMP@("M"))
IF '^("M")
Begin DoDot:2
+17 SET DDSANS=$NAME(^TMP("DDSWP",$JOB,DDP,DDSVDA,DDSFLD))
+18 MERGE @DDSANS=@DDSTMP@("D")
End DoDot:2
QUIT
+19 SET DDSANS=$GET(@DDSTMP@("D"))
IF DDSPARM["E"
IF $DATA(^("X"))#2
SET DDSANS=^("X")
End DoDot:1
+20 IF '$TEST
Begin DoDot:1
+21 DO GNDPC
if $GET(DIERR)
QUIT
+22 IF DDSVPC=0
IF DDSVDV["W"
DO GETWP^DDSVALM
QUIT
+23 SET DDSANS=$$GVAL(DIE,DA,DDSVND,DDSVPC)
+24 IF DDSPARM["E"
SET DDSANS=$$EXTERNAL^DILFD(DDP,DDSFLD,"",DDSANS)
End DoDot:1
+25 ;
GETQ if $GET(DIERR)
DO ERR^DDSVALM("$$GET^DDSVAL")
+1 QUIT DDSANS
+2 ;
PUT(DDSFILE,DA,DDSFLD,DDSVAL,DDSER,DDSPARM) ;Put value for file/field
+1 NEW DDP,DDSVDA,DDSV0,DDSV02,DDSVDL,DIE
+2 NEW DIERR
+3 ;
+4 if $DATA(DDSVAL)[0
SET DDSVAL=""
+5 IF $GET(DDSPARM)'["I"
IF $GET(DDSPARM)'["E"
SET DDSPARM=$GET(DDSPARM)_"E"
+6 ;
+7 DO GDIE($DATA(DDS)#2)
if $GET(DIERR)
GOTO PUTQ
if '$GET(DDSVDA)
GOTO PUTQ
+8 SET DDSFLD=$$FIELD(DDP,DDSFLD)
if $GET(DIERR)
GOTO PUTQ
+9 IF DDSFLD=.01
IF "@"[DDSVAL
DO BLD^DIALOG(3086)
GOTO PUTQ
+10 ;
+11 SET DDSV0=^DD(DDP,DDSFLD,0)
SET DDSV02=$PIECE(DDSV0,U,2)
+12 IF +DDSV02
Begin DoDot:1
+13 DO MULT^DDSVALM
End DoDot:1
+14 IF '$TEST
DO VALPUT
+15 ;
PUTQ if $GET(DIERR)
DO ERR^DDSVALM("PUT^DDSVAL")
+1 QUIT
+2 ;
VALPUT ;Validate and put
+1 NEW DDSVY
+2 IF DDSPARM["E"
Begin DoDot:1
+3 DO VAL^DIE(DDP,DDSVDA,DDSFLD,"ER",DDSVAL,.DDSVY)
End DoDot:1
+4 IF '$TEST
Begin DoDot:1
+5 DO AUXVAL^DIEV(DDP,DDSVDA,DDSFLD,"EIR",DDSVAL,.DDSVY,DDSV0,DDSV02)
End DoDot:1
+6 if $GET(DIERR)
QUIT
+7 IF DDSVY=DDSVY(0)
IF '$DATA(@DDSREFT@("F"_DDP,DDSVDA,DDSFLD,"X"))
KILL DDSVY(0)
+8 ;
+9 IF $DATA(DDS)
Begin DoDot:1
+10 if '$DATA(@DDSREFT@("F"_DDP,DDSVDA,DDSFLD))
SET ^("GL")=DIE
+11 DO UPDATE(DDP,DDSVDA,.DA,DDSFLD,DDSPG,.DDSVY)
+12 SET DDSCHG=1
End DoDot:1
+13 IF '$TEST
Begin DoDot:1
+14 NEW DDSFDA
+15 SET DDSFDA(DDP,DDSVDA,DDSFLD)=DDSVY
+16 DO FILE^DIE("","DDSFDA")
End DoDot:1
+17 QUIT
+18 ;
UPDATE(DDP,DDSVDA,DA,FLD,PG,Y) ;Store value, repaint
+1 NEW DX,DY,BK,DDO,LEN,EXT,PAGE,RJ,REP,VAL
+2 SET (EXT,@DDSREFT@("F"_DDP,DDSVDA,FLD,"D"))=Y
SET ^("F")=3
if $DATA(Y(0))#2
SET (EXT,^("X"))=Y(0)
+3 ;
+4 if FLD=.01
Begin DoDot:1
+5 SET PAGE=0
FOR
SET PAGE=$ORDER(@DDSREFS@("F"_DDP,FLD,"L",PAGE))
if 'PAGE
QUIT
Begin DoDot:2
+6 SET BK=0
FOR
SET BK=$ORDER(@DDSREFS@("F"_DDP,FLD,"L",PAGE,BK))
if 'BK
QUIT
Begin DoDot:3
+7 if $PIECE($GET(@DDSREFS@(PAGE,BK)),U,8)
Begin DoDot:4
+8 NEW DDSPTB
SET DDSPTB=$GET(@DDSREFS@(PAGE,BK,"PTB"))
+9 if DDSPTB]""
DO RPF^DDS7(DDP,DDSPTB,DDSVDA,.DA)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+10 ;
+11 SET BK=0
FOR
SET BK=$ORDER(@DDSREFS@("F"_DDP,FLD,"L",PG,BK))
if 'BK
QUIT
Begin DoDot:1
+12 SET DDO=0
FOR
SET DDO=$ORDER(@DDSREFS@("F"_DDP,FLD,"L",PG,BK,DDO))
if 'DDO
QUIT
Begin DoDot:2
+13 SET LEN=$GET(@DDSREFS@(PG,BK,DDO,"D"))
if LEN=""
QUIT
+14 SET DY=+LEN
SET DX=$PIECE(LEN,U,2)
SET RJ=$PIECE(LEN,U,10)
SET LEN=$PIECE(LEN,U,3)
+15 SET REP=$PIECE($GET(@DDSREFS@(PG,BK)),U,7)
+16 IF $GET(REP)
Begin DoDot:3
+17 NEW SN,PDA,OFS
+18 SET PDA=$GET(@DDSREFT@(PG,BK))
IF 'PDA
SET DY=""
QUIT
+19 SET REP=$PIECE($GET(@DDSREFT@(PG,BK,PDA)),U,2,999)
IF REP=""
SET DY=""
QUIT
+20 SET SN=$GET(@DDSREFT@(PG,BK,PDA,"B",DDSVDA))
IF 'SN
SET DY=""
QUIT
HITE ;DJW/GFT
NEW HITE
SET HITE=$$HITE^DDSR(BK)
SET OFS=SN-$PIECE(REP,U,2)*HITE
+1 ;GFT OFFSET CAN'T BE OUTSIDE SCROLLING WINDOW
IF OFS'<0
IF $PIECE(REP,U,5)*HITE>OFS
SET DY=DY+OFS
+2 IF '$TEST
SET DY=""
End DoDot:3
if DY=""
QUIT
+3 SET VAL=$PIECE(DDGLVID,DDGLDEL)_$EXTRACT(EXT,1,LEN)_$PIECE(DDGLVID,DDGLDEL,10)
+4 XECUTE IOXY
+5 WRITE $SELECT(RJ:$JUSTIFY("",LEN-$LENGTH(EXT))_VAL,1:VAL_$JUSTIFY("",LEN-$LENGTH(EXT)))
End DoDot:2
End DoDot:1
+6 ;
+7 if $DATA(@DDSREFS@("PT",DDP,FLD))
DO RPB^DDS7(DDP,FLD,PG)
+8 if $DATA(@DDSREFS@("COMP",DDP,FLD,PG))
DO RPCF^DDSCOMP(PG)
+9 QUIT
+10 ;
GDIE(DDSVL) ;In:
+1 ; DDSFILE = File # or root
+2 ; DA = Record array
+3 ; DDSVL = Flag to lock record
+4 ;Returns:
+5 ; DIE = Global root of file
+6 ; DDP = File #
+7 ; DDSVDL = Level #
+8 ; DDSVDA = DA,DA(1),...,
+9 SET DDP=$SELECT(DDSFILE=+DDSFILE:DDSFILE,1:+$PIECE($GET(@(DDSFILE_"0)")),U,2))
+10 IF DDP=0
DO BLD^DIALOG(202,"file")
QUIT
+11 DO GL^DDS10(DDP,.DA,.DIE,.DDSVDL,.DDSVDA,$GET(DDSVL))
+12 QUIT
+13 ;
GNDPC ;In:
+1 ; DDP = File #
+2 ; DDSFLD = Field #
+3 ;Returns:
+4 ; DDSVDDL0 = 0 node of DD
+5 ; DDSVND = Node where data resides
+6 ; DDSVPC = Piece where data resides
+7 ; DDSVDV = Field specifications
+8 ; X = Pointed to file root or set of codes
+9 IF $GET(DDSFLD)=""
DO BLD^DIALOG(202,"field")
QUIT
+10 SET DDSVDDL0=$GET(^DD(DDP,DDSFLD,0))
+11 IF DDSVDDL0?."^"
Begin DoDot:1
+12 NEW I,E
+13 SET (I("FILE"),E("FILE"))=DDP
SET I(1)="#"_DDSFLD
SET E("FIELD")=DDSFLD
+14 DO BLD^DIALOG(501,.I,.E)
End DoDot:1
QUIT
+15 ;
+16 SET DDSVPC=$PIECE(DDSVDDL0,U,4)
+17 SET DDSVND=$PIECE(DDSVPC,";")
SET DDSVPC=$PIECE(DDSVPC,";",2)
+18 SET DDSVDV=$PIECE(DDSVDDL0,U,2)
SET X=$PIECE(DDSVDDL0,U,3)
+19 ;
+20 NEW P
SET P("FILE")=DDP
SET P("FIELD")=DDSFLD
+21 IF DDSVPC=" "
Begin DoDot:1
+22 DO BLD^DIALOG(520,"computed",.P)
End DoDot:1
+23 IF DDSVPC=0
Begin DoDot:1
+24 SET DDSVDV=+DDSVDV_$PIECE($GET(^DD(+DDSVDV,.01,0)),U,2)
+25 if DDSVDV'["W"
DO BLD^DIALOG(520,"multiple",.P)
End DoDot:1
+26 QUIT
+27 ;
GVAL(DIE,DA,ND,PC) ;Get value
+1 NEW LN,Y
+2 SET LN=$GET(@(DIE_"DA,ND)"))
+3 IF $EXTRACT(PC)'="E"
SET Y=$PIECE(LN,U,PC)
+4 IF '$TEST
SET Y=$EXTRACT(LN,+$EXTRACT(PC,2,999),$PIECE(PC,",",2))
if Y?." "
SET Y=""
+5 QUIT Y
+6 ;
FIELD(DDP,FLD) ;Get field number
+1 NEW F,P
+2 if $EXTRACT(FLD)=""""
SET FLD=$$UQT^DDSLIB($EXTRACT(FLD,1,$$AFTQ^DDSLIB(FLD)-1))
+3 ;
+4 SET F=FLD
SET P("FILE")=DDP
+5 IF FLD'=+$PIECE(FLD,"E")
Begin DoDot:1
+6 SET F=$ORDER(^DD(DDP,"B",FLD,""))
+7 IF F=""
SET P(1)=FLD
DO BLD^DIALOG(501,.P)
End DoDot:1
if $GET(DIERR)
QUIT ""
+8 ;
+9 IF $DATA(^DD(DDP,F,0))[0
SET P(1)="#"_F
DO BLD^DIALOG(501,.P)
QUIT ""
+10 QUIT F
