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

DICATT3.m

Go to the documentation of this file.
  1. DICATT3 ;SFISC/GFT - COMPUTED FIELDS ;12APR2016
  1. ;;22.2;VA FileMan;**3,5**;Jan 05, 2016;Build 28
  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. ;;GFT;**76,118,1035,1055**
  1. ;
  1. K DIRUT,DTOUT D COMP I $P(^DD(A,DA,0),U,2)["C" G N^DICATT
  1. S DTOUT=1 G CHECK^DICATT
  1. ;
  1. COMP N DIR,DICOMPX,DISPEC,DICMIN,DIL,DIJ,DIE,DIDEC
  1. S DISPEC=$P($G(^DD(A,DA,0)),U,2)
  1. S DIR(0)="FU",DIR("A")="'COMPUTED-FIELD' EXPRESSION"
  1. I O,$D(^DD(A,DA,9.1)) S DIR("B")=^(9.1)
  1. S DIR("?")="^D DICATT3^DIQQ"
  1. D ^DIR Q:$D(DIRUT)
  1. I $D(DIR("B")),DIR("B")=Y G GETTYPE
  1. K DICOMPX S DICOMPX=""
  1. S DICMIN=Y,DQI="Y("_A_","_DA_",",DICMX="X DICMX",DICOMP="?I"
  1. D ^DICOMP I '$D(X) W $C(7)," ...??" G 6
  1. I DUZ(0)="@" W !,"TRANSLATES TO THE FOLLOWING CODE:",!,X,!
  1. I Y["m" W !,"FIELD IS 'MULTIPLE-VALUED'!",!
  1. I O,$D(^DD(A,DA,9.01))!(DICOMPX]"") D ACOMP
  1. S DISPEC=$E("D",Y["D")_$E("B",Y["B")_"C"_$S(Y'["m":"",1:"m"_$E("w",Y["w"))_$S(Y["p":"p"_$S($P(Y,"p",2):+$P(Y,"p",2),1:""),1:"")_$S(Y'["B":"",1:"J1")
  1. S ^DD(A,DA,0)=F_U_DISPEC_"^^ ; ^"_X,^(9)=U,^(9.1)=DICMIN,^(9.01)=DICOMPX
  1. S Y=9.2 F K ^DD(A,DA,Y) S Y=$O(^(Y)) Q:Y\1-9 ;KILL ALL THE 9.2 NODES
  1. F Y=9.2:0 Q:'$D(X(Y)) S ^DD(A,DA,Y)=X(Y),Y=$O(X(Y))
  1. K X,DICOMPX
  1. GETTYPE K DIR S DIR(0)="SBA^S:STRING;N:NUMERIC;B:BOOLEAN;D:DATE;m:MULTIPLE;p:POINTER;mp:MULTIPLE POINTER"
  1. S DIR("A")="TYPE OF RESULT: "
  1. S DIR("B")=$P($E(DIR(0),$F(DIR(0),$$TYPE(DISPEC)_":"),99),";")
  1. D ^DIR I $D(DIRUT) G END
  1. S DISPEC=$TR(Y,"SN") I Y="B"!(Y="D") D P(Y) G END
  1. I Y["p" D POINT G END
  1. S DIJ="",DIE=$P($P(O,U,2),"J",2) F J=0:0 S N=$E(DIE) Q:N?.A S DIE=$E(DIE,2,99),DIJ=DIJ_N
  1. S DIDEC=$P(DIJ,",",2),DIL=$S(DIJ:+DIJ,1:8) S:Y'="N" DIDEC=""
  1. I DISPEC["m" D P(DISPEC) G END
  1. D DEC:Y="N" I '$D(DIRUT) D LEN
  1. END I O S DI=A D PZ^DIU0 Q
  1. D SDIK^DICATT22
  1. 6 Q ;leave this here
  1. ;
  1. ;
  1. DEC N DG,O,M
  1. FRAC K DIR S DIR("A")="NUMBER OF FRACTIONAL DIGITS TO OUTPUT: "
  1. I DIDEC]"" S DIR("B")=DIDEC
  1. S DIR("?")="Enter the number of decimal digits that should normally appear in the result."
  1. S DIR(0)="NAO^0:14:0" D ^DIR Q:$D(DIRUT) S DIDEC=Y
  1. S DG=" S X=$J(X,0,",M=$P(^DD(A,DA,0),DG),%=M_DG_DIDEC_")"'=^(0)+1
  1. W !,"SHOULD VALUE ALWAYS BE INTERNALLY ROUNDED TO ",DIDEC," DECIMAL PLACE",$E("S",DIDEC'=1)
  1. D YN^DICN G FRAC:'% Q:%'>0 S ^DD(A,DA,0)=M_$P(DG_DIDEC_")",U,%)
  1. S S DQI="Y(",O=$D(^(9.02)),X=^(9.1) K DICOMPX,^(9.02) Q:'$D(^(9.01))
  1. F Y=1:1 S M=$P(^(9.01),";",Y) Q:M="" S DICOMPX(1,+M,+$P(M,U,2))="S("""_M_""")",DICOMPX=""
  1. Q:Y<2 I X'["/",X'["\" Q:X'["*" Q:Y<3
  1. D ^DICOMP Q:$D(X)-1
  1. S %=2-O W !,"WHEN TOTALLING THIS FIELD, SHOULD THE SUM BE COMPUTED FROM",!?7,"THE SUMS OF THE COMPONENT FIELDS" D YN^DICN
  1. I %=1 S ^DD(A,DA,9.02)=X_" S Y=X"
  1. S:%<1 DIRUT=1
  1. Q
  1. ;
  1. LEN K DIR
  1. S DIR(0)="NAO^1::0",DIR("A")="LENGTH OF FIELD: ",DIR("B")=DIL
  1. S DIR("?")="Maximum number of character expected to be output."
  1. D ^DIR Q:$D(DIRUT)
  1. D P($P(DISPEC,"J")_"J"_Y_$E(",",DIDEC]"")_DIDEC_DIE) Q
  1. ;
  1. POINT K DIR
  1. S DIR(0)="P^1:QEF",DIR("A")="POINT TO WHAT FILE"
  1. S DIR("S")="I $$OKFILE^DICOMPX(Y,""W"")"
  1. S X=$P($P(^DD(A,DA,0),U,2),"p",2) I 'X S X=$P($P(O,U,2),"p",2)
  1. I X,$D(^DIC(+X,0)) S DIR("B")=$P(^(0),U)
  1. D ^DIR I '$D(DIRUT) S $P(DISPEC,"p",2)=+Y D P(DISPEC)
  1. Q
  1. ;
  1. P(C) S $P(^DD(A,DA,0),U,2)="C"_$TR(C,"C^") Q
  1. ;
  1. ACOMP ;SET/KILL ACOMP NODES CALLED FROM DICATTDE
  1. N X,I I $G(^DD(A,DA,9.01))]"" S X=^(9.01) X ^DD(0,9.01,1,1,2)
  1. I DICOMPX]"" S X=DICOMPX X ^DD(0,9.01,1,1,1)
  1. Q
  1. ;
  1. TYPE(S) ;
  1. Q $S(S["D":"D",S["B":"B",S["mp":"mp",S["m":"m",S["p":"p",S'["J":"S",S[",":"N",1:"S") ;figure out TYPE OF RESULT