1 | PRPFU2 ;VAMC ALTOONA/CTB - MISC UTILITY ROUTINES ;11/22/96 4:48 PM
|
---|
2 | V ;;3.0;PATIENT FUNDS;**6**;JUNE 1, 1989
|
---|
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
|
---|
17 | EXT(DIC,DA,DR,X,DIQ) ;
|
---|
18 | EN1 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
|
---|
43 | LZF(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))
|
---|
47 | RZF(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)
|
---|
51 | LBF(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))
|
---|
55 | RBF(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)
|
---|
59 | DIR() ;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 | ;
|
---|
65 | FULLDAT(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 | ;
|
---|
69 | EXTSSN(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 | ;
|
---|
73 | LOWER(X) ;RETURNS STRING X IN LOWER CASE
|
---|
74 | Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
|
---|
75 | UPPER(X) ;RETURNS STRING X IN UPPER CASE
|
---|
76 | Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
|
---|
77 | AGE(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
|
---|
82 | SETOFCDS ;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 | ;
|
---|
90 | VPHONE(X) ;extrinsic function, for validating telephone numbers
|
---|
91 | NEW PRPFX
|
---|
92 | I X="" Q 0
|
---|
93 | I X?7N Q 1
|
---|
94 | I X?3N1"-"4N Q 1
|
---|
95 | I X?10N Q 1
|
---|
96 | I X?3N1"-"3N1"-"4N Q 1
|
---|
97 | I X?7N1" ".6UN Q 1
|
---|
98 | I X?3N1"-"4N1" ".6UN Q 1
|
---|
99 | I X?10N1" ".6UN Q 1
|
---|
100 | I X?3N1"-"3N1"-"4N1" ".6UN Q 1
|
---|
101 | Q 0
|
---|
102 | PHONEOUT(X) ;extrinsic function to print phone number
|
---|
103 | I $E(X,1,10)?10N Q $E(X,1,3)_"-"_$E(X,4,6)_"-"_$E(X,7,99)
|
---|
104 | I $E(X,1,7)?7N Q " "_$E(X,1,3)_"-"_$E(X,4,99)
|
---|
105 | I X?10N1" ".6UN Q $E(X,1,3)_"-"_$E(X,4,6)_"-"_$E(X,7,99)
|
---|
106 | I X?3N1"-"4N Q " "_X
|
---|
107 | I X?3N1"-"4N.1" ".6UN Q " "_X
|
---|
108 | Q X
|
---|