TIUABBVP ;BPOIFO/JLTP - Print Functions ;11/09/2015
;;1.0;TEXT INTEGRATION UTILITIES;**297**;JUN 20, 1997;Build 40
;
; External Reference DBIA#:
; -------------------------
; #10086 - %ZIS call (Supported)
; #10089 - %ZISC call (Supported)
; #10063 - %ZTLOAD call (Supported)
; #999 - DD reference (Controlled Subscription)
; #10026 - DIR call (Supported)
; #10103 - XLFDT call (Supported)
; #10104 - XLFSTR call (Supported)
;
LA ; List All
N INACT
W ! D LI Q:'$D(INACT)
D:$$DEV("DQ1^TIUABBVP","INACT","List of Unauthorized Abbreviations") DQ1
Q
DQ1 ; List of Unauthorized Abbreviations
U IO K ^TMP($J) N ABBV,ACT,CLS,DESC,DLINE,H1,H2,IFN,LINE,MCH,STOP,X,Y
S (STOP,IFN)=0 F S IFN=$O(^TIU(8927.9,IFN)) Q:'IFN D
.S X=^TIU(8927.9,IFN,0),ABBV=$P(X,U),CLS=$P(X,U,2),MCH=$P(X,U,3),ACT=$P(X,U,4),DESC=$P(X,U,5)
.I ACT]"" S ^TMP($J,ACT,$$UP^XLFSTR(ABBV),IFN)=ABBV_U_CLS_U_MCH_U_DESC
D P1("A","Active Unauthorized Abbreviations","No active entries on file.") D:'$G(STOP) PG
I INACT,'$G(STOP) D P1("I","Inactive Unauthorized Abbreviations","No inactive entries on file.") D:'$G(STOP) PG
K ^TMP($J) D ^%ZISC
Q
P1(ACT,H1,NONE) ; Print one STATUS
N ABBV,CLASS,EXACT,IFN,LINE,NOTE,REC,UABBV
S $P(LINE,"-",IOM)="" D DHD
I '$D(^TMP($J,ACT)) W !,NONE,!
S UABBV="" F S UABBV=$O(^TMP($J,ACT,UABBV)) Q:UABBV=""!($G(STOP)) D
.S IFN=0 F S IFN=$O(^TMP($J,ACT,UABBV,IFN)) Q:'IFN!($G(STOP)) S REC=^(IFN) D
..I $Y>(IOSL-5) D:$E(IOST)="C" PG Q:STOP D DHD
..S ABBV=$P(REC,U),CLASS=$P(REC,U,2),EXACT=$P(REC,U,3),NOTE=$P(REC,U,4)
..W !,ABBV,?32,$$SET(CLASS,.02),?52,$$SET(EXACT,.03),!?3,"Note: ",NOTE
..W !,LINE
Q
DHD ; Report Heading
;;Abbreviation Class Exact Match
N PRTTIM,DLINE,H2
S $P(DLINE,"=",IOM)="",H2=$P($T(DHD+1),";;",2),PRTTIM=$$FMTE^XLFDT($$NOW^XLFDT,5)
S PRTTIM=$P(PRTTIM,"@")_" @"_$P(PRTTIM,"@",2)
W @IOF W !,$$CNTR(H1),!
W $$CNTR("Printed: "_PRTTIM),!!,H2,!,DLINE
Q
PG ; Stop for page break
N X,Y
I $E(IOST)="C" S DIR(0)="E" D ^DIR S STOP='Y W @IOF
I $E(IOST)'="C" S STOP=0
Q
CNTR(X) ; Center X based on IOM
N LM,Y S LM=(IOM\2)-($L(X)\2),Y="",$P(Y," ",LM)=""
Q Y_X
SET(INT,FLD) ; Get External Set-of-Codes Value
N DD,I,P,VAL
S DD=$P(^DD(8927.9,FLD,0),U,3),VAL=""
F I=1:1 S P=$P(DD,";",I) Q:'$L(P) I $P(P,":")=INT S VAL=$P(P,":",2) Q
Q VAL
WR(X,LMARG,WIDTH) ; Word wrap
N I,SIZ,Y
S SIZ=WIDTH-LMARG-1,I=$L(X)
F Q:$L(X)<1 D:$L(X)>SIZ W ?LMARG,X S X=$E(X,I+1,$L(X))
.F I=SIZ:-1 Q:I<1 Q:$E(X,I)?1P
.S:I<1 I=SIZ S Y=$E(X,1,I) W ?LMARG,Y,! S X=$E(X,I+1,$L(X))
Q
LI ; Ask to List Inactive Abbreviations
N DIR,DIRUT,X,Y
S DIR(0)="Y",DIR("A")="Include inactive entries",DIR("B")="No"
D ^DIR Q:$D(DIRUT) S INACT=+Y
Q
DEV(R,VARS,DESC) ; Device Selection
N %ZIS,POP,ZTDESC,ZTRTN,ZTSAVE
S %ZIS="QM" W !! D ^%ZIS Q:POP 0 Q:'$D(%ZIS("Q")) 1
S ZTRTN=R,ZTSAVE(VARS)="",ZTDESC=DESC D ^%ZTLOAD,^%ZISC
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUABBVP 2960 printed Dec 13, 2024@02:38:43 Page 2
TIUABBVP ;BPOIFO/JLTP - Print Functions ;11/09/2015
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**297**;JUN 20, 1997;Build 40
+2 ;
+3 ; External Reference DBIA#:
+4 ; -------------------------
+5 ; #10086 - %ZIS call (Supported)
+6 ; #10089 - %ZISC call (Supported)
+7 ; #10063 - %ZTLOAD call (Supported)
+8 ; #999 - DD reference (Controlled Subscription)
+9 ; #10026 - DIR call (Supported)
+10 ; #10103 - XLFDT call (Supported)
+11 ; #10104 - XLFSTR call (Supported)
+12 ;
LA ; List All
+1 NEW INACT
+2 WRITE !
DO LI
if '$DATA(INACT)
QUIT
+3 if $$DEV("DQ1^TIUABBVP","INACT","List of Unauthorized Abbreviations")
DO DQ1
+4 QUIT
DQ1 ; List of Unauthorized Abbreviations
+1 USE IO
KILL ^TMP($JOB)
NEW ABBV,ACT,CLS,DESC,DLINE,H1,H2,IFN,LINE,MCH,STOP,X,Y
+2 SET (STOP,IFN)=0
FOR
SET IFN=$ORDER(^TIU(8927.9,IFN))
if 'IFN
QUIT
Begin DoDot:1
+3 SET X=^TIU(8927.9,IFN,0)
SET ABBV=$PIECE(X,U)
SET CLS=$PIECE(X,U,2)
SET MCH=$PIECE(X,U,3)
SET ACT=$PIECE(X,U,4)
SET DESC=$PIECE(X,U,5)
+4 IF ACT]""
SET ^TMP($JOB,ACT,$$UP^XLFSTR(ABBV),IFN)=ABBV_U_CLS_U_MCH_U_DESC
End DoDot:1
+5 DO P1("A","Active Unauthorized Abbreviations","No active entries on file.")
if '$GET(STOP)
DO PG
+6 IF INACT
IF '$GET(STOP)
DO P1("I","Inactive Unauthorized Abbreviations","No inactive entries on file.")
if '$GET(STOP)
DO PG
+7 KILL ^TMP($JOB)
DO ^%ZISC
+8 QUIT
P1(ACT,H1,NONE) ; Print one STATUS
+1 NEW ABBV,CLASS,EXACT,IFN,LINE,NOTE,REC,UABBV
+2 SET $PIECE(LINE,"-",IOM)=""
DO DHD
+3 IF '$DATA(^TMP($JOB,ACT))
WRITE !,NONE,!
+4 SET UABBV=""
FOR
SET UABBV=$ORDER(^TMP($JOB,ACT,UABBV))
if UABBV=""!($GET(STOP))
QUIT
Begin DoDot:1
+5 SET IFN=0
FOR
SET IFN=$ORDER(^TMP($JOB,ACT,UABBV,IFN))
if 'IFN!($GET(STOP))
QUIT
SET REC=^(IFN)
Begin DoDot:2
+6 IF $Y>(IOSL-5)
if $EXTRACT(IOST)="C"
DO PG
if STOP
QUIT
DO DHD
+7 SET ABBV=$PIECE(REC,U)
SET CLASS=$PIECE(REC,U,2)
SET EXACT=$PIECE(REC,U,3)
SET NOTE=$PIECE(REC,U,4)
+8 WRITE !,ABBV,?32,$$SET(CLASS,.02),?52,$$SET(EXACT,.03),!?3,"Note: ",NOTE
+9 WRITE !,LINE
End DoDot:2
End DoDot:1
+10 QUIT
DHD ; Report Heading
+1 ;;Abbreviation Class Exact Match
+2 NEW PRTTIM,DLINE,H2
+3 SET $PIECE(DLINE,"=",IOM)=""
SET H2=$PIECE($TEXT(DHD+1),";;",2)
SET PRTTIM=$$FMTE^XLFDT($$NOW^XLFDT,5)
+4 SET PRTTIM=$PIECE(PRTTIM,"@")_" @"_$PIECE(PRTTIM,"@",2)
+5 WRITE @IOF
WRITE !,$$CNTR(H1),!
+6 WRITE $$CNTR("Printed: "_PRTTIM),!!,H2,!,DLINE
+7 QUIT
PG ; Stop for page break
+1 NEW X,Y
+2 IF $EXTRACT(IOST)="C"
SET DIR(0)="E"
DO ^DIR
SET STOP='Y
WRITE @IOF
+3 IF $EXTRACT(IOST)'="C"
SET STOP=0
+4 QUIT
CNTR(X) ; Center X based on IOM
+1 NEW LM,Y
SET LM=(IOM\2)-($LENGTH(X)\2)
SET Y=""
SET $PIECE(Y," ",LM)=""
+2 QUIT Y_X
SET(INT,FLD) ; Get External Set-of-Codes Value
+1 NEW DD,I,P,VAL
+2 SET DD=$PIECE(^DD(8927.9,FLD,0),U,3)
SET VAL=""
+3 FOR I=1:1
SET P=$PIECE(DD,";",I)
if '$LENGTH(P)
QUIT
IF $PIECE(P,":")=INT
SET VAL=$PIECE(P,":",2)
QUIT
+4 QUIT VAL
WR(X,LMARG,WIDTH) ; Word wrap
+1 NEW I,SIZ,Y
+2 SET SIZ=WIDTH-LMARG-1
SET I=$LENGTH(X)
+3 FOR
if $LENGTH(X)<1
QUIT
if $LENGTH(X)>SIZ
Begin DoDot:1
+4 FOR I=SIZ:-1
if I<1
QUIT
if $EXTRACT(X,I)?1P
QUIT
+5 if I<1
SET I=SIZ
SET Y=$EXTRACT(X,1,I)
WRITE ?LMARG,Y,!
SET X=$EXTRACT(X,I+1,$LENGTH(X))
End DoDot:1
WRITE ?LMARG,X
SET X=$EXTRACT(X,I+1,$LENGTH(X))
+6 QUIT
LI ; Ask to List Inactive Abbreviations
+1 NEW DIR,DIRUT,X,Y
+2 SET DIR(0)="Y"
SET DIR("A")="Include inactive entries"
SET DIR("B")="No"
+3 DO ^DIR
if $DATA(DIRUT)
QUIT
SET INACT=+Y
+4 QUIT
DEV(R,VARS,DESC) ; Device Selection
+1 NEW %ZIS,POP,ZTDESC,ZTRTN,ZTSAVE
+2 SET %ZIS="QM"
WRITE !!
DO ^%ZIS
if POP
QUIT 0
if '$DATA(%ZIS("Q"))
QUIT 1
+3 SET ZTRTN=R
SET ZTSAVE(VARS)=""
SET ZTDESC=DESC
DO ^%ZTLOAD
DO ^%ZISC
+4 QUIT 0
