source: FOIAVistA/trunk/r/INTEGRATED_PATIENT_FUNDS-PRPF-PFXIP/PRPFU2.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 4.1 KB
Line 
1PRPFU2 ;VAMC ALTOONA/CTB - MISC UTILITY ROUTINES ;11/22/96 4:48 PM
2V ;;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
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 ;
90VPHONE(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
102PHONEOUT(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
Note: See TracBrowser for help on using the repository browser.