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 Apr 09, 2024@21:12:42 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"
