ABSVSER3 ;VAMC ALTOONA/CTB - SERVER TO FILE DATA FROM AUSTIN ;11/4/99 1:19 PM
V ;;4.0;VOLUNTARY TIMEKEEPING;**3,9,18**;JULY 6, 1994
HDR K X,DELIM,SITE,MSGDATE
S X=XMRG,DELIM=$E(X,6),SITE=$$STRIP($P(X,DELIM,2)),MSGDATE=$P(X,DELIM,3)
S MSG="PROCESSING ANNUAL PURGE MESSAGE" D MSG
S MSG=" " D MSG
F X XMREC Q:XMER'=0 D
. S X=XMRG,TYPE=$P(X,DELIM)
. I TYPE=1 D ONE(X,SITE,DELIM)
. QUIT
S $P(^ABS(503339.1,MFILEDA,0),"^",3)="S"
I '$D(MSGLINE) S XQSTXT(1)=" ",XQSTXT(2)="No errors found during processing for station "_$G(SITE) S MSGLINE=3
S XQSTXT(MSGLINE)=RECCOUNT_" records processed into master file." S MSGLINE=MSGLINE+1
S XQSTXT(MSGLINE)=ERRCOUNT_" records bypassed."
S DONE=1 QUIT
ONE(X,SITE,DEL) N PSEUDO,SSN,DPURGED,SITEDA,MSG
S PSEUDO=$P(X,DEL,2),SSN=$P(X,DEL,3),DPURGED=$P(X,DEL,4),DPURGED=($E(DPURGED,3,6)-1700)_$E(DPURGED,1,2)_"00"
;LOOKUP STATION NUMBER FOR INTERNAL NUMBER ON 4 NODE
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
;LOOKUP VOLUNTEER
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
;CHECK FOR STATION ENTRY
I '$D(^ABS(503330,VOLDA,4,SITEDA,0)) S MSG="Volunteer "_$$EXTSSN^ABSVU2(SSN)_" has no record for station "_SITE_".~" D ERR QUIT
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
S X=^ABS(503330,VOLDA,4,SITEDA,0),$P(X,"^",10,11)="Y^"_DPURGED
S:$P(X,"^",8)="" $P(X,"^",8)=DPURGED
S MSG=$$EXTSSN^ABSVU2(SSN)_" MARKED AS PURGED." D MSG
S ^ABS(503330,VOLDA,4,SITEDA,0)=X
S RECCOUNT=RECCOUNT+1
L -^ABS(503330,VOLDA,4,SITEDA,0)
QUIT
YEAR(X) ;CONVERT COBOL YEAR TO FM YEAR EG 89 TO 289
Q $S($E(X)>3:2_X,1:3_X)
STRIP(X) ;STRIP TRAILING BLANKS
F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
Q X
BLANK(X) ;SET 0 TO BLANKS
I +X=0 S X=""
Q X
ERR ;PROCESS ERROR MESSAGE
S ERRCOUNT=ERRCOUNT+1
MSG S MSGLINE=$G(MSGLINE)+1
S XQSTXT(MSGLINE)=MSG
QUIT
AWD(X,Y,Z) ;
S X=$$BLANK(X)
I +X=0,Y="",Z="" Q ""
I Y="",Z="" Q +X
I Y="" S Y=" "
Q (+X_"/"_$$FULLDAT^ABSVU2(Y)_"/"_Z)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HABSVSER3 2284 printed Jan 14, 2021@17:31:33 Page 2
ABSVSER3 ;VAMC ALTOONA/CTB - SERVER TO FILE DATA FROM AUSTIN ;11/4/99 1:19 PM
V ;;4.0;VOLUNTARY TIMEKEEPING;**3,9,18**;JULY 6, 1994
HDR KILL X,DELIM,SITE,MSGDATE
+1 SET X=XMRG
SET DELIM=$EXTRACT(X,6)
SET SITE=$$STRIP($PIECE(X,DELIM,2))
SET MSGDATE=$PIECE(X,DELIM,3)
+2 SET MSG="PROCESSING ANNUAL PURGE MESSAGE"
DO MSG
+3 SET MSG=" "
DO MSG
+4 FOR
XECUTE XMREC
if XMER'=0
QUIT
Begin DoDot:1
+5 SET X=XMRG
SET TYPE=$PIECE(X,DELIM)
+6 IF TYPE=1
DO ONE(X,SITE,DELIM)
+7 QUIT
End DoDot:1
+8 SET $PIECE(^ABS(503339.1,MFILEDA,0),"^",3)="S"
+9 IF '$DATA(MSGLINE)
SET XQSTXT(1)=" "
SET XQSTXT(2)="No errors found during processing for station "_$GET(SITE)
SET MSGLINE=3
+10 SET XQSTXT(MSGLINE)=RECCOUNT_" records processed into master file."
SET MSGLINE=MSGLINE+1
+11 SET XQSTXT(MSGLINE)=ERRCOUNT_" records bypassed."
+12 SET DONE=1
QUIT
ONE(X,SITE,DEL) NEW PSEUDO,SSN,DPURGED,SITEDA,MSG
+1 SET PSEUDO=$PIECE(X,DEL,2)
SET SSN=$PIECE(X,DEL,3)
SET DPURGED=$PIECE(X,DEL,4)
SET DPURGED=($EXTRACT(DPURGED,3,6)-1700)_$EXTRACT(DPURGED,1,2)_"00"
+2 ;LOOKUP STATION NUMBER FOR INTERNAL NUMBER ON 4 NODE
+3 SET SITEDA=$ORDER(^ABS(503338,"AD",SITE,0))
IF SITEDA=""
SET MSG="Station number "_SITE_" on record "_$$EXTSSN^ABSVU2(SSN)_" not found in file 503338."
DO ERR
QUIT
+4 ;LOOKUP VOLUNTEER
+5 SET VOLDA=$ORDER(^ABS(503330,"D",SSN,0))
IF $SELECT(VOLDA="":1,'$DATA(^ABS(503330,VOLDA)):1,1:0)
SET MSG="No volunteer record found with SSN "_$$EXTSSN^ABSVU2(SSN)_"."
DO ERR
QUIT
+6 ;CHECK FOR STATION ENTRY
+7 IF '$DATA(^ABS(503330,VOLDA,4,SITEDA,0))
SET MSG="Volunteer "_$$EXTSSN^ABSVU2(SSN)_" has no record for station "_SITE_".~"
DO ERR
QUIT
+8 LOCK +^ABS(503330,VOLDA,4,SITEDA,0):20
IF '$TEST
SET MSG="Unable to post record for SSN "_$$EXTSSN^ABSVU2(SSN)_" due to record lock.~"
DO ERR
QUIT
+9 SET X=^ABS(503330,VOLDA,4,SITEDA,0)
SET $PIECE(X,"^",10,11)="Y^"_DPURGED
+10 if $PIECE(X,"^",8)=""
SET $PIECE(X,"^",8)=DPURGED
+11 SET MSG=$$EXTSSN^ABSVU2(SSN)_" MARKED AS PURGED."
DO MSG
+12 SET ^ABS(503330,VOLDA,4,SITEDA,0)=X
+13 SET RECCOUNT=RECCOUNT+1
+14 LOCK -^ABS(503330,VOLDA,4,SITEDA,0)
+15 QUIT
YEAR(X) ;CONVERT COBOL YEAR TO FM YEAR EG 89 TO 289
+1 QUIT $SELECT($EXTRACT(X)>3:2_X,1:3_X)
STRIP(X) ;STRIP TRAILING BLANKS
+1 FOR
if $EXTRACT(X,$LENGTH(X))'=" "
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+2 QUIT X
BLANK(X) ;SET 0 TO BLANKS
+1 IF +X=0
SET X=""
+2 QUIT X
ERR ;PROCESS ERROR MESSAGE
+1 SET ERRCOUNT=ERRCOUNT+1
MSG SET MSGLINE=$GET(MSGLINE)+1
+1 SET XQSTXT(MSGLINE)=MSG
+2 QUIT
AWD(X,Y,Z) ;
+1 SET X=$$BLANK(X)
+2 IF +X=0
IF Y=""
IF Z=""
QUIT ""
+3 IF Y=""
IF Z=""
QUIT +X
+4 IF Y=""
SET Y=" "
+5 QUIT (+X_"/"_$$FULLDAT^ABSVU2(Y)_"/"_Z)
