TIUABBVC ;BPOIFO/EL - Check for UNAUTHORIZED ABBREVIATIONS ;9/2/2015
;;1.0;TEXT INTEGRATION UTILITIES;**297**;JUN 20, 1997;Build 40
;
; External Reference DBIA#:
; #10104 - XLFSTR call (Supported)
;
Q
;
EN(TIUDA) ; Check Unauthorized Abbreviation in Progress Note
N GLBAB,GLBABV
N I,L,TABBV,TCLA,TCNT,TEXT,TIUFIL,TIUNOTE
N TLEN,TMAT,TMES,TPUN,TRES,TSEQ,X,X1,X2,XX
S (GLBAB,GLBABV,I,L,TABBV,TCLA,TEXT,TIUFIL,TIUNOTE,TMAT,TMES)=""
S (TPUN,TRES,X,X1,X2,XX)=""
S (TCNT,TLEN,TSEQ)=0
S TIUFIL=8927.9,TIUNOTE=8925
S TPUN="|^&~\:;,.!?@#$%*()_-+={}[]/""'<>`"
S TCLA=""
AB S TCLA=$O(^TIU(TIUFIL,"AC","A",TCLA)) G ABV:$G(TCLA)=""
S TABBV=""
AB1 S TABBV=$O(^TIU(TIUFIL,"AC","A",TCLA,TABBV)) G AB:$G(TABBV)=""
S TMAT=""
AB2 S TMAT=$O(^TIU(TIUFIL,"AC","A",TCLA,TABBV,TMAT)) G AB1:$G(TMAT)=""
I $G(TMAT)=1 S GLBAB(TABBV,1)=""
E I $G(TMAT)=0 D S GLBAB(X,0)=""
. S X="",X=$TR($$UP^XLFSTR(TABBV),TPUN)
G AB2
;
ABV S TRES="",(TCNT,TLEN,TSEQ)=0
ABV1 S TSEQ=$O(^TIU(TIUNOTE,TIUDA,"TEXT",TSEQ)) G PUT:$G(TSEQ)=""
I $G(^TIU(TIUNOTE,TIUDA,"TEXT",TSEQ,0))="" G ABV1
S TEXT="",TEXT=$G(^TIU(TIUNOTE,TIUDA,"TEXT",TSEQ,0))
S TLEN=$L(TEXT," ")
F I=1:1:TLEN S TABBV="",TABBV=$P(TEXT," ",I) I $G(TABBV)'="" D
. S TMAT=0,X=TABBV
. I $D(GLBAB(TABBV)) D SET Q
. S (L,X,X1,X2,XX)=""
. S L=$L(TABBV),X1=$E(TABBV,1,L-1),X2=$TR($E(TABBV,L,L),TPUN),X=X1_X2
. I $G(X)="" Q
. I $D(GLBAB(X)) S TABBV=X D SET Q
. E D Q:$G(XX)=""
. . S XX="",XX=$TR($$UP^XLFSTR(TABBV),TPUN)
. . I $G(XX)="" Q
. . I $D(GLBAB(XX,0)) S TABBV=X D SET Q
G ABV1
;
SET ;
I $D(GLBABV(TABBV)) Q
S TRES=TRES_TABBV_", ",TCNT=TCNT+1,GLBABV(TABBV)=""
Q
;
PUT ;
K GLBAB,GLBABV
S TMES=""
I $G(TCNT)'>0 Q TMES
S TRES=$P(TRES,",",1,TCNT)
I $G(TCNT)>1 S TMES="0^These abbreviations have "
E S TMES="0^This abbreviation has "
S TMES=TMES_"been identified as a safety concern and must be spelled out: "
S TMES=TMES_TRES
Q TMES
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUABBVC 1971 printed Oct 16, 2024@18:39:19 Page 2
TIUABBVC ;BPOIFO/EL - Check for UNAUTHORIZED ABBREVIATIONS ;9/2/2015
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**297**;JUN 20, 1997;Build 40
+2 ;
+3 ; External Reference DBIA#:
+4 ; #10104 - XLFSTR call (Supported)
+5 ;
+6 QUIT
+7 ;
EN(TIUDA) ; Check Unauthorized Abbreviation in Progress Note
+1 NEW GLBAB,GLBABV
+2 NEW I,L,TABBV,TCLA,TCNT,TEXT,TIUFIL,TIUNOTE
+3 NEW TLEN,TMAT,TMES,TPUN,TRES,TSEQ,X,X1,X2,XX
+4 SET (GLBAB,GLBABV,I,L,TABBV,TCLA,TEXT,TIUFIL,TIUNOTE,TMAT,TMES)=""
+5 SET (TPUN,TRES,X,X1,X2,XX)=""
+6 SET (TCNT,TLEN,TSEQ)=0
+7 SET TIUFIL=8927.9
SET TIUNOTE=8925
+8 SET TPUN="|^&~\:;,.!?@#$%*()_-+={}[]/""'<>`"
+9 SET TCLA=""
AB SET TCLA=$ORDER(^TIU(TIUFIL,"AC","A",TCLA))
if $GET(TCLA)=""
GOTO ABV
+1 SET TABBV=""
AB1 SET TABBV=$ORDER(^TIU(TIUFIL,"AC","A",TCLA,TABBV))
if $GET(TABBV)=""
GOTO AB
+1 SET TMAT=""
AB2 SET TMAT=$ORDER(^TIU(TIUFIL,"AC","A",TCLA,TABBV,TMAT))
if $GET(TMAT)=""
GOTO AB1
+1 IF $GET(TMAT)=1
SET GLBAB(TABBV,1)=""
+2 IF '$TEST
IF $GET(TMAT)=0
Begin DoDot:1
+3 SET X=""
SET X=$TRANSLATE($$UP^XLFSTR(TABBV),TPUN)
End DoDot:1
SET GLBAB(X,0)=""
+4 GOTO AB2
+5 ;
ABV SET TRES=""
SET (TCNT,TLEN,TSEQ)=0
ABV1 SET TSEQ=$ORDER(^TIU(TIUNOTE,TIUDA,"TEXT",TSEQ))
if $GET(TSEQ)=""
GOTO PUT
+1 IF $GET(^TIU(TIUNOTE,TIUDA,"TEXT",TSEQ,0))=""
GOTO ABV1
+2 SET TEXT=""
SET TEXT=$GET(^TIU(TIUNOTE,TIUDA,"TEXT",TSEQ,0))
+3 SET TLEN=$LENGTH(TEXT," ")
+4 FOR I=1:1:TLEN
SET TABBV=""
SET TABBV=$PIECE(TEXT," ",I)
IF $GET(TABBV)'=""
Begin DoDot:1
+5 SET TMAT=0
SET X=TABBV
+6 IF $DATA(GLBAB(TABBV))
DO SET
QUIT
+7 SET (L,X,X1,X2,XX)=""
+8 SET L=$LENGTH(TABBV)
SET X1=$EXTRACT(TABBV,1,L-1)
SET X2=$TRANSLATE($EXTRACT(TABBV,L,L),TPUN)
SET X=X1_X2
+9 IF $GET(X)=""
QUIT
+10 IF $DATA(GLBAB(X))
SET TABBV=X
DO SET
QUIT
+11 IF '$TEST
Begin DoDot:2
+12 SET XX=""
SET XX=$TRANSLATE($$UP^XLFSTR(TABBV),TPUN)
+13 IF $GET(XX)=""
QUIT
+14 IF $DATA(GLBAB(XX,0))
SET TABBV=X
DO SET
QUIT
End DoDot:2
if $GET(XX)=""
QUIT
End DoDot:1
+15 GOTO ABV1
+16 ;
SET ;
+1 IF $DATA(GLBABV(TABBV))
QUIT
+2 SET TRES=TRES_TABBV_", "
SET TCNT=TCNT+1
SET GLBABV(TABBV)=""
+3 QUIT
+4 ;
PUT ;
+1 KILL GLBAB,GLBABV
+2 SET TMES=""
+3 IF $GET(TCNT)'>0
QUIT TMES
+4 SET TRES=$PIECE(TRES,",",1,TCNT)
+5 IF $GET(TCNT)>1
SET TMES="0^These abbreviations have "
+6 IF '$TEST
SET TMES="0^This abbreviation has "
+7 SET TMES=TMES_"been identified as a safety concern and must be spelled out: "
+8 SET TMES=TMES_TRES
+9 QUIT TMES
+10 ;
