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

LEXXST2 ; ISL Lexicon Status (Routine Count)       ; 12-08-97
 ;;2.0;LEXICON UTILITY;**4,5,8**;Sep 23, 1996;Build 1
 Q
RTT ; Total Routines
 D BL,TT("ROUTINES"),BL
 D:$O(^DIC(9.8,"B","LEW~"))'["LEX" BL,TL("     NO ROUTINES FOUND")
 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"
 F  S LEXR=$O(^DIC(9.8,"B",LEXR)) Q:LEXR=""!($E(LEXR,1,$L(LEXC))'=LEXC)  D GET
 I +($G(LEXRC))>0 D SET
 Q
GET ; Retrieve first 2 lines of routine
 ; PCH 8 quit if routine is a environment check, pre/post install
 Q:$E(LEXR,4)?1N
 ; PCH 5 replace indirection $T(@LEXR) with executable string
 K LEXFST,LEXSEC N X,LEXEXC S X=LEXR X ^%ZOSF("TEST") I $T D
 . S LEXRC=+($G(LEXRC))+1
 . S LEXEXC="S LEXFST=$T(^"_LEXR_")"
 . X LEXEXC S LEXFST=$G(LEXFST),LEXL=$$TRIMD($P($G(LEXFST),";",3)) D LAST
 . S LEXEXC="S LEXSEC=$T("_LEXR_"+1^"_LEXR_")"
 . 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
 Q
SET ; Update global array
 N LEXT,LEXV,LEXVD,LEXL
 S LEXV=$G(LEXVER(0)),LEXVD=$G(LEXVERD(0)),LEXL=$G(LEXLAST(0))
 S LEXT="     ROUTINES FOUND:      "_LEXRC D TL(LEXT)
 I $L($G(LEXV)) S LEXT="     VERSION:             "_LEXV D TL(LEXT)
 I $L($G(LEXVD)) S LEXT="     VERSION DATE:        "_LEXVD D TL(LEXT)
 I $L(LEXL) S LEXT="     DATE LAST MODIFIED:  "_LEXL D TL(LEXT)
 Q
PT ; Pointed to ...
 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"))
 N LEXC,LEXFI,LEXFIN,LEXFF,LEXFD,LEXFDN,LEXND,LEXPT,LEXF1,LEXF2,LEXD1,LEXD2
 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
 D:LEXC=0 BL,TL("     NO FILES POINT TO THE LEXICON")
 Q
PTX ; Pointed to Text
 S LEXFIN=$O(^DD(LEXFI,0,"NM","")) Q:LEXFIN=""  S LEXFDN=$P($G(^DD(LEXFI,LEXFD,0)),"^",1) Q:LEXFDN=""
 S LEXFF=LEXFI_";"_LEXFD,LEXF1="    "_LEXFIN_" FILE"
 S LEXD1=$P(LEXFI,".",1),LEXD2=$P(LEXFI,".",2.299),LEXF1=LEXF1_$J("",(55-($L(LEXF1)+$L(LEXD1))))_LEXD1_$S(LEXFF[".":".",1:"")_LEXD2
 S LEXD1=$P(LEXFD,".",1),LEXD2=$P(LEXFD,".",2.299),LEXF1=LEXF1_$J("",(70-($L(LEXF1)+$L(LEXD1))))_LEXD1_$S(LEXFF[".":".",1:"")_LEXD2
 S LEXF2="      "_LEXFDN_" FIELD"
 S LEXC=LEXC+1 D BL,TL(LEXF1),TL(LEXF2)
 Q
TT(LEXX) ; Title Text
 D TT^LEXXST($G(LEXX)) Q
TL(LEXX) ; Noraml Text Line
 D TL^LEXXST($G(LEXX)) Q
BL ; Blank Line
 D BL^LEXXST Q
LAST ; Routine date-last-modified
 S LEXL=$G(LEXL) Q:LEXL=""  N LEXS,LEXD S LEXS=$$DTS^LEXXST4(LEXL)
 S LEXD=$$STL^LEXXST4(LEXS) S:(+(LEXS)>+($G(LEXLAST))) LEXLAST=LEXS,LEXLAST(0)=LEXD Q
VER ; Routine version number
 S LEXV=$G(LEXV) S:(+(LEXV)>+($G(LEXVER))) LEXVER=+(LEXV),LEXVER(0)=LEXV Q
VERD ; Routine version date
 S LEXVD=$G(LEXVD) N LEXY,LEXM,LEXD,LEXL S LEXY=$E(LEXVD,($L(LEXVD)-1),$L(LEXVD))
 S LEXD=+($P(LEXVD," ",2)),LEXM=$$UP^XLFSTR($P(LEXVD," ",1))
 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")
 S LEXL=LEXY_LEXM_LEXD S:+LEXL>+($G(LEXVERD)) LEXVERD=+LEXL,LEXVERD(0)=LEXVD
 Q
TRIMD(LEXX) ; Trim Date
 S LEXX=$G(LEXX),LEXX=$$TRIMS(LEXX)
 S:LEXX["@" LEXX=$P(LEXX,"@",1)
 S:LEXX["-"&(LEXX[" ") LEXX=$P(LEXX," ",1) S:LEXX["/"&(LEXX[" ") LEXX=$P(LEXX," ",1)
 S:$E(LEXX,1)?1A&($L(LEXX," ")>3) LEXX=$P(LEXX," ",1,3)
 S:$E(LEXX,1)?1N&($L(LEXX," ")>3) LEXX=$P(LEXX," ",1,3)
 S LEXX=$$TRIMW(LEXX)
 I $L(LEXX," ")'=3&($L(LEXX,"-")'=3)&($L(LEXX,"/")'=3) S LEXX=""
 N LEX,LEXP S LEX=LEXX
 F LEXP=1:1:3  D
 . I LEX["-",$L($P(LEX,"-",LEXP))>4 S LEXX=""
 . I LEX["/",$L($P(LEX,"/",LEXP))>4 S LEXX=""
 . I LEX[" ",$L($P(LEX," ",LEXP))>4 S LEXX=""
 Q LEXX
TRIMS(LEXX) ; Trim String
 S LEXX=$G(LEXX),LEXX=$TR(LEXX,"*",""),LEXX=$$TRIMW(LEXX) Q LEXX
TRIMW(LEXX) ; Trim Word
 S LEXX=$G(LEXX) F  Q:$E(LEXX,1)'=" "  S LEXX=$E(LEXX,2,$L(LEXX))
 F  Q:$E(LEXX,$L(LEXX))'=" "  S LEXX=$E(LEXX,1,($L(LEXX)-1))
 F  Q:LEXX'["  "  S LEXX=$P(LEXX,"  ",1)_" "_$P(LEXX,"  ",2)
 Q LEXX