RMPRUTL1 ;PHX/HPL - PROSTHETICS UTILITY SUBROUTINES ;10/31/1994
;;3.0;PROSTHETICS;**3,44,49,59**;Feb 09, 1996
;;PROSTHETICS;3.0;Apr. 17, 1995
;OJ - p49 rewrite of RAP to overcome letter printing line wrap problems
;
RAP(LINE,TB) ;WRAP A LINE IF NEEDED
N MAX,S,NW,NXT,FIN,SL
S MAX=IOM-(2*TB),FIN=0
F Q:FIN D
. S SL=$L(LINE)
. I SL'>MAX W !?TB,LINE S FIN=1 Q
. S S=$E(LINE,1,MAX),NXT=MAX
. I $E(S,MAX)'=" " D
. . S NW=$L(S," ")-1
. . I NW=0 D
. . . S NXT=MAX-1,S=$E(S,1,NXT)_"-"
. . . Q
. . E D
. . . S S=$P(S," ",1,NW),NXT=$L(S)
. . . Q
. . Q
. W !?TB,S
. F S NXT=NXT+1 Q:NXT>SL Q:$E(LINE,NXT)'=" "
. I NXT>SL S FIN=1 Q
. S LINE=$E(LINE,NXT,SL)
. Q
Q ""
FND ;FIND NEXT NON SPACE POSITION
Q:'$D(LINE) F NLP=LP:1:H S B=NLP Q:$E(LINE,B,B)'=" "
Q
PARS(NAME) ;PARSE AN INTERNAL FORM NAME INTO A LETTER FORMAT NAME
I NAME["," S LNAME=$P(NAME,",",1),FNAME=$P(NAME,",",2)
E D
.S LNAME=NAME,PIECES=1,FNAME="",FNAME(1)="",TITLE=""
I LNAME'[" " S LP=1,LNAME(1)=LNAME,LNAME(2)=""
E D
.S LP=2,LNAME(2)=$P(LNAME," ",2),LNAME(1)=$P(LNAME," ",1)
F LUP=1:1:LP S NAME=LNAME(LUP) D TRANS S LNAME(LUP)=RMPRNAME
S LASTNAME=LNAME(1)_" "_LNAME(2)
S PIECES=$S($L(FNAME," ")>1:$L(FNAME," "),1:1) S TITLE=""
I PIECES>1&($L($P(FNAME," ",PIECES))>1) D
.S TITLE=$P(FNAME," ",PIECES)
.S PIECES=PIECES-1
S FRSTNAME="" F LP=1:1:PIECES S NAME=$P(FNAME," ",LP) D TRANS S FRSTNAME=FRSTNAME_" "_RMPRNAME
S NAME=TITLE
I TITLE'["I" D TRANS S TITLE=RMPRNAME
S FIXDNAME=FRSTNAME_" "_LASTNAME_" "
Q FIXDNAME
TRANS S RMPRU="ABCDEFGHIJKLMNOPQRSTUVWXYZ",RMPRL="abcdefghijklmnopqrstuvwxyz",RMPR1=$E(NAME),RMPR2=$E(NAME,2,25),RMPRNAME=$TR(RMPR1,RMPRL,RMPRU)_$TR(RMPR2,RMPRU,RMPRL)
Q
DCNT(AMT,PCT) ; CALCULATE A DISCOUNT WITH ROUNDING
S DCNT=AMT*PCT S DCNT=$S(DCNT#.01=.005:DCNT+.005,DCNT#.01>.005:DCNT+(.01-(DCNT#.01)),1:DCNT-(DCNT#.01))
Q DCNT
DISP ;Display help for DIR screens/reads.
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)_" "
Q
EXIT ;GENERIC EXIT TAG
; VARIABLES REQUIRED: NONE
N RMPR,RMPRSITE D KILL^%ZISS,KVAR^VADPT,KILL^XUSCLEAN Q
;
DAT1(X) ; Convert FM date to displayable (mm/dd/yy) format.
N DATE
S DATE=$S(X:$E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3),1:"")
Q DATE
;
DAT2(X) ;Convert FM date to display (mm/dd/yyyy) format.
N DATE
S DATE=$S(X:$E(X,4,5)_"/"_$E(X,6,7)_"/"_(1700+$E(X,1,3)),1:"")
Q DATE
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRUTL1 2554 printed Apr 09, 2024@21:35:42 Page 2
RMPRUTL1 ;PHX/HPL - PROSTHETICS UTILITY SUBROUTINES ;10/31/1994
+1 ;;3.0;PROSTHETICS;**3,44,49,59**;Feb 09, 1996
+2 ;;PROSTHETICS;3.0;Apr. 17, 1995
+3 ;OJ - p49 rewrite of RAP to overcome letter printing line wrap problems
+4 ;
RAP(LINE,TB) ;WRAP A LINE IF NEEDED
+1 NEW MAX,S,NW,NXT,FIN,SL
+2 SET MAX=IOM-(2*TB)
SET FIN=0
+3 FOR
if FIN
QUIT
Begin DoDot:1
+4 SET SL=$LENGTH(LINE)
+5 IF SL'>MAX
WRITE !?TB,LINE
SET FIN=1
QUIT
+6 SET S=$EXTRACT(LINE,1,MAX)
SET NXT=MAX
+7 IF $EXTRACT(S,MAX)'=" "
Begin DoDot:2
+8 SET NW=$LENGTH(S," ")-1
+9 IF NW=0
Begin DoDot:3
+10 SET NXT=MAX-1
SET S=$EXTRACT(S,1,NXT)_"-"
+11 QUIT
End DoDot:3
+12 IF '$TEST
Begin DoDot:3
+13 SET S=$PIECE(S," ",1,NW)
SET NXT=$LENGTH(S)
+14 QUIT
End DoDot:3
+15 QUIT
End DoDot:2
+16 WRITE !?TB,S
+17 FOR
SET NXT=NXT+1
if NXT>SL
QUIT
if $EXTRACT(LINE,NXT)'=" "
QUIT
+18 IF NXT>SL
SET FIN=1
QUIT
+19 SET LINE=$EXTRACT(LINE,NXT,SL)
+20 QUIT
End DoDot:1
+21 QUIT ""
FND ;FIND NEXT NON SPACE POSITION
+1 if '$DATA(LINE)
QUIT
FOR NLP=LP:1:H
SET B=NLP
if $EXTRACT(LINE,B,B)'=" "
QUIT
+2 QUIT
PARS(NAME) ;PARSE AN INTERNAL FORM NAME INTO A LETTER FORMAT NAME
+1 IF NAME[","
SET LNAME=$PIECE(NAME,",",1)
SET FNAME=$PIECE(NAME,",",2)
+2 IF '$TEST
Begin DoDot:1
+3 SET LNAME=NAME
SET PIECES=1
SET FNAME=""
SET FNAME(1)=""
SET TITLE=""
End DoDot:1
+4 IF LNAME'[" "
SET LP=1
SET LNAME(1)=LNAME
SET LNAME(2)=""
+5 IF '$TEST
Begin DoDot:1
+6 SET LP=2
SET LNAME(2)=$PIECE(LNAME," ",2)
SET LNAME(1)=$PIECE(LNAME," ",1)
End DoDot:1
+7 FOR LUP=1:1:LP
SET NAME=LNAME(LUP)
DO TRANS
SET LNAME(LUP)=RMPRNAME
+8 SET LASTNAME=LNAME(1)_" "_LNAME(2)
+9 SET PIECES=$SELECT($LENGTH(FNAME," ")>1:$LENGTH(FNAME," "),1:1)
SET TITLE=""
+10 IF PIECES>1&($LENGTH($PIECE(FNAME," ",PIECES))>1)
Begin DoDot:1
+11 SET TITLE=$PIECE(FNAME," ",PIECES)
+12 SET PIECES=PIECES-1
End DoDot:1
+13 SET FRSTNAME=""
FOR LP=1:1:PIECES
SET NAME=$PIECE(FNAME," ",LP)
DO TRANS
SET FRSTNAME=FRSTNAME_" "_RMPRNAME
+14 SET NAME=TITLE
+15 IF TITLE'["I"
DO TRANS
SET TITLE=RMPRNAME
+16 SET FIXDNAME=FRSTNAME_" "_LASTNAME_" "
+17 QUIT FIXDNAME
TRANS SET RMPRU="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
SET RMPRL="abcdefghijklmnopqrstuvwxyz"
SET RMPR1=$EXTRACT(NAME)
SET RMPR2=$EXTRACT(NAME,2,25)
SET RMPRNAME=$TRANSLATE(RMPR1,RMPRL,RMPRU)_$TRANSLATE(RMPR2,RMPRU,RMPRL)
+1 QUIT
DCNT(AMT,PCT) ; CALCULATE A DISCOUNT WITH ROUNDING
+1 SET DCNT=AMT*PCT
SET DCNT=$SELECT(DCNT#.01=.005:DCNT+.005,DCNT#.01>.005:DCNT+(.01-(DCNT#.01)),1:DCNT-(DCNT#.01))
+2 QUIT DCNT
DISP ;Display help for DIR screens/reads.
+1 NEW RMPR90DP,RMPR90I
WRITE !
SET RMPR90DP=$PIECE(DIR(0),U,2,999)
FOR RMPR90I=1:1:5
IF $PIECE($PIECE(RMPR90DP,";",RMPR90I),":",1)'=""
WRITE " ("_$PIECE($PIECE(RMPR90DP,";",RMPR90I),":",1)_")"_$PIECE($PIECE(RMPR90DP,";",RMPR90I),":",2)_" "
+2 QUIT
EXIT ;GENERIC EXIT TAG
+1 ; VARIABLES REQUIRED: NONE
+2 NEW RMPR,RMPRSITE
DO KILL^%ZISS
DO KVAR^VADPT
DO KILL^XUSCLEAN
QUIT
+3 ;
DAT1(X) ; Convert FM date to displayable (mm/dd/yy) format.
+1 NEW DATE
+2 SET DATE=$SELECT(X:$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3),1:"")
+3 QUIT DATE
+4 ;
DAT2(X) ;Convert FM date to display (mm/dd/yyyy) format.
+1 NEW DATE
+2 SET DATE=$SELECT(X:$EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_(1700+$EXTRACT(X,1,3)),1:"")
+3 QUIT DATE
+4 ;
