source: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRUTL1.m@ 1005

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

initial load of WorldVistAEHR

File size: 2.4 KB
Line 
1RMPRUTL1 ;PHX/HPL - PROSTHETICS UTILITY SUBROUTINES ;10/31/1994
2 ;;3.0;PROSTHETICS;**3,44,49,59**;Feb 09, 1996
3 ;;PROSTHETICS;3.0;Apr. 17, 1995
4 ;OJ - p49 rewrite of RAP to overcome letter printing line wrap problems
5 ;
6RAP(LINE,TB) ;WRAP A LINE IF NEEDED
7 N MAX,S,NW,NXT,FIN,SL
8 S MAX=IOM-(2*TB),FIN=0
9 F Q:FIN D
10 . S SL=$L(LINE)
11 . I SL'>MAX W !?TB,LINE S FIN=1 Q
12 . S S=$E(LINE,1,MAX),NXT=MAX
13 . I $E(S,MAX)'=" " D
14 . . S NW=$L(S," ")-1
15 . . I NW=0 D
16 . . . S NXT=MAX-1,S=$E(S,1,NXT)_"-"
17 . . . Q
18 . . E D
19 . . . S S=$P(S," ",1,NW),NXT=$L(S)
20 . . . Q
21 . . Q
22 . W !?TB,S
23 . F S NXT=NXT+1 Q:NXT>SL Q:$E(LINE,NXT)'=" "
24 . I NXT>SL S FIN=1 Q
25 . S LINE=$E(LINE,NXT,SL)
26 . Q
27 Q ""
28FND ;FIND NEXT NON SPACE POSITION
29 Q:'$D(LINE) F NLP=LP:1:H S B=NLP Q:$E(LINE,B,B)'=" "
30 Q
31PARS(NAME) ;PARSE AN INTERNAL FORM NAME INTO A LETTER FORMAT NAME
32 I NAME["," S LNAME=$P(NAME,",",1),FNAME=$P(NAME,",",2)
33 E D
34 .S LNAME=NAME,PIECES=1,FNAME="",FNAME(1)="",TITLE=""
35 I LNAME'[" " S LP=1,LNAME(1)=LNAME,LNAME(2)=""
36 E D
37 .S LP=2,LNAME(2)=$P(LNAME," ",2),LNAME(1)=$P(LNAME," ",1)
38 F LUP=1:1:LP S NAME=LNAME(LUP) D TRANS S LNAME(LUP)=RMPRNAME
39 S LASTNAME=LNAME(1)_" "_LNAME(2)
40 S PIECES=$S($L(FNAME," ")>1:$L(FNAME," "),1:1) S TITLE=""
41 I PIECES>1&($L($P(FNAME," ",PIECES))>1) D
42 .S TITLE=$P(FNAME," ",PIECES)
43 .S PIECES=PIECES-1
44 S FRSTNAME="" F LP=1:1:PIECES S NAME=$P(FNAME," ",LP) D TRANS S FRSTNAME=FRSTNAME_" "_RMPRNAME
45 S NAME=TITLE
46 I TITLE'["I" D TRANS S TITLE=RMPRNAME
47 S FIXDNAME=FRSTNAME_" "_LASTNAME_" "
48 Q FIXDNAME
49TRANS S RMPRU="ABCDEFGHIJKLMNOPQRSTUVWXYZ",RMPRL="abcdefghijklmnopqrstuvwxyz",RMPR1=$E(NAME),RMPR2=$E(NAME,2,25),RMPRNAME=$TR(RMPR1,RMPRL,RMPRU)_$TR(RMPR2,RMPRU,RMPRL)
50 Q
51DCNT(AMT,PCT) ; CALCULATE A DISCOUNT WITH ROUNDING
52 S DCNT=AMT*PCT S DCNT=$S(DCNT#.01=.005:DCNT+.005,DCNT#.01>.005:DCNT+(.01-(DCNT#.01)),1:DCNT-(DCNT#.01))
53 Q DCNT
54DISP ;Display help for DIR screens/reads.
55 N RMPR90DP,RMPR90I W ! S RMPR90DP=$P(DIR(0),U,2,999) F RMPR90I=1:1:5 I $P($P(RMPR90DP,";",RMPR90I),":",1)'="" W " ("_$P($P(RMPR90DP,";",RMPR90I),":",1)_")"_$P($P(RMPR90DP,";",RMPR90I),":",2)_" "
56 Q
57EXIT ;GENERIC EXIT TAG
58 ; VARIABLES REQUIRED: NONE
59 N RMPR,RMPRSITE D KILL^%ZISS,KVAR^VADPT,KILL^XUSCLEAN Q
60 ;
61DAT1(X) ; Convert FM date to displayable (mm/dd/yy) format.
62 N DATE
63 S DATE=$S(X:$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3),1:"")
64 Q DATE
65 ;
66DAT2(X) ;Convert FM date to display (mm/dd/yyyy) format.
67 N DATE
68 S DATE=$S(X:$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3)),1:"")
69 Q DATE
70 ;
Note: See TracBrowser for help on using the repository browser.