- LEXDFN2 ;ISL/KER - Default Names ;04/21/2014
- ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
- ;
- ; Global Variables
- ; None
- ;
- ; External References
- ; $$UP^XLFSTR ICR 10103
- ;
- AP(X) ; Application Pointer
- S X=$G(X) S X=$$NS(X) Q:X="" 1
- N LEXIEN,LEXNS
- I $L($G(X)),$D(^LEXT(757.2,"AN",X)) S X=$O(^LEXT(757.2,"AN",X,0)) Q X
- I $L($G(X)),$D(^LEXT(757.2,"B",X)) D I LEXNS'="" S X=LEXIEN Q X
- . S LEXIEN=$O(^LEXT(757.2,"B",X,0))
- . S LEXNS=$P($G(^LEXT(757.2,LEXIEN,5)),"^",5)
- I $L($G(X)),$D(^LEXT(757.2,"C",$$UP^XLFSTR(X))) D I LEXNS'="" S X=LEXIEN Q X
- . S LEXIEN=$O(^LEXT(757.2,"C",$$UP^XLFSTR(X),0))
- . S LEXNS=$P($G(^LEXT(757.2,LEXIEN,5)),"^",5)
- I $L($G(X)),$D(^LEXT(757.2,"APPS",X)) D I LEXNS'="" S X=LEXIEN Q X
- . S LEXIEN=$O(^LEXT(757.2,"APPS",X,0))
- . S LEXNS=$P($G(^LEXT(757.2,LEXIEN,5)),"^",5)
- Q 1
- NS(X) ; Namespace
- S X=$G(X) Q:X="" "LEX"
- I +X>0,X?1N.N,$D(^LEXT(757.2,+X)) S X=$P($G(^LEXT(757.2,+X,5)),"^",5) S:X="" X="LEX" Q X
- I X'="",$D(^LEXT(757.2,"AA",X)) D S:X="" X="LEX" Q X
- . N LEXR S LEXR=$O(^LEXT(757.2,"AA",X,0)) I +LEXR>0,$D(^LEXT(757.2,+LEXR,0)) S X=$P($G(^LEXT(757.2,+LEXR,5)),"^",5)
- I X'="",$D(^LEXT(757.2,"AB",X)) D S:X="" X="LEX" Q X
- . N LEXR S LEXR=$O(^LEXT(757.2,"AB",X,0)) I +LEXR>0,$D(^LEXT(757.2,+LEXR,0)) S X=$P($G(^LEXT(757.2,+LEXR,5)),"^",5)
- I X'="",$D(^LEXT(757.2,"APPS",X)) D S:X="" X="LEX" Q X
- . N LEXR S LEXR=$O(^LEXT(757.2,"APPS",X,0)) I +LEXR>0,$D(^LEXT(757.2,+LEXR,0)) S X=$P($G(^LEXT(757.2,+LEXR,5)),"^",5)
- I X'="",$D(^LEXT(757.2,"AN",X)) D S:X="" X="LEX" Q X
- . N LEXR S LEXR=$O(^LEXT(757.2,"AN",X,0)) I +LEXR>0,$D(^LEXT(757.2,+LEXR,0)) S X=$P($G(^LEXT(757.2,+LEXR,5)),"^",5)
- I X'="",$D(^LEXT(757.2,"C",$$UP^XLFSTR(X))) D S:X="" X="LEX" Q X
- . N LEXR S LEXR=$O(^LEXT(757.2,"C",$$UP^XLFSTR(X),0)) I +LEXR>0,$D(^LEXT(757.2,+LEXR,0)) S X=$P($G(^LEXT(757.2,+LEXR,5)),"^",5)
- Q "LEX"
- MD(X) ; Mode/Subset
- S X=$G(X) Q:X="" "WRD"
- I $D(^LEXT(757.2,"AA",X)) D S:X="" X="WRD" Q X
- . N LEXR S LEXR=$O(^LEXT(757.2,"AA",X,0)) I +LEXR>0,$D(^LEXT(757.2,+LEXR,0)) S X=$$MODE(+LEXR)
- I $D(^LEXT(757.2,"AB",X)) D S:X="" X="WRD" Q X
- . N LEXR S LEXR=$O(^LEXT(757.2,"AB",X,0)) I +LEXR>0,$D(^LEXT(757.2,+LEXR,0)) S X=$$MODE(+LEXR)
- I $D(^LEXT(757.2,"APPS",X)) D S:X="" X="WRD" Q X
- . N LEXR S LEXR=$O(^LEXT(757.2,"APPS",X,0)) I +LEXR>0,$D(^LEXT(757.2,+LEXR,0)) S X=$$MODE(+LEXR)
- I $D(^LEXT(757.2,"AN",X)) D S:X="" X="WRD" Q X
- . N LEXR S LEXR=$O(^LEXT(757.2,"AN",X,0)) I +LEXR>0,$D(^LEXT(757.2,+LEXR,0)) S X=$$MODE(+LEXR)
- I $D(^LEXT(757.2,"C",$$UP^XLFSTR(X))) D S:X="" X="WRD" Q X
- . N LEXR S LEXR=$O(^LEXT(757.2,"C",$$UP^XLFSTR(X),0)) I +LEXR>0,$D(^LEXT(757.2,+LEXR,0)) S X=$$MODE(+LEXR)
- I +X>0,$D(^LEXT(757.2,+X)) S X=$$MODE(+X) S:X="" X="WRD" Q X
- Q "WRD"
- MODE(X) ;
- N LEXMD S X=+($G(X)) Q:X=0 "WRD"
- S LEXMD=$P($G(^LEXT(757.2,X,5)),"^",1) I LEXMD'="" S X=LEXMD Q X
- S LEXMD=$P($G(^LEXT(757.2,X,5)),"^",2) I LEXMD'="" S X=LEXMD Q X
- S LEXMD=$P($G(^LEXT(757.2,X,0)),"^",2) I LEXMD'="" S X=LEXMD Q X
- Q "WRD"
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXDFN2 3080 printed Feb 18, 2025@23:33:44 Page 2
- LEXDFN2 ;ISL/KER - Default Names ;04/21/2014
- +1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
- +2 ;
- +3 ; Global Variables
- +4 ; None
- +5 ;
- +6 ; External References
- +7 ; $$UP^XLFSTR ICR 10103
- +8 ;
- AP(X) ; Application Pointer
- +1 SET X=$GET(X)
- SET X=$$NS(X)
- if X=""
- QUIT 1
- +2 NEW LEXIEN,LEXNS
- +3 IF $LENGTH($GET(X))
- IF $DATA(^LEXT(757.2,"AN",X))
- SET X=$ORDER(^LEXT(757.2,"AN",X,0))
- QUIT X
- +4 IF $LENGTH($GET(X))
- IF $DATA(^LEXT(757.2,"B",X))
- Begin DoDot:1
- +5 SET LEXIEN=$ORDER(^LEXT(757.2,"B",X,0))
- +6 SET LEXNS=$PIECE($GET(^LEXT(757.2,LEXIEN,5)),"^",5)
- End DoDot:1
- IF LEXNS'=""
- SET X=LEXIEN
- QUIT X
- +7 IF $LENGTH($GET(X))
- IF $DATA(^LEXT(757.2,"C",$$UP^XLFSTR(X)))
- Begin DoDot:1
- +8 SET LEXIEN=$ORDER(^LEXT(757.2,"C",$$UP^XLFSTR(X),0))
- +9 SET LEXNS=$PIECE($GET(^LEXT(757.2,LEXIEN,5)),"^",5)
- End DoDot:1
- IF LEXNS'=""
- SET X=LEXIEN
- QUIT X
- +10 IF $LENGTH($GET(X))
- IF $DATA(^LEXT(757.2,"APPS",X))
- Begin DoDot:1
- +11 SET LEXIEN=$ORDER(^LEXT(757.2,"APPS",X,0))
- +12 SET LEXNS=$PIECE($GET(^LEXT(757.2,LEXIEN,5)),"^",5)
- End DoDot:1
- IF LEXNS'=""
- SET X=LEXIEN
- QUIT X
- +13 QUIT 1
- NS(X) ; Namespace
- +1 SET X=$GET(X)
- if X=""
- QUIT "LEX"
- +2 IF +X>0
- IF X?1N.N
- IF $DATA(^LEXT(757.2,+X))
- SET X=$PIECE($GET(^LEXT(757.2,+X,5)),"^",5)
- if X=""
- SET X="LEX"
- QUIT X
- +3 IF X'=""
- IF $DATA(^LEXT(757.2,"AA",X))
- Begin DoDot:1
- +4 NEW LEXR
- SET LEXR=$ORDER(^LEXT(757.2,"AA",X,0))
- IF +LEXR>0
- IF $DATA(^LEXT(757.2,+LEXR,0))
- SET X=$PIECE($GET(^LEXT(757.2,+LEXR,5)),"^",5)
- End DoDot:1
- if X=""
- SET X="LEX"
- QUIT X
- +5 IF X'=""
- IF $DATA(^LEXT(757.2,"AB",X))
- Begin DoDot:1
- +6 NEW LEXR
- SET LEXR=$ORDER(^LEXT(757.2,"AB",X,0))
- IF +LEXR>0
- IF $DATA(^LEXT(757.2,+LEXR,0))
- SET X=$PIECE($GET(^LEXT(757.2,+LEXR,5)),"^",5)
- End DoDot:1
- if X=""
- SET X="LEX"
- QUIT X
- +7 IF X'=""
- IF $DATA(^LEXT(757.2,"APPS",X))
- Begin DoDot:1
- +8 NEW LEXR
- SET LEXR=$ORDER(^LEXT(757.2,"APPS",X,0))
- IF +LEXR>0
- IF $DATA(^LEXT(757.2,+LEXR,0))
- SET X=$PIECE($GET(^LEXT(757.2,+LEXR,5)),"^",5)
- End DoDot:1
- if X=""
- SET X="LEX"
- QUIT X
- +9 IF X'=""
- IF $DATA(^LEXT(757.2,"AN",X))
- Begin DoDot:1
- +10 NEW LEXR
- SET LEXR=$ORDER(^LEXT(757.2,"AN",X,0))
- IF +LEXR>0
- IF $DATA(^LEXT(757.2,+LEXR,0))
- SET X=$PIECE($GET(^LEXT(757.2,+LEXR,5)),"^",5)
- End DoDot:1
- if X=""
- SET X="LEX"
- QUIT X
- +11 IF X'=""
- IF $DATA(^LEXT(757.2,"C",$$UP^XLFSTR(X)))
- Begin DoDot:1
- +12 NEW LEXR
- SET LEXR=$ORDER(^LEXT(757.2,"C",$$UP^XLFSTR(X),0))
- IF +LEXR>0
- IF $DATA(^LEXT(757.2,+LEXR,0))
- SET X=$PIECE($GET(^LEXT(757.2,+LEXR,5)),"^",5)
- End DoDot:1
- if X=""
- SET X="LEX"
- QUIT X
- +13 QUIT "LEX"
- MD(X) ; Mode/Subset
- +1 SET X=$GET(X)
- if X=""
- QUIT "WRD"
- +2 IF $DATA(^LEXT(757.2,"AA",X))
- Begin DoDot:1
- +3 NEW LEXR
- SET LEXR=$ORDER(^LEXT(757.2,"AA",X,0))
- IF +LEXR>0
- IF $DATA(^LEXT(757.2,+LEXR,0))
- SET X=$$MODE(+LEXR)
- End DoDot:1
- if X=""
- SET X="WRD"
- QUIT X
- +4 IF $DATA(^LEXT(757.2,"AB",X))
- Begin DoDot:1
- +5 NEW LEXR
- SET LEXR=$ORDER(^LEXT(757.2,"AB",X,0))
- IF +LEXR>0
- IF $DATA(^LEXT(757.2,+LEXR,0))
- SET X=$$MODE(+LEXR)
- End DoDot:1
- if X=""
- SET X="WRD"
- QUIT X
- +6 IF $DATA(^LEXT(757.2,"APPS",X))
- Begin DoDot:1
- +7 NEW LEXR
- SET LEXR=$ORDER(^LEXT(757.2,"APPS",X,0))
- IF +LEXR>0
- IF $DATA(^LEXT(757.2,+LEXR,0))
- SET X=$$MODE(+LEXR)
- End DoDot:1
- if X=""
- SET X="WRD"
- QUIT X
- +8 IF $DATA(^LEXT(757.2,"AN",X))
- Begin DoDot:1
- +9 NEW LEXR
- SET LEXR=$ORDER(^LEXT(757.2,"AN",X,0))
- IF +LEXR>0
- IF $DATA(^LEXT(757.2,+LEXR,0))
- SET X=$$MODE(+LEXR)
- End DoDot:1
- if X=""
- SET X="WRD"
- QUIT X
- +10 IF $DATA(^LEXT(757.2,"C",$$UP^XLFSTR(X)))
- Begin DoDot:1
- +11 NEW LEXR
- SET LEXR=$ORDER(^LEXT(757.2,"C",$$UP^XLFSTR(X),0))
- IF +LEXR>0
- IF $DATA(^LEXT(757.2,+LEXR,0))
- SET X=$$MODE(+LEXR)
- End DoDot:1
- if X=""
- SET X="WRD"
- QUIT X
- +12 IF +X>0
- IF $DATA(^LEXT(757.2,+X))
- SET X=$$MODE(+X)
- if X=""
- SET X="WRD"
- QUIT X
- +13 QUIT "WRD"
- MODE(X) ;
- +1 NEW LEXMD
- SET X=+($GET(X))
- if X=0
- QUIT "WRD"
- +2 SET LEXMD=$PIECE($GET(^LEXT(757.2,X,5)),"^",1)
- IF LEXMD'=""
- SET X=LEXMD
- QUIT X
- +3 SET LEXMD=$PIECE($GET(^LEXT(757.2,X,5)),"^",2)
- IF LEXMD'=""
- SET X=LEXMD
- QUIT X
- +4 SET LEXMD=$PIECE($GET(^LEXT(757.2,X,0)),"^",2)
- IF LEXMD'=""
- SET X=LEXMD
- QUIT X
- +5 QUIT "WRD"