- 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 ;