Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DDS11

DDS11.m

Go to the documentation of this file. 
  1. DDS11 ;SFISC/MLH,MKO - LOAD DATA TO BE SHOWN ON SCREEN ;01MAR2016
  1.  ;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
  1.  ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
  1.  ;;Licensed under the terms of the Apache License, Version 2.0.
  1.  ;Input variables:
  1.  ;  DDSBK   = Block #
  1.  ;  DDSPG   = Page # (needed for form-only fields)
  1.  ;  DDSREFT = Temporary global location
  1.  ;  DDP     = File number of block
  1.  ;  DIE     = Global root of block
  1.  ;  DDSDA   = DA,DA(1),...
  1.  ;  DDSNFO  = Flag means don't reload form only fields
  1.  ;
  1. BEGIN N X,Y
  1.  S DDS1REFD=$NA(@DDSREFT@("F"_DDP,DDSDA))
  1.  ;
  1.  S DDS1FO=0
  1.  F  S DDS1FO=$O(^DIST(.404,DDSBK,40,DDS1FO)) Q:'DDS1FO  D LD
  1.  ;
  1.  I DDP,DDSDA S @DDS1REFD@("GL")=DIE
  1.  ;
  1.  K DDS1REFD,DDS1FLD,DDS1FO,DDS1KEY,DDS1LN,DDS1ND,DDS1PC,DDS1UI,DDS1DV
  1.  K DDS1D1,DDS1D2,DDS1D3
  1.  Q
  1.  ;
  1.  ;
  1.  ;
  1.  ;
  1. EN(DDSBK,DDSNFO) ;Main Entry Point for VEN version
  1.  G BEGIN
  1.  ;
  1.  ;
  1. LD ;Load data for a field
  1.  ;
  1.  ;Get form only fields
  1.  I $P($G(^DIST(.404,DDSBK,40,DDS1FO,0)),U,3)=2,$P($G(^(20)),U)]"" D  Q
  1.  . Q:$G(DDSNFO)
  1.  . N DDP
  1.  . S DDP=0,DDS1FLD=DDS1FO_","_DDSBK
  1.  . Q:"^1^3^"[(U_$G(@DDSREFT@("F0",DDSDA,DDS1FLD,"F"))_U)
  1.  . S Y=""
  1.  . I $D(@DDSREFT@("F0",DDSDA,DDS1FLD,"F"))[0,$G(^DIST(.404,DDSBK,40,DDS1FO,3))]"" D DEF(^(3),$G(^(3.1)))
  1.  . S (@DDSREFT@("F0",DDSDA,DDS1FLD,"D"),^("O"))=Y
  1.  ;
  1.  ;Get DD fields
  1.  S DDS1FLD=$G(^DIST(.404,DDSBK,40,DDS1FO,1)) Q:DDS1FLD?."^"
  1.  Q:"^1^3^"[(U_$G(@DDS1REFD@(DDS1FLD,"F"))_U)
  1.  ;
  1.  S DDS1LN=$G(^DD(DDP,DDS1FLD,0)) Q:DDS1LN?."^"
  1.  S DDS1PC=$P(DDS1LN,U,4),DDS1ND=$P(DDS1PC,";"),DDS1PC=$P(DDS1PC,";",2)
  1.  S DDS1DV=$P(DDS1LN,U,2),X=$P(DDS1LN,U,3)
  1.  ;
  1.  D @($S(DDS1FLD=.001:"L3",DDS1PC=0:"L2",1:"L1"))
  1.  ;
  1.  I DDS1DV["O"!(DDS1DV["P")!(DDS1DV["V")!(DDS1DV["D")!(DDS1DV["S")!(DDS1DV["t") D
  1.  . Q:$D(@DDS1REFD@(DDS1FLD,"X"))
  1.  . D:Y]"" XFORM
  1.  . S @DDS1REFD@(DDS1FLD,"X")=Y
  1.  ;
  1.  I DDS1PC=0,DDS1DV,DDS1DV'["W",$D(@DDS1REFD@(DDS1FLD,"X"))[0 S ^("X")=Y
  1.  Q
  1.  ;
  1. L1 ;Get non-multiple field
  1.  S DDS1LN=$G(@(DIE_"DA,DDS1ND)"))
  1.  I $E(DDS1PC)'="E" S Y=$P(DDS1LN,U,DDS1PC)
  1.  E  S Y=$E(DDS1LN,+$E(DDS1PC,2,999),$P(DDS1PC,",",2)) S:Y?." " Y=""
  1.  ;
  1.  K @DDS1REFD@(DDS1FLD,"X")
  1.  I Y="",$D(@DDS1REFD@(DDS1FLD,"F"))[0,$D(^DIST(.404,DDSBK,40,DDS1FO,3))#2 D DEF(^(3),$G(^(3.1)))
  1. MUMPS I $G(DUZ(0))'="@",DDS1DV["K" S $P(@DDS1REFD@(DDS1FLD,"A"),U,4)=1,Y=$TR($J("",$L(Y))," ","*") ;**151
  1.  S @DDS1REFD@(DDS1FLD,"D")=Y
  1.  ;
  1.  ;Get key info
  1.  I '$D(@DDS1REFD@(DDS1FLD,"K")) D
  1.  . S DDS1KEY=0
  1.  . F  S DDS1KEY=$O(^DD("KEY","F",DDP,DDS1FLD,DDS1KEY)) Q:'DDS1KEY  D
  1.  .. S DDS1UI=$P(^DD("KEY",DDS1KEY,0),U,4) Q:'DDS1UI
  1.  .. Q:$P($G(^DD("IX",DDS1UI,0)),U,6)'="F"
  1.  .. S ^("K")=$G(@DDS1REFD@(DDS1FLD,"K"))_DDS1UI_U
  1.  Q
  1.  ;
  1. L2 ;Get multiple field
  1.  S DDS1SUB=+$P(DDS1LN,U,2) Q:$D(^DD(DDS1SUB,.01,0))[0
  1.  S DDS1DV=DDS1SUB_$P(^DD(DDS1SUB,.01,0),U,2),X=$P(^(0),U,3)
  1.  S DDS1DIC=DIE_DA_","""_DDS1ND_""","
  1.  ;
  1.  D:DDS1DV'["W"
  1.  . I $D(^DIST(.404,DDSBK,40,DDS1FO,3))#2 D  D L22
  1.  .. D DEF(^DIST(.404,DDSBK,40,DDS1FO,3),$G(^(3.1)),1)
  1.  .. S DDS1RN=$S($G(Y)="FIRST":$O(@(DDS1DIC_"0)")),$G(Y)="LAST":$O(@(DDS1DIC_""" "")"),-1),1:+$G(Y))
  1.  . E  I $D(DUZ)#2,$L(DDS1DIC)<29,$D(^DISV(DUZ,DDS1DIC))#2 S DDS1RN=^(DDS1DIC) D L22
  1.  . E  S DDS1RN=$S($D(@(DDS1DIC_"0)"))#2:$P(^(0),U,3),1:$O(^(0))) D L22
  1.  . E  S (Y,@DDS1REFD@(DDS1FLD,"D"))=""
  1.  ;
  1.  S @DDS1REFD@(DDS1FLD,"M")=$S(DDS1DV["W":0,1:1)_DDS1DIC_U_DDS1SUB
  1.  K DDS1DIC,DDS1RN,DDS1SUB
  1.  Q
  1. L22 ;
  1.  I DDS1RN>0,$D(@(DDS1DIC_+DDS1RN_",0)"))#2 S Y=$P(^(0),U),@DDS1REFD@(DDS1FLD,"D")=+DDS1RN
  1.  Q
  1.  ;
  1. DEF(DDS1LN3,DDS1LN31,DDS1MULT) ;Get default
  1.  N DDS1PTR,DDS1OT
  1.  Q:DDS1LN3=""
  1.  I DDS1LN3'="!M" S Y=DDS1LN3
  1.  E  I DDS1LN31'?."^" X DDS1LN31 S:$D(Y)[0 Y=""
  1.  Q:Y=""!$G(DDS1MULT)
  1.  ;
  1.  K DIR
  1.  I DDS1FLD["," D
  1.  . S DIR(0)=$P(^DIST(.404,DDSBK,40,DDS1FO,20),U)_$P(^(20),U,2,3)
  1.  . S:DIR(0)?1"DD".E DIR(0)=$P(DIR(0),U,2,999)
  1.  . I $E($P(DIR(0),U))="P" S DDS1PTR=1
  1.  E  D
  1.  . S DIR(0)=DDP_","_DDS1FLD
  1.  . S DDS1PTR=$P($G(^DD(DDP,DDS1FLD,0)),U,2)
  1.  . S DDS1OT=DDS1PTR["O",DDS1PTR=DDS1PTR["P"
  1.  S DIR("V")="",(X,DIR("B"))=Y
  1.  D ^DIR
  1.  ;
  1.  I DDER S Y=""
  1.  I Y]"" D
  1.  . I $G(DDS1PTR) S Y=$P(Y,U)
  1.  . S $P(@DDSREFT@("F"_DDP,DDSDA,DDS1FLD,"F"),U)=3
  1.  . I $G(DDS1PTR),$G(DDS1OT),$D(^DD(DDP,DDS1FLD,2))#2 K Y(0),Y(0,0)
  1.  . S:$D(Y(0)) @DDSREFT@("F"_DDP,DDSDA,DDS1FLD,"X")=$S($D(Y(0,0))#2:Y(0,0),1:Y(0))
  1.  . S DDSCHG=1
  1.  K DDER,DIR
  1.  Q
  1.  ;
  1. L3 ;Get number field
  1.  S (@DDS1REFD@(.001,"D"),Y)=DA
  1.  Q
  1.  ;
  1. EXT(DDP,DDS1FLD,Y) ;Return external form of Y
  1.  N DDS1DV,X
  1.  S DDS1DV=$P(^DD(DDP,DDS1FLD,0),U,2),X=$P(^(0),U,3)
  1.  I DDS1DV'["O",DDS1DV'["P",DDS1DV'["V",DDS1DV'["D",DDS1DV'["S",DDS1DV'["t" Q Y
  1.  I DDS1DV'["O",Y="" Q ""
  1.  D XFORM
  1.  Q Y
  1.  ;
  1. XFORM ;
  1.  N DDS1N
  1.  I DDS1DV["O"!(DDS1DV["t") X $$OUTPUT^DIETLIBF(DDP,+DDS1FLD) Q
  1.  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
  1.  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
  1.  I DDS1DV["D" X ^DD("DD")
  1.  I DDS1DV["S" D
  1.  .I +DDS1FLD,$G(^DD(DDP,+DDS1FLD,0))[X S Y=$$SET^DIQ(DDP,+DDS1FLD,Y) ;FOREIGN-LANGUAGE SET VALUE
  1.  .E  D PARSET^DIQ(X,.Y)
  1.  Q