- DICATT2 ;SFISC/GFT,XAK - DEFINING MULTIPLES ;12NOV2015
- ;;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.
- ;
- S T=$E(Z) G CHECK^DICATT:$D(DTOUT)
- F P="I","O","L","x" S:$P(O,U,2)[P Z=$P(Z,U)_P_U_$P(Z,U,2)
- 1 K DS S:$P(Z,U)'["K" V=W[";0"
- S P=0,N=DICL,DQ=4,DP=6,DQI=" S:$D(X) DINUM=+X",DREF=$F(O,DQI)-1=$L(O),DE(7,0)="NO",DG(7)="N"
- S:T="*" T=$S($P(Z,U)["S":"S",1:"P") G 1^DICATT22:DA=.001
- G W:T="W" S:$D(DTIME)[0 DTIME=300
- I T'["F",T'["S",T'["K",'O!DREF S:DREF DE(7,0)="YES",DG(7)="Y"
- S F Y=4:1:6 S DQ(Y)=$P($T(DQ+Y),";",3)_F_$P($T(DQ+Y),";",4)_" (Y/N)^RS^Y:YES;N:NO^"_Y_"^Q" I 'V,DA-.01!'N Q
- S DG(5)="Y",DE(4,0)="NO",DP=-1,DL=1
- I T["P"!(T["N") S DE(5,0)="YES"
- I O S DE(6,0)=$E("NY",$P(O,U,2)["M"+1) S:$P(O,U,2)["R" DE(4,0)="Y" I DA=.01,N S P=$O(^DD(J(N-1),"SB",A,0)) S:P="" P=-1 S Y=$P(^DD(J(N-1),P,0),U,2),DE(5,0)=$E("YN",Y["A"+1)
- K Y S DIFLD=-1 D RE^DIED K DQ,DIFLD G:$D(Y) N^DICATT:$P(Z,U)["X",CHECK^DICATT I $D(DTOUT) K DTOUT G CHECK^DICATT
- S:DG(5)="N" T=T_"A" I DG(4)="Y",$P(Z,U)'["R" S Z="R"_Z
- I $D(DG(6)),DG(6)="Y",$P(Z,U)'["M" S Z="M"_Z
- G S DIZ=Z G ^DICATT22
- Q ;
- K T,B,A,J,DA,DIC,E,DR,W,S,Q,P,N,V,I,L,F,DQI,DIK,C,Z,Y,DE,O,DICS,DICL,DDA Q
- ;
- W S %=Z["L"+1 W !,"SHALL THIS TEXT NORMALLY APPEAR IN WORD-WRAP MODE" D YN^DICN
- G CHECK^DICATT:%<0 I % S Z=$P($TR(Z,"L"),U)_$E("L",%=2)_U G WINDOW
- W !,"ANSWER 'YES' IF THE INTERNALLY-STORED '"_F_"' TEXT"
- W !?5,"SHOULD NORMALLY BE PRINTED OUT IN FULL LINES, BREAKING AT WORD BOUNDARIES."
- W !?2,"ANSWER 'NO' IF THE INTERNAL TEXT SHOULD NORMALLY BE PRINTED OUT"
- W !?5,"LINE-FOR-LINE AS IT STANDS.",! G W
- ;
- ;
- WINDOW S %=2-(Z["x"!'O) W !,"SHALL ""|"" CHARACTERS IN THIS TEXT BE TREATED LIKE ANY OTHER CHARACTERS" D YN^DICN
- G CHECK^DICATT:%<0 I % S Z=$P($TR(Z,"x"),U)_$E("x",%=1)_U G G
- W !,"ANSWER 'YES' IF THE INTERNALLY-STORED '"_F_"' TEXT MAY HAVE ""|"" CHARACTERS"
- W !?3,"IN IT (SUCH AS HL7 MESSAGES) THAT NEED TO DISPLAY EXACTLY AS THEY ARE STORED."
- W !,"ANSWER 'NO' IF THE INTERNAL TEXT SHOULD NORMALLY BE PRINTED OUT WITH ANYTHING"
- W !?3,"THAT IS DELIMITED BY ""|"" CHARACTERS INTERPRETED AS VARIABLE TEXT.",! G WINDOW
- ;
- ;
- ;
- X ;
- W " (FIELD DEFINITION IS NOT EDITABLE)"
- I N=4 K DIRUT D LENGTH(A,DA) I $D(DIRUT) K DIRUT G N^DICATT
- S T=$E(^DOPT("DICATT",N,0)),Y=^DD(A,DA,0),Z=$TR($P(Y,U,2),"MR")_U_$P(Y,U,3),W=$P(Y,U,4),C=$P(Y,U,5,99) S:Z["K" V=0
- G N^DICATT:N=6,1
- ;
- LENGTH(DI,DIFIELD) ;
- N DIR,DICY,Y,X,A0,B0,A1,A2
- S DICY=$G(^DD(DI,DIFIELD,0)) I $P(DICY,U,2)'["F" Q
- S A0=250,A1=$P($P($P(DICY,U,4),";",2),"E",2) I A1 S A2=$P(A1,",",2) I A2 S A0=A2-A1+1,DIR("?",1)="Data is stored by '$E"_A1_"'"
- S DIR("A")="MAXIMUM LENGTH OF '"_$P(DICY,U)_"'",DIR(0)="N^1:"_A0,DIR("B")=$$FL^DIQGDDU(DI,DIFIELD)
- S DIR("?")="THIS MAXIMUM WILL BE USED FOR OUTPUT PURPOSES, BUT WILL NOT BE PART OF THE INPUT CHECK FOR THE FIELD"
- D ^DIR Q:'Y
- N F S X=$P(DICY,U,2),F=$F(X,"J") I F Q:+$E(X,F,99)=Y F Q:$E(X,F)'?1N S X=$E(X,1,F-1)_$E(X,F+1,99)
- S X=$TR(X,"J")_"J"_Y,$P(^DD(DI,DIFIELD,0),U,2)=X
- I $D(DDA) S DDA="E",A0="LENGTH^.23",A1=DIR("B"),A2=Y D IT^DICATTA
- Q
- ;
- NO ;
- W !,$C(7)," <DATA DEFINITION UNCHANGED>" I $P(Z,U)["K"&(DUZ(0)'="@") G N^DICATT
- TYPE K Y,M,DE,DIE,DQ,DG G Q^DIB:$D(DTOUT) S N=0,DQI=DICL+9,Y=^DD(A,DA,0),F=$P(Y,U),Z="" W !!,"DATA TYPE OF ",F,": "
- I 'O R X:DTIME S:'$T DTOUT=1 G X^DICATT:X[U!'$T S DIC("S")="I Y-99,Y-10,Y<10!$O(^(201,0))!$O(^DI(.81,Y,101,0))" S:DUZ(0)'="@" DIC("S")="I Y-9,Y-99,Y<10!$O(^(201,0))" S:DA=.001 DIC("S")="I Y<4!(Y=7)" G NEW
- I $P(Y,U,2)["t" S N=+$P($P(Y,U,2),"t",2)
- E F N=9:-1:5,1:1:4 Q:$P(Y,U,2)[$E("DNSFWCPVK",N)
- W $P(^DI(.81,N,0),U) ;Data type
- G X:$P(Y,U,2)["K"&(DUZ(0)'="@") ;non-programmer can't edit MUMPS type
- G X:$P(Y,U,2)["X",6^DICATT:N=6 R "// ",X:DTIME S:'$T DTOUT=1 G N^DICATT:X[U!'$T,0^DICATT:X=""
- S DIC("S")="I Y-6,Y-10,Y<10!$O(^(201,0))!$O(^DI(.81,Y,101,0)),Y-9"_$P(",Y-5",U,N\2-2!(A=B)!(DA-.01)!$O(^DD(A,DA))>0),DIC("S")=DIC("S")_$S(N=7:",Y-8",N=8:",Y-7",1:"")
- NEW I 'O,X=" ",E,$P(^DD(A,E,0),U,2)'["P",$P(^(0),U,2)'["V" D G E^DICATT1
- .W " <",$C(7) D E^DICATT W " DUPLICATED>" S $P(DE,U,2)=$TR($P(DE,U,2),"a"),DIZ=$G(DIZ,DIZZ) ;DO NOT DUPLICATE AUDITING
- S DIC(0)="QEI",DIC="^DI(.81," D ^DIC K DIC ;Look up X in Data Type file
- I Y>0 S:N-Y&O M="",O=$P(O,U,1,2)_U_U_$P(O,U,4) S N=+Y G 0^DICATT
- I 'O,X["?",E,$P(^DD(A,E,0),U,2)'["P",$P(^(0),U,2)'["V" D DICATT^DIQQQ,E^DICATT W ", JUST HIT THE SPACE KEY"
- G TYPE
- ;
- DQ ;;
- ;
- ;
- ;
- ;;IS ; ENTRY MANDATORY
- ;;SHOULD USER SEE AN "ADDING A NEW ;?" MESSAGE FOR NEW ENTRIES
- ;;HAVING ENTERED OR EDITED ONE ;, SHOULD USER BE ASKED ANOTHER
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICATT2 4854 printed Jan 18, 2025@03:46:29 Page 2
- DICATT2 ;SFISC/GFT,XAK - DEFINING MULTIPLES ;12NOV2015
- +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 ;
- +7 SET T=$EXTRACT(Z)
- if $DATA(DTOUT)
- GOTO CHECK^DICATT
- +8 FOR P="I","O","L","x"
- if $PIECE(O,U,2)[P
- SET Z=$PIECE(Z,U)_P_U_$PIECE(Z,U,2)
- 1 KILL DS
- if $PIECE(Z,U)'["K"
- SET V=W[";0"
- +1 SET P=0
- SET N=DICL
- SET DQ=4
- SET DP=6
- SET DQI=" S:$D(X) DINUM=+X"
- SET DREF=$FIND(O,DQI)-1=$LENGTH(O)
- SET DE(7,0)="NO"
- SET DG(7)="N"
- +2 if T="*"
- SET T=$SELECT($PIECE(Z,U)["S":"S",1:"P")
- if DA=.001
- GOTO 1^DICATT22
- +3 if T="W"
- GOTO W
- if $DATA(DTIME)[0
- SET DTIME=300
- +4 IF T'["F"
- IF T'["S"
- IF T'["K"
- IF 'O!DREF
- if DREF
- SET DE(7,0)="YES"
- SET DG(7)="Y"
- S FOR Y=4:1:6
- SET DQ(Y)=$PIECE($TEXT(DQ+Y),";",3)_F_$PIECE($TEXT(DQ+Y),";",4)_" (Y/N)^RS^Y:YES;N:NO^"_Y_"^Q"
- IF 'V
- IF DA-.01!'N
- QUIT
- +1 SET DG(5)="Y"
- SET DE(4,0)="NO"
- SET DP=-1
- SET DL=1
- +2 IF T["P"!(T["N")
- SET DE(5,0)="YES"
- +3 IF O
- SET DE(6,0)=$EXTRACT("NY",$PIECE(O,U,2)["M"+1)
- if $PIECE(O,U,2)["R"
- SET DE(4,0)="Y"
- IF DA=.01
- IF N
- SET P=$ORDER(^DD(J(N-1),"SB",A,0))
- if P=""
- SET P=-1
- SET Y=$PIECE(^DD(J(N-1),P,0),U,2)
- SET DE(5,0)=$EXTRACT("YN",Y["A"+1)
- +4 KILL Y
- SET DIFLD=-1
- DO RE^DIED
- KILL DQ,DIFLD
- if $DATA(Y)
- if $PIECE(Z,U)["X"
- GOTO N^DICATT
- GOTO CHECK^DICATT
- IF $DATA(DTOUT)
- KILL DTOUT
- GOTO CHECK^DICATT
- +5 if DG(5)="N"
- SET T=T_"A"
- IF DG(4)="Y"
- IF $PIECE(Z,U)'["R"
- SET Z="R"_Z
- +6 IF $DATA(DG(6))
- IF DG(6)="Y"
- IF $PIECE(Z,U)'["M"
- SET Z="M"_Z
- G SET DIZ=Z
- GOTO ^DICATT22
- Q ;
- +1 KILL T,B,A,J,DA,DIC,E,DR,W,S,Q,P,N,V,I,L,F,DQI,DIK,C,Z,Y,DE,O,DICS,DICL,DDA
- QUIT
- +2 ;
- W SET %=Z["L"+1
- WRITE !,"SHALL THIS TEXT NORMALLY APPEAR IN WORD-WRAP MODE"
- DO YN^DICN
- +1 if %<0
- GOTO CHECK^DICATT
- IF %
- SET Z=$PIECE($TRANSLATE(Z,"L"),U)_$EXTRACT("L",%=2)_U
- GOTO WINDOW
- +2 WRITE !,"ANSWER 'YES' IF THE INTERNALLY-STORED '"_F_"' TEXT"
- +3 WRITE !?5,"SHOULD NORMALLY BE PRINTED OUT IN FULL LINES, BREAKING AT WORD BOUNDARIES."
- +4 WRITE !?2,"ANSWER 'NO' IF THE INTERNAL TEXT SHOULD NORMALLY BE PRINTED OUT"
- +5 WRITE !?5,"LINE-FOR-LINE AS IT STANDS.",!
- GOTO W
- +6 ;
- +7 ;
- WINDOW SET %=2-(Z["x"!'O)
- WRITE !,"SHALL ""|"" CHARACTERS IN THIS TEXT BE TREATED LIKE ANY OTHER CHARACTERS"
- DO YN^DICN
- +1 if %<0
- GOTO CHECK^DICATT
- IF %
- SET Z=$PIECE($TRANSLATE(Z,"x"),U)_$EXTRACT("x",%=1)_U
- GOTO G
- +2 WRITE !,"ANSWER 'YES' IF THE INTERNALLY-STORED '"_F_"' TEXT MAY HAVE ""|"" CHARACTERS"
- +3 WRITE !?3,"IN IT (SUCH AS HL7 MESSAGES) THAT NEED TO DISPLAY EXACTLY AS THEY ARE STORED."
- +4 WRITE !,"ANSWER 'NO' IF THE INTERNAL TEXT SHOULD NORMALLY BE PRINTED OUT WITH ANYTHING"
- +5 WRITE !?3,"THAT IS DELIMITED BY ""|"" CHARACTERS INTERPRETED AS VARIABLE TEXT.",!
- GOTO WINDOW
- +6 ;
- +7 ;
- +8 ;
- X ;
- +1 WRITE " (FIELD DEFINITION IS NOT EDITABLE)"
- +2 IF N=4
- KILL DIRUT
- DO LENGTH(A,DA)
- IF $DATA(DIRUT)
- KILL DIRUT
- GOTO N^DICATT
- +3 SET T=$EXTRACT(^DOPT("DICATT",N,0))
- SET Y=^DD(A,DA,0)
- SET Z=$TRANSLATE($PIECE(Y,U,2),"MR")_U_$PIECE(Y,U,3)
- SET W=$PIECE(Y,U,4)
- SET C=$PIECE(Y,U,5,99)
- if Z["K"
- SET V=0
- +4 if N=6
- GOTO N^DICATT
- GOTO 1
- +5 ;
- LENGTH(DI,DIFIELD) ;
- +1 NEW DIR,DICY,Y,X,A0,B0,A1,A2
- +2 SET DICY=$GET(^DD(DI,DIFIELD,0))
- IF $PIECE(DICY,U,2)'["F"
- QUIT
- +3 SET A0=250
- SET A1=$PIECE($PIECE($PIECE(DICY,U,4),";",2),"E",2)
- IF A1
- SET A2=$PIECE(A1,",",2)
- IF A2
- SET A0=A2-A1+1
- SET DIR("?",1)="Data is stored by '$E"_A1_"'"
- +4 SET DIR("A")="MAXIMUM LENGTH OF '"_$PIECE(DICY,U)_"'"
- SET DIR(0)="N^1:"_A0
- SET DIR("B")=$$FL^DIQGDDU(DI,DIFIELD)
- +5 SET DIR("?")="THIS MAXIMUM WILL BE USED FOR OUTPUT PURPOSES, BUT WILL NOT BE PART OF THE INPUT CHECK FOR THE FIELD"
- +6 DO ^DIR
- if 'Y
- QUIT
- +7 NEW F
- SET X=$PIECE(DICY,U,2)
- SET F=$FIND(X,"J")
- IF F
- if +$EXTRACT(X,F,99)=Y
- QUIT
- FOR
- if $EXTRACT(X,F)'?1N
- QUIT
- SET X=$EXTRACT(X,1,F-1)_$EXTRACT(X,F+1,99)
- +8 SET X=$TRANSLATE(X,"J")_"J"_Y
- SET $PIECE(^DD(DI,DIFIELD,0),U,2)=X
- +9 IF $DATA(DDA)
- SET DDA="E"
- SET A0="LENGTH^.23"
- SET A1=DIR("B")
- SET A2=Y
- DO IT^DICATTA
- +10 QUIT
- +11 ;
- NO ;
- +1 WRITE !,$CHAR(7)," <DATA DEFINITION UNCHANGED>"
- IF $PIECE(Z,U)["K"&(DUZ(0)'="@")
- GOTO N^DICATT
- TYPE KILL Y,M,DE,DIE,DQ,DG
- if $DATA(DTOUT)
- GOTO Q^DIB
- SET N=0
- SET DQI=DICL+9
- SET Y=^DD(A,DA,0)
- SET F=$PIECE(Y,U)
- SET Z=""
- WRITE !!,"DATA TYPE OF ",F,": "
- +1 IF 'O
- READ X:DTIME
- if '$TEST
- SET DTOUT=1
- if X[U!'$TEST
- GOTO X^DICATT
- SET DIC("S")="I Y-99,Y-10,Y<10!$O(^(201,0))!$O(^DI(.81,Y,101,0))"
- if DUZ(0)'="@"
- SET DIC("S")="I Y-9,Y-99,Y<10!$O(^(201,0))"
- if DA=.001
- SET DIC("S")="I Y<4!(Y=7)"
- GOTO NEW
- +2 IF $PIECE(Y,U,2)["t"
- SET N=+$PIECE($PIECE(Y,U,2),"t",2)
- +3 IF '$TEST
- FOR N=9:-1:5,1:1:4
- if $PIECE(Y,U,2)[$EXTRACT("DNSFWCPVK",N)
- QUIT
- +4 ;Data type
- WRITE $PIECE(^DI(.81,N,0),U)
- +5 ;non-programmer can't edit MUMPS type
- if $PIECE(Y,U,2)["K"&(DUZ(0)'="@")
- GOTO X
- +6 if $PIECE(Y,U,2)["X"
- GOTO X
- if N=6
- GOTO 6^DICATT
- READ "// ",X:DTIME
- if '$TEST
- SET DTOUT=1
- if X[U!'$TEST
- GOTO N^DICATT
- if X=""
- GOTO 0^DICATT
- +7 SET DIC("S")="I Y-6,Y-10,Y<10!$O(^(201,0))!$O(^DI(.81,Y,101,0)),Y-9"_$PIECE(",Y-5",U,N\2-2!(A=B)!(DA-.01)!$ORDER(^DD(A,DA))>0)
- SET DIC("S")=DIC("S")_$SELECT(N=7:",Y-8",N=8:",Y-7",1:"")
- NEW IF 'O
- IF X=" "
- IF E
- IF $PIECE(^DD(A,E,0),U,2)'["P"
- IF $PIECE(^(0),U,2)'["V"
- Begin DoDot:1
- +1 ;DO NOT DUPLICATE AUDITING
- WRITE " <",$CHAR(7)
- DO E^DICATT
- WRITE " DUPLICATED>"
- SET $PIECE(DE,U,2)=$TRANSLATE($PIECE(DE,U,2),"a")
- SET DIZ=$GET(DIZ,DIZZ)
- End DoDot:1
- GOTO E^DICATT1
- +2 ;Look up X in Data Type file
- SET DIC(0)="QEI"
- SET DIC="^DI(.81,"
- DO ^DIC
- KILL DIC
- +3 IF Y>0
- if N-Y&O
- SET M=""
- SET O=$PIECE(O,U,1,2)_U_U_$PIECE(O,U,4)
- SET N=+Y
- GOTO 0^DICATT
- +4 IF 'O
- IF X["?"
- IF E
- IF $PIECE(^DD(A,E,0),U,2)'["P"
- IF $PIECE(^(0),U,2)'["V"
- DO DICATT^DIQQQ
- DO E^DICATT
- WRITE ", JUST HIT THE SPACE KEY"
- +5 GOTO TYPE
- +6 ;
- DQ ;;
- +1 ;
- +2 ;
- +3 ;
- +4 ;;IS ; ENTRY MANDATORY
- +5 ;;SHOULD USER SEE AN "ADDING A NEW ;?" MESSAGE FOR NEW ENTRIES
- +6 ;;HAVING ENTERED OR EDITED ONE ;, SHOULD USER BE ASKED ANOTHER