source: WorldVistAEHR/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDFN2.m@ 724

Last change on this file since 724 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.8 KB
Line 
1LEXDFN2 ; ISL Default Names ; 09-23-96
2 ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
3 ;
4AP(X) ; Application Pointer
5 S X=$G(X) S X=$$NS(X) Q:X="" 1
6 N LEXIEN,LEXNS
7 I $L($G(X)),$D(^LEXT(757.2,"AN",X)) S X=$O(^LEXT(757.2,"AN",X,0)) Q X
8 I $L($G(X)),$D(^LEXT(757.2,"B",X)) D I LEXNS'="" S X=LEXIEN Q X
9 . S LEXIEN=$O(^LEXT(757.2,"B",X,0))
10 . S LEXNS=$P($G(^LEXT(757.2,LEXIEN,5)),"^",5)
11 I $L($G(X)),$D(^LEXT(757.2,"C",$$UP^XLFSTR(X))) D I LEXNS'="" S X=LEXIEN Q X
12 . S LEXIEN=$O(^LEXT(757.2,"C",$$UP^XLFSTR(X),0))
13 . S LEXNS=$P($G(^LEXT(757.2,LEXIEN,5)),"^",5)
14 I $L($G(X)),$D(^LEXT(757.2,"APPS",X)) D I LEXNS'="" S X=LEXIEN Q X
15 . S LEXIEN=$O(^LEXT(757.2,"APPS",X,0))
16 . S LEXNS=$P($G(^LEXT(757.2,LEXIEN,5)),"^",5)
17 Q 1
18NS(X) ; Namespace
19 S X=$G(X) Q:X="" "LEX"
20 I +X>0,$D(^LEXT(757.2,+X)) S X=$P($G(^LEXT(757.2,+X,5)),"^",5) S:X="" X="LEX" Q X
21 I X'="",$D(^LEXT(757.2,"AA",X)) D S:X="" X="LEX" Q X
22 . 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)
23 I X'="",$D(^LEXT(757.2,"AB",X)) D S:X="" X="LEX" Q X
24 . 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)
25 I X'="",$D(^LEXT(757.2,"APPS",X)) D S:X="" X="LEX" Q X
26 . 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)
27 I X'="",$D(^LEXT(757.2,"AN",X)) D S:X="" X="LEX" Q X
28 . 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)
29 I X'="",$D(^LEXT(757.2,"C",$$UP^XLFSTR(X))) D S:X="" X="LEX" Q X
30 . 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)
31 Q "LEX"
32MD(X) ; Mode/Subset
33 S X=$G(X) Q:X="" "WRD"
34 I $D(^LEXT(757.2,"AA",X)) D S:X="" X="WRD" Q X
35 . N LEXR S LEXR=$O(^LEXT(757.2,"AA",X,0)) I +LEXR>0,$D(^LEXT(757.2,+LEXR,0)) S X=$$MODE(+LEXR)
36 I $D(^LEXT(757.2,"AB",X)) D S:X="" X="WRD" Q X
37 . N LEXR S LEXR=$O(^LEXT(757.2,"AB",X,0)) I +LEXR>0,$D(^LEXT(757.2,+LEXR,0)) S X=$$MODE(+LEXR)
38 I $D(^LEXT(757.2,"APPS",X)) D S:X="" X="WRD" Q X
39 . N LEXR S LEXR=$O(^LEXT(757.2,"APPS",X,0)) I +LEXR>0,$D(^LEXT(757.2,+LEXR,0)) S X=$$MODE(+LEXR)
40 I $D(^LEXT(757.2,"AN",X)) D S:X="" X="WRD" Q X
41 . N LEXR S LEXR=$O(^LEXT(757.2,"AN",X,0)) I +LEXR>0,$D(^LEXT(757.2,+LEXR,0)) S X=$$MODE(+LEXR)
42 I $D(^LEXT(757.2,"C",$$UP^XLFSTR(X))) D S:X="" X="WRD" Q X
43 . 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)
44 I +X>0,$D(^LEXT(757.2,+X)) S X=$$MODE(+X) S:X="" X="WRD" Q X
45 Q "WRD"
46MODE(X) ;
47 N LEXMD S X=+($G(X)) Q:X=0 "WRD"
48 S LEXMD=$P($G(^LEXT(757.2,X,5)),"^",1) I LEXMD'="" S X=LEXMD Q X
49 S LEXMD=$P($G(^LEXT(757.2,X,5)),"^",2) I LEXMD'="" S X=LEXMD Q X
50 S LEXMD=$P($G(^LEXT(757.2,X,0)),"^",2) I LEXMD'="" S X=LEXMD Q X
51 Q "WRD"
Note: See TracBrowser for help on using the repository browser.