source: WorldVistAEHR/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXXST4.m@ 1080

LEXXST4 ; ISL Lexicon Status (Dates)               ; 05-17-97
 ;;2.0;LEXICON UTILITY;**4,5**;Sep 23, 1996;Build 1
 Q
DTS(LEXX) ; Date to sequential
 ; PCH 5 default quit value 0
 S LEXX=$$UP^XLFSTR($$TRIM($G(LEXX))) Q:LEXX="" 0
 N LEXCUR,LEXMON S LEXCUR=$$CUR
 N LEXMON S LEXMON="JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC"
 S:LEXX["@" LEXX=$P(LEXX,"@",1)
 S LEXX=$TR(LEXX,"-"," "),LEXX=$TR(LEXX,"/"," ") S:$L(LEXX," ")>3 LEXX=$P(LEXX," ",1,3)
 N LEX1,LEX2,LEX3 S LEX1=$P(LEXX," ",1),LEX2=$P(LEXX," ",2),LEX3=$P(LEXX," ",3)
 S LEXM=$$NM(LEX1) I +LEXM>0,+LEXM<13 D  Q LEXX
 . S:$L(LEXM)=1 LEXM="0"_LEXM S LEXD=$$DTN(LEX2),LEXY=$$YTN(LEX3,$P(LEXCUR,"^",1)),LEXX=LEXY_LEXM_LEXD
 S LEXM=$$NM(LEX2) I +LEXM>0,+LEXM<13 D  Q LEXX
 . S:$L(LEXM)=1 LEXM="0"_LEXM S LEXD=$$DTN(LEX1),LEXY=$$YTN(LEX3,$P(LEXCUR,"^",1)),LEXX=LEXY_LEXM_LEXD
 S LEXM=$$AN(LEX1) I +LEXM>0,+LEXM<13 D  Q LEXX
 . S:$L(LEXM)=1 LEXM="0"_LEXM S LEXD=$$DTN(LEX2),LEXY=$$YTN(LEX3,$P(LEXCUR,"^",1)),LEXX=LEXY_LEXM_LEXD
 S LEXM=$$AN(LEX2) I +LEXM>0,+LEXM<13 D  Q LEXX
 . S:$L(LEXM)=1 LEXM="0"_LEXM S LEXD=$$DTN(LEX1),LEXY=$$YTN(LEX3,$P(LEXCUR,"^",1)),LEXX=LEXY_LEXM_LEXD
 S LEXX=0 Q LEXX
FTE(LEXX) ; Fileman to External (other)
 S LEXX=$G(LEXX) Q:LEXX="" LEXX
 S:LEXX["." LEXX=$P(LEXX,".",1) N LEXY,LEXM,LEXD S LEXY=+($E(LEXX,1,3)),LEXY=LEXY+1700
 S LEXM=$E(LEXX,4,5) S:$E(LEXM,1)="0" LEXM=+($E(LEXM,2)) S:LEXM=0 LEXM=1
 S LEXD=$E(LEXX,6,7) S:$E(LEXD,1)="0" LEXD=+($E(LEXD,2)) S:LEXD=0 LEXD=1 S:$L(LEXD)=1 LEXD=" "_LEXD
 S LEXM=$S(LEXM=1:"Jan",LEXM=2:"FEB",LEXM=3:"Mar",LEXM=4:"Apr",LEXM=5:"May",LEXM=6:"Jun",LEXM=7:"Jul",LEXM=8:"Aug",LEXM=9:"Sep",LEXM=10:"Oct",LEXM=11:"Nov",LEXM=12:"Dec",1:"Jan")
 S LEXX=LEXM_" "_LEXD_", "_LEXY
 Q LEXX
MTN(LEXX,LEXC) ; Alpha Month to 2 character numeric
 S LEXC=$G(LEXC),LEXX=$$UP^XLFSTR($G(LEXX)) Q:'$L(LEXX) LEXC
 S LEXX=$S(LEXX["JAN":"01",LEXX["FEB":"02",LEXX["MAR":"03",LEXX["APR":"04",LEXX["MAY":"05",LEXX["JUN":"06",LEXX["JUL":"07",LEXX["AUG":"08",LEXX["SEP":"09",LEXX["OCT":"10",LEXX["NOV":"11",LEXX["DEC":"12",1:LEXC)
 Q LEXX
DTN(LEXX) ; Day to 2 character numeric
 S LEXX=$G(LEXX) Q:'$L(LEXX) "01"
 S LEXX=$TR(LEXX,",",""),LEXX=$TR(LEXX,"-",""),LEXX=$TR(LEXX,"/",""),LEXX=$$TRIM(LEXX)
 S:$L(LEXX)=1 LEXX="0"_LEXX
 Q LEXX
YTN(LEXX,LEXC) ; Year to 4 character year
 S LEXC=$G(LEXC),LEXX=$$TRIM($G(LEXX)) Q:'$L(LEXX) LEXC  S LEXX=$TR(LEXX,"-",""),LEXX=$TR(LEXX,"/","") Q:$L(LEXX)'=2&($L(LEXX)'=4) LEXC
 S:$L(LEXX)=2&(+LEXX>83) LEXX="19"_LEXX S:$L(LEXX)=2&(+LEXX'>83) LEXX="20"_LEXX
 Q LEXX
STL(LEXX) ; Sequential to Long
 S LEXX=$G(LEXX) N LEXC S LEXC=$TR($$CUR,"^","") S:'$L(LEXX) LEXX=LEXC
 N LEXM,LEXD,LEXY S LEXY=$E(LEXX,1,4),LEXM=$E(LEXX,5,6),LEXD=$E(LEXX,7,8)
 S:$E(LEXM,1)="0" LEXM=$E(LEXM,2) S LEXM=+LEXM
 S LEXM=$S(LEXM=1:"Jan",LEXM=2:"Feb",LEXM=3:"Mar",LEXM=4:"Apr",LEXM=5:"May",LEXM=6:"Jun",LEXM=7:"Jul",LEXM=8:"Aug",LEXM=9:"Sep",LEXM=10:"Oct",LEXM=11:"Nov",LEXM=12:"Dec",1:"Jan")
 S:$E(LEXD,1)="0" LEXD=" "_$E(LEXD,2) S LEXX=LEXM_" "_LEXD_", "_LEXY Q LEXX
CUR(LEXX) ; Current Date
 N I,%,%I,%H,X D NOW^%DTC
 S LEXX=(+($E(X,1,3))+1700)_"^"_$E(X,4,5)_"^"_$E(X,6,7)
 Q LEXX
NM(LEXX) ; Numeric Month
 S LEXX=$$UP^XLFSTR($G(LEXX)) Q:+LEXX>0 ""
 N LEXMON S LEXMON="JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC"
 Q:LEXMON'[LEXX "" N LEXI,LEXM F LEXI=1:1:12 S LEXM=$P(LEXMON,"^",LEXI) S:LEXX=LEXM LEXX=LEXI Q:+LEXX>0
 S LEXX=+LEXX S:LEXX=0 LEXX="" Q LEXX
AN(LEXX) ; Alpha to Numeric
 S LEXX=$G(LEXX) S:$E(LEXX,1)="0" LEXX=$E(LEXX,2) S LEXX=+LEXX
 Q LEXX
TRIM(LEXX) ; Trim Spaces
 S LEXX=$G(LEXX),LEXX=$TR(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