TIUABBV1 ;BPOIFO/JLTP/EL - Entries for UNAUTHORIZED ABBREVIATIONS ;9/23/2015
;;1.0;TEXT INTEGRATION UTILITIES;**297**;JUN 20, 1997;Build 40
;
; External Reference DBIA#:
; -------------------------
; #10009 - DICN call (Supported)
; #2052 - DID call (Supported)
; #2053 - DIE call (Supported)
; #2055 - DILFD call (Supported)
; #2056 - DIQ call (Supported)
; #10026 - DIR call (Supported)
; #510 - DISV reference (Controlled Subscription)
; #10104 - XLFSTR call (Supported)
;
Q
;
EN ;Manage Unauthorized Abbreviations
N ABBV,ABBVU,ACT,ASK,C,CLS,DA,DESC,DR,EXACT,FLD,FILE,FILENAME
N H1,H2,HLP,I,J,L,L1,L2,L3,L4,L5,MCH,NEW,RESP,RESP1,SEQ,STOP
N TIUINP,TP,TPUN,TRET,TSEQ,TWAIT,X,X1,X2,X3,X4,X5,XX,Y,ZZ
N DIC,DIE,DIR,DIRUT,DUOUT
S TPUN="!@#$%^&*()_-+={}[]|\/:;""'<>?,.~`"
S (FILE,FILENAME,TWAIT)="",STOP=0
S FILE="8927.9",FILENAME=$P(^DIC(FILE,0),U)
S (DIC,DIE)="^TIU("_FILE_","
S TWAIT=300
I $G(DTIME)'="" S TWAIT=DTIME
;
ENTER ;
I $G(STOP)=1 Q
D HD
K DIC,DIE,TP,ZZ
S (ABBV,ACT,CLS,DA,DESC,DR,MCH,NEW,X,XX,Y)=""
S DIC("A")="Enter Unauthorized Abbreviation: "
D TIUDIC
I $G(Y)<0!($G(Y)="") S STOP=1 G ENTER
I $G(Y)=0 W ! D STOP G ENTER
S DA=$P(Y,U),ABBV=$P(Y,U,2),NEW=$P(Y,U,3),DIE="^TIU("_FILE_","
D RECALL^DILFD(FILE,DA_",",+($G(DUZ)))
I '$G(NEW) D D STOP G ENTER
. S X=Y(0),CLS=$P(X,U,2),MCH=$P(X,U,3),ACT=$P(X,U,4),DESC=$P(X,U,5)
. I $E(CLS)="N" W !!,"The Abbreviation '"_ABBV_"' has a NATIONAL class. Therefore, it cannot be modified.",! Q
. W !!,"Unauthorized Abbreviation: ",ABBV
. S DR=".03;.04;.05" W !
. L +^TIU(FILE,DA):1 I '$T W *7,!!,"Other user is editing this abbreviation '",ABBV,"'. Try later.",!! Q
. D ^DIE
. L -^TIU(FILE,DA)
. S XX="",XX="STATUS for this Unauthorized Abbreviation '"_ABBV_"' is "
. S XX=XX_$$GETFLD(FILE,SEQ,".04")_" now."
. W !!,XX,!!
S DR=".02///L;.03///1;.04///A"
D ^DIE
W !!,"** New Local '",ABBV,"' has been added. **"
W !,"Abbreviation Exact Match: "_$$GETFLD(FILE,SEQ,".03")
W !,"Status: "_$$GETFLD(FILE,SEQ,".04")
W !!,"Unauthorized Abbreviation: ",ABBV
S DR=".02///^S X=""LOCAL"";.03//^S X=""YES"";.04//^S X=""ACTIVE"";.05"
D ^DIE
S XX="",XX="STATUS for this Unauthorized Abbreviation '"_ABBV_"' is "
S XX=XX_$$GETFLD(FILE,SEQ,".04")_" now."
W !!,XX,!!
D STOP
G ENTER
;
STOP ;
S J="",STOP=0
R !,"Enter <RETURN> to continue or '^' to exit: ",J:TWAIT S:'$T J=U
I $G(J)=U S STOP=1
Q
;
;
HD ; Header for Enter/Edit Unauthorized Abbreviation
S (H1,H2,I,X)=""
S H1="Enter/Edit Unauthorized Abbreviation(s)"
F I=1:1:$L(H1) S H2=H2_"="
I $G(IOM)="" S IOM=80
S X=(IOM-$L(H1))/2
W @IOF,!! F I=1:1:X W " "
W H1,! F I=1:1:X W " "
W H2
Q
;
TIUDIC ;
S (ASK,C,I,RESP,SEQ,TP,X,XX,Y)=""
W !!,DIC("A") R X:TWAIT S:'$T X=U I U[X S Y=-1 Q
I X=" ",$D(^DISV(DUZ,"^TIU("_FILE_",")) D I $G(Y)="" S Y=-1 Q
. S Y=$G(^DISV(DUZ,"^TIU("_FILE_","))
. I $G(Y)="" Q
. S X=$P($G(^TIU(FILE,Y,0)),U) W X
W !
I X="?"!(X="??") D DICHLP S Y=0 Q
S TIUINP=$$GET1^DID(FILE,.01,"","INPUT TRANSFORM")
I $G(TIUINP)]"" X TIUINP
I '$D(X)#2 S Y=0 Q
K TP S RESP=X,C=0,TP(C)=0
D SEARCH(RESP,.TP)
W !
I $G(C)'>0 S ASK=$$ASK(RESP) D Q
. W !
. I '$G(ASK) S Y=0
. E S Y=ASK,SEQ=$P(ASK,U),Y(0)=$G(^TIU(FILE,SEQ,0))
K DIR S DIR("T")=TWAIT
S DIR(0)="NO^1:"_C
I $P(TP(0),U)=1 S DIR("A")="For EDIT Unauthorized Abbreviation, Select number"
E S DIR("A")="For EDIT or CREATE Unauthorized Abbreviation, Select number"
F I=1:1:C S DIR("A",I)=I_") "_$E($P(TP(I),U,3),1,75)
S DIR("A",C+1)=""
D ^DIR
I $D(DUOUT) W !!,"No action has been taken !!",! S Y=0 Q
I TP(0)=1,X="" W !!,"Nothing is selected !!",! S Y=0 Q
I Y="" W !!,"Nothing is selected !!",! S Y=0 Q
I $G(Y(0))="NO" W !!,"No action has been taken !!",! S Y=0 Q
I $G(Y(0))="YES"!($E($P(TP(X),U,3),1,3)="** ") D Q
. I $P(TP(0),U,2)'="" D I $G(STOP)=1 Q
. . S XX="",XX=$P(TP(0),U,2)
. . W !!,"The EXACT-MATCH for the following active abbreviation is set to """_"NO"_""""_": "
. . W !," "_XX
. . W !,"As a result, this abbreviation '"_RESP_"' will be flagged as unauthorized.",!
. . K DIR S DIR("T")=TWAIT
. . S DIR(0)="Y"
. . S DIR("A")="Do you still want to add '"_RESP_"'"
. . S DIR("B")="NO"
. . D ^DIR
. . I $D(DIRUT)!('Y) W !!,"No action has been taken !!",! S Y=0,STOP=1 Q
. S DIC="^TIU(FILE,",DIC(0)="",X=RESP D FILE^DICN
. S SEQ=$P(Y,U),Y(0)=$G(^TIU(FILE,SEQ,0))
I $G(Y)'="" S SEQ=$P(TP(Y),U,1),Y=$P(TP(Y),U,1,2),Y(0)=$G(^TIU(FILE,SEQ,0)) Q
Q
;
SEARCH(RESP,TP) ; Search for matching ABBREVIATION
S (ABBV,ABBVU,C,EXACT,L1,L2,L3,L4,L5,RESP1)=""
S (SEQ,X1,X2,X3,X4,X5,XX)=""
S (C,EXACT,L1,L2,L3,L4,L5)=0 S TP(0)=EXACT
S RESP1=$$UP^XLFSTR(RESP)
S ABBV=""
S10 S ABBV=$O(^TIU(FILE,"B",ABBV)) G:$G(ABBV)="" SOUT
S ABBVU=$$UP^XLFSTR(ABBV)
I $TR(ABBVU,TPUN)'=$TR(RESP1,TPUN) G S10
I ABBV=RESP S EXACT=1,$P(TP(0),U)=EXACT
S SEQ=""
S20 S SEQ=$O(^TIU(FILE,"B",ABBV,SEQ)) G:$G(SEQ)="" S10
S XX="",XX=$G(^TIU(FILE,SEQ,0))
I $G(XX)="" G S20
S C=C+1
S (X1,X2,X3,X4,X5)=""
S X1=$P(XX,U),X2=$P(XX,U,2),X3=$P(XX,U,3),X4=$P(XX,U,4),X5=$P(XX,U,5)
I $G(X3)=0,($G(X4)="A") D
. I $P(TP(0),U,2)'="" S $P(TP(0),U,2)=$P(TP(0),U,2)_", "_X1
. E S $P(TP(0),U,2)=X1
I $L(X1)>L1 S L1=$L(X1)
S X2=$$GETFLD(FILE,SEQ,".02"),X2="CLASS="_X2
I $L(X2)>L2 S L2=$L(X2)
S X3=$$GETFLD(FILE,SEQ,".03"),X3="EXACT-MATCH="_X3
I $L(X3)>L3 S L3=$L(X3)
S X4=$$GETFLD(FILE,SEQ,".04"),X4="STATUS="_X4
I $L(X4)>L4 S L4=$L(X4)
I $G(X5)'="" S X5="NOTE: "_X5
S TP(C)=SEQ_U_ABBV_U_X1_","_X2_","_X3_","_X4_","_X5
G S20
;
SOUT ; OUT from SEARCH
I C'>0 Q
S (I,J,L,X1,X2,X3,X4,X5,XX)=""
S I=0
S30 S I=$O(TP(I)) G:$G(I)="" S40
S (J,L,X1,X2,X3,X4,X5,XX)=""
S XX=$P(TP(I),U,3)
S X1=$P(XX,",",1),L=L1-$L(X1) I L>0 F J=1:1:L S X1=X1_" "
S X2=$P(XX,",",2),L=L2-$L(X2) I L>0 F J=1:1:L S X2=X2_" "
S X3=$P(XX,",",3),L=L3-$L(X3) I L>0 F J=1:1:L S X3=X3_" "
S X4=$P(XX,",",4),L=L4-$L(X4) I L>0 F J=1:1:L S X4=X4_" "
S X5=$P(XX,",",5)
S $P(TP(I),U,3)=X1_" : "_X3_" "_X4_" "_X2
G S30
;
S40 I '$D(^TIU(8927.9,"B",RESP)) D Q
. S SEQ=$P(^TIU(FILE,0),U,3),SEQ=$G(SEQ)+1,C=C+1
. S TP(C)=SEQ_U_RESP_U_"** Create a new entry '"_RESP_"' as new Unauthorized Abbreviation."
Q
;
ASK(RESP) ; Ask if adding a new entry
K DIC,DIR
S DIR("T")=TWAIT
S DIR(0)="Y",DIR("A")="Are you adding '"_RESP_"' as a new "_FILENAME
S DIR("B")="No" D ^DIR Q:$D(DIRUT)!('Y) 0
S DIC="^TIU(FILE,",DIC(0)="",X=RESP D FILE^DICN
Q Y
;
GETFLD(FILE,SEQ,FLD) ; Get field value
S (TRET,TSEQ)=""
S TSEQ=SEQ_","
D GETS^DIQ(FILE,TSEQ,FLD,"E","ZZ")
S TRET=$G(ZZ(FILE,TSEQ,FLD,"E"))
Q $G(TRET)
;
DICHLP ; Help for lookup
K DIR S (HLP,C,J,X1,X2,X3,X4,X5,ABBV,SEQ)=""
S DIR("T")=TWAIT
W !! D HELP^DIE(8927.9,"",.01,"??","HLP")
S HLP=HLP("DIHELP") F HLP=3:1:HLP("DIHELP") W !,HLP("DIHELP",HLP)
S DIR(0)="Y"
s DIR("A")="Do you want the list of Unauthorized Abbreviation(s)"
S DIR("B")="Yes" W !! D ^DIR Q:$D(DIRUT)!('Y)
S ABBV="",C=0 W !
H10 S ABBV=$O(^TIU(FILE,"B",ABBV)) Q:$G(ABBV)=""
S SEQ=0
H20 S SEQ=$O(^TIU(FILE,"B",ABBV,SEQ)) G:$G(SEQ)="" H10
S XX="",XX=$G(^TIU(FILE,SEQ,0))
I $G(XX)="" G H20
S C=C+1
I C#20'>0 R !!,"Enter <RETURN> to continue or '^' to exit: ",J:DIR("T") S:'$T J=U Q:$G(J)=U
S (X1,X2,X3,X4,X5)=""
S X1=$P(XX,U),X2=$P(XX,U,2),X3=$P(XX,U,3)
S X4=$P(XX,U,4),X5=$P(XX,U,5)
S X1=X1_" : "
S X2=$$GETFLD(FILE,SEQ,".02"),X2="CLASS="_X2
S X3=$$GETFLD(FILE,SEQ,".03"),X3="EXACT-MATCH="_X3_" "
S X4=$$GETFLD(FILE,SEQ,".04"),X4="STATUS="_X4_" "
S XX=X1_X3_X4_X2
W !,C,")",?6,$E(XX,1,74)
G H20
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUABBV1 7684 printed Jan 18, 2025@03:39:50 Page 2
TIUABBV1 ;BPOIFO/JLTP/EL - Entries for UNAUTHORIZED ABBREVIATIONS ;9/23/2015
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**297**;JUN 20, 1997;Build 40
+2 ;
+3 ; External Reference DBIA#:
+4 ; -------------------------
+5 ; #10009 - DICN call (Supported)
+6 ; #2052 - DID call (Supported)
+7 ; #2053 - DIE call (Supported)
+8 ; #2055 - DILFD call (Supported)
+9 ; #2056 - DIQ call (Supported)
+10 ; #10026 - DIR call (Supported)
+11 ; #510 - DISV reference (Controlled Subscription)
+12 ; #10104 - XLFSTR call (Supported)
+13 ;
+14 QUIT
+15 ;
EN ;Manage Unauthorized Abbreviations
+1 NEW ABBV,ABBVU,ACT,ASK,C,CLS,DA,DESC,DR,EXACT,FLD,FILE,FILENAME
+2 NEW H1,H2,HLP,I,J,L,L1,L2,L3,L4,L5,MCH,NEW,RESP,RESP1,SEQ,STOP
+3 NEW TIUINP,TP,TPUN,TRET,TSEQ,TWAIT,X,X1,X2,X3,X4,X5,XX,Y,ZZ
+4 NEW DIC,DIE,DIR,DIRUT,DUOUT
+5 SET TPUN="!@#$%^&*()_-+={}[]|\/:;""'<>?,.~`"
+6 SET (FILE,FILENAME,TWAIT)=""
SET STOP=0
+7 SET FILE="8927.9"
SET FILENAME=$PIECE(^DIC(FILE,0),U)
+8 SET (DIC,DIE)="^TIU("_FILE_","
+9 SET TWAIT=300
+10 IF $GET(DTIME)'=""
SET TWAIT=DTIME
+11 ;
ENTER ;
+1 IF $GET(STOP)=1
QUIT
+2 DO HD
+3 KILL DIC,DIE,TP,ZZ
+4 SET (ABBV,ACT,CLS,DA,DESC,DR,MCH,NEW,X,XX,Y)=""
+5 SET DIC("A")="Enter Unauthorized Abbreviation: "
+6 DO TIUDIC
+7 IF $GET(Y)<0!($GET(Y)="")
SET STOP=1
GOTO ENTER
+8 IF $GET(Y)=0
WRITE !
DO STOP
GOTO ENTER
+9 SET DA=$PIECE(Y,U)
SET ABBV=$PIECE(Y,U,2)
SET NEW=$PIECE(Y,U,3)
SET DIE="^TIU("_FILE_","
+10 DO RECALL^DILFD(FILE,DA_",",+($GET(DUZ)))
+11 IF '$GET(NEW)
Begin DoDot:1
+12 SET X=Y(0)
SET CLS=$PIECE(X,U,2)
SET MCH=$PIECE(X,U,3)
SET ACT=$PIECE(X,U,4)
SET DESC=$PIECE(X,U,5)
+13 IF $EXTRACT(CLS)="N"
WRITE !!,"The Abbreviation '"_ABBV_"' has a NATIONAL class. Therefore, it cannot be modified.",!
QUIT
+14 WRITE !!,"Unauthorized Abbreviation: ",ABBV
+15 SET DR=".03;.04;.05"
WRITE !
+16 LOCK +^TIU(FILE,DA):1
IF '$TEST
WRITE *7,!!,"Other user is editing this abbreviation '",ABBV,"'. Try later.",!!
QUIT
+17 DO ^DIE
+18 LOCK -^TIU(FILE,DA)
+19 SET XX=""
SET XX="STATUS for this Unauthorized Abbreviation '"_ABBV_"' is "
+20 SET XX=XX_$$GETFLD(FILE,SEQ,".04")_" now."
+21 WRITE !!,XX,!!
End DoDot:1
DO STOP
GOTO ENTER
+22 SET DR=".02///L;.03///1;.04///A"
+23 DO ^DIE
+24 WRITE !!,"** New Local '",ABBV,"' has been added. **"
+25 WRITE !,"Abbreviation Exact Match: "_$$GETFLD(FILE,SEQ,".03")
+26 WRITE !,"Status: "_$$GETFLD(FILE,SEQ,".04")
+27 WRITE !!,"Unauthorized Abbreviation: ",ABBV
+28 SET DR=".02///^S X=""LOCAL"";.03//^S X=""YES"";.04//^S X=""ACTIVE"";.05"
+29 DO ^DIE
+30 SET XX=""
SET XX="STATUS for this Unauthorized Abbreviation '"_ABBV_"' is "
+31 SET XX=XX_$$GETFLD(FILE,SEQ,".04")_" now."
+32 WRITE !!,XX,!!
+33 DO STOP
+34 GOTO ENTER
+35 ;
STOP ;
+1 SET J=""
SET STOP=0
+2 READ !,"Enter <RETURN> to continue or '^' to exit: ",J:TWAIT
if '$TEST
SET J=U
+3 IF $GET(J)=U
SET STOP=1
+4 QUIT
+5 ;
+6 ;
HD ; Header for Enter/Edit Unauthorized Abbreviation
+1 SET (H1,H2,I,X)=""
+2 SET H1="Enter/Edit Unauthorized Abbreviation(s)"
+3 FOR I=1:1:$LENGTH(H1)
SET H2=H2_"="
+4 IF $GET(IOM)=""
SET IOM=80
+5 SET X=(IOM-$LENGTH(H1))/2
+6 WRITE @IOF,!!
FOR I=1:1:X
WRITE " "
+7 WRITE H1,!
FOR I=1:1:X
WRITE " "
+8 WRITE H2
+9 QUIT
+10 ;
TIUDIC ;
+1 SET (ASK,C,I,RESP,SEQ,TP,X,XX,Y)=""
+2 WRITE !!,DIC("A")
READ X:TWAIT
if '$TEST
SET X=U
IF U[X
SET Y=-1
QUIT
+3 IF X=" "
IF $DATA(^DISV(DUZ,"^TIU("_FILE_","))
Begin DoDot:1
+4 SET Y=$GET(^DISV(DUZ,"^TIU("_FILE_","))
+5 IF $GET(Y)=""
QUIT
+6 SET X=$PIECE($GET(^TIU(FILE,Y,0)),U)
WRITE X
End DoDot:1
IF $GET(Y)=""
SET Y=-1
QUIT
+7 WRITE !
+8 IF X="?"!(X="??")
DO DICHLP
SET Y=0
QUIT
+9 SET TIUINP=$$GET1^DID(FILE,.01,"","INPUT TRANSFORM")
+10 IF $GET(TIUINP)]""
XECUTE TIUINP
+11 IF '$DATA(X)#2
SET Y=0
QUIT
+12 KILL TP
SET RESP=X
SET C=0
SET TP(C)=0
+13 DO SEARCH(RESP,.TP)
+14 WRITE !
+15 IF $GET(C)'>0
SET ASK=$$ASK(RESP)
Begin DoDot:1
+16 WRITE !
+17 IF '$GET(ASK)
SET Y=0
+18 IF '$TEST
SET Y=ASK
SET SEQ=$PIECE(ASK,U)
SET Y(0)=$GET(^TIU(FILE,SEQ,0))
End DoDot:1
QUIT
+19 KILL DIR
SET DIR("T")=TWAIT
+20 SET DIR(0)="NO^1:"_C
+21 IF $PIECE(TP(0),U)=1
SET DIR("A")="For EDIT Unauthorized Abbreviation, Select number"
+22 IF '$TEST
SET DIR("A")="For EDIT or CREATE Unauthorized Abbreviation, Select number"
+23 FOR I=1:1:C
SET DIR("A",I)=I_") "_$EXTRACT($PIECE(TP(I),U,3),1,75)
+24 SET DIR("A",C+1)=""
+25 DO ^DIR
+26 IF $DATA(DUOUT)
WRITE !!,"No action has been taken !!",!
SET Y=0
QUIT
+27 IF TP(0)=1
IF X=""
WRITE !!,"Nothing is selected !!",!
SET Y=0
QUIT
+28 IF Y=""
WRITE !!,"Nothing is selected !!",!
SET Y=0
QUIT
+29 IF $GET(Y(0))="NO"
WRITE !!,"No action has been taken !!",!
SET Y=0
QUIT
+30 IF $GET(Y(0))="YES"!($EXTRACT($PIECE(TP(X),U,3),1,3)="** ")
Begin DoDot:1
+31 IF $PIECE(TP(0),U,2)'=""
Begin DoDot:2
+32 SET XX=""
SET XX=$PIECE(TP(0),U,2)
+33 WRITE !!,"The EXACT-MATCH for the following active abbreviation is set to """_"NO"_""""_": "
+34 WRITE !," "_XX
+35 WRITE !,"As a result, this abbreviation '"_RESP_"' will be flagged as unauthorized.",!
+36 KILL DIR
SET DIR("T")=TWAIT
+37 SET DIR(0)="Y"
+38 SET DIR("A")="Do you still want to add '"_RESP_"'"
+39 SET DIR("B")="NO"
+40 DO ^DIR
+41 IF $DATA(DIRUT)!('Y)
WRITE !!,"No action has been taken !!",!
SET Y=0
SET STOP=1
QUIT
End DoDot:2
IF $GET(STOP)=1
QUIT
+42 SET DIC="^TIU(FILE,"
SET DIC(0)=""
SET X=RESP
DO FILE^DICN
+43 SET SEQ=$PIECE(Y,U)
SET Y(0)=$GET(^TIU(FILE,SEQ,0))
End DoDot:1
QUIT
+44 IF $GET(Y)'=""
SET SEQ=$PIECE(TP(Y),U,1)
SET Y=$PIECE(TP(Y),U,1,2)
SET Y(0)=$GET(^TIU(FILE,SEQ,0))
QUIT
+45 QUIT
+46 ;
SEARCH(RESP,TP) ; Search for matching ABBREVIATION
+1 SET (ABBV,ABBVU,C,EXACT,L1,L2,L3,L4,L5,RESP1)=""
+2 SET (SEQ,X1,X2,X3,X4,X5,XX)=""
+3 SET (C,EXACT,L1,L2,L3,L4,L5)=0
SET TP(0)=EXACT
+4 SET RESP1=$$UP^XLFSTR(RESP)
+5 SET ABBV=""
S10 SET ABBV=$ORDER(^TIU(FILE,"B",ABBV))
if $GET(ABBV)=""
GOTO SOUT
+1 SET ABBVU=$$UP^XLFSTR(ABBV)
+2 IF $TRANSLATE(ABBVU,TPUN)'=$TRANSLATE(RESP1,TPUN)
GOTO S10
+3 IF ABBV=RESP
SET EXACT=1
SET $PIECE(TP(0),U)=EXACT
+4 SET SEQ=""
S20 SET SEQ=$ORDER(^TIU(FILE,"B",ABBV,SEQ))
if $GET(SEQ)=""
GOTO S10
+1 SET XX=""
SET XX=$GET(^TIU(FILE,SEQ,0))
+2 IF $GET(XX)=""
GOTO S20
+3 SET C=C+1
+4 SET (X1,X2,X3,X4,X5)=""
+5 SET X1=$PIECE(XX,U)
SET X2=$PIECE(XX,U,2)
SET X3=$PIECE(XX,U,3)
SET X4=$PIECE(XX,U,4)
SET X5=$PIECE(XX,U,5)
+6 IF $GET(X3)=0
IF ($GET(X4)="A")
Begin DoDot:1
+7 IF $PIECE(TP(0),U,2)'=""
SET $PIECE(TP(0),U,2)=$PIECE(TP(0),U,2)_", "_X1
+8 IF '$TEST
SET $PIECE(TP(0),U,2)=X1
End DoDot:1
+9 IF $LENGTH(X1)>L1
SET L1=$LENGTH(X1)
+10 SET X2=$$GETFLD(FILE,SEQ,".02")
SET X2="CLASS="_X2
+11 IF $LENGTH(X2)>L2
SET L2=$LENGTH(X2)
+12 SET X3=$$GETFLD(FILE,SEQ,".03")
SET X3="EXACT-MATCH="_X3
+13 IF $LENGTH(X3)>L3
SET L3=$LENGTH(X3)
+14 SET X4=$$GETFLD(FILE,SEQ,".04")
SET X4="STATUS="_X4
+15 IF $LENGTH(X4)>L4
SET L4=$LENGTH(X4)
+16 IF $GET(X5)'=""
SET X5="NOTE: "_X5
+17 SET TP(C)=SEQ_U_ABBV_U_X1_","_X2_","_X3_","_X4_","_X5
+18 GOTO S20
+19 ;
SOUT ; OUT from SEARCH
+1 IF C'>0
QUIT
+2 SET (I,J,L,X1,X2,X3,X4,X5,XX)=""
+3 SET I=0
S30 SET I=$ORDER(TP(I))
if $GET(I)=""
GOTO S40
+1 SET (J,L,X1,X2,X3,X4,X5,XX)=""
+2 SET XX=$PIECE(TP(I),U,3)
+3 SET X1=$PIECE(XX,",",1)
SET L=L1-$LENGTH(X1)
IF L>0
FOR J=1:1:L
SET X1=X1_" "
+4 SET X2=$PIECE(XX,",",2)
SET L=L2-$LENGTH(X2)
IF L>0
FOR J=1:1:L
SET X2=X2_" "
+5 SET X3=$PIECE(XX,",",3)
SET L=L3-$LENGTH(X3)
IF L>0
FOR J=1:1:L
SET X3=X3_" "
+6 SET X4=$PIECE(XX,",",4)
SET L=L4-$LENGTH(X4)
IF L>0
FOR J=1:1:L
SET X4=X4_" "
+7 SET X5=$PIECE(XX,",",5)
+8 SET $PIECE(TP(I),U,3)=X1_" : "_X3_" "_X4_" "_X2
+9 GOTO S30
+10 ;
S40 IF '$DATA(^TIU(8927.9,"B",RESP))
Begin DoDot:1
+1 SET SEQ=$PIECE(^TIU(FILE,0),U,3)
SET SEQ=$GET(SEQ)+1
SET C=C+1
+2 SET TP(C)=SEQ_U_RESP_U_"** Create a new entry '"_RESP_"' as new Unauthorized Abbreviation."
End DoDot:1
QUIT
+3 QUIT
+4 ;
ASK(RESP) ; Ask if adding a new entry
+1 KILL DIC,DIR
+2 SET DIR("T")=TWAIT
+3 SET DIR(0)="Y"
SET DIR("A")="Are you adding '"_RESP_"' as a new "_FILENAME
+4 SET DIR("B")="No"
DO ^DIR
if $DATA(DIRUT)!('Y)
QUIT 0
+5 SET DIC="^TIU(FILE,"
SET DIC(0)=""
SET X=RESP
DO FILE^DICN
+6 QUIT Y
+7 ;
GETFLD(FILE,SEQ,FLD) ; Get field value
+1 SET (TRET,TSEQ)=""
+2 SET TSEQ=SEQ_","
+3 DO GETS^DIQ(FILE,TSEQ,FLD,"E","ZZ")
+4 SET TRET=$GET(ZZ(FILE,TSEQ,FLD,"E"))
+5 QUIT $GET(TRET)
+6 ;
DICHLP ; Help for lookup
+1 KILL DIR
SET (HLP,C,J,X1,X2,X3,X4,X5,ABBV,SEQ)=""
+2 SET DIR("T")=TWAIT
+3 WRITE !!
DO HELP^DIE(8927.9,"",.01,"??","HLP")
+4 SET HLP=HLP("DIHELP")
FOR HLP=3:1:HLP("DIHELP")
WRITE !,HLP("DIHELP",HLP)
+5 SET DIR(0)="Y"
+6 SET DIR("A")="Do you want the list of Unauthorized Abbreviation(s)"
+7 SET DIR("B")="Yes"
WRITE !!
DO ^DIR
if $DATA(DIRUT)!('Y)
QUIT
+8 SET ABBV=""
SET C=0
WRITE !
H10 SET ABBV=$ORDER(^TIU(FILE,"B",ABBV))
if $GET(ABBV)=""
QUIT
+1 SET SEQ=0
H20 SET SEQ=$ORDER(^TIU(FILE,"B",ABBV,SEQ))
if $GET(SEQ)=""
GOTO H10
+1 SET XX=""
SET XX=$GET(^TIU(FILE,SEQ,0))
+2 IF $GET(XX)=""
GOTO H20
+3 SET C=C+1
+4 IF C#20'>0
READ !!,"Enter <RETURN> to continue or '^' to exit: ",J:DIR("T")
if '$TEST
SET J=U
if $GET(J)=U
QUIT
+5 SET (X1,X2,X3,X4,X5)=""
+6 SET X1=$PIECE(XX,U)
SET X2=$PIECE(XX,U,2)
SET X3=$PIECE(XX,U,3)
+7 SET X4=$PIECE(XX,U,4)
SET X5=$PIECE(XX,U,5)
+8 SET X1=X1_" : "
+9 SET X2=$$GETFLD(FILE,SEQ,".02")
SET X2="CLASS="_X2
+10 SET X3=$$GETFLD(FILE,SEQ,".03")
SET X3="EXACT-MATCH="_X3_" "
+11 SET X4=$$GETFLD(FILE,SEQ,".04")
SET X4="STATUS="_X4_" "
+12 SET XX=X1_X3_X4_X2
+13 WRITE !,C,")",?6,$EXTRACT(XX,1,74)
+14 GOTO H20
+15 ;
