LEXINF5 ;ISL/KER - Information - Display ;05/23/2017
;;2.0;LEXICON UTILITY;**103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^LEX(757.02 SACC 1.3
; ^LEX(757.03 SACC 1.3
; ^TMP("LEXINF" SACC 2.3.2.5.1
;
; External References
; ^%ZIS ICR 10086
; HOME^%ZIS ICR 10086
; ^%ZISC ICR 10089
; ^%ZTLOAD ICR 10063
; ^DIR ICR 10026
; $$FMTE^XLFDT ICR 10103
;
TERM(ARY) ; Display by Expression
K ^TMP("LEXINF",$J) N LEXTYPE S LEXTYPE="T" D MP(.ARY),FS(.ARY),OT(.ARY),CO(.ARY),SR(.ARY),SB(.ARY),DC(.ARY),CP(.ARY) D:$D(^TMP("LEXINF",$J)) DEV
Q
CODE(ARY) ; Display by Code
K ^TMP("LEXINF",$J) S LEXTYPE="C" D CO(.ARY),MP(.ARY),FS(.ARY),OT(.ARY),SR(.ARY),SB(.ARY),DC(.ARY),CP(.ARY) D:$D(^TMP("LEXINF",$J)) DEV
Q
;
; Display Components
MP(ARY) ; Major Concept/Preferred Term MC/PF
N LEXA,LEXEXP,LEXI,LEXMC,LEXPF,LEXTTL S LEXMC=$P($G(ARY("MC",1,"I")),"^",4) Q:LEXMC'>0
S LEXPF=$P($G(ARY("PF",1,"I")),"^",4),LEXTTL="Major Concept" S:LEXPF=LEXMC LEXTTL=LEXTTL_"/Preferred Term"
S LEXEXP=$G(ARY("MC",1)) Q:'$L(LEXEXP) S:$D(LEXIIEN) LEXEXP=LEXEXP_" (IEN "_LEXMC_")"
K LEXA S LEXA(1)=LEXEXP D PR^LEXU(.LEXA,70) D TL((" "_LEXTTL)) S LEXI=0
F S LEXI=$O(LEXA(LEXI)) Q:+LEXI'>0 D:LEXI=1 BL D TL((" "_$G(LEXA(LEXI))))
D ID("MC",1,.ARY),SK("MC",1,.ARY) I LEXPF>0,LEXPF'=LEXMC D
. N LEXEXP,LEXA,LEXTTL,LEXI S LEXEXP=$G(ARY("PF",1)) S:$D(LEXIIEN) LEXEXP=LEXEXP_" (IEN "_+LEXPF_")"
. S LEXTTL="Preferred Term" K LEXA S LEXA(1)=LEXEXP D PR^LEXU(.LEXA,70)
. D BL,TL((" "_LEXTTL)) S LEXI=0 F S LEXI=$O(LEXA(LEXI)) Q:+LEXI'>0 D:LEXI=1 BL D TL((" "_$G(LEXA(LEXI))))
. D ID("PF",1,.ARY),SK("PF",1,.ARY)
N LEXIIEN,TEST
Q
FS(ARY) ; Fully Specified Names FS
N LEXA,LEXEXP,LEXI,LEXIEN,LEXSEQ,LEXSTA,LEXTTL S LEXTTL="Fully Specified Name"
S:$O(ARY("FS"," "),-1)>1 LEXTTL=LEXTTL_"s" D:$O(ARY("FS",0))>0 BL,TL((" "_LEXTTL))
S LEXSEQ=0 F S LEXSEQ=$O(ARY("FS",LEXSEQ)) Q:+LEXSEQ'>0 D
. N LEXA,LEXEXP,LEXI,LEXIEN,LEXSTA
. S LEXIEN=$P($G(ARY("FS",LEXSEQ,"I")),"^",4) Q:LEXIEN'>0
. S LEXSTA=$P($G(ARY("FS",LEXSEQ,"I")),"^",3) S:LEXSTA'["Retire" LEXSTA=""
. S LEXEXP=$G(ARY("FS",LEXSEQ)) Q:'$L(LEXEXP)
. S:$L(LEXSTA) LEXEXP=LEXEXP_" ("_LEXSTA_")"
. S:$D(LEXIIEN) LEXEXP=LEXEXP_" (IEN "_LEXIEN_")" K LEXA S LEXA(1)=LEXEXP D PR^LEXU(.LEXA,70)
. S LEXI=0 F S LEXI=$O(LEXA(LEXI)) Q:+LEXI'>0 D:LEXI=1 BL D TL((" "_$G(LEXA(LEXI))))
. D ID("FS",LEXSEQ,.ARY)
. D SK("FS",LEXSEQ,.ARY)
Q
OT(ARY) ; Other Terms SY/LV
N LEXPF,LEXTY S LEXPF=$P($G(ARY("PF",1,"I")),"^",4) F LEXTY="SY","LV" D
. N LEXTTL,LEXSEQ S LEXTTL=$S(LEXTY="LV":"Lexical Variant",1:"Synonym")
. S:$O(ARY(LEXTY," "),-1)>1 LEXTTL=LEXTTL_"s" D:$O(ARY(LEXTY,0))>0 BL,TL((" "_LEXTTL))
. S LEXSEQ=0 F S LEXSEQ=$O(ARY(LEXTY,LEXSEQ)) Q:+LEXSEQ'>0 D
. . N LEXIEN,LEXSTA,LEXEXP,LEXA,LEXI
. . S LEXIEN=$P($G(ARY(LEXTY,LEXSEQ,"I")),"^",4)
. . S LEXSTA=$P($G(ARY(LEXTY,LEXSEQ,"I")),"^",3) S:LEXSTA'["Retire" LEXSTA=""
. . S LEXEXP=$G(ARY(LEXTY,LEXSEQ))
. . S:$L(LEXSTA) LEXEXP=LEXEXP_" ("_LEXSTA_")"
. . S:$D(LEXIIEN) LEXEXP=LEXEXP_" (IEN "_LEXIEN_")"
. . K LEXA S LEXA(1)=LEXEXP D PR^LEXU(.LEXA,70)
. . S LEXI=0 F S LEXI=$O(LEXA(LEXI)) Q:+LEXI'>0 D:LEXI=1 BL D TL((" "_$G(LEXA(LEXI))))
. . D ID(LEXTY,LEXSEQ,.ARY)
Q
ID(X,Y,ARY) ; Designation ID ID
N LEXC,LEXCT,LEXH,LEXID,LEXSEQ,LEXSTR,LEXT,LEXTTL,LEXTY S LEXTY=$G(X),LEXSEQ=$G(Y) Q:'$L(LEXTY) Q:+LEXSEQ'>0
Q:'$D(ARY(LEXTY,LEXSEQ,"ID")) Q:$O(ARY(LEXTY,LEXSEQ,"ID",0))'>0 S LEXT=20,LEXTTL="Designation ID"
S:$L($P($G(ARY(LEXTY,LEXSEQ,"ID",1,"I")),"^",3)) LEXTTL=LEXTTL_$J(" ",(LEXT-$L(LEXTTL)))_"Hierarchy "
S (LEXCT,LEXID)=0 F S LEXID=$O(ARY(LEXTY,LEXSEQ,"ID",LEXID)) Q:+LEXID'>0 D
. N LEXC,LEXH,LEXSTR S LEXC=$G(ARY(LEXTY,LEXSEQ,"ID",LEXID)) Q:'$L(LEXC)
. S LEXH=$P($G(ARY(LEXTY,LEXSEQ,"ID",LEXID,"I")),"^",3)
. S LEXSTR=LEXC S:$L(LEXH) LEXSTR=LEXSTR_$J(" ",((LEXT-2)-$L(LEXSTR)))_LEXH
. S LEXCT=LEXCT+1 D:LEXCT=1 TL((" "_LEXTTL)) D TL((" "_LEXSTR))
Q
SK(X,Y,ARY) ; Supplemental Keywords SK
N LEXA,LEXCL,LEXI,LEXK,LEXMX,LEXNM,LEXSEQ,LEXSK,LEXSTR,LEXTTL,LEXTY S LEXTY=$G(X),LEXSEQ=$G(Y) Q:'$L(LEXTY)
Q:+LEXSEQ'>0 Q:'$D(ARY(LEXTY,LEXSEQ,"SK")) Q:$O(ARY(LEXTY,LEXSEQ,"SK",0))'>0 S LEXMX=0
S LEXSK=0 F S LEXSK=$O(ARY(LEXTY,LEXSEQ,"SK",LEXSK)) Q:+LEXSK'>0 D
. N LEXK S LEXK=$G(ARY(LEXTY,LEXSEQ,"SK",LEXSK)) S:$L(LEXK)>LEXMX LEXMX=$L(LEXK)
S LEXMX=LEXMX+2,LEXNM=65\LEXMX,LEXTTL="Supplemental Keywords" K LEXA S LEXI=1,LEXSK=0,LEXCL=0
S LEXSTR="" K LEXA F S LEXSK=$O(ARY(LEXTY,LEXSEQ,"SK",LEXSK)) Q:+LEXSK'>0 D
. N LEXK S LEXK=$G(ARY(LEXTY,LEXSEQ,"SK",LEXSK)) Q:'$L(LEXK)
. S LEXSTR=LEXSTR_LEXK_$J(" ",(LEXMX-$L(LEXK))),LEXCL=LEXCL+1
. S:LEXCL'<LEXNM LEXA(LEXI)=LEXSTR,LEXCL=0,LEXSTR="",LEXI=LEXI+1
. S:LEXCL<LEXNM LEXA(LEXI)=LEXSTR
I $O(LEXA(0))>0 D
. N LEXI,LEXSTR D TL((" "_LEXTTL)) S LEXI=0 F S LEXI=$O(LEXA(LEXI)) Q:+LEXI'>0 D
. . N LEXSTR S LEXSTR=$$TM($G(LEXA(LEXI))) D TL((" "_LEXSTR))
Q
SR(ARY) ; Sources SR
N LEXA,LEXCT,LEXI,LEXIEN,LEXND,LEXNOM,LEXSAB,LEXSEQ,LEXSTR,LEXTTL
Q:'$D(ARY("SR")) Q:$O(ARY("SR",0))'>0
S LEXTTL="Sources",LEXCT=0
S LEXSEQ=0 F S LEXSEQ=$O(ARY("SR",LEXSEQ)) Q:+LEXSEQ'>0 D
. N LEXA,LEXIEN,LEXND,LEXNOM,LEXSAB,LEXSDO,LEXSTR S LEXND=$G(ARY("SR",LEXSEQ,"I"))
. S LEXSAB=$P(LEXND,"^",1) Q:'$L(LEXSAB) S LEXIEN=$O(^LEX(757.03,"ASAB",LEXSAB,0)) Q:LEXIEN'>0
. S LEXNOM=$P(LEXND,"^",2) Q:'$L(LEXNOM) S LEXSDO=$P(LEXND,"^",3) S:$D(LEXIIEN) LEXSDO=LEXSDO_" (IEN "_LEXIEN_")"
. S LEXA(1)=LEXSDO D PR^LEXU(.LEXA,(78-26)) S LEXSTR=LEXNOM,LEXSTR=LEXSTR_$J(" ",(15-$L(LEXSTR)))_LEXSAB,LEXCT=LEXCT+1
. D:LEXCT=1 BL,TL((" "_LEXTTL)),BL S LEXSTR=" "_LEXSTR
. S:$L(LEXA(1)) LEXSTR=LEXSTR_$J(" ",(27-$L(LEXSTR)))_$G(LEXA(1)) D TL(LEXSTR)
. I $O(LEXA(1))>1 D
. . N LEXI S LEXI=1 F S LEXI=$O(LEXA(LEXI)) Q:+LEXI'>0 D
. . . N LEXSTR S LEXSTR=$J(" ",27)_$G(LEXA(LEXI)) D TL(LEXSTR)
Q
CO(ARY) ; Codes CO
N LEXTTL,LEXSEQ,LEXCT S LEXTTL="Codes",(LEXSEQ,LEXCT)=0 F S LEXSEQ=$O(ARY("CO",LEXSEQ)) Q:+LEXSEQ'>0 D
. N LEXCO,LEXND,LEXST,LEXEF,LEXIE,LEXSR,LEXNM,LEXSTR S LEXCO=$G(ARY("CO",LEXSEQ)),LEXND=$G(ARY("CO",LEXSEQ,"I"))
. S LEXST=$P(LEXND,"^",1) Q:LEXST'?1N S LEXEF=$P(LEXND,"^",2) Q:LEXEF'?7N S LEXIE=$P(LEXND,"^",4) Q:LEXIE'>0
. S LEXSR=$P($G(^LEX(757.02,+LEXIE,0)),"^",3) Q:LEXSR'>0 S LEXNM=$P($G(^LEX(757.03,+LEXSR,0)),"^",2) Q:'$L(LEXNM)
. S LEXST=$S(LEXST>0:"Active",1:"Inactive"),LEXSTR=LEXCO,LEXSTR=LEXSTR_" "_$J(" ",(21-$L(LEXSTR)))_LEXNM
. S LEXSTR=LEXSTR_" "_$J(" ",(33-$L(LEXSTR)))_LEXST,LEXSTR=LEXSTR_" "_$J(" ",(43-$L(LEXSTR)))_$$FMTE^XLFDT(LEXEF,"5Z")
. S:$D(LEXIIEN) LEXSTR=LEXSTR_$J(" ",(51-$L(LEXSTR)))_" (IEN "_LEXIE_")" S LEXCT=LEXCT+1 D:LEXCT=1 BL,TL((" "_LEXTTL)),BL
. S LEXSTR=" "_LEXSTR D TL(LEXSTR) D MA(LEXCO,LEXSR,.ARY)
D:LEXCT>0&($G(LEXTYPE)'="T") BL
Q
MA(X,Y,ARY) ; Mappings MP
N LEXSEQ,LEXSRC,LEXSYS,LEXNOM,LEXTTL,LEXCT,LEXSEQ
S LEXSRC=$G(X),LEXSYS=$G(Y) Q:'$L(LEXSRC) Q:+LEXSYS'>0 S LEXNOM=$P($G(^LEX(757.03,+LEXSYS,0)),"^",2)
Q:'$L(LEXNOM) S LEXTTL="Mappings",(LEXCT,LEXSEQ)=0 F S LEXSEQ=$O(ARY("MP",LEXSEQ)) Q:+LEXSEQ'>0 D
. N LEXTAR,LEXND,LEXTST,LEXTEF,LEXTSY,LEXIEN,LEXMAT,LEXSTR S LEXTAR=$G(ARY("MP",LEXSEQ)),LEXND=$G(ARY("MP",LEXSEQ,"I"))
. Q:$P(LEXND,"^",6)'=LEXSRC Q:$P(LEXND,"^",7)'=LEXSYS S LEXTST=$P(LEXND,"^",1) Q:LEXTST'?1N
. S LEXTST=$S(LEXTST>0:"Active",1:"Inactive"),LEXTEF=$P(LEXND,"^",2) Q:LEXTEF'?7N
. S LEXTEF=$$FMTE^XLFDT(LEXTEF,"5Z"),LEXTSY=$P(LEXND,"^",3) Q:'$L(LEXTSY)
. S LEXIEN=$P(LEXND,"^",4) Q:+LEXIEN'>0 S LEXMAT=$P(LEXND,"^",5) Q:'$L(LEXMAT)
. S LEXCT=LEXCT+1 D:LEXCT=1 TL((" "_LEXTTL)) S LEXSTR=LEXTAR
. S LEXSTR=LEXSTR_" "_$J(" ",(17-$L(LEXSTR)))_LEXTSY,LEXSTR=LEXSTR_" "_$J(" ",(29-$L(LEXSTR)))_LEXTST
. S LEXSTR=LEXSTR_" "_$J(" ",(39-$L(LEXSTR)))_LEXTEF S:$D(LEXIIEN) LEXSTR=LEXSTR_$J(" ",(51-$L(LEXSTR)))_" (IEN "_LEXIEN_")"
. D TL((" "_LEXSTR))
Q
DC(ARY) ; Diagnostic Categories (ICD-10-CM) DC
Q:'$D(ARY("CO","B",30)) N LEXSEQ,LEXTTL,LEXCT S LEXTTL="Diagnostic Categories (ICD-10-CM)",(LEXCT,LEXSEQ)=0
F S LEXSEQ=$O(ARY("DC",LEXSEQ)) Q:+LEXSEQ'>0 D
. N LEXA,LEXDC,LEXND,LEXI,LEXST,LEXEF,LEXNM,LEXIE,LEXSTR,LEXT
. S LEXDC=$G(ARY("DC",LEXSEQ)),LEXND=$G(ARY("DC",LEXSEQ,"I")),LEXST=$P(LEXND,"^",1),LEXEF=$P(LEXND,"^",2)
. S LEXNM=$P(LEXND,"^",3),LEXIE=$P(LEXND,"^",4) S:$D(LEXIIEN) LEXNM=LEXNM_" (IEN "_LEXIE_")"
. K LEXA S LEXA(1)=LEXNM D PR^LEXU(.LEXA,61) S LEXSTR=LEXDC,LEXSTR=LEXSTR_$J(" ",(12-$L(LEXSTR)))_$G(LEXA(1))
. S LEXCT=LEXCT+1 D:LEXCT=1 BL,TL((" "_LEXTTL)),BL S LEXSTR=" "_LEXSTR D TL(LEXSTR)
. S LEXI=1 F S LEXI=$O(LEXA(LEXI)) Q:+LEXI'>0 D
. . N LEXT S LEXT="",LEXT=LEXT_$J(" ",(12-$L(LEXT)))_$G(LEXA(LEXI)) S LEXT=" "_LEXT D TL(LEXT)
Q
CP(ARY) ; Character Positions (ICD-10-PCS) CP
Q:'$D(ARY("CO","B",31)) N LEXSEQ,LEXTTL,LEXCT,LEXCODE S LEXTTL="Procedure Character Positions (ICD-10-PCS)"
S (LEXCT,LEXSEQ)=0,LEXCODE=$G(ARY("CP","I"))
F S LEXSEQ=$O(ARY("CP",LEXSEQ)) Q:+LEXSEQ'>0 D
. N LEXA,LEXDC,LEXND,LEXI,LEXST,LEXEF,LEXNM,LEXIE,LEXSTR,LEXT
. S LEXDC=$G(ARY("CP",LEXSEQ)),LEXND=$G(ARY("CP",LEXSEQ,"I")),LEXST=$P(LEXND,"^",1),LEXEF=$P(LEXND,"^",2)
. S LEXNM=$P(LEXND,"^",3),LEXIE=$P(LEXND,"^",4) S:$D(LEXIIEN) LEXNM=LEXNM_" (IEN "_LEXIE_")"
. K LEXA S LEXA(1)=LEXNM D PR^LEXU(.LEXA,61) S LEXSTR=LEXDC,LEXSTR=LEXSTR_$J(" ",(12-$L(LEXSTR)))_$G(LEXA(1))
. S LEXCT=LEXCT+1 I LEXCT=1 D
. . N LEXT D BL,TL((" "_LEXTTL)),BL I $L($G(LEXCODE)) D
. . . S LEXT=LEXCODE,LEXT=LEXT_$J(" ",(12-$L(LEXT)))_"Code",LEXT=" "_LEXT D TL(LEXT)
. S LEXSTR=" "_LEXSTR D TL(LEXSTR)
. S LEXI=1 F S LEXI=$O(LEXA(LEXI)) Q:+LEXI'>0 D
. . N LEXT S LEXT="",LEXT=LEXT_$J(" ",(12-$L(LEXT)))_$G(LEXA(LEXI)) S LEXT=" "_LEXT D TL(LEXT)
Q
SB(ARY) ; Subsets SB
N LEXA,LEXCT,LEXI,LEXSEQ,LEXTTL,LEXT
S LEXTTL="Subsets",(LEXCT,LEXSEQ)=0 F S LEXSEQ=$O(ARY("SB",LEXSEQ)) Q:LEXSEQ'>0 D
. N LEXND,LEXNM,LEXST,LEXSS,LEXEX,LEXIE,LEXAB,LEXT S LEXNM=$G(ARY("SB",LEXSEQ)) Q:'$L(LEXNM)
. S LEXND=$G(ARY("SB",LEXSEQ,"I")),LEXST=+LEXND,LEXSS=$P(LEXND,"^",2),LEXEX=$P(LEXND,"^",3)
. S LEXIE=$P(LEXND,"^",4),LEXAB=$P(LEXND,"^",5) Q:$L(LEXAB)'=3 S LEXT=LEXNM
. S LEXT=LEXT_$J(" ",(36-$L(LEXT)))_LEXAB S:$D(LEXIIEN) LEXT=LEXT_" (IEN "_LEXIE_")"
. S LEXCT=LEXCT+1 D:LEXCT=1 BL,TL((" "_LEXTTL)),BL S LEXT=" "_LEXT D TL(LEXT)
Q
;
DEV ; Device/Output
N %ZIS,LEXCF,LEXCONT,LEXDNC,LEXEOP,LEXI,LEXLC,ZTDESC,ZTDTH,ZTIO,ZTQUEUED,ZTREQ,ZTRTN,ZTSAVE,ZTSK,POP
S %ZIS("A")=" Device: ",ZTRTN="OUT^LEXINF5",ZTDESC="Display Lexicon Data"
S ZTIO=ION,ZTDTH=$H,%ZIS="Q",ZTSAVE(("^TMP(""LEXINF"","_$J_","))="" D ^%ZIS I POP K %ZIS("A"),^TMP("LEXINF",$J) Q
S ZTIO=ION I $D(IO("Q")) D QUE,^%ZISC,HOME^%ZIS K %ZIS("A") Q
K %ZIS("A") D NOQUE K ^TMP("LEXINF",$J) Q
NOQUE ; Do not queue Display
W @IOF W:IOST["P-" !,"< Not queued, printing Lexicon data >",! U:IOST["P-" IO D @ZTRTN,^%ZISC,HOME^%ZIS Q
QUE ; Task queued to print Help
K IO("Q") D ^%ZTLOAD W !,$S($D(ZTSK):"Request Queued",1:"Request Cancelled"),! Q
Q
OUT ; Output
Q:'$D(^TMP("LEXINF",$J)) W:$L($G(IOF))&($G(IOST)'["P-MESSAGE") @IOF
N LEXLN,LEXLC,LEXCF,LEXCONT,LEXEOP,LEXIT S LEXIT=0,LEXEOP=+($G(IOSL))
S:LEXEOP=0 LEXEOP=24 S LEXEOP=LEXEOP-2 S (LEXLC,LEXLN)=0 F S LEXLN=$O(^TMP("LEXINF",$J,LEXLN)) Q:+LEXLN'>0 D Q:LEXIT
. N LEXT S LEXT=$G(^TMP("LEXINF",$J,LEXLN)) W !," ",LEXT S LEXCF=0 D LF
I LEXCF,LEXIT>0 D EOP W:$L($G(IOF)) @IOF K ^TMP("LEXINF",$J) Q
I 'LEXCF D EOP W:$L($G(IOF)) @IOF
K ^TMP("LEXINF",$J)
Q
LF ; Line Feed
S LEXLC=LEXLC+1 D:IOST["P-"&(LEXLC>(LEXEOP-7)) EOP D:IOST'["P-"&(LEXLC>(LEXEOP-4)) EOP
Q
EOP ; End of Page
N LEXCONT S LEXLC=0 W:IOST["P-" @IOF Q:IOST["P-" W !! S LEXCONT=$$CONT S LEXCF=1
Q
CONT(X) ; Ask to Continue
Q:+($G(LEXIT))>0 "^^" N DIR,DIROUT,DIRUT,DUOUT,DTOUT,Y S DIR(0)="EAO",DIR("A")=" Enter RETURN to continue or '^' to exit: "
S DIR("PRE")="S:X[""?"" X=""??"" S:X[""^"" X=""^""",(DIR("?"),DIR("??"))="^D CONTH^LEXINF5"
D ^DIR S:X["^"!($D(DTOUT)) LEXIT=1 Q:$D(DIROUT)!($D(DIRUT))!($D(DUOUT))!($D(DTOUT))!(X["^") "^"
Q ""
CONTH ; Ask to Continue Help
W !," Enter either RETURN or '^'."
Q
;
; Miscellaneous
BL ; Blank Line
D TL(" ")
Q
TL(X) ; Text Line
W:$D(TEST) !,$G(X) Q:$D(TEST)
N LEXI S LEXI=$O(^TMP("LEXINF",$J," "),-1)+1 S ^TMP("LEXINF",$J,LEXI)=$G(X)
Q
TM(X,Y) ; Trim Character Y - Default " "
S X=$G(X) Q:X="" X S Y=$G(Y) S:'$L(Y) Y=" "
F Q:$E(X,1)'=Y S X=$E(X,2,$L(X))
F Q:$E(X,$L(X))'=Y S X=$E(X,1,($L(X)-1))
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXINF5 12986 printed Dec 13, 2024@02:08:08 Page 2
LEXINF5 ;ISL/KER - Information - Display ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.02 SACC 1.3
+5 ; ^LEX(757.03 SACC 1.3
+6 ; ^TMP("LEXINF" SACC 2.3.2.5.1
+7 ;
+8 ; External References
+9 ; ^%ZIS ICR 10086
+10 ; HOME^%ZIS ICR 10086
+11 ; ^%ZISC ICR 10089
+12 ; ^%ZTLOAD ICR 10063
+13 ; ^DIR ICR 10026
+14 ; $$FMTE^XLFDT ICR 10103
+15 ;
TERM(ARY) ; Display by Expression
+1 KILL ^TMP("LEXINF",$JOB)
NEW LEXTYPE
SET LEXTYPE="T"
DO MP(.ARY)
DO FS(.ARY)
DO OT(.ARY)
DO CO(.ARY)
DO SR(.ARY)
DO SB(.ARY)
DO DC(.ARY)
DO CP(.ARY)
if $DATA(^TMP("LEXINF",$JOB))
DO DEV
+2 QUIT
CODE(ARY) ; Display by Code
+1 KILL ^TMP("LEXINF",$JOB)
SET LEXTYPE="C"
DO CO(.ARY)
DO MP(.ARY)
DO FS(.ARY)
DO OT(.ARY)
DO SR(.ARY)
DO SB(.ARY)
DO DC(.ARY)
DO CP(.ARY)
if $DATA(^TMP("LEXINF",$JOB))
DO DEV
+2 QUIT
+3 ;
+4 ; Display Components
MP(ARY) ; Major Concept/Preferred Term MC/PF
+1 NEW LEXA,LEXEXP,LEXI,LEXMC,LEXPF,LEXTTL
SET LEXMC=$PIECE($GET(ARY("MC",1,"I")),"^",4)
if LEXMC'>0
QUIT
+2 SET LEXPF=$PIECE($GET(ARY("PF",1,"I")),"^",4)
SET LEXTTL="Major Concept"
if LEXPF=LEXMC
SET LEXTTL=LEXTTL_"/Preferred Term"
+3 SET LEXEXP=$GET(ARY("MC",1))
if '$LENGTH(LEXEXP)
QUIT
if $DATA(LEXIIEN)
SET LEXEXP=LEXEXP_" (IEN "_LEXMC_")"
+4 KILL LEXA
SET LEXA(1)=LEXEXP
DO PR^LEXU(.LEXA,70)
DO TL((" "_LEXTTL))
SET LEXI=0
+5 FOR
SET LEXI=$ORDER(LEXA(LEXI))
if +LEXI'>0
QUIT
if LEXI=1
DO BL
DO TL((" "_$GET(LEXA(LEXI))))
+6 DO ID("MC",1,.ARY)
DO SK("MC",1,.ARY)
IF LEXPF>0
IF LEXPF'=LEXMC
Begin DoDot:1
+7 NEW LEXEXP,LEXA,LEXTTL,LEXI
SET LEXEXP=$GET(ARY("PF",1))
if $DATA(LEXIIEN)
SET LEXEXP=LEXEXP_" (IEN "_+LEXPF_")"
+8 SET LEXTTL="Preferred Term"
KILL LEXA
SET LEXA(1)=LEXEXP
DO PR^LEXU(.LEXA,70)
+9 DO BL
DO TL((" "_LEXTTL))
SET LEXI=0
FOR
SET LEXI=$ORDER(LEXA(LEXI))
if +LEXI'>0
QUIT
if LEXI=1
DO BL
DO TL((" "_$GET(LEXA(LEXI))))
+10 DO ID("PF",1,.ARY)
DO SK("PF",1,.ARY)
End DoDot:1
+11 NEW LEXIIEN,TEST
+12 QUIT
FS(ARY) ; Fully Specified Names FS
+1 NEW LEXA,LEXEXP,LEXI,LEXIEN,LEXSEQ,LEXSTA,LEXTTL
SET LEXTTL="Fully Specified Name"
+2 if $ORDER(ARY("FS"," "),-1)>1
SET LEXTTL=LEXTTL_"s"
if $ORDER(ARY("FS",0))>0
DO BL
DO TL((" "_LEXTTL))
+3 SET LEXSEQ=0
FOR
SET LEXSEQ=$ORDER(ARY("FS",LEXSEQ))
if +LEXSEQ'>0
QUIT
Begin DoDot:1
+4 NEW LEXA,LEXEXP,LEXI,LEXIEN,LEXSTA
+5 SET LEXIEN=$PIECE($GET(ARY("FS",LEXSEQ,"I")),"^",4)
if LEXIEN'>0
QUIT
+6 SET LEXSTA=$PIECE($GET(ARY("FS",LEXSEQ,"I")),"^",3)
if LEXSTA'["Retire"
SET LEXSTA=""
+7 SET LEXEXP=$GET(ARY("FS",LEXSEQ))
if '$LENGTH(LEXEXP)
QUIT
+8 if $LENGTH(LEXSTA)
SET LEXEXP=LEXEXP_" ("_LEXSTA_")"
+9 if $DATA(LEXIIEN)
SET LEXEXP=LEXEXP_" (IEN "_LEXIEN_")"
KILL LEXA
SET LEXA(1)=LEXEXP
DO PR^LEXU(.LEXA,70)
+10 SET LEXI=0
FOR
SET LEXI=$ORDER(LEXA(LEXI))
if +LEXI'>0
QUIT
if LEXI=1
DO BL
DO TL((" "_$GET(LEXA(LEXI))))
+11 DO ID("FS",LEXSEQ,.ARY)
+12 DO SK("FS",LEXSEQ,.ARY)
End DoDot:1
+13 QUIT
OT(ARY) ; Other Terms SY/LV
+1 NEW LEXPF,LEXTY
SET LEXPF=$PIECE($GET(ARY("PF",1,"I")),"^",4)
FOR LEXTY="SY","LV"
Begin DoDot:1
+2 NEW LEXTTL,LEXSEQ
SET LEXTTL=$SELECT(LEXTY="LV":"Lexical Variant",1:"Synonym")
+3 if $ORDER(ARY(LEXTY," "),-1)>1
SET LEXTTL=LEXTTL_"s"
if $ORDER(ARY(LEXTY,0))>0
DO BL
DO TL((" "_LEXTTL))
+4 SET LEXSEQ=0
FOR
SET LEXSEQ=$ORDER(ARY(LEXTY,LEXSEQ))
if +LEXSEQ'>0
QUIT
Begin DoDot:2
+5 NEW LEXIEN,LEXSTA,LEXEXP,LEXA,LEXI
+6 SET LEXIEN=$PIECE($GET(ARY(LEXTY,LEXSEQ,"I")),"^",4)
+7 SET LEXSTA=$PIECE($GET(ARY(LEXTY,LEXSEQ,"I")),"^",3)
if LEXSTA'["Retire"
SET LEXSTA=""
+8 SET LEXEXP=$GET(ARY(LEXTY,LEXSEQ))
+9 if $LENGTH(LEXSTA)
SET LEXEXP=LEXEXP_" ("_LEXSTA_")"
+10 if $DATA(LEXIIEN)
SET LEXEXP=LEXEXP_" (IEN "_LEXIEN_")"
+11 KILL LEXA
SET LEXA(1)=LEXEXP
DO PR^LEXU(.LEXA,70)
+12 SET LEXI=0
FOR
SET LEXI=$ORDER(LEXA(LEXI))
if +LEXI'>0
QUIT
if LEXI=1
DO BL
DO TL((" "_$GET(LEXA(LEXI))))
+13 DO ID(LEXTY,LEXSEQ,.ARY)
End DoDot:2
End DoDot:1
+14 QUIT
ID(X,Y,ARY) ; Designation ID ID
+1 NEW LEXC,LEXCT,LEXH,LEXID,LEXSEQ,LEXSTR,LEXT,LEXTTL,LEXTY
SET LEXTY=$GET(X)
SET LEXSEQ=$GET(Y)
if '$LENGTH(LEXTY)
QUIT
if +LEXSEQ'>0
QUIT
+2 if '$DATA(ARY(LEXTY,LEXSEQ,"ID"))
QUIT
if $ORDER(ARY(LEXTY,LEXSEQ,"ID",0))'>0
QUIT
SET LEXT=20
SET LEXTTL="Designation ID"
+3 if $LENGTH($PIECE($GET(ARY(LEXTY,LEXSEQ,"ID",1,"I")),"^",3))
SET LEXTTL=LEXTTL_$JUSTIFY(" ",(LEXT-$LENGTH(LEXTTL)))_"Hierarchy "
+4 SET (LEXCT,LEXID)=0
FOR
SET LEXID=$ORDER(ARY(LEXTY,LEXSEQ,"ID",LEXID))
if +LEXID'>0
QUIT
Begin DoDot:1
+5 NEW LEXC,LEXH,LEXSTR
SET LEXC=$GET(ARY(LEXTY,LEXSEQ,"ID",LEXID))
if '$LENGTH(LEXC)
QUIT
+6 SET LEXH=$PIECE($GET(ARY(LEXTY,LEXSEQ,"ID",LEXID,"I")),"^",3)
+7 SET LEXSTR=LEXC
if $LENGTH(LEXH)
SET LEXSTR=LEXSTR_$JUSTIFY(" ",((LEXT-2)-$LENGTH(LEXSTR)))_LEXH
+8 SET LEXCT=LEXCT+1
if LEXCT=1
DO TL((" "_LEXTTL))
DO TL((" "_LEXSTR))
End DoDot:1
+9 QUIT
SK(X,Y,ARY) ; Supplemental Keywords SK
+1 NEW LEXA,LEXCL,LEXI,LEXK,LEXMX,LEXNM,LEXSEQ,LEXSK,LEXSTR,LEXTTL,LEXTY
SET LEXTY=$GET(X)
SET LEXSEQ=$GET(Y)
if '$LENGTH(LEXTY)
QUIT
+2 if +LEXSEQ'>0
QUIT
if '$DATA(ARY(LEXTY,LEXSEQ,"SK"))
QUIT
if $ORDER(ARY(LEXTY,LEXSEQ,"SK",0))'>0
QUIT
SET LEXMX=0
+3 SET LEXSK=0
FOR
SET LEXSK=$ORDER(ARY(LEXTY,LEXSEQ,"SK",LEXSK))
if +LEXSK'>0
QUIT
Begin DoDot:1
+4 NEW LEXK
SET LEXK=$GET(ARY(LEXTY,LEXSEQ,"SK",LEXSK))
if $LENGTH(LEXK)>LEXMX
SET LEXMX=$LENGTH(LEXK)
End DoDot:1
+5 SET LEXMX=LEXMX+2
SET LEXNM=65\LEXMX
SET LEXTTL="Supplemental Keywords"
KILL LEXA
SET LEXI=1
SET LEXSK=0
SET LEXCL=0
+6 SET LEXSTR=""
KILL LEXA
FOR
SET LEXSK=$ORDER(ARY(LEXTY,LEXSEQ,"SK",LEXSK))
if +LEXSK'>0
QUIT
Begin DoDot:1
+7 NEW LEXK
SET LEXK=$GET(ARY(LEXTY,LEXSEQ,"SK",LEXSK))
if '$LENGTH(LEXK)
QUIT
+8 SET LEXSTR=LEXSTR_LEXK_$JUSTIFY(" ",(LEXMX-$LENGTH(LEXK)))
SET LEXCL=LEXCL+1
+9 if LEXCL'<LEXNM
SET LEXA(LEXI)=LEXSTR
SET LEXCL=0
SET LEXSTR=""
SET LEXI=LEXI+1
+10 if LEXCL<LEXNM
SET LEXA(LEXI)=LEXSTR
End DoDot:1
+11 IF $ORDER(LEXA(0))>0
Begin DoDot:1
+12 NEW LEXI,LEXSTR
DO TL((" "_LEXTTL))
SET LEXI=0
FOR
SET LEXI=$ORDER(LEXA(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:2
+13 NEW LEXSTR
SET LEXSTR=$$TM($GET(LEXA(LEXI)))
DO TL((" "_LEXSTR))
End DoDot:2
End DoDot:1
+14 QUIT
SR(ARY) ; Sources SR
+1 NEW LEXA,LEXCT,LEXI,LEXIEN,LEXND,LEXNOM,LEXSAB,LEXSEQ,LEXSTR,LEXTTL
+2 if '$DATA(ARY("SR"))
QUIT
if $ORDER(ARY("SR",0))'>0
QUIT
+3 SET LEXTTL="Sources"
SET LEXCT=0
+4 SET LEXSEQ=0
FOR
SET LEXSEQ=$ORDER(ARY("SR",LEXSEQ))
if +LEXSEQ'>0
QUIT
Begin DoDot:1
+5 NEW LEXA,LEXIEN,LEXND,LEXNOM,LEXSAB,LEXSDO,LEXSTR
SET LEXND=$GET(ARY("SR",LEXSEQ,"I"))
+6 SET LEXSAB=$PIECE(LEXND,"^",1)
if '$LENGTH(LEXSAB)
QUIT
SET LEXIEN=$ORDER(^LEX(757.03,"ASAB",LEXSAB,0))
if LEXIEN'>0
QUIT
+7 SET LEXNOM=$PIECE(LEXND,"^",2)
if '$LENGTH(LEXNOM)
QUIT
SET LEXSDO=$PIECE(LEXND,"^",3)
if $DATA(LEXIIEN)
SET LEXSDO=LEXSDO_" (IEN "_LEXIEN_")"
+8 SET LEXA(1)=LEXSDO
DO PR^LEXU(.LEXA,(78-26))
SET LEXSTR=LEXNOM
SET LEXSTR=LEXSTR_$JUSTIFY(" ",(15-$LENGTH(LEXSTR)))_LEXSAB
SET LEXCT=LEXCT+1
+9 if LEXCT=1
DO BL
DO TL((" "_LEXTTL))
DO BL
SET LEXSTR=" "_LEXSTR
+10 if $LENGTH(LEXA(1))
SET LEXSTR=LEXSTR_$JUSTIFY(" ",(27-$LENGTH(LEXSTR)))_$GET(LEXA(1))
DO TL(LEXSTR)
+11 IF $ORDER(LEXA(1))>1
Begin DoDot:2
+12 NEW LEXI
SET LEXI=1
FOR
SET LEXI=$ORDER(LEXA(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:3
+13 NEW LEXSTR
SET LEXSTR=$JUSTIFY(" ",27)_$GET(LEXA(LEXI))
DO TL(LEXSTR)
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT
CO(ARY) ; Codes CO
+1 NEW LEXTTL,LEXSEQ,LEXCT
SET LEXTTL="Codes"
SET (LEXSEQ,LEXCT)=0
FOR
SET LEXSEQ=$ORDER(ARY("CO",LEXSEQ))
if +LEXSEQ'>0
QUIT
Begin DoDot:1
+2 NEW LEXCO,LEXND,LEXST,LEXEF,LEXIE,LEXSR,LEXNM,LEXSTR
SET LEXCO=$GET(ARY("CO",LEXSEQ))
SET LEXND=$GET(ARY("CO",LEXSEQ,"I"))
+3 SET LEXST=$PIECE(LEXND,"^",1)
if LEXST'?1N
QUIT
SET LEXEF=$PIECE(LEXND,"^",2)
if LEXEF'?7N
QUIT
SET LEXIE=$PIECE(LEXND,"^",4)
if LEXIE'>0
QUIT
+4 SET LEXSR=$PIECE($GET(^LEX(757.02,+LEXIE,0)),"^",3)
if LEXSR'>0
QUIT
SET LEXNM=$PIECE($GET(^LEX(757.03,+LEXSR,0)),"^",2)
if '$LENGTH(LEXNM)
QUIT
+5 SET LEXST=$SELECT(LEXST>0:"Active",1:"Inactive")
SET LEXSTR=LEXCO
SET LEXSTR=LEXSTR_" "_$JUSTIFY(" ",(21-$LENGTH(LEXSTR)))_LEXNM
+6 SET LEXSTR=LEXSTR_" "_$JUSTIFY(" ",(33-$LENGTH(LEXSTR)))_LEXST
SET LEXSTR=LEXSTR_" "_$JUSTIFY(" ",(43-$LENGTH(LEXSTR)))_$$FMTE^XLFDT(LEXEF,"5Z")
+7 if $DATA(LEXIIEN)
SET LEXSTR=LEXSTR_$JUSTIFY(" ",(51-$LENGTH(LEXSTR)))_" (IEN "_LEXIE_")"
SET LEXCT=LEXCT+1
if LEXCT=1
DO BL
DO TL((" "_LEXTTL))
DO BL
+8 SET LEXSTR=" "_LEXSTR
DO TL(LEXSTR)
DO MA(LEXCO,LEXSR,.ARY)
End DoDot:1
+9 if LEXCT>0&($GET(LEXTYPE)'="T")
DO BL
+10 QUIT
MA(X,Y,ARY) ; Mappings MP
+1 NEW LEXSEQ,LEXSRC,LEXSYS,LEXNOM,LEXTTL,LEXCT,LEXSEQ
+2 SET LEXSRC=$GET(X)
SET LEXSYS=$GET(Y)
if '$LENGTH(LEXSRC)
QUIT
if +LEXSYS'>0
QUIT
SET LEXNOM=$PIECE($GET(^LEX(757.03,+LEXSYS,0)),"^",2)
+3 if '$LENGTH(LEXNOM)
QUIT
SET LEXTTL="Mappings"
SET (LEXCT,LEXSEQ)=0
FOR
SET LEXSEQ=$ORDER(ARY("MP",LEXSEQ))
if +LEXSEQ'>0
QUIT
Begin DoDot:1
+4 NEW LEXTAR,LEXND,LEXTST,LEXTEF,LEXTSY,LEXIEN,LEXMAT,LEXSTR
SET LEXTAR=$GET(ARY("MP",LEXSEQ))
SET LEXND=$GET(ARY("MP",LEXSEQ,"I"))
+5 if $PIECE(LEXND,"^",6)'=LEXSRC
QUIT
if $PIECE(LEXND,"^",7)'=LEXSYS
QUIT
SET LEXTST=$PIECE(LEXND,"^",1)
if LEXTST'?1N
QUIT
+6 SET LEXTST=$SELECT(LEXTST>0:"Active",1:"Inactive")
SET LEXTEF=$PIECE(LEXND,"^",2)
if LEXTEF'?7N
QUIT
+7 SET LEXTEF=$$FMTE^XLFDT(LEXTEF,"5Z")
SET LEXTSY=$PIECE(LEXND,"^",3)
if '$LENGTH(LEXTSY)
QUIT
+8 SET LEXIEN=$PIECE(LEXND,"^",4)
if +LEXIEN'>0
QUIT
SET LEXMAT=$PIECE(LEXND,"^",5)
if '$LENGTH(LEXMAT)
QUIT
+9 SET LEXCT=LEXCT+1
if LEXCT=1
DO TL((" "_LEXTTL))
SET LEXSTR=LEXTAR
+10 SET LEXSTR=LEXSTR_" "_$JUSTIFY(" ",(17-$LENGTH(LEXSTR)))_LEXTSY
SET LEXSTR=LEXSTR_" "_$JUSTIFY(" ",(29-$LENGTH(LEXSTR)))_LEXTST
+11 SET LEXSTR=LEXSTR_" "_$JUSTIFY(" ",(39-$LENGTH(LEXSTR)))_LEXTEF
if $DATA(LEXIIEN)
SET LEXSTR=LEXSTR_$JUSTIFY(" ",(51-$LENGTH(LEXSTR)))_" (IEN "_LEXIEN_")"
+12 DO TL((" "_LEXSTR))
End DoDot:1
+13 QUIT
DC(ARY) ; Diagnostic Categories (ICD-10-CM) DC
+1 if '$DATA(ARY("CO","B",30))
QUIT
NEW LEXSEQ,LEXTTL,LEXCT
SET LEXTTL="Diagnostic Categories (ICD-10-CM)"
SET (LEXCT,LEXSEQ)=0
+2 FOR
SET LEXSEQ=$ORDER(ARY("DC",LEXSEQ))
if +LEXSEQ'>0
QUIT
Begin DoDot:1
+3 NEW LEXA,LEXDC,LEXND,LEXI,LEXST,LEXEF,LEXNM,LEXIE,LEXSTR,LEXT
+4 SET LEXDC=$GET(ARY("DC",LEXSEQ))
SET LEXND=$GET(ARY("DC",LEXSEQ,"I"))
SET LEXST=$PIECE(LEXND,"^",1)
SET LEXEF=$PIECE(LEXND,"^",2)
+5 SET LEXNM=$PIECE(LEXND,"^",3)
SET LEXIE=$PIECE(LEXND,"^",4)
if $DATA(LEXIIEN)
SET LEXNM=LEXNM_" (IEN "_LEXIE_")"
+6 KILL LEXA
SET LEXA(1)=LEXNM
DO PR^LEXU(.LEXA,61)
SET LEXSTR=LEXDC
SET LEXSTR=LEXSTR_$JUSTIFY(" ",(12-$LENGTH(LEXSTR)))_$GET(LEXA(1))
+7 SET LEXCT=LEXCT+1
if LEXCT=1
DO BL
DO TL((" "_LEXTTL))
DO BL
SET LEXSTR=" "_LEXSTR
DO TL(LEXSTR)
+8 SET LEXI=1
FOR
SET LEXI=$ORDER(LEXA(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:2
+9 NEW LEXT
SET LEXT=""
SET LEXT=LEXT_$JUSTIFY(" ",(12-$LENGTH(LEXT)))_$GET(LEXA(LEXI))
SET LEXT=" "_LEXT
DO TL(LEXT)
End DoDot:2
End DoDot:1
+10 QUIT
CP(ARY) ; Character Positions (ICD-10-PCS) CP
+1 if '$DATA(ARY("CO","B",31))
QUIT
NEW LEXSEQ,LEXTTL,LEXCT,LEXCODE
SET LEXTTL="Procedure Character Positions (ICD-10-PCS)"
+2 SET (LEXCT,LEXSEQ)=0
SET LEXCODE=$GET(ARY("CP","I"))
+3 FOR
SET LEXSEQ=$ORDER(ARY("CP",LEXSEQ))
if +LEXSEQ'>0
QUIT
Begin DoDot:1
+4 NEW LEXA,LEXDC,LEXND,LEXI,LEXST,LEXEF,LEXNM,LEXIE,LEXSTR,LEXT
+5 SET LEXDC=$GET(ARY("CP",LEXSEQ))
SET LEXND=$GET(ARY("CP",LEXSEQ,"I"))
SET LEXST=$PIECE(LEXND,"^",1)
SET LEXEF=$PIECE(LEXND,"^",2)
+6 SET LEXNM=$PIECE(LEXND,"^",3)
SET LEXIE=$PIECE(LEXND,"^",4)
if $DATA(LEXIIEN)
SET LEXNM=LEXNM_" (IEN "_LEXIE_")"
+7 KILL LEXA
SET LEXA(1)=LEXNM
DO PR^LEXU(.LEXA,61)
SET LEXSTR=LEXDC
SET LEXSTR=LEXSTR_$JUSTIFY(" ",(12-$LENGTH(LEXSTR)))_$GET(LEXA(1))
+8 SET LEXCT=LEXCT+1
IF LEXCT=1
Begin DoDot:2
+9 NEW LEXT
DO BL
DO TL((" "_LEXTTL))
DO BL
IF $LENGTH($GET(LEXCODE))
Begin DoDot:3
+10 SET LEXT=LEXCODE
SET LEXT=LEXT_$JUSTIFY(" ",(12-$LENGTH(LEXT)))_"Code"
SET LEXT=" "_LEXT
DO TL(LEXT)
End DoDot:3
End DoDot:2
+11 SET LEXSTR=" "_LEXSTR
DO TL(LEXSTR)
+12 SET LEXI=1
FOR
SET LEXI=$ORDER(LEXA(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:2
+13 NEW LEXT
SET LEXT=""
SET LEXT=LEXT_$JUSTIFY(" ",(12-$LENGTH(LEXT)))_$GET(LEXA(LEXI))
SET LEXT=" "_LEXT
DO TL(LEXT)
End DoDot:2
End DoDot:1
+14 QUIT
SB(ARY) ; Subsets SB
+1 NEW LEXA,LEXCT,LEXI,LEXSEQ,LEXTTL,LEXT
+2 SET LEXTTL="Subsets"
SET (LEXCT,LEXSEQ)=0
FOR
SET LEXSEQ=$ORDER(ARY("SB",LEXSEQ))
if LEXSEQ'>0
QUIT
Begin DoDot:1
+3 NEW LEXND,LEXNM,LEXST,LEXSS,LEXEX,LEXIE,LEXAB,LEXT
SET LEXNM=$GET(ARY("SB",LEXSEQ))
if '$LENGTH(LEXNM)
QUIT
+4 SET LEXND=$GET(ARY("SB",LEXSEQ,"I"))
SET LEXST=+LEXND
SET LEXSS=$PIECE(LEXND,"^",2)
SET LEXEX=$PIECE(LEXND,"^",3)
+5 SET LEXIE=$PIECE(LEXND,"^",4)
SET LEXAB=$PIECE(LEXND,"^",5)
if $LENGTH(LEXAB)'=3
QUIT
SET LEXT=LEXNM
+6 SET LEXT=LEXT_$JUSTIFY(" ",(36-$LENGTH(LEXT)))_LEXAB
if $DATA(LEXIIEN)
SET LEXT=LEXT_" (IEN "_LEXIE_")"
+7 SET LEXCT=LEXCT+1
if LEXCT=1
DO BL
DO TL((" "_LEXTTL))
DO BL
SET LEXT=" "_LEXT
DO TL(LEXT)
End DoDot:1
+8 QUIT
+9 ;
DEV ; Device/Output
+1 NEW %ZIS,LEXCF,LEXCONT,LEXDNC,LEXEOP,LEXI,LEXLC,ZTDESC,ZTDTH,ZTIO,ZTQUEUED,ZTREQ,ZTRTN,ZTSAVE,ZTSK,POP
+2 SET %ZIS("A")=" Device: "
SET ZTRTN="OUT^LEXINF5"
SET ZTDESC="Display Lexicon Data"
+3 SET ZTIO=ION
SET ZTDTH=$HOROLOG
SET %ZIS="Q"
SET ZTSAVE(("^TMP(""LEXINF"","_$JOB_","))=""
DO ^%ZIS
IF POP
KILL %ZIS("A"),^TMP("LEXINF",$JOB)
QUIT
+4 SET ZTIO=ION
IF $DATA(IO("Q"))
DO QUE
DO ^%ZISC
DO HOME^%ZIS
KILL %ZIS("A")
QUIT
+5 KILL %ZIS("A")
DO NOQUE
KILL ^TMP("LEXINF",$JOB)
QUIT
NOQUE ; Do not queue Display
+1 WRITE @IOF
if IOST["P-"
WRITE !,"< Not queued, printing Lexicon data >",!
if IOST["P-"
USE IO
DO @ZTRTN
DO ^%ZISC
DO HOME^%ZIS
QUIT
QUE ; Task queued to print Help
+1 KILL IO("Q")
DO ^%ZTLOAD
WRITE !,$SELECT($DATA(ZTSK):"Request Queued",1:"Request Cancelled"),!
QUIT
+2 QUIT
OUT ; Output
+1 if '$DATA(^TMP("LEXINF",$JOB))
QUIT
if $LENGTH($GET(IOF))&($GET(IOST)'["P-MESSAGE")
WRITE @IOF
+2 NEW LEXLN,LEXLC,LEXCF,LEXCONT,LEXEOP,LEXIT
SET LEXIT=0
SET LEXEOP=+($GET(IOSL))
+3 if LEXEOP=0
SET LEXEOP=24
SET LEXEOP=LEXEOP-2
SET (LEXLC,LEXLN)=0
FOR
SET LEXLN=$ORDER(^TMP("LEXINF",$JOB,LEXLN))
if +LEXLN'>0
QUIT
Begin DoDot:1
+4 NEW LEXT
SET LEXT=$GET(^TMP("LEXINF",$JOB,LEXLN))
WRITE !," ",LEXT
SET LEXCF=0
DO LF
End DoDot:1
if LEXIT
QUIT
+5 IF LEXCF
IF LEXIT>0
DO EOP
if $LENGTH($GET(IOF))
WRITE @IOF
KILL ^TMP("LEXINF",$JOB)
QUIT
+6 IF 'LEXCF
DO EOP
if $LENGTH($GET(IOF))
WRITE @IOF
+7 KILL ^TMP("LEXINF",$JOB)
+8 QUIT
LF ; Line Feed
+1 SET LEXLC=LEXLC+1
if IOST["P-"&(LEXLC>(LEXEOP-7))
DO EOP
if IOST'["P-"&(LEXLC>(LEXEOP-4))
DO EOP
+2 QUIT
EOP ; End of Page
+1 NEW LEXCONT
SET LEXLC=0
if IOST["P-"
WRITE @IOF
if IOST["P-"
QUIT
WRITE !!
SET LEXCONT=$$CONT
SET LEXCF=1
+2 QUIT
CONT(X) ; Ask to Continue
+1 if +($GET(LEXIT))>0
QUIT "^^"
NEW DIR,DIROUT,DIRUT,DUOUT,DTOUT,Y
SET DIR(0)="EAO"
SET DIR("A")=" Enter RETURN to continue or '^' to exit: "
+2 SET DIR("PRE")="S:X[""?"" X=""??"" S:X[""^"" X=""^"""
SET (DIR("?"),DIR("??"))="^D CONTH^LEXINF5"
+3 DO ^DIR
if X["^"!($DATA(DTOUT))
SET LEXIT=1
if $DATA(DIROUT)!($DATA(DIRUT))!($DATA(DUOUT))!($DATA(DTOUT))!(X["^")
QUIT "^"
+4 QUIT ""
CONTH ; Ask to Continue Help
+1 WRITE !," Enter either RETURN or '^'."
+2 QUIT
+3 ;
+4 ; Miscellaneous
BL ; Blank Line
+1 DO TL(" ")
+2 QUIT
TL(X) ; Text Line
+1 if $DATA(TEST)
WRITE !,$GET(X)
if $DATA(TEST)
QUIT
+2 NEW LEXI
SET LEXI=$ORDER(^TMP("LEXINF",$JOB," "),-1)+1
SET ^TMP("LEXINF",$JOB,LEXI)=$GET(X)
+3 QUIT
TM(X,Y) ; Trim Character Y - Default " "
+1 SET X=$GET(X)
if X=""
QUIT X
SET Y=$GET(Y)
if '$LENGTH(Y)
SET Y=" "
+2 FOR
if $EXTRACT(X,1)'=Y
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+3 FOR
if $EXTRACT(X,$LENGTH(X))'=Y
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+4 QUIT X
