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