ASUUY2K ; IHS/ITSC/LMH -Y2K COMPLIENT RTN ;
;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
START(A,B,C,D) ;EP
;;4.2T1;SUPPLY ACCOUNTING MGMT SYSTEM;;JAN 28, 2000
;11/16/98 WAR - This routine is designed to create a Fileman date
; from either a 4 digit date (YYMM or MMYY) or a 6
; digit date (MMDDYY or YYMMDD).
;5/14/99 WAR - Due to Y2K compliance issues, "00" was imbedded in
; between the MMYY format to avoid FM problems with dates
; between 2000 and 2031
;
; A - Contains a numeric string or an array
; B - Number of piece, within array, if applicable
; C - Delimeter, if applicable
; D - Contains either 'Y' or 'N' (order to be set)
;
; NOTE: Incoming formats that need to be changed:
; YYMM or YYMMDD
;
;
N X,Z ;X newed because of VA FM
;
I +B>0 D ;if null, value is zero and no piece needed
.S Z=$P(A,C,B)
E D
.S Z=A
;U IO(0) W !,"Z IS ->",Z
I $L(Z)#2=0 D ;watching for even number char's
.I D="Y" D ;fld needs to be put in correct order for VA FM
..I $L(Z)=6 D
...S Z=$E(Z,3,4)_$E(Z,5,6)_$E(Z,1,2) ;set to MMDDYY
..E I $L(4) D ;IHS/DSD/JLG 5/27/99
...S Z=$E(Z,3,4)_"00"_$E(Z,1,2) ;set to MM00YY
.E D
..I $L(Z)=4 D
...S Z=$E(Z,1,2)_"00"_$E(Z,3,4) ;include 00
S X=Z
D ^%DT
I Y=-1 S Y=X ;IHS/DSD/JLG 5/27/99 If X is null leave it
I +B>0 D
.S $P(A,C,B)=Y
E D
.S A=Y
Q
ASUUY2K ; IHS/ITSC/LMH -Y2K COMPLIENT RTN ;
+1 ;;4.2T2;Supply Accounting Mgmt. System;;JUN 30, 2000
START(A,B,C,D) ;EP
+1 ;;4.2T1;SUPPLY ACCOUNTING MGMT SYSTEM;;JAN 28, 2000
+2 ;11/16/98 WAR - This routine is designed to create a Fileman date
+3 ; from either a 4 digit date (YYMM or MMYY) or a 6
+4 ; digit date (MMDDYY or YYMMDD).
+5 ;5/14/99 WAR - Due to Y2K compliance issues, "00" was imbedded in
+6 ; between the MMYY format to avoid FM problems with dates
+7 ; between 2000 and 2031
+8 ;
+9 ; A - Contains a numeric string or an array
+10 ; B - Number of piece, within array, if applicable
+11 ; C - Delimeter, if applicable
+12 ; D - Contains either 'Y' or 'N' (order to be set)
+13 ;
+14 ; NOTE: Incoming formats that need to be changed:
+15 ; YYMM or YYMMDD
+16 ;
+17 ;
+18 ;X newed because of VA FM
NEW X,Z
+19 ;
+20 ;if null, value is zero and no piece needed
IF +B>0
Begin DoDot:1
+21 SET Z=$PIECE(A,C,B)
End DoDot:1
+22 IF '$TEST
Begin DoDot:1
+23 SET Z=A
End DoDot:1
+24 ;U IO(0) W !,"Z IS ->",Z
+25 ;watching for even number char's
IF $LENGTH(Z)#2=0
Begin DoDot:1
+26 ;fld needs to be put in correct order for VA FM
IF D="Y"
Begin DoDot:2
+27 IF $LENGTH(Z)=6
Begin DoDot:3
+28 ;set to MMDDYY
SET Z=$EXTRACT(Z,3,4)_$EXTRACT(Z,5,6)_$EXTRACT(Z,1,2)
End DoDot:3
+29 ;IHS/DSD/JLG 5/27/99
IF '$TEST
IF $LENGTH(4)
Begin DoDot:3
+30 ;set to MM00YY
SET Z=$EXTRACT(Z,3,4)_"00"_$EXTRACT(Z,1,2)
End DoDot:3
End DoDot:2
+31 IF '$TEST
Begin DoDot:2
+32 IF $LENGTH(Z)=4
Begin DoDot:3
+33 ;include 00
SET Z=$EXTRACT(Z,1,2)_"00"_$EXTRACT(Z,3,4)
End DoDot:3
End DoDot:2
End DoDot:1
+34 SET X=Z
+35 DO ^%DT
+36 ;IHS/DSD/JLG 5/27/99 If X is null leave it
IF Y=-1
SET Y=X
+37 IF +B>0
Begin DoDot:1
+38 SET $PIECE(A,C,B)=Y
End DoDot:1
+39 IF '$TEST
Begin DoDot:1
+40 SET A=Y
End DoDot:1
+41 QUIT
