LEXDDSD ;ISL/KER - Display Defaults - Single User Disp ;04/21/2014
;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
;
; Global Variables
; ^TMP("LEXDIC") SACC 2.3.2.5.1
;
; External References
; ^DIR ICR 10026
;
LEXSHOW ; Translate LEXSHOW
D:$G(^LEXT(757.2,LEXAP,200,DUZ,2))'=""
. D DIS^LEXDDSS($G(^LEXT(757.2,LEXAP,200,DUZ,2.5)))
. D CODES(^LEXT(757.2,LEXAP,200,DUZ,2))
D:$G(^LEXT(757.2,LEXAP,200,DUZ,2))=""
. D DIS^LEXDDSS("No default display defined")
Q
DICS ; Save filter in array LEX(
N LEXID,LEXIC,LEXEC,LEXCLA
N LEXCTR,LEXXI,LEXXE,LEXCT
D LB^LEXDDSS(" Include: Exclude:")
S LEXID="",(LEXIC,LEXEC)=0
I $D(^TMP("LEXDIC",$J,"INC","CLASS")) D
. F S LEXID=$O(^TMP("LEXDIC",$J,"INC","CLASS",LEXID)) Q:LEXID="" D
. . Q:'$D(^LEX(757.11,"B",LEXID))
. . S LEXCLA=$O(^LEX(757.11,"B",LEXID,0)),LEXIC=LEXIC+1
. . S ^TMP("LEXDIC",$J,"INCLUDE",LEXIC,$P(^LEX(757.11,LEXCLA,0),U,2))=""
I $D(^TMP("LEXDIC",$J,"INC","TYPE")) D
. S LEXID=0
. F S LEXID=$O(^TMP("LEXDIC",$J,"INC","TYPE",LEXID)) Q:+LEXID=0 D
. . S LEXIC=LEXIC+1
. . S ^TMP("LEXDIC",$J,"INCLUDE",LEXIC,$P(^LEX(757.12,LEXID,0),U,2))=""
I $D(^TMP("LEXDIC",$J,"EXC","CLASS")) D
. F S LEXID=$O(^TMP("LEXDIC",$J,"EXC","CLASS",LEXID)) Q:LEXID="" D
. . Q:'$D(^LEX(757.11,"B",LEXID))
. . S LEXCLA=$O(^LEX(757.11,"B",LEXID,0)),LEXEC=LEXEC+1
. . S ^TMP("LEXDIC",$J,"EXCLUDE",LEXEC,$P(^LEX(757.11,LEXCLA,0),U,2))=""
I $D(^TMP("LEXDIC",$J,"EXC","TYPE")) D
. S LEXID=0
. F S LEXID=$O(^TMP("LEXDIC",$J,"EXC","TYPE",LEXID)) Q:+LEXID=0 D
. . S LEXEC=LEXEC+1
. . S ^TMP("LEXDIC",$J,"EXCLUDE",LEXEC,$P(^LEX(757.12,LEXID,0),U,2))=""
S LEXCTR=$S(LEXIC>LEXEC:LEXIC,1:LEXEC)
N LEXXI,LEXXE F LEXCT=1:1:LEXCTR D
. S (LEXXI,LEXXE)=""
. S:$D(^TMP("LEXDIC",$J,"INCLUDE",LEXCT)) LEXXI=$E($O(^TMP("LEXDIC",$J,"INCLUDE",LEXCT,"")),1,35)
. S:$D(^TMP("LEXDIC",$J,"EXCLUDE",LEXCT)) LEXXE=$E($O(^TMP("LEXDIC",$J,"EXCLUDE",LEXCT,"")),1,35)
. D FIE^LEXDDSS(LEXXI,LEXXE)
K ^TMP("LEXDIC",$J) Q
Q
CODES(LEXSTR) ; Save contents of LEXSHOW in local array LEX(
N LEXCT F LEXCT=1:1:$L(LEXSTR,"/") D DISE^LEXDDSS(($P(LEXSTR,"/",LEXCT)))
D:$L(LEXSTR,"/")>0 BL^LEXDDSS Q
DP ; Display single user defaults in array LEX( continuous
N LEXC Q:+($G(LEX(0)))=0 F LEXC=1:1:LEX(0) W !,LEX(LEXC)
K LEX
Q
DSPLY ; Display Defaults contained in LEX(
Q:'$D(LEX(0)) N LEXC,LEXLC,LEXI S LEXC="",LEXLC=0
F LEXI=1:1:LEX(0) D Q:$G(LEXC)[U
. W !,LEX(LEXI) D LF Q:$G(LEXC)[U
D:LEXC'[U&(IOST["C-") CONT W:IOST["P-" @IOF
K LEX Q
LF ; Line Feed
Q:LEXI=LEX(0) S LEXLC=LEXLC+1
I IOST["P-",LEXLC>(IOSL-7) D CONT
I IOST'["P-",LEXLC>(IOSL-4) D CONT
Q
CONT ; Page/Form Feed
S LEXLC=0 I IOST["P-" W @IOF Q
W ! S DIR("?")=" Additional information is available"
S LEXC="" N X,Y S DIR(0)="E" D ^DIR
S:$D(DTOUT)!(X[U) LEXC=U
K DIR,DTOUT,DUOUT,DIRUT,DIROUT W ! Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXDDSD 2987 printed Apr 09, 2024@21:13:04 Page 2
LEXDDSD ;ISL/KER - Display Defaults - Single User Disp ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
+2 ;
+3 ; Global Variables
+4 ; ^TMP("LEXDIC") SACC 2.3.2.5.1
+5 ;
+6 ; External References
+7 ; ^DIR ICR 10026
+8 ;
LEXSHOW ; Translate LEXSHOW
+1 if $GET(^LEXT(757.2,LEXAP,200,DUZ,2))'=""
Begin DoDot:1
+2 DO DIS^LEXDDSS($GET(^LEXT(757.2,LEXAP,200,DUZ,2.5)))
+3 DO CODES(^LEXT(757.2,LEXAP,200,DUZ,2))
End DoDot:1
+4 if $GET(^LEXT(757.2,LEXAP,200,DUZ,2))=""
Begin DoDot:1
+5 DO DIS^LEXDDSS("No default display defined")
End DoDot:1
+6 QUIT
DICS ; Save filter in array LEX(
+1 NEW LEXID,LEXIC,LEXEC,LEXCLA
+2 NEW LEXCTR,LEXXI,LEXXE,LEXCT
+3 DO LB^LEXDDSS(" Include: Exclude:")
+4 SET LEXID=""
SET (LEXIC,LEXEC)=0
+5 IF $DATA(^TMP("LEXDIC",$JOB,"INC","CLASS"))
Begin DoDot:1
+6 FOR
SET LEXID=$ORDER(^TMP("LEXDIC",$JOB,"INC","CLASS",LEXID))
if LEXID=""
QUIT
Begin DoDot:2
+7 if '$DATA(^LEX(757.11,"B",LEXID))
QUIT
+8 SET LEXCLA=$ORDER(^LEX(757.11,"B",LEXID,0))
SET LEXIC=LEXIC+1
+9 SET ^TMP("LEXDIC",$JOB,"INCLUDE",LEXIC,$PIECE(^LEX(757.11,LEXCLA,0),U,2))=""
End DoDot:2
End DoDot:1
+10 IF $DATA(^TMP("LEXDIC",$JOB,"INC","TYPE"))
Begin DoDot:1
+11 SET LEXID=0
+12 FOR
SET LEXID=$ORDER(^TMP("LEXDIC",$JOB,"INC","TYPE",LEXID))
if +LEXID=0
QUIT
Begin DoDot:2
+13 SET LEXIC=LEXIC+1
+14 SET ^TMP("LEXDIC",$JOB,"INCLUDE",LEXIC,$PIECE(^LEX(757.12,LEXID,0),U,2))=""
End DoDot:2
End DoDot:1
+15 IF $DATA(^TMP("LEXDIC",$JOB,"EXC","CLASS"))
Begin DoDot:1
+16 FOR
SET LEXID=$ORDER(^TMP("LEXDIC",$JOB,"EXC","CLASS",LEXID))
if LEXID=""
QUIT
Begin DoDot:2
+17 if '$DATA(^LEX(757.11,"B",LEXID))
QUIT
+18 SET LEXCLA=$ORDER(^LEX(757.11,"B",LEXID,0))
SET LEXEC=LEXEC+1
+19 SET ^TMP("LEXDIC",$JOB,"EXCLUDE",LEXEC,$PIECE(^LEX(757.11,LEXCLA,0),U,2))=""
End DoDot:2
End DoDot:1
+20 IF $DATA(^TMP("LEXDIC",$JOB,"EXC","TYPE"))
Begin DoDot:1
+21 SET LEXID=0
+22 FOR
SET LEXID=$ORDER(^TMP("LEXDIC",$JOB,"EXC","TYPE",LEXID))
if +LEXID=0
QUIT
Begin DoDot:2
+23 SET LEXEC=LEXEC+1
+24 SET ^TMP("LEXDIC",$JOB,"EXCLUDE",LEXEC,$PIECE(^LEX(757.12,LEXID,0),U,2))=""
End DoDot:2
End DoDot:1
+25 SET LEXCTR=$SELECT(LEXIC>LEXEC:LEXIC,1:LEXEC)
+26 NEW LEXXI,LEXXE
FOR LEXCT=1:1:LEXCTR
Begin DoDot:1
+27 SET (LEXXI,LEXXE)=""
+28 if $DATA(^TMP("LEXDIC",$JOB,"INCLUDE",LEXCT))
SET LEXXI=$EXTRACT($ORDER(^TMP("LEXDIC",$JOB,"INCLUDE",LEXCT,"")),1,35)
+29 if $DATA(^TMP("LEXDIC",$JOB,"EXCLUDE",LEXCT))
SET LEXXE=$EXTRACT($ORDER(^TMP("LEXDIC",$JOB,"EXCLUDE",LEXCT,"")),1,35)
+30 DO FIE^LEXDDSS(LEXXI,LEXXE)
End DoDot:1
+31 KILL ^TMP("LEXDIC",$JOB)
QUIT
+32 QUIT
CODES(LEXSTR) ; Save contents of LEXSHOW in local array LEX(
+1 NEW LEXCT
FOR LEXCT=1:1:$LENGTH(LEXSTR,"/")
DO DISE^LEXDDSS(($PIECE(LEXSTR,"/",LEXCT)))
+2 if $LENGTH(LEXSTR,"/")>0
DO BL^LEXDDSS
QUIT
DP ; Display single user defaults in array LEX( continuous
+1 NEW LEXC
if +($GET(LEX(0)))=0
QUIT
FOR LEXC=1:1:LEX(0)
WRITE !,LEX(LEXC)
+2 KILL LEX
+3 QUIT
DSPLY ; Display Defaults contained in LEX(
+1 if '$DATA(LEX(0))
QUIT
NEW LEXC,LEXLC,LEXI
SET LEXC=""
SET LEXLC=0
+2 FOR LEXI=1:1:LEX(0)
Begin DoDot:1
+3 WRITE !,LEX(LEXI)
DO LF
if $GET(LEXC)[U
QUIT
End DoDot:1
if $GET(LEXC)[U
QUIT
+4 if LEXC'[U&(IOST["C-")
DO CONT
if IOST["P-"
WRITE @IOF
+5 KILL LEX
QUIT
LF ; Line Feed
+1 if LEXI=LEX(0)
QUIT
SET LEXLC=LEXLC+1
+2 IF IOST["P-"
IF LEXLC>(IOSL-7)
DO CONT
+3 IF IOST'["P-"
IF LEXLC>(IOSL-4)
DO CONT
+4 QUIT
CONT ; Page/Form Feed
+1 SET LEXLC=0
IF IOST["P-"
WRITE @IOF
QUIT
+2 WRITE !
SET DIR("?")=" Additional information is available"
+3 SET LEXC=""
NEW X,Y
SET DIR(0)="E"
DO ^DIR
+4 if $DATA(DTOUT)!(X[U)
SET LEXC=U
+5 KILL DIR,DTOUT,DUOUT,DIRUT,DIROUT
WRITE !
QUIT
