source: FOIAVistA/trunk/r/VOLUNTARY_TIMEKEEPING-ABSV/ABSVU2.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: 5.2 KB
Line 
1ABSVU2 ;VAMC ALTOONA/CTB - MISC UTILITY ROUTINES ;5/2/00 9:32 AM
2V ;;4.0;VOLUNTARY TIMEKEEPING;**7,10,15,18**;JULY 6, 1994
3 ;ENTRY TO PLACE VALUES OF FIELDS INTO VARIABLES
4 ;REQUIRES INPUT OF DIC, DA, DR, X
5 ;DIC = FILE NUMBER OR GLOBAL ROOT
6 ;DA = INTERNAL RECORD NUMBER
7 ;DR = LIST OF FIELD NUMBERS DELIMITED WITH ';'
8 ;X = LIST OF VARIABLE NAMES MAPPED TO FIELDS IN DR
9 ; NOTE VARIABLE NAME ALONE IMPLIES EXTERNAL
10 ; IF BOTH INTERNAL AND EXTERNAL VALUES ARE REQUIRED, ';' PIECE
11 ; SHOULD BE "VNAME,I,VNAME2,E;" OR "VNAME,,VNAME2,I;
12 ;DIQ OPTIONAL VARIABLE CONTAINING GLOBAL ROOT IE ^TMP( . STORE
13 ; ERROR COULD OCCUR FOR EXTREMELY LONG EXTRACTIONS. SETTING
14 ; DIQ WILL FORCE PROGRAM TO PLACE DATA IN GLOBAL
15 ;USES VARIABLE ARRAY TMP FOR TEMPORARY STORAGE UNLESS OVERRIDEN BY
16 ; GLOBAL ROOT IN DIQ
17EXT(DIC,DA,DR,X,DIQ) ;
18EN1 N TMP,I,FN,FNX,ZX,ZY,N,DAX,DRX,D0,S,C
19 S ZX=X I $O(X(0)) S N=0 F S N=$O(X(N)) Q:'N S ZX(N)=X(N)
20 S U="^",DIQ(0)=$S(X[",I":"EI",1:"E") S:$G(DIQ)="" DIQ="TMP("
21 D EN^DIQ1
22 S FN=+$P($G(@(DIC_"0)")),"^",2) Q:'FN
23 I $O(DA(0)) S N=0 F S N=$O(DA(N)) Q:'N S FN(N)=N
24 F I=1:1 Q:$P(ZX,";",I)="" D
25 . S ZY=$P(ZX,";",I)
26 . Q:ZY=""
27 . S S=";",C="," X "S "_$P(ZY,",")_"=$G("_DIQ_"FN,DA,$P(DR,S,I),$S($P(ZY,"","",2)[""I"":""I"",1:""E"")))"
28 . I $P(ZY,",",3)]"" S ZY=$P(ZY,",",3,4) X "S "_$P(ZY,",")_"=$G("_DIQ_"FN,DA,$P(DR,S,I),$S($P(ZY,"","",2)[""I"":""I"",1:""E"")))"
29 . Q
30 I $O(FN(0)) S N=0 F S N=$O(FN(N)) Q:'N D
31 . Q:FN(N)="" S FNX=FN(N)
32 . Q:($G(DR(FNX))="")!($G(DA(FNX))="")!($G(ZX(FNX))="")
33 . S ZX=ZX(FNX),FNX=FN(N),DAX=DA(FNX),DRX=DR(FNX)
34 . F I=1:1 Q:$P(ZX,";",I)="" D
35 . . S ZY=$P(ZX,";",I)
36 . . Q:ZY=""
37 . . X "S "_$P(ZY,",")_"=$G("_DIQ_"FNX,DAX,$P(DRX,"";"",I),$S($P(ZY,"","",2)[""I"":""I"",1:""E"")))"
38 . . I $P(ZY,",",3)]"" S ZY=$P(ZY,",",3,4) X "S "_$P(ZY,",")_"=$G("_DIQ_"FNX,DAX,$P(DRX,"";"",I),$S($P(ZY,"","",2)[""I"":""I"",1:""E"")))"
39 . . Q
40 I $E(DIQ,$L(DIQ))="," K @($E(DIQ,$L(DIQ)-1)_")")
41 I $E(DIQ,$L(DIQ))="(" K @($E(DIQ,$L(DIQ)-1))
42 Q
43LZF(STRING,LENGTH) ;LEFT ZERO FILL STRING IN A FIELD LENGTH OF LENGTH
44 N X
45 S $P(X,"0",LENGTH)="0",STRING=X_STRING
46 Q $E(STRING,$L(STRING)-(LENGTH-1),$L(STRING))
47RZF(STRING,LENGTH) ;RIGHT ZERO FILL STRING IN A FIELD LENGTH OF LENGTH
48 N X
49 S $P(X,"0",LENGTH)=0,STRING=STRING_X
50 Q $E(STRING,1,LENGTH)
51LBF(STRING,LENGTH) ;LEFT BLANK FILL STRING IN A FIELD LENGTH OF LENGTH
52 N X
53 S $P(X," ",LENGTH)=" ",STRING=X_STRING
54 Q $E(STRING,$L(STRING)-(LENGTH-1),$L(STRING))
55RBF(STRING,LENGTH) ;RIGHT BLANK FILL STRING IN A FIELD LENGTH OF LENGTH
56 N X
57 S $P(X," ",LENGTH)=" ",STRING=STRING_X
58 Q $E(STRING,1,LENGTH)
59DIR() ;SET VARIABLE STRING RETURNING FROM DIR
60 NEW X
61 S X=$D(DTOUT)_$D(DUOUT)_$D(DIRUT)_$D(DIROUT)
62 K DTOUT,DUOUT,DIRUT,DIROUT
63 Q X
64 ;
65FULLDAT(Y) ;CONVERTS FILEMAN INTERNAL DATE TO EXTERNAL FORMAT
66 S:Y Y=$S($E(Y,4,5):$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+$E(Y,4,5))_" ",1:"")_$S($E(Y,6,7):+$E(Y,6,7)_",",1:"")_($E(Y,1,3)+1700)_$P("@"_$E(Y_0,9,10)_":"_$E(Y_"000",11,12),"^",Y[".")
67 Q Y
68 ;
69EXTSSN(X) ;RETURNS EXTERNAL VALUE OF SSN
70 I X'?9N Q X
71 Q $E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,9)
72 ;
73LOWER(X) ;RETURNS STRING X IN LOWER CASE
74 Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
75UPPER(X) ;RETURNS STRING X IN UPPER CASE
76 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
77AGE(X2,X1) ;extrinsic function returns current age based on date X
78 N %,%H,%I,%T,X,%Y
79 I $G(X1)="" D NOW^%DTC S X1=X
80 D ^%DTC
81 Q X\365.25
82SETOFCDS ;display set of codes
83 N X,LN,Y
84 Q:$P($G(DIR(0)),"^",1)'["S"
85 W !,"Select From:",!
86 S X=$P(DIR(0),"^",2)
87 F LN=1:1 Q:$P(X,";",LN)="" S Y=$P(X,";",LN) W !?5,$P(Y,":"),?15,$P(Y,":",2)
88 QUIT
89 ;
90ACTIVE(DA,INST,SILENT) ;extrinsic function to determine termination status of volunteer.
91 ;sets $T=1 if active, $T=0 if terminated
92 I '$D(SILENT) S SILENT=0
93 I '$D(^ABS(503330,DA,4,INST,0)) S X="Volunteer is not a registered volunteer for station "_ABSV("SITE")_". No actions are allowed." D:'SILENT MSG^ABSVQ Q 0
94 I $P($G(^ABS(503330,DA,4,INST,0)),"^",8)]"" S X="Volunteer has been terminated. No actions allowed.*" D:'SILENT MSG^ABSVQ Q 0
95 Q 1
96VPHONE(X) ;extrinsic function, for validating telephone numbers
97 NEW ABSVX
98 I X="" Q 0
99 I X?7N Q 1
100 I X?3N1"-"4N Q 1
101 I X?10N Q 1
102 I X?3N1"-"3N1"-"4N Q 1
103 I X?7N1" ".6UN Q 1
104 I X?3N1"-"4N1" ".6UN Q 1
105 I X?10N1" ".6UN Q 1
106 I X?3N1"-"3N1"-"4N1" ".6UN Q 1
107 Q 0
108PHONEOUT(X) ;extrinsic function to print phone number
109 I $E(X,1,10)?10N Q $E(X,1,3)_"-"_$E(X,4,6)_"-"_$E(X,7,99)
110 I $E(X,1,7)?7N Q " "_$E(X,1,3)_"-"_$E(X,4,99)
111 I X?10N1" ".6UN Q $E(X,1,3)_"-"_$E(X,4,6)_"-"_$E(X,7,99)
112 I X?3N1"-"4N Q " "_X
113 I X?3N1"-"4N.1" ".6UN Q " "_X
114 Q X
115REMPUNC(X) ;REMOVE PUNCTUATION FROM STRING FOR MAILING
116 N Y,Z
117 S Y="~`!@#$%^&*()_+={}[]:;'|\<>.?/"_""""
118 S X=$TR(X,Y,"")
119 Q $TR(X,",-"," ")
120REP(DA,SITE) ;This function will determine if a volunter is a vavs representative
121 ;for the medical center. Determination is based on the combination
122 ;code containing the characters 'R135A'
123 N M,N,X
124 S (M,X)=0
125 F S M=$O(^ABS(503330,DA,1,M)) Q:'M S N=$G(^(M,0)) I $P(N,"-",1)=SITE,$P(N,"^",5)["R135A" S X=1 QUIT
126 Q X
127LINE(X) ;This function will return a line of X length
128 N Y
129 S $P(Y,"_",X+1)=""
130 Q Y
131DELFILE ;DELETE DATA FOR FILE 503339.2
132 S X=$P(^ABS(503339.2,0),"^",1,2)
133 K ^ABS(503339.2) S ^ABS(503339.2,0)=X
Note: See TracBrowser for help on using the repository browser.