- 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
