Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: TIUABBV1

TIUABBV1.m

Go to the documentation of this file.
  1. TIUABBV1 ;BPOIFO/JLTP/EL - Entries for UNAUTHORIZED ABBREVIATIONS ;9/23/2015
  1. ;;1.0;TEXT INTEGRATION UTILITIES;**297**;JUN 20, 1997;Build 40
  1. ;
  1. ; External Reference DBIA#:
  1. ; -------------------------
  1. ; #10009 - DICN call (Supported)
  1. ; #2052 - DID call (Supported)
  1. ; #2053 - DIE call (Supported)
  1. ; #2055 - DILFD call (Supported)
  1. ; #2056 - DIQ call (Supported)
  1. ; #10026 - DIR call (Supported)
  1. ; #510 - DISV reference (Controlled Subscription)
  1. ; #10104 - XLFSTR call (Supported)
  1. ;
  1. Q
  1. ;
  1. EN ;Manage Unauthorized Abbreviations
  1. N ABBV,ABBVU,ACT,ASK,C,CLS,DA,DESC,DR,EXACT,FLD,FILE,FILENAME
  1. N H1,H2,HLP,I,J,L,L1,L2,L3,L4,L5,MCH,NEW,RESP,RESP1,SEQ,STOP
  1. N TIUINP,TP,TPUN,TRET,TSEQ,TWAIT,X,X1,X2,X3,X4,X5,XX,Y,ZZ
  1. N DIC,DIE,DIR,DIRUT,DUOUT
  1. S TPUN="!@#$%^&*()_-+={}[]|\/:;""'<>?,.~`"
  1. S (FILE,FILENAME,TWAIT)="",STOP=0
  1. S FILE="8927.9",FILENAME=$P(^DIC(FILE,0),U)
  1. S (DIC,DIE)="^TIU("_FILE_","
  1. S TWAIT=300
  1. I $G(DTIME)'="" S TWAIT=DTIME
  1. ;
  1. ENTER ;
  1. I $G(STOP)=1 Q
  1. D HD
  1. K DIC,DIE,TP,ZZ
  1. S (ABBV,ACT,CLS,DA,DESC,DR,MCH,NEW,X,XX,Y)=""
  1. S DIC("A")="Enter Unauthorized Abbreviation: "
  1. D TIUDIC
  1. I $G(Y)<0!($G(Y)="") S STOP=1 G ENTER
  1. I $G(Y)=0 W ! D STOP G ENTER
  1. S DA=$P(Y,U),ABBV=$P(Y,U,2),NEW=$P(Y,U,3),DIE="^TIU("_FILE_","
  1. D RECALL^DILFD(FILE,DA_",",+($G(DUZ)))
  1. I '$G(NEW) D D STOP G ENTER
  1. . S X=Y(0),CLS=$P(X,U,2),MCH=$P(X,U,3),ACT=$P(X,U,4),DESC=$P(X,U,5)
  1. . I $E(CLS)="N" W !!,"The Abbreviation '"_ABBV_"' has a NATIONAL class. Therefore, it cannot be modified.",! Q
  1. . W !!,"Unauthorized Abbreviation: ",ABBV
  1. . S DR=".03;.04;.05" W !
  1. . L +^TIU(FILE,DA):1 I '$T W *7,!!,"Other user is editing this abbreviation '",ABBV,"'. Try later.",!! Q
  1. . D ^DIE
  1. . L -^TIU(FILE,DA)
  1. . S XX="",XX="STATUS for this Unauthorized Abbreviation '"_ABBV_"' is "
  1. . S XX=XX_$$GETFLD(FILE,SEQ,".04")_" now."
  1. . W !!,XX,!!
  1. S DR=".02///L;.03///1;.04///A"
  1. D ^DIE
  1. W !!,"** New Local '",ABBV,"' has been added. **"
  1. W !,"Abbreviation Exact Match: "_$$GETFLD(FILE,SEQ,".03")
  1. W !,"Status: "_$$GETFLD(FILE,SEQ,".04")
  1. W !!,"Unauthorized Abbreviation: ",ABBV
  1. S DR=".02///^S X=""LOCAL"";.03//^S X=""YES"";.04//^S X=""ACTIVE"";.05"
  1. D ^DIE
  1. S XX="",XX="STATUS for this Unauthorized Abbreviation '"_ABBV_"' is "
  1. S XX=XX_$$GETFLD(FILE,SEQ,".04")_" now."
  1. W !!,XX,!!
  1. D STOP
  1. G ENTER
  1. ;
  1. STOP ;
  1. S J="",STOP=0
  1. R !,"Enter <RETURN> to continue or '^' to exit: ",J:TWAIT S:'$T J=U
  1. I $G(J)=U S STOP=1
  1. Q
  1. ;
  1. ;
  1. HD ; Header for Enter/Edit Unauthorized Abbreviation
  1. S (H1,H2,I,X)=""
  1. S H1="Enter/Edit Unauthorized Abbreviation(s)"
  1. F I=1:1:$L(H1) S H2=H2_"="
  1. I $G(IOM)="" S IOM=80
  1. S X=(IOM-$L(H1))/2
  1. W @IOF,!! F I=1:1:X W " "
  1. W H1,! F I=1:1:X W " "
  1. W H2
  1. Q
  1. ;
  1. TIUDIC ;
  1. S (ASK,C,I,RESP,SEQ,TP,X,XX,Y)=""
  1. W !!,DIC("A") R X:TWAIT S:'$T X=U I U[X S Y=-1 Q
  1. I X=" ",$D(^DISV(DUZ,"^TIU("_FILE_",")) D I $G(Y)="" S Y=-1 Q
  1. . S Y=$G(^DISV(DUZ,"^TIU("_FILE_","))
  1. . I $G(Y)="" Q
  1. . S X=$P($G(^TIU(FILE,Y,0)),U) W X
  1. W !
  1. I X="?"!(X="??") D DICHLP S Y=0 Q
  1. S TIUINP=$$GET1^DID(FILE,.01,"","INPUT TRANSFORM")
  1. I $G(TIUINP)]"" X TIUINP
  1. I '$D(X)#2 S Y=0 Q
  1. K TP S RESP=X,C=0,TP(C)=0
  1. D SEARCH(RESP,.TP)
  1. W !
  1. I $G(C)'>0 S ASK=$$ASK(RESP) D Q
  1. . W !
  1. . I '$G(ASK) S Y=0
  1. . E S Y=ASK,SEQ=$P(ASK,U),Y(0)=$G(^TIU(FILE,SEQ,0))
  1. K DIR S DIR("T")=TWAIT
  1. S DIR(0)="NO^1:"_C
  1. I $P(TP(0),U)=1 S DIR("A")="For EDIT Unauthorized Abbreviation, Select number"
  1. E S DIR("A")="For EDIT or CREATE Unauthorized Abbreviation, Select number"
  1. F I=1:1:C S DIR("A",I)=I_") "_$E($P(TP(I),U,3),1,75)
  1. S DIR("A",C+1)=""
  1. D ^DIR
  1. I $D(DUOUT) W !!,"No action has been taken !!",! S Y=0 Q
  1. I TP(0)=1,X="" W !!,"Nothing is selected !!",! S Y=0 Q
  1. I Y="" W !!,"Nothing is selected !!",! S Y=0 Q
  1. I $G(Y(0))="NO" W !!,"No action has been taken !!",! S Y=0 Q
  1. I $G(Y(0))="YES"!($E($P(TP(X),U,3),1,3)="** ") D Q
  1. . I $P(TP(0),U,2)'="" D I $G(STOP)=1 Q
  1. . . S XX="",XX=$P(TP(0),U,2)
  1. . . W !!,"The EXACT-MATCH for the following active abbreviation is set to """_"NO"_""""_": "
  1. . . W !," "_XX
  1. . . W !,"As a result, this abbreviation '"_RESP_"' will be flagged as unauthorized.",!
  1. . . K DIR S DIR("T")=TWAIT
  1. . . S DIR(0)="Y"
  1. . . S DIR("A")="Do you still want to add '"_RESP_"'"
  1. . . S DIR("B")="NO"
  1. . . D ^DIR
  1. . . I $D(DIRUT)!('Y) W !!,"No action has been taken !!",! S Y=0,STOP=1 Q
  1. . S DIC="^TIU(FILE,",DIC(0)="",X=RESP D FILE^DICN
  1. . S SEQ=$P(Y,U),Y(0)=$G(^TIU(FILE,SEQ,0))
  1. 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
  1. Q
  1. ;
  1. S (ABBV,ABBVU,C,EXACT,L1,L2,L3,L4,L5,RESP1)=""
  1. S (SEQ,X1,X2,X3,X4,X5,XX)=""
  1. S (C,EXACT,L1,L2,L3,L4,L5)=0 S TP(0)=EXACT
  1. S RESP1=$$UP^XLFSTR(RESP)
  1. S ABBV=""
  1. S10 S ABBV=$O(^TIU(FILE,"B",ABBV)) G:$G(ABBV)="" SOUT
  1. S ABBVU=$$UP^XLFSTR(ABBV)
  1. I $TR(ABBVU,TPUN)'=$TR(RESP1,TPUN) G S10
  1. I ABBV=RESP S EXACT=1,$P(TP(0),U)=EXACT
  1. S SEQ=""
  1. S20 S SEQ=$O(^TIU(FILE,"B",ABBV,SEQ)) G:$G(SEQ)="" S10
  1. S XX="",XX=$G(^TIU(FILE,SEQ,0))
  1. I $G(XX)="" G S20
  1. S C=C+1
  1. S (X1,X2,X3,X4,X5)=""
  1. 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)
  1. I $G(X3)=0,($G(X4)="A") D
  1. . I $P(TP(0),U,2)'="" S $P(TP(0),U,2)=$P(TP(0),U,2)_", "_X1
  1. . E S $P(TP(0),U,2)=X1
  1. I $L(X1)>L1 S L1=$L(X1)
  1. S X2=$$GETFLD(FILE,SEQ,".02"),X2="CLASS="_X2
  1. I $L(X2)>L2 S L2=$L(X2)
  1. S X3=$$GETFLD(FILE,SEQ,".03"),X3="EXACT-MATCH="_X3
  1. I $L(X3)>L3 S L3=$L(X3)
  1. S X4=$$GETFLD(FILE,SEQ,".04"),X4="STATUS="_X4
  1. I $L(X4)>L4 S L4=$L(X4)
  1. I $G(X5)'="" S X5="NOTE: "_X5
  1. S TP(C)=SEQ_U_ABBV_U_X1_","_X2_","_X3_","_X4_","_X5
  1. G S20
  1. ;
  1. SOUT ; OUT from SEARCH
  1. I C'>0 Q
  1. S (I,J,L,X1,X2,X3,X4,X5,XX)=""
  1. S I=0
  1. S30 S I=$O(TP(I)) G:$G(I)="" S40
  1. S (J,L,X1,X2,X3,X4,X5,XX)=""
  1. S XX=$P(TP(I),U,3)
  1. S X1=$P(XX,",",1),L=L1-$L(X1) I L>0 F J=1:1:L S X1=X1_" "
  1. S X2=$P(XX,",",2),L=L2-$L(X2) I L>0 F J=1:1:L S X2=X2_" "
  1. S X3=$P(XX,",",3),L=L3-$L(X3) I L>0 F J=1:1:L S X3=X3_" "
  1. S X4=$P(XX,",",4),L=L4-$L(X4) I L>0 F J=1:1:L S X4=X4_" "
  1. S X5=$P(XX,",",5)
  1. S $P(TP(I),U,3)=X1_" : "_X3_" "_X4_" "_X2
  1. G S30
  1. ;
  1. S40 I '$D(^TIU(8927.9,"B",RESP)) D Q
  1. . S SEQ=$P(^TIU(FILE,0),U,3),SEQ=$G(SEQ)+1,C=C+1
  1. . S TP(C)=SEQ_U_RESP_U_"** Create a new entry '"_RESP_"' as new Unauthorized Abbreviation."
  1. Q
  1. ;
  1. ASK(RESP) ; Ask if adding a new entry
  1. K DIC,DIR
  1. S DIR("T")=TWAIT
  1. S DIR(0)="Y",DIR("A")="Are you adding '"_RESP_"' as a new "_FILENAME
  1. S DIR("B")="No" D ^DIR Q:$D(DIRUT)!('Y) 0
  1. S DIC="^TIU(FILE,",DIC(0)="",X=RESP D FILE^DICN
  1. Q Y
  1. ;
  1. GETFLD(FILE,SEQ,FLD) ; Get field value
  1. S (TRET,TSEQ)=""
  1. S TSEQ=SEQ_","
  1. D GETS^DIQ(FILE,TSEQ,FLD,"E","ZZ")
  1. S TRET=$G(ZZ(FILE,TSEQ,FLD,"E"))
  1. Q $G(TRET)
  1. ;
  1. DICHLP ; Help for lookup
  1. K DIR S (HLP,C,J,X1,X2,X3,X4,X5,ABBV,SEQ)=""
  1. S DIR("T")=TWAIT
  1. W !! D HELP^DIE(8927.9,"",.01,"??","HLP")
  1. S HLP=HLP("DIHELP") F HLP=3:1:HLP("DIHELP") W !,HLP("DIHELP",HLP)
  1. S DIR(0)="Y"
  1. s DIR("A")="Do you want the list of Unauthorized Abbreviation(s)"
  1. S DIR("B")="Yes" W !! D ^DIR Q:$D(DIRUT)!('Y)
  1. S ABBV="",C=0 W !
  1. H10 S ABBV=$O(^TIU(FILE,"B",ABBV)) Q:$G(ABBV)=""
  1. S SEQ=0
  1. H20 S SEQ=$O(^TIU(FILE,"B",ABBV,SEQ)) G:$G(SEQ)="" H10
  1. S XX="",XX=$G(^TIU(FILE,SEQ,0))
  1. I $G(XX)="" G H20
  1. S C=C+1
  1. I C#20'>0 R !!,"Enter <RETURN> to continue or '^' to exit: ",J:DIR("T") S:'$T J=U Q:$G(J)=U
  1. S (X1,X2,X3,X4,X5)=""
  1. S X1=$P(XX,U),X2=$P(XX,U,2),X3=$P(XX,U,3)
  1. S X4=$P(XX,U,4),X5=$P(XX,U,5)
  1. S X1=X1_" : "
  1. S X2=$$GETFLD(FILE,SEQ,".02"),X2="CLASS="_X2
  1. S X3=$$GETFLD(FILE,SEQ,".03"),X3="EXACT-MATCH="_X3_" "
  1. S X4=$$GETFLD(FILE,SEQ,".04"),X4="STATUS="_X4_" "
  1. S XX=X1_X3_X4_X2
  1. W !,C,")",?6,$E(XX,1,74)
  1. G H20
  1. ;