source: FOIAVistA/trunk/r/VOLUNTARY_TIMEKEEPING-ABSV/ABSVSERV.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 4.4 KB
Line 
1ABSVSERV ;VAMC ALTOONA/CTB - SERVER TO FILE DATA FROM AUSTIN ;1/11/01 10:21 AM
2V ;;4.0;VOLUNTARY TIMEKEEPING;**3,9,10,19,21,23**;JULY 6, 1994
3 D NOW^ABSVQ S DATE=%
4 ;CHECK MESSAGE FILE FOR ENTRY, IF NONE ADD, IF SERVED, QUIT
5 S RECCOUNT=0,ERRCOUNT=0
6 S X=XMZ,DIC=503339.1,DIC(0)="ML",DLAYGO=DIC D ^DIC
7 I Y<0 QUIT
8 S MSGNUM=XMZ,MFILEDA=+Y
9 I $P(^ABS(503339.1,MFILEDA,0),"^",3)="S" S MSG="Message previously filed. No action taken." D ERR QUIT
10 S $P(^ABS(503339.1,MFILEDA,0),"^",3,4)="R^"_DATE
11 S DONE=0
12 F X XMREC Q:XMER'=0 D Q:DONE
13 . I $E(XMRG,1,2)="01"!($E(XMRG,1,5)="SERV2") D START Q:DONE
14 . I $E(XMRG,1,5)="SERV3" D ^ABSVSER3 Q:DONE
15 . QUIT
16 QUIT
17START ;
18 S MSG="PROCESSING MONTHLY MASTER RECORD DOWNLOAD." D MSG
19 S MSG=" " D MSG
20 D TYPE01
21 F X XMREC Q:XMER'=0 D
22 . I $E(XMRG,1,2)="01" D TYPE01 QUIT
23 . I $E(XMRG,1,5)="SERV2" D TYPE02 QUIT
24 . QUIT
25 S $P(^ABS(503339.1,MFILEDA,0),"^",3)="S"
26 I '$D(MSGLINE) S XQSTXT(1)=" ",XQSTXT(2)="No errors found during processing for station "_$G(SITE) S MSGLINE=3
27 S XQSTXT(MSGLINE)=RECCOUNT_" records processed into master file." S MSGLINE=MSGLINE+1
28 S XQSTXT(MSGLINE)=ERRCOUNT_" records bypassed."
29 S DONE=1 QUIT
30TYPE01 K X,TRANSNUM,SITE,DATE,SSN,TERMMO,TERMYR,SERVYRS,HRSPRYR,HRSCURYR,AWDCODE,AWDHRS,AWDMO,AWDYR,HRSTOT,ZIP
31 S X=XMRG
32 S TRANSNUM=$E(X,1,2),SITE=$$STRIP($E(X,3,6))
33 S DATE=$E(X,7,12),PSSN=$$STRIP($E(X,13))
34 S SSN=$$STRIP($E(X,14,22))
35 S TERMMO=$E(X,23,24),TERMYR=$E(X,25,26)
36 S TERMDATE=""
37 I TERMYR]"",+TERMMO'=0 S TERMDATE=$$YEAR(TERMYR)_TERMMO_"00"
38 S SERVYRS=+$E(X,27,28),HRSPRYR=+$E(X,29,33),HRSCURYR=+$E(X,34,37),HRSTOT=HRSPRYR+HRSCURYR
39 S AWDCODE=$$STRIP($E(X,38,39)) I AWDCODE]"" S AWDCODE=$O(^ABS(503337,"C",AWDCODE,0))
40 S AWDHRS=+$E(X,40,44)
41 S AWDMO=$E(X,45,46),AWDYR=$E(X,47,48)
42 S AWDDATE=""
43 I AWDYR]"",+AWDMO'=0 S AWDDATE=$$YEAR(AWDYR)_AWDMO_"00"
44 S ZIP=$$STRIP($E(X,49,57)) I $L(ZIP)>5 S ZIP=$E(ZIP,1,5)_"-"_$E(ZIP,6,9)
45 D FILE QUIT
46TYPE02 K X,TRANSNUM,SITE,DATE,SSN,TERMMO,TERMYR,SERVYRS,HRSPRYR,HRSCURYR,AWDCODE,AWDHRS,AWDMO,AWDYR,HRSTOT,ZIP
47 S X=XMRG
48 S TRANSNUM=$P(X,"^",1),SITE=$$STRIP($P(X,"^",2))
49 S DATE=$$FMDATE($P(X,"^",3)),PSSN=$$STRIP($P(X,"^",3))
50 S SSN=$$STRIP($P(X,"^",4))
51 S TERMDATE=$$FMDATE($P(X,"^",5))
52 S SERVYRS=+$P(X,"^",6),HRSPRYR=+$P(X,"^",7),HRSCURYR=+$P(X,"^",8),HRSTOT=HRSPRYR+HRSCURYR
53 S AWDCODE=$$STRIP($P(X,"^",9)) I AWDCODE]"" S AWDCODE=$O(^ABS(503337,"C",AWDCODE,0))
54 S AWDHRS=+$P(X,"^",10)
55 S AWDDATE=$$FMDATE($P(X,"^",11))
56 S ZIP=$$STRIP($P(X,"^",12)) I $L(ZIP)>5 S ZIP=$E(ZIP,1,5)_"-"_$E(ZIP,6,9)
57 D FILE QUIT
58FILE ;LOOKUP STATION NUMBER FOR INTERNAL NUMBER ON 4 NODE
59 S SITEDA=$O(^ABS(503338,"AD",SITE,0)) I SITEDA="" S MSG="Station number "_SITE_" on record "_$$EXTSSN^ABSVU2(SSN)_" not found in file 503338." D ERR QUIT
60 ;LOOKUP VOLUNTEER
61 S VOLDA=$O(^ABS(503330,"D",SSN,0)) I $S(VOLDA="":1,'$D(^ABS(503330,VOLDA)):1,1:0) S MSG="No volunteer record found with SSN "_$$EXTSSN^ABSVU2(SSN)_"." D ERR QUIT
62 ;CHECK FOR STATION ENTRY
63 I '$D(^ABS(503330,VOLDA,4,SITEDA,0)) S MSG="Volunteer "_$$EXTSSN^ABSVU2(SSN)_" has no record for station "_SITE_".~" D ERR QUIT
64 L +^ABS(503330,VOLDA,4,SITEDA,0):20 ELSE S MSG="Unable to post record for SSN "_$$EXTSSN^ABSVU2(SSN)_" due to record lock.~" D ERR QUIT
65 S $P(^ABS(503330,VOLDA,4,SITEDA,0),"^",3,8)=$$BLANK(SERVYRS)_"^"_$$BLANK(HRSTOT)_"^"_$$BLANK(AWDHRS)_"^"_AWDDATE_"^"_AWDCODE_"^"_TERMDATE,$P(^(0),"^",20,21)=$$BLANK(HRSPRYR)_"^"_$$BLANK(HRSCURYR)
66 S RECCOUNT=RECCOUNT+1
67 L -^ABS(503330,VOLDA,4,SITEDA,0)
68 L +^ABS(503330,VOLDA,0):20 ELSE S MSG="Unable to post record for SSN "_$$EXTSSN^ABSVU2(SSN)_" due to record lock.~" D ERR QUIT
69 I $E(ZIP,1,5)?5N S $P(^ABS(503330,VOLDA,0),"^",6)=ZIP
70 L -^ABS(503330,VOLDA,0)
71 QUIT
72 ;
73FMDATE(X) ;CONVERT MMDDYYYY OR MMYYYY TO FILEMAN INTERNAL DATE
74 I $L(X)=4 Q (X-1700)_"0000"
75 I $L(X)=6 Q ($E(X,3,6)-1700)_$E(X,1,2)_"00"
76 Q ($E(X,5,8)-1700)_$E(X,1,2)_$E(X,3,4)
77YEAR(X) ;CONVERT COBOL YEAR TO FM YEAR EG 89 TO 289
78 Q $S($E(X)>3:2_X,1:3_X)
79STRIP(X) ;STRIP TRAILING BLANKS
80 F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
81 Q X
82BLANK(X) ;SET 0 TO BLANKS
83 I +X=0 S X=""
84 Q X
85ERR ;POST ERROR MESSGE
86 S ERRCOUNT=$G(ERRCOUNT)+1
87MSG S MSGLINE=$G(MSGLINE)+1
88 S XQSTXT(MSGLINE)=$P(MSG,"~",1)
89 Q:MSG'["~"
90 S XQSTXT(MSGLINE)=" YRS="_+SERVYRS_" TOT HRS="_+(HRSPRYR+HRSCURYR)_" AWD HRS/DATE/CODE="_$$AWD(AWDHRS,AWDDATE,AWDCODE)_" TERM DATE="_$$FULLDAT^ABSVU2(TERMDATE) S MSGLINE=MSGLINE+1
91 QUIT
92AWD(X,Y,Z) ;
93 S X=$$BLANK(X)
94 I +X=0,Y="",Z="" Q ""
95 I Y="",Z="" Q +X
96 I Y="" S Y=" "
97 Q (+X_"/"_$$FULLDAT^ABSVU2(Y)_"/"_Z)
Note: See TracBrowser for help on using the repository browser.