| [613] | 1 | RMPRUTL1 ;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 | ;
|
|---|
| 6 | RAP(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 ""
|
|---|
| 28 | FND ;FIND NEXT NON SPACE POSITION
|
|---|
| 29 | Q:'$D(LINE) F NLP=LP:1:H S B=NLP Q:$E(LINE,B,B)'=" "
|
|---|
| 30 | Q
|
|---|
| 31 | PARS(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
|
|---|
| 49 | TRANS S RMPRU="ABCDEFGHIJKLMNOPQRSTUVWXYZ",RMPRL="abcdefghijklmnopqrstuvwxyz",RMPR1=$E(NAME),RMPR2=$E(NAME,2,25),RMPRNAME=$TR(RMPR1,RMPRL,RMPRU)_$TR(RMPR2,RMPRU,RMPRL)
|
|---|
| 50 | Q
|
|---|
| 51 | DCNT(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
|
|---|
| 54 | DISP ;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
|
|---|
| 57 | EXIT ;GENERIC EXIT TAG
|
|---|
| 58 | ; VARIABLES REQUIRED: NONE
|
|---|
| 59 | N RMPR,RMPRSITE D KILL^%ZISS,KVAR^VADPT,KILL^XUSCLEAN Q
|
|---|
| 60 | ;
|
|---|
| 61 | DAT1(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 | ;
|
|---|
| 66 | DAT2(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 | ;
|
|---|
