DDS11(DDSBK,DDSNFO) ;SFISC/MLH,MKO-LOAD DATA ; 04 Jun 2007
;;22.0;VA FileMan;**151**;Mar 30, 1999;Build 10
;Per VHA Directive 2004-038, this routine should not be modified.
;Input variables:
; DDSBK = Block #
; DDSPG = Page # (needed for form-only fields)
; DDSREFT = Temporary global location
; DDP = File number of block
; DIE = Global root of block
; DDSDA = DA,DA(1),...
; DDSNFO = Flag means don't reload form only fields
;
N X,Y
S DDS1REFD=$NA(@DDSREFT@("F"_DDP,DDSDA))
;
S DDS1FO=0
F S DDS1FO=$O(^DIST(.404,DDSBK,40,DDS1FO)) Q:'DDS1FO D LD
;
I DDP,DDSDA S @DDS1REFD@("GL")=DIE
;
K DDS1REFD,DDS1FLD,DDS1FO,DDS1KEY,DDS1LN,DDS1ND,DDS1PC,DDS1UI,DDS1DV
K DDS1D1,DDS1D2,DDS1D3
Q
;
LD ;Load data for a field
;
;Get form only fields
I $P($G(^DIST(.404,DDSBK,40,DDS1FO,0)),U,3)=2,$P($G(^(20)),U)]"" D Q
. Q:$G(DDSNFO)
. N DDP
. S DDP=0,DDS1FLD=DDS1FO_","_DDSBK
. Q:"^1^3^"[(U_$G(@DDSREFT@("F0",DDSDA,DDS1FLD,"F"))_U)
. S Y=""
. I $D(@DDSREFT@("F0",DDSDA,DDS1FLD,"F"))[0,$G(^DIST(.404,DDSBK,40,DDS1FO,3))]"" D DEF(^(3),$G(^(3.1)))
. S (@DDSREFT@("F0",DDSDA,DDS1FLD,"D"),^("O"))=Y
;
;Get DD fields
S DDS1FLD=$G(^DIST(.404,DDSBK,40,DDS1FO,1)) Q:DDS1FLD?."^"
Q:"^1^3^"[(U_$G(@DDS1REFD@(DDS1FLD,"F"))_U)
;
S DDS1LN=$G(^DD(DDP,DDS1FLD,0)) Q:DDS1LN?."^"
S DDS1PC=$P(DDS1LN,U,4),DDS1ND=$P(DDS1PC,";"),DDS1PC=$P(DDS1PC,";",2)
S DDS1DV=$P(DDS1LN,U,2),X=$P(DDS1LN,U,3)
;
D @($S(DDS1FLD=.001:"L3",DDS1PC=0:"L2",1:"L1"))
;
I DDS1DV["O"!(DDS1DV["P")!(DDS1DV["V")!(DDS1DV["D")!(DDS1DV["S") D
. Q:$D(@DDS1REFD@(DDS1FLD,"X"))
. D:Y]"" XFORM
. S @DDS1REFD@(DDS1FLD,"X")=Y
;
I DDS1PC=0,DDS1DV,DDS1DV'["W",$D(@DDS1REFD@(DDS1FLD,"X"))[0 S ^("X")=Y
Q
;
L1 ;Get non-multiple field
S DDS1LN=$G(@(DIE_"DA,DDS1ND)"))
I $E(DDS1PC)'="E" S Y=$P(DDS1LN,U,DDS1PC)
E S Y=$E(DDS1LN,+$E(DDS1PC,2,999),$P(DDS1PC,",",2)) S:Y?." " Y=""
;
K @DDS1REFD@(DDS1FLD,"X")
I Y="",$D(@DDS1REFD@(DDS1FLD,"F"))[0,$D(^DIST(.404,DDSBK,40,DDS1FO,3))#2 D DEF(^(3),$G(^(3.1)))
MUMPS I $G(DUZ(0))'="@",DDS1DV["K" S $P(@DDS1REFD@(DDS1FLD,"A"),U,4)=1,Y=$TR($J("",$L(Y))," ","*") ;**151
S @DDS1REFD@(DDS1FLD,"D")=Y
;
;Get key info
I '$D(@DDS1REFD@(DDS1FLD,"K")) D
. S DDS1KEY=0
. F S DDS1KEY=$O(^DD("KEY","F",DDP,DDS1FLD,DDS1KEY)) Q:'DDS1KEY D
.. S DDS1UI=$P(^DD("KEY",DDS1KEY,0),U,4) Q:'DDS1UI
.. Q:$P($G(^DD("IX",DDS1UI,0)),U,6)'="F"
.. S ^("K")=$G(@DDS1REFD@(DDS1FLD,"K"))_DDS1UI_U
Q
;
L2 ;Get multiple field
S DDS1SUB=+$P(DDS1LN,U,2) Q:$D(^DD(DDS1SUB,.01,0))[0
S DDS1DV=DDS1SUB_$P(^DD(DDS1SUB,.01,0),U,2),X=$P(^(0),U,3)
S DDS1DIC=DIE_DA_","""_DDS1ND_""","
;
D:DDS1DV'["W"
. I $D(^DIST(.404,DDSBK,40,DDS1FO,3))#2 D D L22
.. D DEF(^DIST(.404,DDSBK,40,DDS1FO,3),$G(^(3.1)),1)
.. S DDS1RN=$S($G(Y)="FIRST":$O(@(DDS1DIC_"0)")),$G(Y)="LAST":$O(@(DDS1DIC_""" "")"),-1),1:+$G(Y))
. E I $D(DUZ)#2,$L(DDS1DIC)<29,$D(^DISV(DUZ,DDS1DIC))#2 S DDS1RN=^(DDS1DIC) D L22
. E S DDS1RN=$S($D(@(DDS1DIC_"0)"))#2:$P(^(0),U,3),1:$O(^(0))) D L22
. E S (Y,@DDS1REFD@(DDS1FLD,"D"))=""
;
S @DDS1REFD@(DDS1FLD,"M")=$S(DDS1DV["W":0,1:1)_DDS1DIC_U_DDS1SUB
K DDS1DIC,DDS1RN,DDS1SUB
Q
L22 ;
I DDS1RN>0,$D(@(DDS1DIC_+DDS1RN_",0)"))#2 S Y=$P(^(0),U),@DDS1REFD@(DDS1FLD,"D")=+DDS1RN
Q
;
DEF(DDS1LN3,DDS1LN31,DDS1MULT) ;Get default
N DDS1PTR,DDS1OT
Q:DDS1LN3=""
I DDS1LN3'="!M" S Y=DDS1LN3
E I DDS1LN31'?."^" X DDS1LN31 S:$D(Y)[0 Y=""
Q:Y=""!$G(DDS1MULT)
;
K DIR
I DDS1FLD["," D
. S DIR(0)=$P(^DIST(.404,DDSBK,40,DDS1FO,20),U)_$P(^(20),U,2,3)
. S:DIR(0)?1"DD".E DIR(0)=$P(DIR(0),U,2,999)
. I $E($P(DIR(0),U))="P" S DDS1PTR=1
E D
. S DIR(0)=DDP_","_DDS1FLD
. S DDS1PTR=$P($G(^DD(DDP,DDS1FLD,0)),U,2)
. S DDS1OT=DDS1PTR["O",DDS1PTR=DDS1PTR["P"
S DIR("V")="",(X,DIR("B"))=Y
D ^DIR
;
I DDER S Y=""
I Y]"" D
. I $G(DDS1PTR) S Y=$P(Y,U)
. S $P(@DDSREFT@("F"_DDP,DDSDA,DDS1FLD,"F"),U)=3
. I $G(DDS1PTR),$G(DDS1OT),$D(^DD(DDP,DDS1FLD,2))#2 K Y(0),Y(0,0)
. S:$D(Y(0)) @DDSREFT@("F"_DDP,DDSDA,DDS1FLD,"X")=$S($D(Y(0,0))#2:Y(0,0),1:Y(0))
. S DDSCHG=1
K DDER,DIR
Q
;
L3 ;Get number field
S (@DDS1REFD@(.001,"D"),Y)=DA
Q
;
EXT(DDP,DDS1FLD,Y) ;Return external form of Y
N DDS1DV,X
S DDS1DV=$P(^DD(DDP,DDS1FLD,0),U,2),X=$P(^(0),U,3)
I DDS1DV'["O",DDS1DV'["P",DDS1DV'["V",DDS1DV'["D",DDS1DV'["S" Q Y
I DDS1DV'["O",Y="" Q ""
D XFORM
Q Y
;
XFORM ;
N DDS1N
I DDS1DV["O",+DDS1FLD,$D(^DD(DDP,+DDS1FLD,2))#2 X ^(2) Q
I DDS1DV["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) Q:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DDS1DV=$P(^(0),U,2) G XFORM
I DDS1DV["V",+$P(Y,"E"),$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)"))#2 S X=+$P($P(^(0),U,2),"E") Q:$D(^(+$P(Y,"E"),0))[0 S Y=$P(^(0),U) I $D(^DD(+$P(X,"E"),.01,0))#2 S DDS1DV=$P(^(0),U,2),X=$P(^(0),U,3) G XFORM
I DDS1DV["D" X ^DD("DD")
I DDS1DV["S" S DDS1N=$P($P(";"_X,";"_Y_":",2),";",1) S:DDS1N]"" Y=DDS1N
Q
DDS11(DDSBK,DDSNFO) ;SFISC/MLH,MKO-LOAD DATA ; 04 Jun 2007
+1 ;;22.0;VA FileMan;**151**;Mar 30, 1999;Build 10
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;Input variables:
+4 ; DDSBK = Block #
+5 ; DDSPG = Page # (needed for form-only fields)
+6 ; DDSREFT = Temporary global location
+7 ; DDP = File number of block
+8 ; DIE = Global root of block
+9 ; DDSDA = DA,DA(1),...
+10 ; DDSNFO = Flag means don't reload form only fields
+11 ;
+12 NEW X,Y
+13 SET DDS1REFD=$NAME(@DDSREFT@("F"_DDP,DDSDA))
+14 ;
+15 SET DDS1FO=0
+16 FOR
SET DDS1FO=$ORDER(^DIST(.404,DDSBK,40,DDS1FO))
IF 'DDS1FO
QUIT
DO LD
+17 ;
+18 IF DDP
IF DDSDA
SET @DDS1REFD@("GL")=DIE
+19 ;
+20 KILL DDS1REFD,DDS1FLD,DDS1FO,DDS1KEY,DDS1LN,DDS1ND,DDS1PC,DDS1UI,DDS1DV
+21 KILL DDS1D1,DDS1D2,DDS1D3
+22 QUIT
+23 ;
LD ;Load data for a field
+1 ;
+2 ;Get form only fields
+3 IF $PIECE($GET(^DIST(.404,DDSBK,40,DDS1FO,0)),U,3)=2
IF $PIECE($GET(^(20)),U)]""
Begin DoDot:1
+4 IF $GET(DDSNFO)
QUIT
+5 NEW DDP
+6 SET DDP=0
SET DDS1FLD=DDS1FO_","_DDSBK
+7 IF "^1^3^"[(U_$GET(@DDSREFT@("F0",DDSDA,DDS1FLD,"F"))_U)
QUIT
+8 SET Y=""
+9 IF $DATA(@DDSREFT@("F0",DDSDA,DDS1FLD,"F"))[0
IF $GET(^DIST(.404,DDSBK,40,DDS1FO,3))]""
DO DEF(^(3),$GET(^(3.1)))
+10 SET (@DDSREFT@("F0",DDSDA,DDS1FLD,"D"),^("O"))=Y
End DoDot:1
QUIT
+11 ;
+12 ;Get DD fields
+13 SET DDS1FLD=$GET(^DIST(.404,DDSBK,40,DDS1FO,1))
IF DDS1FLD?."^"
QUIT
+14 IF "^1^3^"[(U_$GET(@DDS1REFD@(DDS1FLD,"F"))_U)
QUIT
+15 ;
+16 SET DDS1LN=$GET(^DD(DDP,DDS1FLD,0))
IF DDS1LN?."^"
QUIT
+17 SET DDS1PC=$PIECE(DDS1LN,U,4)
SET DDS1ND=$PIECE(DDS1PC,";")
SET DDS1PC=$PIECE(DDS1PC,";",2)
+18 SET DDS1DV=$PIECE(DDS1LN,U,2)
SET X=$PIECE(DDS1LN,U,3)
+19 ;
+20 DO @($SELECT(DDS1FLD=.001:"L3",DDS1PC=0:"L2",1:"L1"))
+21 ;
+22 IF DDS1DV["O"!(DDS1DV["P")!(DDS1DV["V")!(DDS1DV["D")!(DDS1DV["S")
Begin DoDot:1
+23 IF $DATA(@DDS1REFD@(DDS1FLD,"X"))
QUIT
+24 IF Y]""
DO XFORM
+25 SET @DDS1REFD@(DDS1FLD,"X")=Y
End DoDot:1
+26 ;
+27 IF DDS1PC=0
IF DDS1DV
IF DDS1DV'["W"
IF $DATA(@DDS1REFD@(DDS1FLD,"X"))[0
SET ^("X")=Y
+28 QUIT
+29 ;
L1 ;Get non-multiple field
+1 SET DDS1LN=$GET(@(DIE_"DA,DDS1ND)"))
+2 IF $EXTRACT(DDS1PC)'="E"
SET Y=$PIECE(DDS1LN,U,DDS1PC)
+3 IF '$TEST
SET Y=$EXTRACT(DDS1LN,+$EXTRACT(DDS1PC,2,999),$PIECE(DDS1PC,",",2))
IF Y?." "
SET Y=""
+4 ;
+5 KILL @DDS1REFD@(DDS1FLD,"X")
+6 IF Y=""
IF $DATA(@DDS1REFD@(DDS1FLD,"F"))[0
IF $DATA(^DIST(.404,DDSBK,40,DDS1FO,3))#2
DO DEF(^(3),$GET(^(3.1)))
MUMPS ;**151
IF $GET(DUZ(0))'="@"
IF DDS1DV["K"
SET $PIECE(@DDS1REFD@(DDS1FLD,"A"),U,4)=1
SET Y=$TRANSLATE($JUSTIFY("",$LENGTH(Y))," ","*")
+1 SET @DDS1REFD@(DDS1FLD,"D")=Y
+2 ;
+3 ;Get key info
+4 IF '$DATA(@DDS1REFD@(DDS1FLD,"K"))
Begin DoDot:1
+5 SET DDS1KEY=0
+6 FOR
SET DDS1KEY=$ORDER(^DD("KEY","F",DDP,DDS1FLD,DDS1KEY))
IF 'DDS1KEY
QUIT
Begin DoDot:2
+7 SET DDS1UI=$PIECE(^DD("KEY",DDS1KEY,0),U,4)
IF 'DDS1UI
QUIT
+8 IF $PIECE($GET(^DD("IX",DDS1UI,0)),U,6)'="F"
QUIT
+9 SET ^("K")=$GET(@DDS1REFD@(DDS1FLD,"K"))_DDS1UI_U
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
L2 ;Get multiple field
+1 SET DDS1SUB=+$PIECE(DDS1LN,U,2)
IF $DATA(^DD(DDS1SUB,.01,0))[0
QUIT
+2 SET DDS1DV=DDS1SUB_$PIECE(^DD(DDS1SUB,.01,0),U,2)
SET X=$PIECE(^(0),U,3)
+3 SET DDS1DIC=DIE_DA_","""_DDS1ND_""","
+4 ;
+5 IF DDS1DV'["W"
Begin DoDot:1
+6 IF $DATA(^DIST(.404,DDSBK,40,DDS1FO,3))#2
Begin DoDot:2
+7 DO DEF(^DIST(.404,DDSBK,40,DDS1FO,3),$GET(^(3.1)),1)
+8 SET DDS1RN=$SELECT($GET(Y)="FIRST":$ORDER(@(DDS1DIC_"0)")),$GET(Y)="LAST":$ORDER(@(DDS1DIC_""" "")"),-1),1:+$GET(Y))
End DoDot:2
DO L22
+9 IF '$TEST
IF $DATA(DUZ)#2
IF $LENGTH(DDS1DIC)<29
IF $DATA(^DISV(DUZ,DDS1DIC))#2
SET DDS1RN=^(DDS1DIC)
DO L22
+10 IF '$TEST
SET DDS1RN=$SELECT($DATA(@(DDS1DIC_"0)"))#2:$PIECE(^(0),U,3),1:$ORDER(^(0)))
DO L22
+11 IF '$TEST
SET (Y,@DDS1REFD@(DDS1FLD,"D"))=""
End DoDot:1
+12 ;
+13 SET @DDS1REFD@(DDS1FLD,"M")=$SELECT(DDS1DV["W":0,1:1)_DDS1DIC_U_DDS1SUB
+14 KILL DDS1DIC,DDS1RN,DDS1SUB
+15 QUIT
L22 ;
+1 IF DDS1RN>0
IF $DATA(@(DDS1DIC_+DDS1RN_",0)"))#2
SET Y=$PIECE(^(0),U)
SET @DDS1REFD@(DDS1FLD,"D")=+DDS1RN
+2 QUIT
+3 ;
DEF(DDS1LN3,DDS1LN31,DDS1MULT) ;Get default
+1 NEW DDS1PTR,DDS1OT
+2 IF DDS1LN3=""
QUIT
+3 IF DDS1LN3'="!M"
SET Y=DDS1LN3
+4 IF '$TEST
IF DDS1LN31'?."^"
XECUTE DDS1LN31
IF $DATA(Y)[0
SET Y=""
+5 IF Y=""!$GET(DDS1MULT)
QUIT
+6 ;
+7 KILL DIR
+8 IF DDS1FLD[","
Begin DoDot:1
+9 SET DIR(0)=$PIECE(^DIST(.404,DDSBK,40,DDS1FO,20),U)_$PIECE(^(20),U,2,3)
+10 IF DIR(0)?1"DD".E
SET DIR(0)=$PIECE(DIR(0),U,2,999)
+11 IF $EXTRACT($PIECE(DIR(0),U))="P"
SET DDS1PTR=1
End DoDot:1
+12 IF '$TEST
Begin DoDot:1
+13 SET DIR(0)=DDP_","_DDS1FLD
+14 SET DDS1PTR=$PIECE($GET(^DD(DDP,DDS1FLD,0)),U,2)
+15 SET DDS1OT=DDS1PTR["O"
SET DDS1PTR=DDS1PTR["P"
End DoDot:1
+16 SET DIR("V")=""
SET (X,DIR("B"))=Y
+17 DO ^DIR
+18 ;
+19 IF DDER
SET Y=""
+20 IF Y]""
Begin DoDot:1
+21 IF $GET(DDS1PTR)
SET Y=$PIECE(Y,U)
+22 SET $PIECE(@DDSREFT@("F"_DDP,DDSDA,DDS1FLD,"F"),U)=3
+23 IF $GET(DDS1PTR)
IF $GET(DDS1OT)
IF $DATA(^DD(DDP,DDS1FLD,2))#2
KILL Y(0),Y(0,0)
+24 IF $DATA(Y(0))
SET @DDSREFT@("F"_DDP,DDSDA,DDS1FLD,"X")=$SELECT($DATA(Y(0,0))#2:Y(0,0),1:Y(0))
+25 SET DDSCHG=1
End DoDot:1
+26 KILL DDER,DIR
+27 QUIT
+28 ;
L3 ;Get number field
+1 SET (@DDS1REFD@(.001,"D"),Y)=DA
+2 QUIT
+3 ;
EXT(DDP,DDS1FLD,Y) ;Return external form of Y
+1 NEW DDS1DV,X
+2 SET DDS1DV=$PIECE(^DD(DDP,DDS1FLD,0),U,2)
SET X=$PIECE(^(0),U,3)
+3 IF DDS1DV'["O"
IF DDS1DV'["P"
IF DDS1DV'["V"
IF DDS1DV'["D"
IF DDS1DV'["S"
QUIT Y
+4 IF DDS1DV'["O"
IF Y=""
QUIT ""
+5 DO XFORM
+6 QUIT Y
+7 ;
XFORM ;
+1 NEW DDS1N
+2 IF DDS1DV["O"
IF +DDS1FLD
IF $DATA(^DD(DDP,+DDS1FLD,2))#2
XECUTE ^(2)
QUIT
+3 IF DDS1DV["P"
IF @("$D(^"_X_"0))")
SET X=+$PIECE(^(0),U,2)
IF '$DATA(^(Y,0))
QUIT
SET Y=$PIECE(^(0),U)
SET X=$PIECE(^DD(X,.01,0),U,3)
SET DDS1DV=$PIECE(^(0),U,2)
GOTO XFORM
+4 IF DDS1DV["V"
IF +$PIECE(Y,"E")
IF $PIECE(Y,";",2)["("
IF $DATA(@(U_$PIECE(Y,";",2)_"0)"))#2
SET X=+$PIECE($PIECE(^(0),U,2),"E")
IF $DATA(^(+$PIECE(Y,"E"),0))[0
QUIT
SET Y=$PIECE(^(0),U)
IF $DATA(^DD(+$PIECE(X,"E"),.01,0))#2
SET DDS1DV=$PIECE(^(0),U,2)
SET X=$PIECE(^(0),U,3)
GOTO XFORM
+5 IF DDS1DV["D"
XECUTE ^DD("DD")
+6 IF DDS1DV["S"
SET DDS1N=$PIECE($PIECE(";"_X,";"_Y_":",2),";",1)
IF DDS1N]""
SET Y=DDS1N
+7 QUIT
