- LEXSC3 ;ISL/KER - Shortcuts Add/Delete ;04/21/2014
- ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
- ;
- ; 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
- LEXSC3 ;ISL/KER - Shortcuts Add/Delete ;04/21/2014
- +1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
- +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
