DDS11 ;SFISC/MLH,MKO - LOAD DATA TO BE SHOWN ON SCREEN ;01MAR2016
;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
;;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.
;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
;
BEGIN 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
;
;
;
;
EN(DDSBK,DDSNFO) ;Main Entry Point for VEN version
G BEGIN
;
;
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")!(DDS1DV["t") 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",DDS1DV'["t" Q Y
I DDS1DV'["O",Y="" Q ""
D XFORM
Q Y
;
XFORM ;
N DDS1N
I DDS1DV["O"!(DDS1DV["t") X $$OUTPUT^DIETLIBF(DDP,+DDS1FLD) 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" D
.I +DDS1FLD,$G(^DD(DDP,+DDS1FLD,0))[X S Y=$$SET^DIQ(DDP,+DDS1FLD,Y) ;FOREIGN-LANGUAGE SET VALUE
.E D PARSET^DIQ(X,.Y)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDS11 5334 printed Apr 09, 2024@21:50:50 Page 2
DDS11 ;SFISC/MLH,MKO - LOAD DATA TO BE SHOWN ON SCREEN ;01MAR2016
+1 ;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
+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 ;Input variables:
+7 ; DDSBK = Block #
+8 ; DDSPG = Page # (needed for form-only fields)
+9 ; DDSREFT = Temporary global location
+10 ; DDP = File number of block
+11 ; DIE = Global root of block
+12 ; DDSDA = DA,DA(1),...
+13 ; DDSNFO = Flag means don't reload form only fields
+14 ;
BEGIN NEW X,Y
+1 SET DDS1REFD=$NAME(@DDSREFT@("F"_DDP,DDSDA))
+2 ;
+3 SET DDS1FO=0
+4 FOR
SET DDS1FO=$ORDER(^DIST(.404,DDSBK,40,DDS1FO))
if 'DDS1FO
QUIT
DO LD
+5 ;
+6 IF DDP
IF DDSDA
SET @DDS1REFD@("GL")=DIE
+7 ;
+8 KILL DDS1REFD,DDS1FLD,DDS1FO,DDS1KEY,DDS1LN,DDS1ND,DDS1PC,DDS1UI,DDS1DV
+9 KILL DDS1D1,DDS1D2,DDS1D3
+10 QUIT
+11 ;
+12 ;
+13 ;
+14 ;
EN(DDSBK,DDSNFO) ;Main Entry Point for VEN version
+1 GOTO BEGIN
+2 ;
+3 ;
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")!(DDS1DV["t")
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"
IF DDS1DV'["t"
QUIT Y
+4 IF DDS1DV'["O"
IF Y=""
QUIT ""
+5 DO XFORM
+6 QUIT Y
+7 ;
XFORM ;
+1 NEW DDS1N
+2 IF DDS1DV["O"!(DDS1DV["t")
XECUTE $$OUTPUT^DIETLIBF(DDP,+DDS1FLD)
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"
Begin DoDot:1
+7 ;FOREIGN-LANGUAGE SET VALUE
IF +DDS1FLD
IF $GET(^DD(DDP,+DDS1FLD,0))[X
SET Y=$$SET^DIQ(DDP,+DDS1FLD,Y)
+8 IF '$TEST
DO PARSET^DIQ(X,.Y)
End DoDot:1
+9 QUIT
