LEXSC3 ;ISL/KER - Shortcuts Add/Delete ;04/21/2014
;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
;
; Global Variables
; ^LEX(757.4) N/A
;
; External References
; $$UP^XLFSTR ICR 10103
; FILE^DICN ICR 10009
; ^DIK ICR 10013
; ^XTLKKWL ICR 10122
;
ADD ; Add a shortcut
N LEXADD,LEXERM
ADD2 F D Q:$G(LEXRP)[U!(+($G(Y))>0)
. W ! S LEXERM=$$TERM^LEXSC2 Q:LEXRP[U
. D LK(LEXERM)
I LEXRP[U,LEXRP'["^^" W ! S LEXRP="" Q
Q:LEXRP["^^" I +Y>0 D ASKADD I $G(LEXADD)>0 D ADDSC(+Y,LEXSC,LEXCX)
I LEXRP[U,LEXRP'["^^" S LEXRP="" G ADD2
Q
ASKADD ;
N LEXERM,LEXSTR S LEXERM=+Y
S LEXERM=$S(+LEXERM'>0:"",1:$G(^LEX(757.01,LEXERM,0)))
S LEXSTR="Add """_LEXSC_""" as a short cut "
S LEXSTR=LEXSTR_"(in the context of "_LEXCXN_")"
S:LEXERM'="" LEXSTR=LEXSTR_" pointing to the term """_LEXERM_""""
D WRT^LEXSC2(LEXSTR) S LEXADD=$$ADDOK^LEXSC2
Q
ADDSC(LEXEXP,LEXSC,LEXCX) ; Add shortcut
I '$D(^LEX(757.4,"B",LEXEXP)) D ADDR
I $D(^LEX(757.4,"B",LEXEXP)) D ADDS
Q
ADDS ; Add Shortcut to sub-file
N DIC,DLAYGO,X,Y,DTOUT,DUOUT
N LEXR S LEXR=$O(^LEX(757.4,"B",LEXEXP,0)) Q:'$D(^LEX(757.4,LEXR,0)) K DD,DO S DA(1)=LEXR,X=LEXSC
S DLAYGO=757.401,DIC="^LEX(757.4,"_DA(1)_",1,",DIC(0)="AEMQL",DIC("P")="757.401",DIC("DR")="1////^S X=LEXCX" D FILE^DICN
Q
ADDR ; Add record
N DIC,DLAYGO,X,Y,DTOUT,DUOUT
N LEXERM S LEXERM=$G(^LEX(757.01,LEXEXP,0))
K DD,DO S X=LEXEXP,DIC="^LEX(757.4,",DLAYGO=757.4,DIC(0)="AEMQL" D FILE^DICN
Q
LK(X) ; Set up Lookup
S X=$G(X) K DLAYGO N DIC,DIPGM,DO G:X=""!(X["^") LKQ S:$L($G(LEXDICS)) DIC("S")=LEXDICS
S XTLKKSCH("INDEX")="AWRD",(DIC,XTLKGBL,XTLKKSCH("GBL"))="^LEX(757.01,"
S LEXSHOW="ICD/CPT/DSM/NAN/OMA/NIC"
S:$L($G(^LEXT(757.2,1,2))) XTLKHLP="D "_^LEXT(757.2,1,2)
S:$L($G(^LEXT(757.2,1,3))) XTLKKSCH("DSPLY")=^LEXT(757.2,1,3)
S:'$L($G(XTLKHLP)) XTLKHLP="D XTLK^LEXHLP" S:'$L($G(XTLKKSCH("DSPLY"))) XTLKKSCH="XTLK^LEXPRNT"
S (X,XTLKX)=$$UP^XLFSTR(LEXERM),DO=@(DIC_"0)"),DIC(0)="EMQ",XTLKSAY=0
W !,"Searching ... "
D ^XTLKKWL K XTLKSAY,XTLKHLP S LEXRP=X
LKQ ;
K LEXSUB,LEXU,LEXAP,LEXUN,LEXLST,LEXLL,LEXSHOW
K XTLKX,XTLKKSCH,XTLKHLP,XTLKSAY,XTLKGBL,XTLKWD2
Q
DELS ;
N DIK,LEXC S LEXCX=+($G(LEXCX)) Q:'$L($G(LEXSC)) Q:LEXCX=0 N LEXR,LEXS
S LEXR=$O(^LEX(757.4,"ARA",$E($$UP^XLFSTR(LEXSC),1,63),LEXCX,0)) Q:+LEXR=0
S LEXS=$O(^LEX(757.4,"ARA",$E($$UP^XLFSTR(LEXSC),1,63),LEXCX,+LEXR,0)) Q:+LEXS=0
S DA(1)=+LEXR,DA=+LEXS,DIK="^LEX(757.4,"_DA(1)_",1," D ^DIK
S LEXC=$$CNT(LEXR) I LEXC'[U,+LEXC=0 D DELR(LEXR)
Q
DELR(DA) ;
S DA=+($G(DA)) Q:DA=0 Q:'$D(^LEX(757.4,DA)) N DIK S DIK="^LEX(757.4," D ^DIK
Q
CNT(X) ;
N LEXR,LEXC,LEXI S (LEXC,LEXI)=0,LEXR=+$G(X)
Q:'$L($G(^LEX(757.4,LEXR,0))) "^"
F S LEXI=$O(^LEX(757.4,LEXR,1,LEXI)) Q:+LEXI=0 D
. S LEXC=LEXC+1
S X=LEXC Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXSC3 2923 printed Nov 22, 2024@17:19:43 Page 2
LEXSC3 ;ISL/KER - Shortcuts Add/Delete ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.4) N/A
+5 ;
+6 ; External References
+7 ; $$UP^XLFSTR ICR 10103
+8 ; FILE^DICN ICR 10009
+9 ; ^DIK ICR 10013
+10 ; ^XTLKKWL ICR 10122
+11 ;
ADD ; Add a shortcut
+1 NEW LEXADD,LEXERM
ADD2 FOR
Begin DoDot:1
+1 WRITE !
SET LEXERM=$$TERM^LEXSC2
if LEXRP[U
QUIT
+2 DO LK(LEXERM)
End DoDot:1
if $GET(LEXRP)[U!(+($GET(Y))>0)
QUIT
+3 IF LEXRP[U
IF LEXRP'["^^"
WRITE !
SET LEXRP=""
QUIT
+4 if LEXRP["^^"
QUIT
IF +Y>0
DO ASKADD
IF $GET(LEXADD)>0
DO ADDSC(+Y,LEXSC,LEXCX)
+5 IF LEXRP[U
IF LEXRP'["^^"
SET LEXRP=""
GOTO ADD2
+6 QUIT
ASKADD ;
+1 NEW LEXERM,LEXSTR
SET LEXERM=+Y
+2 SET LEXERM=$SELECT(+LEXERM'>0:"",1:$GET(^LEX(757.01,LEXERM,0)))
+3 SET LEXSTR="Add """_LEXSC_""" as a short cut "
+4 SET LEXSTR=LEXSTR_"(in the context of "_LEXCXN_")"
+5 if LEXERM'=""
SET LEXSTR=LEXSTR_" pointing to the term """_LEXERM_""""
+6 DO WRT^LEXSC2(LEXSTR)
SET LEXADD=$$ADDOK^LEXSC2
+7 QUIT
ADDSC(LEXEXP,LEXSC,LEXCX) ; Add shortcut
+1 IF '$DATA(^LEX(757.4,"B",LEXEXP))
DO ADDR
+2 IF $DATA(^LEX(757.4,"B",LEXEXP))
DO ADDS
+3 QUIT
ADDS ; Add Shortcut to sub-file
+1 NEW DIC,DLAYGO,X,Y,DTOUT,DUOUT
+2 NEW LEXR
SET LEXR=$ORDER(^LEX(757.4,"B",LEXEXP,0))
if '$DATA(^LEX(757.4,LEXR,0))
QUIT
KILL DD,DO
SET DA(1)=LEXR
SET X=LEXSC
+3 SET DLAYGO=757.401
SET DIC="^LEX(757.4,"_DA(1)_",1,"
SET DIC(0)="AEMQL"
SET DIC("P")="757.401"
SET DIC("DR")="1////^S X=LEXCX"
DO FILE^DICN
+4 QUIT
ADDR ; Add record
+1 NEW DIC,DLAYGO,X,Y,DTOUT,DUOUT
+2 NEW LEXERM
SET LEXERM=$GET(^LEX(757.01,LEXEXP,0))
+3 KILL DD,DO
SET X=LEXEXP
SET DIC="^LEX(757.4,"
SET DLAYGO=757.4
SET DIC(0)="AEMQL"
DO FILE^DICN
+4 QUIT
LK(X) ; Set up Lookup
+1 SET X=$GET(X)
KILL DLAYGO
NEW DIC,DIPGM,DO
if X=""!(X["^")
GOTO LKQ
if $LENGTH($GET(LEXDICS))
SET DIC("S")=LEXDICS
+2 SET XTLKKSCH("INDEX")="AWRD"
SET (DIC,XTLKGBL,XTLKKSCH("GBL"))="^LEX(757.01,"
+3 SET LEXSHOW="ICD/CPT/DSM/NAN/OMA/NIC"
+4 if $LENGTH($GET(^LEXT(757.2,1,2)))
SET XTLKHLP="D "_^LEXT(757.2,1,2)
+5 if $LENGTH($GET(^LEXT(757.2,1,3)))
SET XTLKKSCH("DSPLY")=^LEXT(757.2,1,3)
+6 if '$LENGTH($GET(XTLKHLP))
SET XTLKHLP="D XTLK^LEXHLP"
if '$LENGTH($GET(XTLKKSCH("DSPLY")))
SET XTLKKSCH="XTLK^LEXPRNT"
+7 SET (X,XTLKX)=$$UP^XLFSTR(LEXERM)
SET DO=@(DIC_"0)")
SET DIC(0)="EMQ"
SET XTLKSAY=0
+8 WRITE !,"Searching ... "
+9 DO ^XTLKKWL
KILL XTLKSAY,XTLKHLP
SET LEXRP=X
LKQ ;
+1 KILL LEXSUB,LEXU,LEXAP,LEXUN,LEXLST,LEXLL,LEXSHOW
+2 KILL XTLKX,XTLKKSCH,XTLKHLP,XTLKSAY,XTLKGBL,XTLKWD2
+3 QUIT
DELS ;
+1 NEW DIK,LEXC
SET LEXCX=+($GET(LEXCX))
if '$LENGTH($GET(LEXSC))
QUIT
if LEXCX=0
QUIT
NEW LEXR,LEXS
+2 SET LEXR=$ORDER(^LEX(757.4,"ARA",$EXTRACT($$UP^XLFSTR(LEXSC),1,63),LEXCX,0))
if +LEXR=0
QUIT
+3 SET LEXS=$ORDER(^LEX(757.4,"ARA",$EXTRACT($$UP^XLFSTR(LEXSC),1,63),LEXCX,+LEXR,0))
if +LEXS=0
QUIT
+4 SET DA(1)=+LEXR
SET DA=+LEXS
SET DIK="^LEX(757.4,"_DA(1)_",1,"
DO ^DIK
+5 SET LEXC=$$CNT(LEXR)
IF LEXC'[U
IF +LEXC=0
DO DELR(LEXR)
+6 QUIT
DELR(DA) ;
+1 SET DA=+($GET(DA))
if DA=0
QUIT
if '$DATA(^LEX(757.4,DA))
QUIT
NEW DIK
SET DIK="^LEX(757.4,"
DO ^DIK
+2 QUIT
CNT(X) ;
+1 NEW LEXR,LEXC,LEXI
SET (LEXC,LEXI)=0
SET LEXR=+$GET(X)
+2 if '$LENGTH($GET(^LEX(757.4,LEXR,0)))
QUIT "^"
+3 FOR
SET LEXI=$ORDER(^LEX(757.4,LEXR,1,LEXI))
if +LEXI=0
QUIT
Begin DoDot:1
+4 SET LEXC=LEXC+1
End DoDot:1
+5 SET X=LEXC
QUIT X
