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 Dec 13, 2024@02:45:53 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
