source: WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXUTL1.m@ 1005

Last change on this file since 1005 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.8 KB
Line 
1ECXUTL1 ;ALB/GTS - Utilities for DSS Extracts ;July 16, 1998
2 ;;3.0;DSS EXTRACTS;**9,49**;Dec 22, 1997
3 ;
4CYFY(ECXFMDT) ;** Return the calandar and fiscal years for a FM date
5 ;
6 ; Input
7 ; ECXFMDT - Fileman formated date
8 ;
9 ; Output
10 ; X - CY begin date^ CY end date^ FY begin date^ FY end date
11 ;
12 N X,Y,Y2
13 S X=""
14 S ECXFMDT=$G(ECXFMDT)\1
15 I ECXFMDT?7N DO
16 .S (Y,Y2)=$E(ECXFMDT,1,3)
17 .I $E(ECXFMDT,4,5)>9 S Y2=Y+1
18 .S X=Y_"0101^"_Y_"1231^"_(Y2-1)_"1001^"_Y2_"0930"
19 Q X
20 ;
21FISCAL(DATE) ;Return fiscal year
22 ; Input: DATE = Date (FileMan format) (defaults to today)
23 ;Output: YYYY = Fiscal year that input date falls within
24 ;
25 N YEAR
26 I '$G(DATE) S DATE=$$DT^XLFDT()
27 S DATE=$$ECXYM^ECXUTL(DATE)
28 S YEAR=$E(DATE,1,4)
29 I $E(DATE,5,6)>9 S YEAR=YEAR+1
30 Q YEAR
31 ;
32DTRNG() ;** Prompt the user for a date range
33 ;
34 N ECXBEG,ECXEND,ECXRNG,ENDRNG
35 S ECXRNG=0
36 ;
37 ;* Prompt for beginning date
38 W ! S DIR(0)="DA^:DT:EX",DIR("A")="Enter Start Date: "
39 S DIR("?")="^W ""*** Future dates are not allowed ***"",! D HELP^%DTC"
40 D ^DIR K DIR
41 S:'$D(DIRUT) ECXBEG=+Y
42 K %DT,Y,DTOUT,DUOUT,DIRUT
43 ;
44 ;* Prompt for ending date
45 I $G(ECXBEG) DO
46 .S ENDRNG=$$CYFY(ECXBEG)
47 .S ENDRNG=$S($P(ENDRNG,"^",4)<DT:$P(ENDRNG,"^",4),1:DT)
48 .W ! S DIR(0)="DA^"_ECXBEG_":"_ENDRNG_":EX"
49 .S DIR("A")="Enter End date: "
50 .S DIR("?")="^W ""Future dates and dates after the beginning date's FY end are not allowed."",! D HELP^%DTC"
51 .D ^DIR
52 .S ECXEND=+Y
53 .S:'$D(DIRUT) ECXRNG=ECXBEG_"^"_ECXEND
54 .K DIR,%DT,Y,DIRUT,DTOUT,DUOUT
55 Q ECXRNG
56 ;
57STRIP(ECXFIELD,ECXLGTH,ECXPOS) ;* Strip blanks from a padded field
58 ;
59 ; Input
60 ; ECXFIELD - Data to remove blanks from
61 ; ECXLGTH - Total length of padded field
62 ; ECXPOS - Front or Back indicator ('F' or 'B')
63 ;
64 ; Output
65 ; ECXVAL - Field with blanks removed
66 ;
67 N ECXPVAL,QVAL
68 S:ECXPOS="B" ECXPVAL=ECXLGTH
69 S:ECXPOS="F" ECXPVAL=1
70 S QVAL=0
71 F Q:QVAL DO
72 .I ECXPOS="B" DO
73 ..S:($E(ECXFIELD,ECXPVAL)'=" ") QVAL=1
74 ..S:($E(ECXFIELD,ECXPVAL)=" ") ECXFIELD=$E(ECXFIELD,1,ECXPVAL-1)
75 ..S ECXPVAL=ECXPVAL-1
76 ..S:(ECXPVAL<1) QVAL=1
77 .I ECXPOS="F" DO
78 ..S:($E(ECXFIELD,1)'=" ") QVAL=1
79 ..S:($E(ECXFIELD,1)=" ") ECXFIELD=$E(ECXFIELD,2,ECXLGTH-(ECXPVAL-1))
80 ..S ECXPVAL=ECXPVAL+1
81 ..S:(ECXPVAL>ECXLGTH) QVAL=1
82 Q ECXFIELD
83 ;
84PAD(ECXVAL,ECXLGTH,ECXFB,ECXCHAR) ;* Pad the value passed in with ECXCHAR
85 ;
86 ; ECXVAL - The value to pad
87 ; ECXLGTH - The maximum length
88 ; ECXFB - 'F': Pad on front; 'B' Pad on back
89 ; ECXCHAR - The character to pad ECXVAL with
90 ;
91 ; Output
92 ; ECXVAR - The padded result
93 ;
94 N ECXLPCT,ECXVAR
95 I $D(ECXVAL),($D(ECXLGTH)),($D(ECXFB)),($D(ECXCHAR)) DO
96 .S (ECXVAL,ECXVAR)=$E(ECXVAL,1,ECXLGTH)
97 .F ECXLPCT=1:1:ECXLGTH-$L($E(ECXVAR,1,ECXLGTH)) DO
98 ..S:ECXFB="B" ECXVAL=ECXVAL_ECXCHAR
99 ..S:ECXFB="F" ECXVAL=ECXCHAR_ECXVAL
100 I '$D(ECXVAL) S ECXVAL=""
101 Q ECXVAL
Note: See TracBrowser for help on using the repository browser.