- LEXXGI2 ;ISL/KER - Global Import (Protocol/Checksum/Misc) ;05/23/2017
- ;;2.0;LEXICON UTILITY;**25,26,28,29,46,49,50,73,80,103**;Sep 23, 1996;Build 2
- ;
- ; Global Variables
- ; ^LEXM N/A
- ; ^ORD(101, ICR 872
- ;
- ; External References
- ; $$FMDIFF^XLFDT ICR 10103
- ; $$FMTE^XLFDT ICR 10103
- ; $$NOW^XLFDT ICR 10103
- ; BMES^XPDUTL ICR 10141
- ; MES^XPDUTL ICR 10141
- ; EN^XQOR ICR 10101
- ;
- ; Local Variables NEWed or KILLed Elsewhere
- ; LEXCHG Post-Install
- ; LEXNOPRO Post-Install
- ; XPDNM KIDS install
- ;
- Q
- NOTIFY ; Notify by Protocol - LEXICAL SERVICES UPDATE
- ; Uses LEXSCHG() from the Post-Install
- ; Sets ^LEXM(0,"PRO")=$$NOW^XLFDT
- Q:$D(LEXNOPRO) Q:'$D(LEXSCHG("ICD"))&('$D(LEXSCHG("CPT")))&('$D(LEXSCHG("LEX")))
- S:$D(LEXSCHG("ICD")) LEXSCHG("ICD")=0,LEXSCHG("LEX")=0 S:$D(LEXSCHG("CPT")) LEXSCHG("CPT")=0,LEXSCHG("LEX")=0
- S:'$D(LEXSCHG("ICD"))&('$D(LEXSCHG("CPT")))&($D(LEXSCHG("LEX"))) LEXSCHG("ICD")=0,LEXSCHG("CPT")=0
- N X,LEXU,LEXF,LEXI,LEXL,LEX1,LEX2,LEX3,LEXN,LEXP,LEXUP,LEXPC S LEXUP="",LEXPC=0
- S:$D(LEXSCHG("ICD")) LEXUP=$G(LEXUP)_"ICD" S:$D(LEXSCHG("CPT")) LEXUP=$G(LEXUP)_"/CPT"
- S:$E(LEXUP,1)="/" LEXUP=$E(LEXUP,2,$L(LEXUP)) S:$L(LEXUP) LEXUP=LEXUP_" "
- S:$D(LEXSCHG("LEX")) LEXF="Lexicon" S:$D(LEXSCHG("ICD")) LEXF=$G(LEXF)_", ICD" S:$D(LEXSCHG("CPT")) LEXF=$G(LEXF)_", CPT"
- S:$E($G(LEXF),1,2)=", " LEXF=$E($G(LEXF),3,$L($G(LEXF))),LEXF=$$TRIM(LEXF)
- I $L(LEXF) D
- . S:$L(LEXF,", ")>1 LEXF=$P($G(LEXF),", ",1,($L($G(LEXF),", ")-1))_" and "_$P($G(LEXF),", ",$L($G(LEXF),", "))
- . S:$L($P(LEXF,", ",1)) LEXF=$G(LEXF)_" File"_$S(LEXF[", ":"s",LEXF[" and ":"s",1:"")_" Updated"
- S LEXL=78-($L(LEXF)+4),LEXU="Lexical Files Updated"
- Q:'$D(LEXSCHG) S LEXP=+($O(^ORD(101,"B","LEXICAL SERVICES UPDATE",0))) Q:LEXP=0 S X=LEXP_";ORD(101," D EN^XQOR
- S:$G(LEXSCHG("LEX"))>0!($G(LEXSCHG("ICD"))>0)!($G(LEXSCHG("CPT"))>0) ^LEXM(0,"PRO")=$$NOW^XLFDT
- S:$G(LEXSCHG("ICD"))>0!($G(LEXSCHG("CPT"))>0) LEXU="Lexicon/Code Sets Updated"
- Q:+($G(^LEXM(0,"PRO")))'>0 K LEXPROC D:$L($G(LEXU)) BL,TL($G(LEXU)),BL
- I +($G(LEXSCHG("LEX")))>0 D
- . N X,LEXED S X=" 'LEXICAL SERVICES UPDATE' ",X=X_$J(" ",(30-$L(X)))
- . S LEXED=$$EDT($G(LEXSCHG("LEX"))) S:$L(LEXED) X=X_" "_LEXED S LEXPC=+($G(LEXPC))+1 S:$L(LEXED) LEXPROC((LEXPC+1))=X
- I +($G(LEXSCHG("ICD")))>0 D
- . N X,LEXED S X=" 'ICD CODE UPDATE EVENT' ",X=X_$J(" ",(30-$L(X)))
- . S LEXED=$$EDT($G(LEXSCHG("ICD"))) S:$L(LEXED) X=X_" "_LEXED S LEXPC=+($G(LEXPC))+1 S:$L(LEXED) LEXPROC((LEXPC+1))=X
- I +($G(LEXSCHG("CPT")))>0 D
- . N X,LEXED S X=" 'CPT CODE UPDATE EVENT' ",X=X_$J(" ",(30-$L(X)))
- . S LEXED=$$EDT($G(LEXSCHG("CPT"))) S:$L(LEXED) X=X_" "_LEXED S LEXPC=+($G(LEXPC))+1 S:$L(LEXED) LEXPROC((LEXPC+1))=X
- S:$O(LEXPROC(" "),-1)>1 LEXPROC(1)="Protocol invoked:" S:$O(LEXPROC(" "),-1)>2 LEXPROC(1)="Protocols invoked:"
- S LEXPC=0 F S LEXPC=$O(LEXPROC(LEXPC)) Q:+LEXPC'>0 D
- . S X=$G(LEXPROC(LEXPC)) D TL(X) D:X["Protocol" BL
- S X="Subscribing applications were notified of the "_LEXUP_"update" D BL,TL(X),BL
- Q
- UPCHG ;
- Q:+($G(LEXFI))'>0 N LEXID S LEXID=$S($P(LEXFI,".",1)="757":"LEX",$P(LEXFI,".",1)="80":"ICD",$P(LEXFI,".",1)="81":"CPT",1:"") Q:'$L(LEXID)
- S LEXSCHG(LEXID)=+($G(LEXSCHG(LEXID)))
- Q
- SCHG ; Change Array LEXSCHG (Some or all, but never nothing)
- N LEXFI,LEXID K LEXSCHG S LEXCHG=0
- N LEXFI S LEXFI=0 F S LEXFI=$O(^LEXM(LEXFI)) Q:+LEXFI'>0 D
- . S LEXID=$S(LEXFI=80!(LEXFI=80.1):"ICD",LEXFI=81!(LEXFI=81.1)!(LEXFI=81.2)!(LEXFI=81.3):"CPT",$P(LEXFI,".",1)=757:"LEX",1:"UNK")
- . S LEXSCHG(LEXFI,0)=+($G(^LEXM(LEXFI,0))),LEXSCHG("B",LEXFI)="" S LEXSCHG("C",LEXID,LEXFI)=""
- S:$D(LEXSCHG("C","CPT"))!($D(LEXSCHG("C","ICD"))) LEXSCHG("D","PRO")=""
- S:$D(^LEXM(80))!($D(^LEXM(80.1)))!($D(^LEXM(81)))!($D(^LEXM(81.2)))!($D(^LEXM(81.3)))!($D(LEXSCHG("D","PRO"))) LEXCHG=1,LEXSCHG(0)=1
- D:$O(LEXSCHG(0))'>0 SALL S:$D(LEXSCHG("C","CPT"))!($D(LEXSCHG("C","ICD"))) LEXSCHG("D","PRO")=""
- Q
- SALL ; Set All (ICD/CPT/Lexicon)
- D SICD,SCPT,SLEX
- Q
- SICD ; Set ICD
- S (LEXSCHG("80",0),LEXSCHG("B","80"),LEXSCHG("C","ICD","80"))="",(LEXSCHG("80.1",0),LEXSCHG("B","80.1"),LEXSCHG("C","ICD","80.1"))="" D SLEX
- Q
- SCPT ; Set CPT
- S (LEXSCHG("81",0),LEXSCHG("B","81"),LEXSCHG("C","CPT","81"))="",(LEXSCHG("81.1",0),LEXSCHG("B","81.1"),LEXSCHG("C","CPT","81.1"))=""
- S (LEXSCHG("81.2",0),LEXSCHG("B","81.2"),LEXSCHG("C","CPT","81.2"))="",(LEXSCHG("81.3",0),LEXSCHG("B","81.3"),LEXSCHG("C","CPT","81.3"))="" D SLEX
- Q
- SLEX ; Set Lexicon
- S (LEXSCHG("757",0),LEXSCHG("B","757"),LEXSCHG("C","LEX","757"))="",(LEXSCHG("757.001",0),LEXSCHG("B","757.001"),LEXSCHG("C","LEX","757.001"))=""
- S (LEXSCHG("757.01",0),LEXSCHG("B","757.01"),LEXSCHG("C","LEX","757.01"))="",(LEXSCHG("757.02",0),LEXSCHG("B","757.02"),LEXSCHG("C","LEX","757.02"))=""
- S (LEXSCHG("757.1",0),LEXSCHG("B","757.1"),LEXSCHG("C","LEX","757.1"))=""
- Q
- CS ; Checksum for import global
- N LEXCHK,LEXNDS,LEXVER S LEXCHK=+($G(^LEXM(0,"CHECKSUM")))
- W !," Running checksum routine on the ^LEXM import global, please wait"
- S LEXNDS=+($G(^LEXM(0,"NODES"))),LEXVER=+($$VC(LEXCHK,LEXNDS)) W !
- W:LEXVER>0 !," Checksum is ok",! Q:LEXVER>0
- I LEXVER=0 W !!," Import global ^LEXM is missing. Please obtain a copy of ^LEXM before",!," continuing." Q
- I LEXVER<0 D Q
- . I LEXVER'=-3 W !," Unable to verify checksum for import global ^LEXM (possibly corrupt)"
- . I LEXVER=-3 W !," Import global ^LEXM failed checksum"
- . W !!," Please KILL the existing import global ^LEXM from your system and"
- . W !," obtain a new copy of ^LEXM before continuing with the installation."
- Q
- VC(X,Y) ; Verify Checksum for import global
- Q:'$D(^LEXM)!('$D(^LEXM(0)))!($O(^LEXM(0))'>0) 0 N LEXCHK,LEXNDS,LEXCNT,LEXLC,LEXL,LEXS,LEXNC,LEXD,LEXN,LEXC,LEXGCS,LEXP,LEXT
- S LEXCHK=+($G(X)),LEXNDS=+($G(Y)) Q:LEXCHK'>0!(LEXNDS'>0) -2 S LEXL=64,(LEXCNT,LEXLC)=0,LEXS=(+(LEXNDS\LEXL))
- S:LEXS=0 LEXS=1 W:+($O(^LEXM(0)))>0 ! S (LEXC,LEXN)="^LEXM",(LEXNC,LEXGCS)=0 W " "
- F S LEXN=$Q(@LEXN) Q:LEXN=""!(LEXN'[LEXC) D
- . Q:LEXN="^LEXM(0,""CHECKSUM"")" Q:LEXN="^LEXM(0,""NODES"")" S LEXCNT=LEXCNT+1
- . I LEXCNT'<LEXS S LEXLC=LEXLC+1 W:LEXLC'>LEXL "." S LEXCNT=0
- . S LEXNC=LEXNC+1,LEXD=@LEXN,LEXT=LEXN_"="_LEXD F LEXP=1:1:$L(LEXT) S LEXGCS=$A(LEXT,LEXP)*LEXP+LEXGCS
- Q:LEXNC'=LEXNDS -3 Q:LEXGCS'=LEXCHK -3
- Q 1
- ; Miscellaneous
- NF ; Import Global Not Found
- D PB(" Import Global ^LEXM not found, consult the installation instructions")
- D TL(" to install this global")
- Q
- IG ; Invalid Import Global
- D PB(" Invalid Import Global ^LEXM, please consult the installation")
- D TL(" instructions to reload this global")
- Q
- BL ; Blank Line
- N X S X="" W:'$D(XPDNM) ! D:$D(XPDNM) MES^XPDUTL(X) Q
- PB(X) ; Preceeding Blank Line
- S X=$G(X) Q:'$L(X) W:'$D(XPDNM) !!,X D:$D(XPDNM) BMES^XPDUTL(X) Q
- TL(X) ; Text Line
- S X=$G(X) Q:'$L(X) W:'$D(XPDNM) !,X D:$D(XPDNM) MES^XPDUTL(X) Q
- HACK(X) ; Time
- S X=$$NOW^XLFDT Q X
- ELAP(LEX1,LEX2) ; Elapsed Time
- N X S X=$$FMDIFF^XLFDT(+($G(LEX2)),+($G(LEX1)),3)
- S:X="" X="00:00:00" S X=$TR(X," ","0") S LEX1=X Q LEX1
- Q
- KLEXM ; Subscripted Kill of ^LEXM - files only
- N LEX S LEX=0 F S LEX=$O(^LEXM(LEX)) Q:+LEX'>0 K ^LEXM(LEX)
- Q
- KALL ; Subscripted Kill of ^LEXM - all
- K LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR,LEXB,LEXCD,LEXSTR,LEXLAST
- K DIC,DICR,DILOCKTM,DIW,XMDUN,XMZ,ZTSK
- N LEX S LEX=0 F S LEX=$O(^LEXM(LEX)) Q:+LEX'>0 K ^LEXM(LEX)
- K ^LEXM(0)
- Q
- ; Error Text
- ET(X) ; Save Text
- N LEXI S LEXI=+($G(LEXE(0))),LEXI=LEXI+1,LEXE(LEXI)=$G(X),LEXE(0)=LEXI Q
- ED ; Display Text
- N LEXI S LEXI=0 F S LEXI=$O(LEXE(LEXI)) Q:+LEXI=0 W !,LEXE(LEXI)
- W ! K LEXE
- Q
- ; Case
- MIX(X) ; Mixed Case
- S X=$G(X) N LEXT,LEXI S LEXT=""
- F LEXI=1:1:$L(X," ") S LEXT=LEXT_" "_$$UP($E($P(X," ",LEXI),1))_$$LO($E($P(X," ",LEXI),2,$L($P(X," ",LEXI))))
- F Q:$E(LEXT,1)'=" " S LEXT=$E(LEXT,2,$L(LEXT))
- S:$E(LEXT,1,3)="Cpt" LEXT="CPT"_$E(LEXT,4,$L(LEXT)) S:$E(LEXT,1,3)="Icd" LEXT="ICD"_$E(LEXT,4,$L(LEXT)) S X=LEXT
- Q X
- UP(X) ; Uppercase
- Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
- LO(X) ; Lowercase
- Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
- CLR ; Clear
- K DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,DTOUT,DUOUT,LEX
- K LEX1,LEX2,LEX3,LEXC,LEXCHK,LEXCNT,LEXCT,LEXD,LEXE,LEXED
- K LEXF,LEXFI,LEXGCS,LEXI,LEXID,LEXL,LEXLC,LEXLEN,LEXN,LEXNC
- K LEXNDS,LEXP,LEXPC,LEXPROC,LEXS,LEXSCHG,LEXT,LEXTI,LEXU
- K LEXUP,LEXVER,X,Y
- Q
- EDT(LEX) ; External Date
- S LEX=$$FMTE^XLFDT($G(LEX),"1Z") S:LEX["@" LEX=$P(LEX,"@",1)_" "_$P(LEX,"@",2,4000)
- Q LEX
- TRIM(X) ; Trim Spaces
- N XPDNM S X=$G(X) Q:X="" X F Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
- F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
- F Q:X'[" " S X=$P(X," ",1)_" "_$P(X," ",2,229)
- Q X
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXXGI2 9029 printed Mar 13, 2025@21:14:43 Page 2
- LEXXGI2 ;ISL/KER - Global Import (Protocol/Checksum/Misc) ;05/23/2017
- +1 ;;2.0;LEXICON UTILITY;**25,26,28,29,46,49,50,73,80,103**;Sep 23, 1996;Build 2
- +2 ;
- +3 ; Global Variables
- +4 ; ^LEXM N/A
- +5 ; ^ORD(101, ICR 872
- +6 ;
- +7 ; External References
- +8 ; $$FMDIFF^XLFDT ICR 10103
- +9 ; $$FMTE^XLFDT ICR 10103
- +10 ; $$NOW^XLFDT ICR 10103
- +11 ; BMES^XPDUTL ICR 10141
- +12 ; MES^XPDUTL ICR 10141
- +13 ; EN^XQOR ICR 10101
- +14 ;
- +15 ; Local Variables NEWed or KILLed Elsewhere
- +16 ; LEXCHG Post-Install
- +17 ; LEXNOPRO Post-Install
- +18 ; XPDNM KIDS install
- +19 ;
- +20 QUIT
- NOTIFY ; Notify by Protocol - LEXICAL SERVICES UPDATE
- +1 ; Uses LEXSCHG() from the Post-Install
- +2 ; Sets ^LEXM(0,"PRO")=$$NOW^XLFDT
- +3 if $DATA(LEXNOPRO)
- QUIT
- if '$DATA(LEXSCHG("ICD"))&('$DATA(LEXSCHG("CPT")))&('$DATA(LEXSCHG("LEX")))
- QUIT
- +4 if $DATA(LEXSCHG("ICD"))
- SET LEXSCHG("ICD")=0
- SET LEXSCHG("LEX")=0
- if $DATA(LEXSCHG("CPT"))
- SET LEXSCHG("CPT")=0
- SET LEXSCHG("LEX")=0
- +5 if '$DATA(LEXSCHG("ICD"))&('$DATA(LEXSCHG("CPT")))&($DATA(LEXSCHG("LEX")))
- SET LEXSCHG("ICD")=0
- SET LEXSCHG("CPT")=0
- +6 NEW X,LEXU,LEXF,LEXI,LEXL,LEX1,LEX2,LEX3,LEXN,LEXP,LEXUP,LEXPC
- SET LEXUP=""
- SET LEXPC=0
- +7 if $DATA(LEXSCHG("ICD"))
- SET LEXUP=$GET(LEXUP)_"ICD"
- if $DATA(LEXSCHG("CPT"))
- SET LEXUP=$GET(LEXUP)_"/CPT"
- +8 if $EXTRACT(LEXUP,1)="/"
- SET LEXUP=$EXTRACT(LEXUP,2,$LENGTH(LEXUP))
- if $LENGTH(LEXUP)
- SET LEXUP=LEXUP_" "
- +9 if $DATA(LEXSCHG("LEX"))
- SET LEXF="Lexicon"
- if $DATA(LEXSCHG("ICD"))
- SET LEXF=$GET(LEXF)_", ICD"
- if $DATA(LEXSCHG("CPT"))
- SET LEXF=$GET(LEXF)_", CPT"
- +10 if $EXTRACT($GET(LEXF),1,2)=", "
- SET LEXF=$EXTRACT($GET(LEXF),3,$LENGTH($GET(LEXF)))
- SET LEXF=$$TRIM(LEXF)
- +11 IF $LENGTH(LEXF)
- Begin DoDot:1
- +12 if $LENGTH(LEXF,", ")>1
- SET LEXF=$PIECE($GET(LEXF),", ",1,($LENGTH($GET(LEXF),", ")-1))_" and "_$PIECE($GET(LEXF),", ",$LENGTH($GET(LEXF),", "))
- +13 if $LENGTH($PIECE(LEXF,", ",1))
- SET LEXF=$GET(LEXF)_" File"_$SELECT(LEXF[", ":"s",LEXF[" and ":"s",1:"")_" Updated"
- End DoDot:1
- +14 SET LEXL=78-($LENGTH(LEXF)+4)
- SET LEXU="Lexical Files Updated"
- +15 if '$DATA(LEXSCHG)
- QUIT
- SET LEXP=+($ORDER(^ORD(101,"B","LEXICAL SERVICES UPDATE",0)))
- if LEXP=0
- QUIT
- SET X=LEXP_";ORD(101,"
- DO EN^XQOR
- +16 if $GET(LEXSCHG("LEX"))>0!($GET(LEXSCHG("ICD"))>0)!($GET(LEXSCHG("CPT"))>0)
- SET ^LEXM(0,"PRO")=$$NOW^XLFDT
- +17 if $GET(LEXSCHG("ICD"))>0!($GET(LEXSCHG("CPT"))>0)
- SET LEXU="Lexicon/Code Sets Updated"
- +18 if +($GET(^LEXM(0,"PRO")))'>0
- QUIT
- KILL LEXPROC
- if $LENGTH($GET(LEXU))
- DO BL
- DO TL($GET(LEXU))
- DO BL
- +19 IF +($GET(LEXSCHG("LEX")))>0
- Begin DoDot:1
- +20 NEW X,LEXED
- SET X=" 'LEXICAL SERVICES UPDATE' "
- SET X=X_$JUSTIFY(" ",(30-$LENGTH(X)))
- +21 SET LEXED=$$EDT($GET(LEXSCHG("LEX")))
- if $LENGTH(LEXED)
- SET X=X_" "_LEXED
- SET LEXPC=+($GET(LEXPC))+1
- if $LENGTH(LEXED)
- SET LEXPROC((LEXPC+1))=X
- End DoDot:1
- +22 IF +($GET(LEXSCHG("ICD")))>0
- Begin DoDot:1
- +23 NEW X,LEXED
- SET X=" 'ICD CODE UPDATE EVENT' "
- SET X=X_$JUSTIFY(" ",(30-$LENGTH(X)))
- +24 SET LEXED=$$EDT($GET(LEXSCHG("ICD")))
- if $LENGTH(LEXED)
- SET X=X_" "_LEXED
- SET LEXPC=+($GET(LEXPC))+1
- if $LENGTH(LEXED)
- SET LEXPROC((LEXPC+1))=X
- End DoDot:1
- +25 IF +($GET(LEXSCHG("CPT")))>0
- Begin DoDot:1
- +26 NEW X,LEXED
- SET X=" 'CPT CODE UPDATE EVENT' "
- SET X=X_$JUSTIFY(" ",(30-$LENGTH(X)))
- +27 SET LEXED=$$EDT($GET(LEXSCHG("CPT")))
- if $LENGTH(LEXED)
- SET X=X_" "_LEXED
- SET LEXPC=+($GET(LEXPC))+1
- if $LENGTH(LEXED)
- SET LEXPROC((LEXPC+1))=X
- End DoDot:1
- +28 if $ORDER(LEXPROC(" "),-1)>1
- SET LEXPROC(1)="Protocol invoked:"
- if $ORDER(LEXPROC(" "),-1)>2
- SET LEXPROC(1)="Protocols invoked:"
- +29 SET LEXPC=0
- FOR
- SET LEXPC=$ORDER(LEXPROC(LEXPC))
- if +LEXPC'>0
- QUIT
- Begin DoDot:1
- +30 SET X=$GET(LEXPROC(LEXPC))
- DO TL(X)
- if X["Protocol"
- DO BL
- End DoDot:1
- +31 SET X="Subscribing applications were notified of the "_LEXUP_"update"
- DO BL
- DO TL(X)
- DO BL
- +32 QUIT
- UPCHG ;
- +1 if +($GET(LEXFI))'>0
- QUIT
- NEW LEXID
- SET LEXID=$SELECT($PIECE(LEXFI,".",1)="757":"LEX",$PIECE(LEXFI,".",1)="80":"ICD",$PIECE(LEXFI,".",1)="81":"CPT",1:"")
- if '$LENGTH(LEXID)
- QUIT
- +2 SET LEXSCHG(LEXID)=+($GET(LEXSCHG(LEXID)))
- +3 QUIT
- SCHG ; Change Array LEXSCHG (Some or all, but never nothing)
- +1 NEW LEXFI,LEXID
- KILL LEXSCHG
- SET LEXCHG=0
- +2 NEW LEXFI
- SET LEXFI=0
- FOR
- SET LEXFI=$ORDER(^LEXM(LEXFI))
- if +LEXFI'>0
- QUIT
- Begin DoDot:1
- +3 SET LEXID=$SELECT(LEXFI=80!(LEXFI=80.1):"ICD",LEXFI=81!(LEXFI=81.1)!(LEXFI=81.2)!(LEXFI=81.3):"CPT",$PIECE(LEXFI,".",1)=757:"LEX",1:"UNK")
- +4 SET LEXSCHG(LEXFI,0)=+($GET(^LEXM(LEXFI,0)))
- SET LEXSCHG("B",LEXFI)=""
- SET LEXSCHG("C",LEXID,LEXFI)=""
- End DoDot:1
- +5 if $DATA(LEXSCHG("C","CPT"))!($DATA(LEXSCHG("C","ICD")))
- SET LEXSCHG("D","PRO")=""
- +6 if $DATA(^LEXM(80))!($DATA(^LEXM(80.1)))!($DATA(^LEXM(81)))!($DATA(^LEXM(81.2)))!($DATA(^LEXM(81.3)))!($DATA(LEXSCHG("D","PRO")))
- SET LEXCHG=1
- SET LEXSCHG(0)=1
- +7 if $ORDER(LEXSCHG(0))'>0
- DO SALL
- if $DATA(LEXSCHG("C","CPT"))!($DATA(LEXSCHG("C","ICD")))
- SET LEXSCHG("D","PRO")=""
- +8 QUIT
- SALL ; Set All (ICD/CPT/Lexicon)
- +1 DO SICD
- DO SCPT
- DO SLEX
- +2 QUIT
- SICD ; Set ICD
- +1 SET (LEXSCHG("80",0),LEXSCHG("B","80"),LEXSCHG("C","ICD","80"))=""
- SET (LEXSCHG("80.1",0),LEXSCHG("B","80.1"),LEXSCHG("C","ICD","80.1"))=""
- DO SLEX
- +2 QUIT
- SCPT ; Set CPT
- +1 SET (LEXSCHG("81",0),LEXSCHG("B","81"),LEXSCHG("C","CPT","81"))=""
- SET (LEXSCHG("81.1",0),LEXSCHG("B","81.1"),LEXSCHG("C","CPT","81.1"))=""
- +2 SET (LEXSCHG("81.2",0),LEXSCHG("B","81.2"),LEXSCHG("C","CPT","81.2"))=""
- SET (LEXSCHG("81.3",0),LEXSCHG("B","81.3"),LEXSCHG("C","CPT","81.3"))=""
- DO SLEX
- +3 QUIT
- SLEX ; Set Lexicon
- +1 SET (LEXSCHG("757",0),LEXSCHG("B","757"),LEXSCHG("C","LEX","757"))=""
- SET (LEXSCHG("757.001",0),LEXSCHG("B","757.001"),LEXSCHG("C","LEX","757.001"))=""
- +2 SET (LEXSCHG("757.01",0),LEXSCHG("B","757.01"),LEXSCHG("C","LEX","757.01"))=""
- SET (LEXSCHG("757.02",0),LEXSCHG("B","757.02"),LEXSCHG("C","LEX","757.02"))=""
- +3 SET (LEXSCHG("757.1",0),LEXSCHG("B","757.1"),LEXSCHG("C","LEX","757.1"))=""
- +4 QUIT
- CS ; Checksum for import global
- +1 NEW LEXCHK,LEXNDS,LEXVER
- SET LEXCHK=+($GET(^LEXM(0,"CHECKSUM")))
- +2 WRITE !," Running checksum routine on the ^LEXM import global, please wait"
- +3 SET LEXNDS=+($GET(^LEXM(0,"NODES")))
- SET LEXVER=+($$VC(LEXCHK,LEXNDS))
- WRITE !
- +4 if LEXVER>0
- WRITE !," Checksum is ok",!
- if LEXVER>0
- QUIT
- +5 IF LEXVER=0
- WRITE !!," Import global ^LEXM is missing. Please obtain a copy of ^LEXM before",!," continuing."
- QUIT
- +6 IF LEXVER<0
- Begin DoDot:1
- +7 IF LEXVER'=-3
- WRITE !," Unable to verify checksum for import global ^LEXM (possibly corrupt)"
- +8 IF LEXVER=-3
- WRITE !," Import global ^LEXM failed checksum"
- +9 WRITE !!," Please KILL the existing import global ^LEXM from your system and"
- +10 WRITE !," obtain a new copy of ^LEXM before continuing with the installation."
- End DoDot:1
- QUIT
- +11 QUIT
- VC(X,Y) ; Verify Checksum for import global
- +1 if '$DATA(^LEXM)!('$DATA(^LEXM(0)))!($ORDER(^LEXM(0))'>0)
- QUIT 0
- NEW LEXCHK,LEXNDS,LEXCNT,LEXLC,LEXL,LEXS,LEXNC,LEXD,LEXN,LEXC,LEXGCS,LEXP,LEXT
- +2 SET LEXCHK=+($GET(X))
- SET LEXNDS=+($GET(Y))
- if LEXCHK'>0!(LEXNDS'>0)
- QUIT -2
- SET LEXL=64
- SET (LEXCNT,LEXLC)=0
- SET LEXS=(+(LEXNDS\LEXL))
- +3 if LEXS=0
- SET LEXS=1
- if +($ORDER(^LEXM(0)))>0
- WRITE !
- SET (LEXC,LEXN)="^LEXM"
- SET (LEXNC,LEXGCS)=0
- WRITE " "
- +4 FOR
- SET LEXN=$QUERY(@LEXN)
- if LEXN=""!(LEXN'[LEXC)
- QUIT
- Begin DoDot:1
- +5 if LEXN="^LEXM(0,""CHECKSUM"")"
- QUIT
- if LEXN="^LEXM(0,""NODES"")"
- QUIT
- SET LEXCNT=LEXCNT+1
- +6 IF LEXCNT'<LEXS
- SET LEXLC=LEXLC+1
- if LEXLC'>LEXL
- WRITE "."
- SET LEXCNT=0
- +7 SET LEXNC=LEXNC+1
- SET LEXD=@LEXN
- SET LEXT=LEXN_"="_LEXD
- FOR LEXP=1:1:$LENGTH(LEXT)
- SET LEXGCS=$ASCII(LEXT,LEXP)*LEXP+LEXGCS
- End DoDot:1
- +8 if LEXNC'=LEXNDS
- QUIT -3
- if LEXGCS'=LEXCHK
- QUIT -3
- +9 QUIT 1
- +10 ; Miscellaneous
- NF ; Import Global Not Found
- +1 DO PB(" Import Global ^LEXM not found, consult the installation instructions")
- +2 DO TL(" to install this global")
- +3 QUIT
- IG ; Invalid Import Global
- +1 DO PB(" Invalid Import Global ^LEXM, please consult the installation")
- +2 DO TL(" instructions to reload this global")
- +3 QUIT
- BL ; Blank Line
- +1 NEW X
- SET X=""
- if '$DATA(XPDNM)
- WRITE !
- if $DATA(XPDNM)
- DO MES^XPDUTL(X)
- QUIT
- PB(X) ; Preceeding Blank Line
- +1 SET X=$GET(X)
- if '$LENGTH(X)
- QUIT
- if '$DATA(XPDNM)
- WRITE !!,X
- if $DATA(XPDNM)
- DO BMES^XPDUTL(X)
- QUIT
- TL(X) ; Text Line
- +1 SET X=$GET(X)
- if '$LENGTH(X)
- QUIT
- if '$DATA(XPDNM)
- WRITE !,X
- if $DATA(XPDNM)
- DO MES^XPDUTL(X)
- QUIT
- HACK(X) ; Time
- +1 SET X=$$NOW^XLFDT
- QUIT X
- ELAP(LEX1,LEX2) ; Elapsed Time
- +1 NEW X
- SET X=$$FMDIFF^XLFDT(+($GET(LEX2)),+($GET(LEX1)),3)
- +2 if X=""
- SET X="00:00:00"
- SET X=$TRANSLATE(X," ","0")
- SET LEX1=X
- QUIT LEX1
- +3 QUIT
- KLEXM ; Subscripted Kill of ^LEXM - files only
- +1 NEW LEX
- SET LEX=0
- FOR
- SET LEX=$ORDER(^LEXM(LEX))
- if +LEX'>0
- QUIT
- KILL ^LEXM(LEX)
- +2 QUIT
- KALL ; Subscripted Kill of ^LEXM - all
- +1 KILL LEXPTYPE,LEXLREV,LEXREQP,LEXBUILD,LEXIGHF,LEXFY,LEXQTR,LEXB,LEXCD,LEXSTR,LEXLAST
- +2 KILL DIC,DICR,DILOCKTM,DIW,XMDUN,XMZ,ZTSK
- +3 NEW LEX
- SET LEX=0
- FOR
- SET LEX=$ORDER(^LEXM(LEX))
- if +LEX'>0
- QUIT
- KILL ^LEXM(LEX)
- +4 KILL ^LEXM(0)
- +5 QUIT
- +6 ; Error Text
- ET(X) ; Save Text
- +1 NEW LEXI
- SET LEXI=+($GET(LEXE(0)))
- SET LEXI=LEXI+1
- SET LEXE(LEXI)=$GET(X)
- SET LEXE(0)=LEXI
- QUIT
- ED ; Display Text
- +1 NEW LEXI
- SET LEXI=0
- FOR
- SET LEXI=$ORDER(LEXE(LEXI))
- if +LEXI=0
- QUIT
- WRITE !,LEXE(LEXI)
- +2 WRITE !
- KILL LEXE
- +3 QUIT
- +4 ; Case
- MIX(X) ; Mixed Case
- +1 SET X=$GET(X)
- NEW LEXT,LEXI
- SET LEXT=""
- +2 FOR LEXI=1:1:$LENGTH(X," ")
- SET LEXT=LEXT_" "_$$UP($EXTRACT($PIECE(X," ",LEXI),1))_$$LO($EXTRACT($PIECE(X," ",LEXI),2,$LENGTH($PIECE(X," ",LEXI))))
- +3 FOR
- if $EXTRACT(LEXT,1)'=" "
- QUIT
- SET LEXT=$EXTRACT(LEXT,2,$LENGTH(LEXT))
- +4 if $EXTRACT(LEXT,1,3)="Cpt"
- SET LEXT="CPT"_$EXTRACT(LEXT,4,$LENGTH(LEXT))
- if $EXTRACT(LEXT,1,3)="Icd"
- SET LEXT="ICD"_$EXTRACT(LEXT,4,$LENGTH(LEXT))
- SET X=LEXT
- +5 QUIT X
- UP(X) ; Uppercase
- +1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
- LO(X) ; Lowercase
- +1 QUIT $TRANSLATE(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
- CLR ; Clear
- +1 KILL DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,DTOUT,DUOUT,LEX
- +2 KILL LEX1,LEX2,LEX3,LEXC,LEXCHK,LEXCNT,LEXCT,LEXD,LEXE,LEXED
- +3 KILL LEXF,LEXFI,LEXGCS,LEXI,LEXID,LEXL,LEXLC,LEXLEN,LEXN,LEXNC
- +4 KILL LEXNDS,LEXP,LEXPC,LEXPROC,LEXS,LEXSCHG,LEXT,LEXTI,LEXU
- +5 KILL LEXUP,LEXVER,X,Y
- +6 QUIT
- EDT(LEX) ; External Date
- +1 SET LEX=$$FMTE^XLFDT($GET(LEX),"1Z")
- if LEX["@"
- SET LEX=$PIECE(LEX,"@",1)_" "_$PIECE(LEX,"@",2,4000)
- +2 QUIT LEX
- TRIM(X) ; Trim Spaces
- +1 NEW XPDNM
- SET X=$GET(X)
- if X=""
- QUIT X
- FOR
- if $EXTRACT(X,1)'=" "
- QUIT
- SET X=$EXTRACT(X,2,$LENGTH(X))
- +2 FOR
- if $EXTRACT(X,$LENGTH(X))'=" "
- QUIT
- SET X=$EXTRACT(X,1,($LENGTH(X)-1))
- +3 FOR
- if X'[" "
- QUIT
- SET X=$PIECE(X," ",1)_" "_$PIECE(X," ",2,229)
- +4 QUIT X
