- 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 Mar 13, 2025@21:43:37 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
