- DICE ;SFISC/GFT-CREATE AN XREF ;17DEC2010
- ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
- ;;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 %=2,DCOND="CROSS-REFERENCE" W !,"WANT TO CREATE A NEW ",DCOND," FOR THIS FIELD" D YN^DICN G Q:%-1
- N F DQ=1:1 Q:'$D(^DD(DI,DA,1,DQ))
- W !,"CROSS-REFERENCE NUMBER: "_DQ_"// " R X:DTIME S:'$T DTOUT=1 G Q:'$T S:X="" X=DQ G NQ:X'?.N!'X,X:$D(^(X)) S DQ=X
- S DH=0,DIC="^DOPT(""DICR"",",DIC(0)="EQA",DIC("B")=1,DIC("S")="I 1"_$P(",Y-4",U,DUZ(0)'="@")_$P(",Y-5",U,$D(^DD(J(N),0,"LOOK"))>0)_$P(",Y-7",U,'$D(^XMB(3.6))) S:$P($G(^DD($$FNO^DILIBF(J(N)),0,"DI")),U)="Y" DIC("S")=DIC("S")_",Y-4,Y-6,Y-7"
- D ^DIC K DIC D QQ S Y=+Y G X:Y<0,6^DICE0:Y=6,^DICE7:Y=7 ;1=REGULAR 2=KWIC 3=MNEMONIC 4=MUMPS 5=SOUNDEX 6=TRIGGER 7=BULLETIN
- G A:'N W !,"WANT TO ",DCOND," WHOLE FILE BY THIS FIELD" D YN^DICN G X:%<1 I %=1 S DH=N G A
- F DH=N-1:-1 Q:'DH S %=1 W !,"WANT TO "_DCOND_" "_$P(^DD(J(N-DH),0),U,1)_" BY THIS FIELD" D YN^DICN G X:%<1,A:%=1
- A S %=1,DIK="" I Y=1!(Y=4) W !,"WANT ",DCOND," TO BE USED FOR LOOKUP AS WELL AS FOR SORTING" D YN^DICN G X:%<1 I %=2 S DIK="A"
- I Y=2 S DIKWIC="(,.?! '-/&:;)" W !,"PARSE ON THE FOLLOWING CHARACTERS: ",DIKWIC,"//" R X:DTIME S:'$T DTOUT=1 G Q:X=U!'$T S:X]"" DIKWIC=X I X["""" S X="?"
- I Y=2,X]"",X'?1P.P!(X?1"?"."?") W !?5,"Please enter the punctuation marks (except quotes) which will be used to ",!?5,"separate the words in this field." G A
- I Y=3 F I=0:0 S I=$O(^DD(J(N-DH),.01,1,I)) G X:I=""!(DL=.01&'DH) I $D(^(I,0)) S DE=$P(^(0),U,2) G CKF:DE?1U.UN
- I Y=4 D M G:$D(DIRUT) Q S:$D(XX(1)) X(1)=XX(1) S:$D(XX(2)) X(2)=XX(2) K XX
- ;GFT MODIFIED NEXT 6 LINES: INDEX MUST BE UPPER-CASE, START WITH PROPER LETTER, AND NOT BE A DUPLICATE
- N DISTART S DISTART=$S(Y-1&(Y-3)!(DA-.01):67,1:66) ;START WITH "B" OR "C"
- IX F X=DISTART:1 S DE=DIK_$C(X) D I $D(DE) G CKF:DUZ(0)'="@" W !,"INDEX: ",DE,"// " R X:DTIME S:'$T DTOUT=1 S:X]"" DE=X G Q:X[U!'$T D G IX:'$D(DE) Q
- .I $D(^DD(J(N-DH),0,"IX",DE))!$D(^DD("IX","BB",J(N-DH),DE)) K DE Q ;SUBROUTINE CALLED TWICE! KILLS 'DE' IF NO GOOD CAN'T ALREADY EXIST
- .I DE'?1U.UN K DE Q
- .I DIK="A" K:DE'?1"A".E DE Q
- .E I DE?1"A".E K DE
- CKF W !,"..." S DREF=Y
- D ^DICE0 W ! D DSC,DIEZ^DIU0,F G Q
- ;
- F S X=^DD(J(N),DA,1,DQ,1),%=1 I DREF=1!(DREF=4)!$D(^("CONDITION")),@("$O("_DIU_"0))>0") D G:'% F
- . W !!,"DO YOU WANT TO CROSS-REFERENCE EXISTING DATA NOW"
- . S %=0 D YN^DICN Q:%
- . W !!,"Enter 'YES' to execute the new set logic now."
- . W !,"Otherwise, enter 'NO'."
- D DD^DICD:%=1 I $D(DDA),DDA="" S DDA="N" D XA^DICATTA
- K % Q
- ;
- M N Y,DQ
- F I=1,2 S DIR(0)=".1,"_I D Q:$D(DTOUT)!$D(DUOUT)
- . F D ^DIR Q:$D(DTOUT)!$D(DUOUT) I X]"" S XX(I)=X Q
- K DIR Q
- ;
- Q D QQ K DE,DB,DREF,DCOND,DICOMPX,I,DQ,DA,DH,DIK,DIC,N,DL,J,X,Y,A,XX Q
- ;
- EDT ;
- I DH(DQ,4) D R^DICD Q:'$D(DICD) S DQ=DICD
- I $D(DDA) S DDA="E" D XS^DICATTA
- W ! F A0=1:1:2 S A1(A0)=^DD(J(N),DA,1,DQ,A0)
- S A0=DI,DR=$S(DUZ(0)="@"&($P(DH(DQ),U,3)["MUMPS"):"1:3;10;666",DUZ(0)="@"&($P(DH(DQ),U,3)]""):"3;10;666",1:"3;10") D ED ;NOREINDEX PATCH 167
- F A0=1:1:2 I A1(A0)'=^DD(J(N),DA,1,DQ,A0) S ^("DT")=DT,DREF=4 D DIEZ^DIU0,KOLD^DICD,F,D^DICD Q
- K A0,A1 I $D(DDA) D XA^DICATTA
- Q
- ;
- ED S:$D(DA(1))#2 A1(3)=DA(1) S DICD=DL,DA(2)=A0,DA(1)=DA,DA=DQ,DIE="^DD("_DA(2)_","_DA(1)_",1," D DIE K DIE,DR
- S DL=DICD,DQ=DA,DA=DA(1) S:$D(A1(3)) DA(1)=A1(3) K DICD Q
- ;
- DIE N J,N,DI,A1 D ^DIE Q
- DSC S A0=J(N),DR="3;4///"_DT_";10" D ED K A0 Q
- ;
- NQ I X'[U D HLP G N
- X W $C(7),"??" G Q
- ;
- QQ K ^UTILITY("DICE",$J),DBOOL,DLAY,DQI,DICOMPX,DIN,DCNEW,DFLD,DREF,DENEW,DLOC,DSUB,DHI,DOLD,DNEW,%X,V
- Q
- HLP ; Traditional Cross Reference Help - Called From NQ
- ; SF-CIOFO/SO 1/12/00
- W !
- W !,?5,"You may use the number shown if you are the custodian of the file this"
- W !,?5,"cross-reference is in. If you are not the custodian of the file, you"
- W !,?5,"should select a number that corresponds with a numberspace for which you"
- W !,?5,"have custody. Questions regarding numberspace custody may be referred"
- W !,?5,"to: DBA@DOMAIN.EXT",!
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICE 4258 printed Feb 19, 2025@00:12:07 Page 2
- DICE ;SFISC/GFT-CREATE AN XREF ;17DEC2010
- +1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
- +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 %=2
- SET DCOND="CROSS-REFERENCE"
- WRITE !,"WANT TO CREATE A NEW ",DCOND," FOR THIS FIELD"
- DO YN^DICN
- if %-1
- GOTO Q
- N FOR DQ=1:1
- if '$DATA(^DD(DI,DA,1,DQ))
- QUIT
- +1 WRITE !,"CROSS-REFERENCE NUMBER: "_DQ_"// "
- READ X:DTIME
- if '$TEST
- SET DTOUT=1
- if '$TEST
- GOTO Q
- if X=""
- SET X=DQ
- if X'?.N!'X
- GOTO NQ
- if $DATA(^(X))
- GOTO X
- SET DQ=X
- +2 SET DH=0
- SET DIC="^DOPT(""DICR"","
- SET DIC(0)="EQA"
- SET DIC("B")=1
- SET DIC("S")="I 1"_$PIECE(",Y-4",U,DUZ(0)'="@")_$PIECE(",Y-5",U,$DATA(^DD(J(N),0,"LOOK"))>0)_$PIECE(",Y-7",U,'$DATA(^XMB(3.6)))
- if $PIECE($GET(^DD($$FNO^DILIBF(J(N)),0,"DI")),U)="Y"
- SET DIC("S")=DIC("S")_",Y-4,Y-6,Y-7"
- +3 ;1=REGULAR 2=KWIC 3=MNEMONIC 4=MUMPS 5=SOUNDEX 6=TRIGGER 7=BULLETIN
- DO ^DIC
- KILL DIC
- DO QQ
- SET Y=+Y
- if Y<0
- GOTO X
- if Y=6
- GOTO 6^DICE0
- if Y=7
- GOTO ^DICE7
- +4 if 'N
- GOTO A
- WRITE !,"WANT TO ",DCOND," WHOLE FILE BY THIS FIELD"
- DO YN^DICN
- if %<1
- GOTO X
- IF %=1
- SET DH=N
- GOTO A
- +5 FOR DH=N-1:-1
- if 'DH
- QUIT
- SET %=1
- WRITE !,"WANT TO "_DCOND_" "_$PIECE(^DD(J(N-DH),0),U,1)_" BY THIS FIELD"
- DO YN^DICN
- if %<1
- GOTO X
- if %=1
- GOTO A
- A SET %=1
- SET DIK=""
- IF Y=1!(Y=4)
- WRITE !,"WANT ",DCOND," TO BE USED FOR LOOKUP AS WELL AS FOR SORTING"
- DO YN^DICN
- if %<1
- GOTO X
- IF %=2
- SET DIK="A"
- +1 IF Y=2
- SET DIKWIC="(,.?! '-/&:;)"
- WRITE !,"PARSE ON THE FOLLOWING CHARACTERS: ",DIKWIC,"//"
- READ X:DTIME
- if '$TEST
- SET DTOUT=1
- if X=U!'$TEST
- GOTO Q
- if X]""
- SET DIKWIC=X
- IF X[""""
- SET X="?"
- +2 IF Y=2
- IF X]""
- IF X'?1P.P!(X?1"?"."?")
- WRITE !?5,"Please enter the punctuation marks (except quotes) which will be used to ",!?5,"separate the words in this field."
- GOTO A
- +3 IF Y=3
- FOR I=0:0
- SET I=$ORDER(^DD(J(N-DH),.01,1,I))
- if I=""!(DL=.01&'DH)
- GOTO X
- IF $DATA(^(I,0))
- SET DE=$PIECE(^(0),U,2)
- if DE?1U.UN
- GOTO CKF
- +4 IF Y=4
- DO M
- if $DATA(DIRUT)
- GOTO Q
- if $DATA(XX(1))
- SET X(1)=XX(1)
- if $DATA(XX(2))
- SET X(2)=XX(2)
- KILL XX
- +5 ;GFT MODIFIED NEXT 6 LINES: INDEX MUST BE UPPER-CASE, START WITH PROPER LETTER, AND NOT BE A DUPLICATE
- +6 ;START WITH "B" OR "C"
- NEW DISTART
- SET DISTART=$SELECT(Y-1&(Y-3)!(DA-.01):67,1:66)
- IX FOR X=DISTART:1
- SET DE=DIK_$CHAR(X)
- Begin DoDot:1
- +1 ;SUBROUTINE CALLED TWICE! KILLS 'DE' IF NO GOOD CAN'T ALREADY EXIST
- IF $DATA(^DD(J(N-DH),0,"IX",DE))!$DATA(^DD("IX","BB",J(N-DH),DE))
- KILL DE
- QUIT
- +2 IF DE'?1U.UN
- KILL DE
- QUIT
- +3 IF DIK="A"
- if DE'?1"A".E
- KILL DE
- QUIT
- +4 IF '$TEST
- IF DE?1"A".E
- KILL DE
- End DoDot:1
- IF $DATA(DE)
- if DUZ(0)'="@"
- GOTO CKF
- WRITE !,"INDEX: ",DE,"// "
- READ X:DTIME
- if '$TEST
- SET DTOUT=1
- if X]""
- SET DE=X
- if X[U!'$TEST
- GOTO Q
- Begin DoDot:1
- End DoDot:1
- if '$DATA(DE)
- GOTO IX
- QUIT
- CKF WRITE !,"..."
- SET DREF=Y
- +1 DO ^DICE0
- WRITE !
- DO DSC
- DO DIEZ^DIU0
- DO F
- GOTO Q
- +2 ;
- F SET X=^DD(J(N),DA,1,DQ,1)
- SET %=1
- IF DREF=1!(DREF=4)!$DATA(^("CONDITION"))
- IF @("$O("_DIU_"0))>0")
- Begin DoDot:1
- +1 WRITE !!,"DO YOU WANT TO CROSS-REFERENCE EXISTING DATA NOW"
- +2 SET %=0
- DO YN^DICN
- if %
- QUIT
- +3 WRITE !!,"Enter 'YES' to execute the new set logic now."
- +4 WRITE !,"Otherwise, enter 'NO'."
- End DoDot:1
- if '%
- GOTO F
- +5 if %=1
- DO DD^DICD
- IF $DATA(DDA)
- IF DDA=""
- SET DDA="N"
- DO XA^DICATTA
- +6 KILL %
- QUIT
- +7 ;
- M NEW Y,DQ
- +1 FOR I=1,2
- SET DIR(0)=".1,"_I
- Begin DoDot:1
- +2 FOR
- DO ^DIR
- if $DATA(DTOUT)!$DATA(DUOUT)
- QUIT
- IF X]""
- SET XX(I)=X
- QUIT
- End DoDot:1
- if $DATA(DTOUT)!$DATA(DUOUT)
- QUIT
- +3 KILL DIR
- QUIT
- +4 ;
- Q DO QQ
- KILL DE,DB,DREF,DCOND,DICOMPX,I,DQ,DA,DH,DIK,DIC,N,DL,J,X,Y,A,XX
- QUIT
- +1 ;
- EDT ;
- +1 IF DH(DQ,4)
- DO R^DICD
- if '$DATA(DICD)
- QUIT
- SET DQ=DICD
- +2 IF $DATA(DDA)
- SET DDA="E"
- DO XS^DICATTA
- +3 WRITE !
- FOR A0=1:1:2
- SET A1(A0)=^DD(J(N),DA,1,DQ,A0)
- +4 ;NOREINDEX PATCH 167
- SET A0=DI
- SET DR=$SELECT(DUZ(0)="@"&($PIECE(DH(DQ),U,3)["MUMPS"):"1:3;10;666",DUZ(0)="@"&($PIECE(DH(DQ),U,3)]""):"3;10;666",1:"3;10")
- DO ED
- +5 FOR A0=1:1:2
- IF A1(A0)'=^DD(J(N),DA,1,DQ,A0)
- SET ^("DT")=DT
- SET DREF=4
- DO DIEZ^DIU0
- DO KOLD^DICD
- DO F
- DO D^DICD
- QUIT
- +6 KILL A0,A1
- IF $DATA(DDA)
- DO XA^DICATTA
- +7 QUIT
- +8 ;
- ED if $DATA(DA(1))#2
- SET A1(3)=DA(1)
- SET DICD=DL
- SET DA(2)=A0
- SET DA(1)=DA
- SET DA=DQ
- SET DIE="^DD("_DA(2)_","_DA(1)_",1,"
- DO DIE
- KILL DIE,DR
- +1 SET DL=DICD
- SET DQ=DA
- SET DA=DA(1)
- if $DATA(A1(3))
- SET DA(1)=A1(3)
- KILL DICD
- QUIT
- +2 ;
- DIE NEW J,N,DI,A1
- DO ^DIE
- QUIT
- DSC SET A0=J(N)
- SET DR="3;4///"_DT_";10"
- DO ED
- KILL A0
- QUIT
- +1 ;
- NQ IF X'[U
- DO HLP
- GOTO N
- X WRITE $CHAR(7),"??"
- GOTO Q
- +1 ;
- QQ KILL ^UTILITY("DICE",$JOB),DBOOL,DLAY,DQI,DICOMPX,DIN,DCNEW,DFLD,DREF,DENEW,DLOC,DSUB,DHI,DOLD,DNEW,%X,V
- +1 QUIT
- HLP ; Traditional Cross Reference Help - Called From NQ
- +1 ; SF-CIOFO/SO 1/12/00
- +2 WRITE !
- +3 WRITE !,?5,"You may use the number shown if you are the custodian of the file this"
- +4 WRITE !,?5,"cross-reference is in. If you are not the custodian of the file, you"
- +5 WRITE !,?5,"should select a number that corresponds with a numberspace for which you"
- +6 WRITE !,?5,"have custody. Questions regarding numberspace custody may be referred"
- +7 WRITE !,?5,"to: DBA@DOMAIN.EXT",!
- +8 QUIT
