- DIDT ;SFISC/GFT-DATE/TIME UTILITY ;2014-12-26 12:32 PM
- ;;22.2;VA FileMan;**14**;Jan 05, 2016;Build 8
- ;;Per VA Directive 6402, this routine should not be modified.
- ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- ;;Licensed under the terms of the Apache License, Version 2.0.
- ;
- %DT ;
- I $G(DUZ("LANG"))>1,($G(^DI(.85,DUZ("LANG"),20.2))]"") X ^(20.2) Q
- CONT ;
- K % S:$D(%DT)[0 %DT="" S:$G(DIQUIET)!($D(DDS)#2)!($D(ZTQUEUED)) %DT=$P(%DT,"E")_$P(%DT,"E",2) G NA:%DT'["A"
- W !,$S($D(%DT("A")):%DT("A"),1:"DATE: "),$S($D(%DT("B")):%DT("B")_"//",1:"")
- R X:$S($D(DTIME):DTIME,1:300) S:'$T X="^",DTOUT=1 G:$L(X)>39 1
- I $D(%DT("B")),X="" S X=%DT("B")
- I "^"[X S Y=-1 K %I,% Q
- NA S %(0)=X G 1:X'?.ANP,1:$P(X,"@")?15.N,1:$P(X,"@",2)?15.N,1:$L(X)>39
- F %=1:1:$L(X) Q:X?.UNP S Y=$E(X,%) I Y?1L S X=$E(X,1,%-1)_$C($A(Y)-32)_$E(X,%+1,99) ;UPPER CASE
- I %DT["E",X?."?" D HELP^%DTC G B
- I %DT["N",X?.N G NO
- I X?1.A,(X["MID"!(X["NOON")) S X="@"_X
- I X'?1"NOV".E,X?1"N".1"OW".1P.E G N^%DTC:%DT["T"!(%DT["R")&(%DT'["M") S X=$E(X,2,99),X="T"_$P(X,"OW")_$P(X,"OW",2)
- I X?1.N." "1.2A!(X?1.N1":"2N." ".2A)!(X?1.N1":"2N1":"2N." ".2A) S X="T@"_X
- I X?7N1"."1.N G R
- I X'["@",%DT'["R" G R
- I %DT'["T",%DT'["R" G NO
- I %DT["M" G NO
- S Y=$P(X,"@",2,9),X=$P(X,"@")
- F %=2,3 S %I=$P(Y,":",%) I %I?1N.E,%I'?2N.PA G 1
- S:X="" X="T" S Y=$P(Y,":")_$P(Y,":",2)_$P(Y,":",3,9),%I=Y
- I Y?1.A S Y=$S(Y["MID":2400,Y["NOON":1200,1:"")
- T G G:Y?4N,G1:Y?6N&(%DT["S"),1:Y'?1.6N." ".1(1"AM",1"A",1"A.M",1"PM",1"P",1"P.M").P I %DT["R",Y="" G NO
- S %I=$P(1_%I,+(1_Y),2) S:%I]"" Y=$P(Y,%I)
- I Y?5.6N G:%DT'["S" 1 S %(3)=$E(Y,$L(Y)-1,$L(Y)),Y=$E(Y,1,$L(Y)-2) G 1:%(3)>59
- I Y?1.2N G:Y'<13 1 S Y=Y_"00" S:$E(Y)=0 %I="A"
- I %I["A" S Y=$S(Y=1200&'$G(%(3)):2400,Y>1159:Y-1200,1:Y)
- E I Y?1.2"0"2N G:%I["P" 1
- E I Y<1200,%I["P"!(Y<600) S Y=Y+1200 ;ASSUME PM
- G G 1:Y>2400,1:Y#100>59,1:('Y&('$G(%(3)))) S %(1)=$S('Y:".0000",1:Y/10000) G R
- G1 G 1:Y>240000!'Y,1:$E(Y,3,4)#100>59,1:$E(Y,5,6)#100>59 S %(1)=Y/1000000
- R I %DT["F"!(%DT["P") D TY S %(9)=%
- 7 G 8:X'?7N1".".E&(X'?7N) S Y=$E(X,8,16),%=$E(Y_"000000",2,7)
- I Y,%DT'["T"!(%DT["M") G NO
- ;I %DT["E",(%'?.N)!(%>240000)!($E(%,3,4)>59)!($E(%,5,6)>59) G NO
- I (%'?.N)!(%>240000)!($E(%,3,4)>59)!($E(%,5,6)>59) G NO ;p14
- S:Y %(1)=+Y S X=$E(X,4,7)_($E(X,1,3)+1700),%(7)=1
- I %DT["I",'$D(%("ALPHA")) S X=$E(X,3,4)_$E(X,1,2)_$E(X,5,9)
- 8 S %I=0,%="" I X'?.N G T^%DTC:"T+-"[$E(X),U:X["^",1:$E(X)?1P,MTH:X?3.A&(%DT["M"),X
- I X?8N,X>17999999,$E(X,5,8)<1300 S X=$E(X,5,8)_$E(X,1,4),%("ALPHA")=1 ;MAY BE '200101231' FOR 2001DEC31
- I %DT'["X",X\300=6!(X?2N) S (%I(1),%I(2))=0,%I(3)=X G 3
- F %I=0:1 S Y=$E(X,1,2),X=$E(X,3,9) G OT:Y="" D G:%I="" 1
- . I %DT["X",%DT'["M",%I<2,'Y S %I="" Q
- . S:%I=2 Y=Y_X,X=""
- . I %DT["X",%I=2,$L(Y)>2,Y'>1799 S %I="" Q
- . S %I(%I+1)=Y Q
- ;
- X S Y=$E(X),X=$E(X,2,99) I Y?1N G A:%?.N,Y ;PEEL OFF CHARACTER-BY-CHARACTER
- I Y?1A G A:%?.A,Y
- OT D:%]"" % G 1:%I>3,X:Y?1P,1:Y]"",@%I
- Y D % S %=Y G 1:%I>3,X
- A S %=%_Y G X
- TY S %=$H#1461,%=$H\1461*4+(%\365)+141-(%=1460) Q
- 0 ;
- 1 W:%DT["E"&'$D(DIER) $C(7),$S('$D(DDS):" ??",1:"") ;INPUT IS BAD!
- B G %DT:%DT["A",NO
- U S X="^",%(0)=X
- ;S Y=-1 G Q:%DT'["A",Q:X["^" W $C(7)," ??" G %DT
- NO S Y=-1 G Q:%DT'["A"!(%DT'["E"),Q:X["^" W $C(7)," ??" G %DT ;p14
- 2 I %DT["M" S %I(3)=%I(2),%I(2)=0 G 3
- I %I(2)>31!'%I(2),%DT'["X" S %I(3)=%I(2),%I(2)=0 G 1:'%I(2)&$G(%(1)) G 3
- D TY S %I(3)=% D PF^%DTC:$D(%(9)) G C
- 3 I %I(1)>1700 S %("YF")=%I(1),%I(1)=%I(2),%I(2)=%I(3),%I(3)=%("YF") ;YEAR FIRST: ALLOW '2010-1-31'
- I %I(3)?2N D G C
- . I '$D(%(9)) D TY S %(9)=%
- . N A S A=$E(%(9))*100
- . I $E(%(9),2,3)=%I(3) S %I(3)=A+%I(3) Q
- . I %DT["P" S %I(3)=$S(%I(3)<$E(%(9),2,3):A,1:A-100)+%I(3) Q
- . I %DT["F" S %I(3)=$S(%I(3)>$E(%(9),2,3):A,1:A+100)+%I(3) Q
- . S %I(3)=A+%I(3)
- . I %(9)-%I(3)>80 S %I(3)=%I(3)+100 Q
- . I %I(3)-%(9)>20 S %I(3)=%I(3)-100
- . Q
- S %I(3)=%I(3)-1700 G 1:%I(3)'?3N
- C I %DT["I",'$D(%("ALPHA")),'$D(%("YF")),%I(2)>0 S %=%I(2),%I(2)=%I(1),%I(1)=% ;INTERNATIONAL: REVERSE MONTH/DAY
- I %I(2)="00",'$G(%(7)) G 1
- I %DT["M",$G(%I(2)) G 1
- I %I(1)>12!(%I(1)="00") G 1
- I %I(2)>28,$E("303232332323",%I(1))+28<%I(2),%I(1)-2!(%I(2)-29)!(%I(3)#4)!('(%I(3)#100)&(%I(3)+1700#400)) G 1
- D I %DT["M",$G(%I(2)) S %I(2)=0
- D P
- E I $D(%(1)) S:$D(%(3)) %(1)=$E(%(1)_"000",1,5)_%(3) S Y=+(Y_%(1))
- I '$E(Y,6,7),Y["." G 1
- I %DT["E" S %=Y D DD W " ("_Y_")" S Y=%
- I $D(%DT(0)) S %=%DT(0),%I=$S(%["-":Y,1:-Y) D:'% Z I $S(%DT["S":%,1:%\.0001/10000)+%I>0 G 1
- Q S X=%(0) K %,%I,%H Q
- ;
- Z I $P("NOW",%(0))="" S %=Y
- E D NOW^%DTC
- S:%DT(0)["-" %=-% Q
- ;
- DD I $G(DUZ("LANG"))>1 S Y=$$OUT^DIALOGU(Y,"DD") Q ;create writable date from 'Y' to 'Y'
- Q:'Y
- N M,MI,COMMA S M=$S($E(Y,4,5):$E($P($T(M)," ",$E(Y,4,5)+2),1,3)_" ",1:""),MI="",COMMA="," I $G(%DT)["I" S MI=M,M="",COMMA="" ;INTERNATIONAL (UK)
- S Y=M_$S($E(Y,6,7):$E(Y,6,7)_COMMA_" ",1:"")_MI_($E(Y,1,3)+1700)_$S(Y[".":"."_$P(Y,".",2),1:"")
- I Y["." S Y=$P(Y,".")_"@"_$E(Y_0,14,15)_":"_$E(Y_"000",16,17)_$S($E(Y,18,19):":"_$E(Y_0,18,19),1:"")
- I $D(%DT)#2,%DT["S",Y["@",$P(Y,":",3)="" S Y=Y_":00"
- Q
- ;
- P S Y=%I(3)_$E(%I(1)+100,2,3)_$E(%I(2)+100,2,3) Q
- ;
- MTH S %=X D % G:%I>3 1
- S %I(2)=0
- D TY S %I(3)=% D:$D(%(9)) PF^%DTC
- G D
- % ;I %DT["I",%?3.A S %I=9 Q
- I %?3.A S %=$F($T(M)," "_%) I %>0 S %=$L($E($T(M),6,%-1)," ") D:%I=1 S %("ALPHA")=1 ;ONLY MONTH IS ALPHA
- . N T S T=%I(1),%I(1)=%,%=T I $D(%("ALPHA")) S %I=9
- S:%<1&(%'="00")&(%I'=2) %I=9 S %I=%I+1,%I(%I)=%,%=""
- M ;; JANUARY FEBRUARY MARCH APRIL MAY JUNE JULY AUGUST SEPTEMBER OCTOBER NOVEMBER DECEMBER
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIDT 5656 printed Jan 18, 2025@03:47:52 Page 2
- DIDT ;SFISC/GFT-DATE/TIME UTILITY ;2014-12-26 12:32 PM
- +1 ;;22.2;VA FileMan;**14**;Jan 05, 2016;Build 8
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- +4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- +5 ;;Licensed under the terms of the Apache License, Version 2.0.
- +6 ;
- %DT ;
- +1 IF $GET(DUZ("LANG"))>1
- IF ($GET(^DI(.85,DUZ("LANG"),20.2))]"")
- XECUTE ^(20.2)
- QUIT
- CONT ;
- +1 KILL %
- if $DATA(%DT)[0
- SET %DT=""
- if $GET(DIQUIET)!($DATA(DDS)#2)!($DATA(ZTQUEUED))
- SET %DT=$PIECE(%DT,"E")_$PIECE(%DT,"E",2)
- if %DT'["A"
- GOTO NA
- +2 WRITE !,$SELECT($DATA(%DT("A")):%DT("A"),1:"DATE: "),$SELECT($DATA(%DT("B")):%DT("B")_"//",1:"")
- +3 READ X:$SELECT($DATA(DTIME):DTIME,1:300)
- if '$TEST
- SET X="^"
- SET DTOUT=1
- if $LENGTH(X)>39
- GOTO 1
- +4 IF $DATA(%DT("B"))
- IF X=""
- SET X=%DT("B")
- +5 IF "^"[X
- SET Y=-1
- KILL %I,%
- QUIT
- NA SET %(0)=X
- if X'?.ANP
- GOTO 1
- if $PIECE(X,"@")?15.N
- GOTO 1
- if $PIECE(X,"@",2)?15.N
- GOTO 1
- if $LENGTH(X)>39
- GOTO 1
- +1 ;UPPER CASE
- FOR %=1:1:$LENGTH(X)
- if X?.UNP
- QUIT
- SET Y=$EXTRACT(X,%)
- IF Y?1L
- SET X=$EXTRACT(X,1,%-1)_$CHAR($ASCII(Y)-32)_$EXTRACT(X,%+1,99)
- +2 IF %DT["E"
- IF X?."?"
- DO HELP^%DTC
- GOTO B
- +3 IF %DT["N"
- IF X?.N
- GOTO NO
- +4 IF X?1.A
- IF (X["MID"!(X["NOON"))
- SET X="@"_X
- +5 IF X'?1"NOV".E
- IF X?1"N".1"OW".1P.E
- if %DT["T"!(%DT["R")&(%DT'["M")
- GOTO N^%DTC
- SET X=$EXTRACT(X,2,99)
- SET X="T"_$PIECE(X,"OW")_$PIECE(X,"OW",2)
- +6 IF X?1.N." "1.2A!(X?1.N1":"2N." ".2A)!(X?1.N1":"2N1":"2N." ".2A)
- SET X="T@"_X
- +7 IF X?7N1"."1.N
- GOTO R
- +8 IF X'["@"
- IF %DT'["R"
- GOTO R
- +9 IF %DT'["T"
- IF %DT'["R"
- GOTO NO
- +10 IF %DT["M"
- GOTO NO
- +11 SET Y=$PIECE(X,"@",2,9)
- SET X=$PIECE(X,"@")
- +12 FOR %=2,3
- SET %I=$PIECE(Y,":",%)
- IF %I?1N.E
- IF %I'?2N.PA
- GOTO 1
- +13 if X=""
- SET X="T"
- SET Y=$PIECE(Y,":")_$PIECE(Y,":",2)_$PIECE(Y,":",3,9)
- SET %I=Y
- +14 IF Y?1.A
- SET Y=$SELECT(Y["MID":2400,Y["NOON":1200,1:"")
- T if Y?4N
- GOTO G
- if Y?6N&(%DT["S")
- GOTO G1
- if Y'?1.6N." ".1(1"AM",1"A",1"A.M",1"PM",1"P",1"P.M").P
- GOTO 1
- IF %DT["R"
- IF Y=""
- GOTO NO
- +1 SET %I=$PIECE(1_%I,+(1_Y),2)
- if %I]""
- SET Y=$PIECE(Y,%I)
- +2 IF Y?5.6N
- if %DT'["S"
- GOTO 1
- SET %(3)=$EXTRACT(Y,$LENGTH(Y)-1,$LENGTH(Y))
- SET Y=$EXTRACT(Y,1,$LENGTH(Y)-2)
- if %(3)>59
- GOTO 1
- +3 IF Y?1.2N
- if Y'<13
- GOTO 1
- SET Y=Y_"00"
- if $EXTRACT(Y)=0
- SET %I="A"
- +4 IF %I["A"
- SET Y=$SELECT(Y=1200&'$GET(%(3)):2400,Y>1159:Y-1200,1:Y)
- +5 IF '$TEST
- IF Y?1.2"0"2N
- if %I["P"
- GOTO 1
- +6 ;ASSUME PM
- IF '$TEST
- IF Y<1200
- IF %I["P"!(Y<600)
- SET Y=Y+1200
- G if Y>2400
- GOTO 1
- if Y#100>59
- GOTO 1
- if ('Y&('$GET(%(3))))
- GOTO 1
- SET %(1)=$SELECT('Y:".0000",1:Y/10000)
- GOTO R
- G1 if Y>240000!'Y
- GOTO 1
- if $EXTRACT(Y,3,4)#100>59
- GOTO 1
- if $EXTRACT(Y,5,6)#100>59
- GOTO 1
- SET %(1)=Y/1000000
- R IF %DT["F"!(%DT["P")
- DO TY
- SET %(9)=%
- 7 if X'?7N1".".E&(X'?7N)
- GOTO 8
- SET Y=$EXTRACT(X,8,16)
- SET %=$EXTRACT(Y_"000000",2,7)
- +1 IF Y
- IF %DT'["T"!(%DT["M")
- GOTO NO
- +2 ;I %DT["E",(%'?.N)!(%>240000)!($E(%,3,4)>59)!($E(%,5,6)>59) G NO
- +3 ;p14
- IF (%'?.N)!(%>240000)!($EXTRACT(%,3,4)>59)!($EXTRACT(%,5,6)>59)
- GOTO NO
- +4 if Y
- SET %(1)=+Y
- SET X=$EXTRACT(X,4,7)_($EXTRACT(X,1,3)+1700)
- SET %(7)=1
- +5 IF %DT["I"
- IF '$DATA(%("ALPHA"))
- SET X=$EXTRACT(X,3,4)_$EXTRACT(X,1,2)_$EXTRACT(X,5,9)
- 8 SET %I=0
- SET %=""
- IF X'?.N
- if "T+-"[$EXTRACT(X)
- GOTO T^%DTC
- if X["^"
- GOTO U
- if $EXTRACT(X)?1P
- GOTO 1
- if X?3.A&(%DT["M")
- GOTO MTH
- GOTO X
- +1 ;MAY BE '200101231' FOR 2001DEC31
- IF X?8N
- IF X>17999999
- IF $EXTRACT(X,5,8)<1300
- SET X=$EXTRACT(X,5,8)_$EXTRACT(X,1,4)
- SET %("ALPHA")=1
- +2 IF %DT'["X"
- IF X\300=6!(X?2N)
- SET (%I(1),%I(2))=0
- SET %I(3)=X
- GOTO 3
- +3 FOR %I=0:1
- SET Y=$EXTRACT(X,1,2)
- SET X=$EXTRACT(X,3,9)
- if Y=""
- GOTO OT
- Begin DoDot:1
- +4 IF %DT["X"
- IF %DT'["M"
- IF %I<2
- IF 'Y
- SET %I=""
- QUIT
- +5 if %I=2
- SET Y=Y_X
- SET X=""
- +6 IF %DT["X"
- IF %I=2
- IF $LENGTH(Y)>2
- IF Y'>1799
- SET %I=""
- QUIT
- +7 SET %I(%I+1)=Y
- QUIT
- End DoDot:1
- if %I=""
- GOTO 1
- +8 ;
- X ;PEEL OFF CHARACTER-BY-CHARACTER
- SET Y=$EXTRACT(X)
- SET X=$EXTRACT(X,2,99)
- IF Y?1N
- if %?.N
- GOTO A
- GOTO Y
- +1 IF Y?1A
- if %?.A
- GOTO A
- GOTO Y
- OT if %]""
- DO %
- if %I>3
- GOTO 1
- if Y?1P
- GOTO X
- if Y]""
- GOTO 1
- GOTO @%I
- Y DO %
- SET %=Y
- if %I>3
- GOTO 1
- GOTO X
- A SET %=%_Y
- GOTO X
- TY SET %=$HOROLOG#1461
- SET %=$HOROLOG\1461*4+(%\365)+141-(%=1460)
- QUIT
- 0 ;
- 1 ;INPUT IS BAD!
- if %DT["E"&'$DATA(DIER)
- WRITE $CHAR(7),$SELECT('$DATA(DDS):" ??",1:"")
- B if %DT["A"
- GOTO %DT
- GOTO NO
- U SET X="^"
- SET %(0)=X
- +1 ;S Y=-1 G Q:%DT'["A",Q:X["^" W $C(7)," ??" G %DT
- NO ;p14
- SET Y=-1
- if %DT'["A"!(%DT'["E")
- GOTO Q
- if X["^"
- GOTO Q
- WRITE $CHAR(7)," ??"
- GOTO %DT
- 2 IF %DT["M"
- SET %I(3)=%I(2)
- SET %I(2)=0
- GOTO 3
- +1 IF %I(2)>31!'%I(2)
- IF %DT'["X"
- SET %I(3)=%I(2)
- SET %I(2)=0
- if '%I(2)&$GET(%(1))
- GOTO 1
- GOTO 3
- +2 DO TY
- SET %I(3)=%
- if $DATA(%(9))
- DO PF^%DTC
- GOTO C
- 3 ;YEAR FIRST: ALLOW '2010-1-31'
- IF %I(1)>1700
- SET %("YF")=%I(1)
- SET %I(1)=%I(2)
- SET %I(2)=%I(3)
- SET %I(3)=%("YF")
- +1 IF %I(3)?2N
- Begin DoDot:1
- +2 IF '$DATA(%(9))
- DO TY
- SET %(9)=%
- +3 NEW A
- SET A=$EXTRACT(%(9))*100
- +4 IF $EXTRACT(%(9),2,3)=%I(3)
- SET %I(3)=A+%I(3)
- QUIT
- +5 IF %DT["P"
- SET %I(3)=$SELECT(%I(3)<$EXTRACT(%(9),2,3):A,1:A-100)+%I(3)
- QUIT
- +6 IF %DT["F"
- SET %I(3)=$SELECT(%I(3)>$EXTRACT(%(9),2,3):A,1:A+100)+%I(3)
- QUIT
- +7 SET %I(3)=A+%I(3)
- +8 IF %(9)-%I(3)>80
- SET %I(3)=%I(3)+100
- QUIT
- +9 IF %I(3)-%(9)>20
- SET %I(3)=%I(3)-100
- +10 QUIT
- End DoDot:1
- GOTO C
- +11 SET %I(3)=%I(3)-1700
- if %I(3)'?3N
- GOTO 1
- C ;INTERNATIONAL: REVERSE MONTH/DAY
- IF %DT["I"
- IF '$DATA(%("ALPHA"))
- IF '$DATA(%("YF"))
- IF %I(2)>0
- SET %=%I(2)
- SET %I(2)=%I(1)
- SET %I(1)=%
- +1 IF %I(2)="00"
- IF '$GET(%(7))
- GOTO 1
- +2 IF %DT["M"
- IF $GET(%I(2))
- GOTO 1
- +3 IF %I(1)>12!(%I(1)="00")
- GOTO 1
- +4 IF %I(2)>28
- IF $EXTRACT("303232332323",%I(1))+28<%I(2)
- IF %I(1)-2!(%I(2)-29)!(%I(3)#4)!('(%I(3)#100)&(%I(3)+1700#400))
- GOTO 1
- D IF %DT["M"
- IF $GET(%I(2))
- SET %I(2)=0
- +1 DO P
- E IF $DATA(%(1))
- if $DATA(%(3))
- SET %(1)=$EXTRACT(%(1)_"000",1,5)_%(3)
- SET Y=+(Y_%(1))
- +1 IF '$EXTRACT(Y,6,7)
- IF Y["."
- GOTO 1
- +2 IF %DT["E"
- SET %=Y
- DO DD
- WRITE " ("_Y_")"
- SET Y=%
- +3 IF $DATA(%DT(0))
- SET %=%DT(0)
- SET %I=$SELECT(%["-":Y,1:-Y)
- if '%
- DO Z
- IF $SELECT(%DT["S":%,1:%\.0001/10000)+%I>0
- GOTO 1
- Q SET X=%(0)
- KILL %,%I,%H
- QUIT
- +1 ;
- Z IF $PIECE("NOW",%(0))=""
- SET %=Y
- +1 IF '$TEST
- DO NOW^%DTC
- +2 if %DT(0)["-"
- SET %=-%
- QUIT
- +3 ;
- DD ;create writable date from 'Y' to 'Y'
- IF $GET(DUZ("LANG"))>1
- SET Y=$$OUT^DIALOGU(Y,"DD")
- QUIT
- +1 if 'Y
- QUIT
- +2 ;INTERNATIONAL (UK)
- NEW M,MI,COMMA
- SET M=$SELECT($EXTRACT(Y,4,5):$EXTRACT($PIECE($TEXT(M)," ",$EXTRACT(Y,4,5)+2),1,3)_" ",1:"")
- SET MI=""
- SET COMMA=","
- IF $GET(%DT)["I"
- SET MI=M
- SET M=""
- SET COMMA=""
- +3 SET Y=M_$SELECT($EXTRACT(Y,6,7):$EXTRACT(Y,6,7)_COMMA_" ",1:"")_MI_($EXTRACT(Y,1,3)+1700)_$SELECT(Y[".":"."_$PIECE(Y,".",2),1:"")
- +4 IF Y["."
- SET Y=$PIECE(Y,".")_"@"_$EXTRACT(Y_0,14,15)_":"_$EXTRACT(Y_"000",16,17)_$SELECT($EXTRACT(Y,18,19):":"_$EXTRACT(Y_0,18,19),1:"")
- +5 IF $DATA(%DT)#2
- IF %DT["S"
- IF Y["@"
- IF $PIECE(Y,":",3)=""
- SET Y=Y_":00"
- +6 QUIT
- +7 ;
- P SET Y=%I(3)_$EXTRACT(%I(1)+100,2,3)_$EXTRACT(%I(2)+100,2,3)
- QUIT
- +1 ;
- MTH SET %=X
- DO %
- if %I>3
- GOTO 1
- +1 SET %I(2)=0
- +2 DO TY
- SET %I(3)=%
- if $DATA(%(9))
- DO PF^%DTC
- +3 GOTO D
- % ;I %DT["I",%?3.A S %I=9 Q
- +1 ;ONLY MONTH IS ALPHA
- IF %?3.A
- SET %=$FIND($TEXT(M)," "_%)
- IF %>0
- SET %=$LENGTH($EXTRACT($TEXT(M),6,%-1)," ")
- if %I=1
- Begin DoDot:1
- +2 NEW T
- SET T=%I(1)
- SET %I(1)=%
- SET %=T
- IF $DATA(%("ALPHA"))
- SET %I=9
- End DoDot:1
- SET %("ALPHA")=1
- +3 if %<1&(%'="00")&(%I'=2)
- SET %I=9
- SET %I=%I+1
- SET %I(%I)=%
- SET %=""
- M ;; JANUARY FEBRUARY MARCH APRIL MAY JUNE JULY AUGUST SEPTEMBER OCTOBER NOVEMBER DECEMBER