source: WorldVistAEHR/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXXST2.m@ 623

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

initial load of WorldVistAEHR

File size: 4.1 KB
Line 
1LEXXST2 ; ISL Lexicon Status (Routine Count) ; 12-08-97
2 ;;2.0;LEXICON UTILITY;**4,5,8**;Sep 23, 1996;Build 1
3 Q
4RTT ; Total Routines
5 D BL,TT("ROUTINES"),BL
6 D:$O(^DIC(9.8,"B","LEW~"))'["LEX" BL,TL(" NO ROUTINES FOUND")
7 Q:$O(^DIC(9.8,"B","LEW~"))'["LEX" N LEXT,LEXR,LEXROU,LEXV,LEXVD,LEXL,LEXP,LEXROU,LEXRC,LEXC,LEXVER,LEXVERD,LEXLAST,LEXFST,LEXSEC S LEXRC=0,LEXR=$E("LEX",1,($L("LEX")-1))_$C($A($E("LEX",$L("LEX")))-1)_"~",LEXC="LEX"
8 F S LEXR=$O(^DIC(9.8,"B",LEXR)) Q:LEXR=""!($E(LEXR,1,$L(LEXC))'=LEXC) D GET
9 I +($G(LEXRC))>0 D SET
10 Q
11GET ; Retrieve first 2 lines of routine
12 ; PCH 8 quit if routine is a environment check, pre/post install
13 Q:$E(LEXR,4)?1N
14 ; PCH 5 replace indirection $T(@LEXR) with executable string
15 K LEXFST,LEXSEC N X,LEXEXC S X=LEXR X ^%ZOSF("TEST") I $T D
16 . S LEXRC=+($G(LEXRC))+1
17 . S LEXEXC="S LEXFST=$T(^"_LEXR_")"
18 . X LEXEXC S LEXFST=$G(LEXFST),LEXL=$$TRIMD($P($G(LEXFST),";",3)) D LAST
19 . S LEXEXC="S LEXSEC=$T("_LEXR_"+1^"_LEXR_")"
20 . X LEXEXC S LEXSEC=$G(LEXSEC),LEXV=$$TRIMS($P($G(LEXSEC),";",3)),LEXVD=$$TRIMS($P($G(LEXSEC),";",6)),LEXP=$$TRIMS($P($G(LEXSEC),";",5)) D VER,VERD
21 Q
22SET ; Update global array
23 N LEXT,LEXV,LEXVD,LEXL
24 S LEXV=$G(LEXVER(0)),LEXVD=$G(LEXVERD(0)),LEXL=$G(LEXLAST(0))
25 S LEXT=" ROUTINES FOUND: "_LEXRC D TL(LEXT)
26 I $L($G(LEXV)) S LEXT=" VERSION: "_LEXV D TL(LEXT)
27 I $L($G(LEXVD)) S LEXT=" VERSION DATE: "_LEXVD D TL(LEXT)
28 I $L(LEXL) S LEXT=" DATE LAST MODIFIED: "_LEXL D TL(LEXT)
29 Q
30PT ; Pointed to ...
31 D BL,TT("POINTED TO BY") D:'$D(^DD(757.01,0,"PT")) BL,TL(" NO FILES POINT TO THE LEXICON") Q:'$D(^DD(757.01,0,"PT"))
32 N LEXC,LEXFI,LEXFIN,LEXFF,LEXFD,LEXFDN,LEXND,LEXPT,LEXF1,LEXF2,LEXD1,LEXD2
33 S (LEXFI,LEXC)=0 F S LEXFI=$O(^DD(757.01,0,"PT",LEXFI)) Q:+LEXFI=0 I $E(LEXFI,1,3)'["757" S LEXFD=0 F S LEXFD=$O(^DD(757.01,0,"PT",LEXFI,LEXFD)) Q:+LEXFD=0 D PTX
34 D:LEXC=0 BL,TL(" NO FILES POINT TO THE LEXICON")
35 Q
36PTX ; Pointed to Text
37 S LEXFIN=$O(^DD(LEXFI,0,"NM","")) Q:LEXFIN="" S LEXFDN=$P($G(^DD(LEXFI,LEXFD,0)),"^",1) Q:LEXFDN=""
38 S LEXFF=LEXFI_";"_LEXFD,LEXF1=" "_LEXFIN_" FILE"
39 S LEXD1=$P(LEXFI,".",1),LEXD2=$P(LEXFI,".",2.299),LEXF1=LEXF1_$J("",(55-($L(LEXF1)+$L(LEXD1))))_LEXD1_$S(LEXFF[".":".",1:"")_LEXD2
40 S LEXD1=$P(LEXFD,".",1),LEXD2=$P(LEXFD,".",2.299),LEXF1=LEXF1_$J("",(70-($L(LEXF1)+$L(LEXD1))))_LEXD1_$S(LEXFF[".":".",1:"")_LEXD2
41 S LEXF2=" "_LEXFDN_" FIELD"
42 S LEXC=LEXC+1 D BL,TL(LEXF1),TL(LEXF2)
43 Q
44TT(LEXX) ; Title Text
45 D TT^LEXXST($G(LEXX)) Q
46TL(LEXX) ; Noraml Text Line
47 D TL^LEXXST($G(LEXX)) Q
48BL ; Blank Line
49 D BL^LEXXST Q
50LAST ; Routine date-last-modified
51 S LEXL=$G(LEXL) Q:LEXL="" N LEXS,LEXD S LEXS=$$DTS^LEXXST4(LEXL)
52 S LEXD=$$STL^LEXXST4(LEXS) S:(+(LEXS)>+($G(LEXLAST))) LEXLAST=LEXS,LEXLAST(0)=LEXD Q
53VER ; Routine version number
54 S LEXV=$G(LEXV) S:(+(LEXV)>+($G(LEXVER))) LEXVER=+(LEXV),LEXVER(0)=LEXV Q
55VERD ; Routine version date
56 S LEXVD=$G(LEXVD) N LEXY,LEXM,LEXD,LEXL S LEXY=$E(LEXVD,($L(LEXVD)-1),$L(LEXVD))
57 S LEXD=+($P(LEXVD," ",2)),LEXM=$$UP^XLFSTR($P(LEXVD," ",1))
58 S LEXM=$S(LEXM["JAN":"01",LEXM["FEB":"02",LEXM["MAR":"03",LEXM["APR":"04",LEXM["MAY":"05",LEXM["JUN":"06",LEXM["JUL":"07",LEXM["AUG":"08",LEXM["SEP":"09",LEXM["OCT":"10",LEXM["NOV":"11",LEXM["DEC":"12",1:"01")
59 S LEXL=LEXY_LEXM_LEXD S:+LEXL>+($G(LEXVERD)) LEXVERD=+LEXL,LEXVERD(0)=LEXVD
60 Q
61TRIMD(LEXX) ; Trim Date
62 S LEXX=$G(LEXX),LEXX=$$TRIMS(LEXX)
63 S:LEXX["@" LEXX=$P(LEXX,"@",1)
64 S:LEXX["-"&(LEXX[" ") LEXX=$P(LEXX," ",1) S:LEXX["/"&(LEXX[" ") LEXX=$P(LEXX," ",1)
65 S:$E(LEXX,1)?1A&($L(LEXX," ")>3) LEXX=$P(LEXX," ",1,3)
66 S:$E(LEXX,1)?1N&($L(LEXX," ")>3) LEXX=$P(LEXX," ",1,3)
67 S LEXX=$$TRIMW(LEXX)
68 I $L(LEXX," ")'=3&($L(LEXX,"-")'=3)&($L(LEXX,"/")'=3) S LEXX=""
69 N LEX,LEXP S LEX=LEXX
70 F LEXP=1:1:3 D
71 . I LEX["-",$L($P(LEX,"-",LEXP))>4 S LEXX=""
72 . I LEX["/",$L($P(LEX,"/",LEXP))>4 S LEXX=""
73 . I LEX[" ",$L($P(LEX," ",LEXP))>4 S LEXX=""
74 Q LEXX
75TRIMS(LEXX) ; Trim String
76 S LEXX=$G(LEXX),LEXX=$TR(LEXX,"*",""),LEXX=$$TRIMW(LEXX) Q LEXX
77TRIMW(LEXX) ; Trim Word
78 S LEXX=$G(LEXX) F Q:$E(LEXX,1)'=" " S LEXX=$E(LEXX,2,$L(LEXX))
79 F Q:$E(LEXX,$L(LEXX))'=" " S LEXX=$E(LEXX,1,($L(LEXX)-1))
80 F Q:LEXX'[" " S LEXX=$P(LEXX," ",1)_" "_$P(LEXX," ",2)
81 Q LEXX
Note: See TracBrowser for help on using the repository browser.