- 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 Mar 13, 2025@21:12:39 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
