ABSPOSU9 ; IHS/FCS/DRS - copied for POS ; [ 09/12/2002 10:20 AM ]
ABSUD009 ;;1.0;PHARMACY POINT OF SALE;**3**;JUN 21, 2001;Build 38
;----------------------------------------------------------------------
;----------------------------------------------------------------------
;Standard W and String Formatting Functions
;----------------------------------------------------------------------
;W a line of centered text
;WCENTER(Text,Margin)
;W ?Margin-$L(Text)/2,Text,!
;Q
;W a line of centered text. OPTion UL is for UNDERLINING.
WCENTER(TEXT,IOM,UL) ;EP
S:$G(IOM)="" IOM=80
W ?IOM-$L(TEXT)/2,TEXT,!
I $G(UL) W ?IOM-$L(TEXT)/2,$TR($J("",$L(TEXT))," ","-"),!
Q
;----------------------------------------------------------------------
;W Standard Underlined HEADER
Q:$G(TEXT)=""
S:$G(IOF)="" IOF="#"
S:$G(IOM)="" IOM=80
W @IOF,!
D WCENTER(TEXT,IOM)
D WCENTER($TR($J("",$L(TEXT))," ","-"),IOM)
Q
;----------------------------------------------------------------------
;W Column HEADERs (with option to underline)
WCOLUMNS(INDENT,COLDEFS,CNAMES,ULINE) ;EP
N CHEAD1,CHEAD2,INDEX,CDEF
Q:$G(CNAMES)=""
S:$G(INDENT)="" INDENT=0
S:$G(COLDEFS)="" COLDEFS=2
S:$G(ULINE)="" ULINE=1
;
S COLDEFS=$J("",COLDEFS)
S (CHEAD1,CHEAD2)=""
F INDEX=1:1:$L(CNAMES,",") D
.S CDEF=$P(CNAMES,",",INDEX)
.S CHEAD1=CHEAD1_$S(INDEX=1:"",1:COLDEFS)_$$LJBF($P(CDEF,":",1),$P(CDEF,":",2))
.S:ULINE CHEAD2=CHEAD2_$S(INDEX=1:"",1:COLDEFS)_$TR($J("",$P(CDEF,":",2))," ","-")
W ?INDENT,CHEAD1,!
W:ULINE ?INDENT,CHEAD2,!
Q
;----------------------------------------------------------------------
WDATA(INDENT,COLDEFS,VNAMES) ;EP
N INDEX,DEF,DLINE,VAR,LEN
Q:$G(VNAMES)=""
S:$G(INDENT)="" INDENT=0
S:$G(COLDEFS)="" COLDEFS=2
;
S COLDEFS=$J("",COLDEFS)
S DLINE=""
F INDEX=1:1:$L(VNAMES,",") D
.S DEF=$P(VNAMES,",",INDEX)
.S VAR=$P(DEF,":",1)
.S LEN=$P(DEF,":",2)
.S DLINE=DLINE_$S(INDEX=1:"",1:COLDEFS)_$$LJBF($S(VAR="":"",1:$G(@VAR)),LEN)
W ?INDENT,DLINE,!
Q
;
;----------------------------------------------------------------------
;Left justifies and blank fills
LJBF(X,L) ;EP
Q $E(X_$J("",L-$L(X)),1,L)
;----------------------------------------------------------------------
;Right justifies and blank fills
RJBF(X,L) ;EP
Q $E($J("",L-$L(X))_X,1,L)
;----------------------------------------------------------------------
;CENTER justifies and blank fills
CJBF(X,L) ;
Q $$LJBF($E($J("",(L-$L(X))\2)_X,1,L),L)
;----------------------------------------------------------------------
;Convert lower case characters to upper case characters
UCASE(X) ;EP
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
;----------------------------------------------------------------------
;Convert upper case characters to lower case characters
LCASE(X) ;
Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
;----------------------------------------------------------------------
;Delete leading and trailing blanks
CLIP(X) ;EP
F D Q:$E(X,1)'=" "
.S:$E(X,1)=" " X=$E(X,2,$L(X))
F D Q:$E(X,$L(X))'=" "
.S:$E(X,$L(X))=" " X=$E(X,1,$L(X)-1)
Q X
ABSPOSU9 ; IHS/FCS/DRS - copied for POS ; [ 09/12/2002 10:20 AM ]
ABSUD009 ;;1.0;PHARMACY POINT OF SALE;**3**;JUN 21, 2001;Build 38
+1 ;----------------------------------------------------------------------
+2 ;----------------------------------------------------------------------
+3 ;Standard W and String Formatting Functions
+4 ;----------------------------------------------------------------------
+5 ;W a line of centered text
+6 ;WCENTER(Text,Margin)
+7 ;W ?Margin-$L(Text)/2,Text,!
+8 ;Q
+9 ;W a line of centered text. OPTion UL is for UNDERLINING.
WCENTER(TEXT,IOM,UL) ;EP
+1 IF $GET(IOM)=""
SET IOM=80
+2 WRITE ?IOM-$LENGTH(TEXT)/2,TEXT,!
+3 IF $GET(UL)
WRITE ?IOM-$LENGTH(TEXT)/2,$TRANSLATE($JUSTIFY("",$LENGTH(TEXT))," ","-"),!
+4 QUIT
+5 ;----------------------------------------------------------------------
+6 ;W Standard Underlined HEADER
+1 IF $GET(TEXT)=""
QUIT
+2 IF $GET(IOF)=""
SET IOF="#"
+3 IF $GET(IOM)=""
SET IOM=80
+4 WRITE @IOF,!
+5 DO WCENTER(TEXT,IOM)
+6 DO WCENTER($TRANSLATE($JUSTIFY("",$LENGTH(TEXT))," ","-"),IOM)
+7 QUIT
+8 ;----------------------------------------------------------------------
+9 ;W Column HEADERs (with option to underline)
WCOLUMNS(INDENT,COLDEFS,CNAMES,ULINE) ;EP
+1 NEW CHEAD1,CHEAD2,INDEX,CDEF
+2 IF $GET(CNAMES)=""
QUIT
+3 IF $GET(INDENT)=""
SET INDENT=0
+4 IF $GET(COLDEFS)=""
SET COLDEFS=2
+5 IF $GET(ULINE)=""
SET ULINE=1
+6 ;
+7 SET COLDEFS=$JUSTIFY("",COLDEFS)
+8 SET (CHEAD1,CHEAD2)=""
+9 FOR INDEX=1:1:$LENGTH(CNAMES,",")
Begin DoDot:1
+10 SET CDEF=$PIECE(CNAMES,",",INDEX)
+11 SET CHEAD1=CHEAD1_$SELECT(INDEX=1:"",1:COLDEFS)_$$LJBF($PIECE(CDEF,":",1),$PIECE(CDEF,":",2))
+12 IF ULINE
SET CHEAD2=CHEAD2_$SELECT(INDEX=1:"",1:COLDEFS)_$TRANSLATE($JUSTIFY("",$PIECE(CDEF,":",2))," ","-")
End DoDot:1
+13 WRITE ?INDENT,CHEAD1,!
+14 IF ULINE
WRITE ?INDENT,CHEAD2,!
+15 QUIT
+16 ;----------------------------------------------------------------------
WDATA(INDENT,COLDEFS,VNAMES) ;EP
+1 NEW INDEX,DEF,DLINE,VAR,LEN
+2 IF $GET(VNAMES)=""
QUIT
+3 IF $GET(INDENT)=""
SET INDENT=0
+4 IF $GET(COLDEFS)=""
SET COLDEFS=2
+5 ;
+6 SET COLDEFS=$JUSTIFY("",COLDEFS)
+7 SET DLINE=""
+8 FOR INDEX=1:1:$LENGTH(VNAMES,",")
Begin DoDot:1
+9 SET DEF=$PIECE(VNAMES,",",INDEX)
+10 SET VAR=$PIECE(DEF,":",1)
+11 SET LEN=$PIECE(DEF,":",2)
+12 SET DLINE=DLINE_$SELECT(INDEX=1:"",1:COLDEFS)_$$LJBF($SELECT(VAR="":"",1:$GET(@VAR)),LEN)
End DoDot:1
+13 WRITE ?INDENT,DLINE,!
+14 QUIT
+15 ;
+16 ;----------------------------------------------------------------------
+17 ;Left justifies and blank fills
LJBF(X,L) ;EP
+1 QUIT $EXTRACT(X_$JUSTIFY("",L-$LENGTH(X)),1,L)
+2 ;----------------------------------------------------------------------
+3 ;Right justifies and blank fills
RJBF(X,L) ;EP
+1 QUIT $EXTRACT($JUSTIFY("",L-$LENGTH(X))_X,1,L)
+2 ;----------------------------------------------------------------------
+3 ;CENTER justifies and blank fills
CJBF(X,L) ;
+1 QUIT $$LJBF($EXTRACT($JUSTIFY("",(L-$LENGTH(X))\2)_X,1,L),L)
+2 ;----------------------------------------------------------------------
+3 ;Convert lower case characters to upper case characters
UCASE(X) ;EP
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 ;----------------------------------------------------------------------
+3 ;Convert upper case characters to lower case characters
LCASE(X) ;
+1 QUIT $TRANSLATE(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
+2 ;----------------------------------------------------------------------
+3 ;Delete leading and trailing blanks
CLIP(X) ;EP
+1 FOR
Begin DoDot:1
+2 IF $EXTRACT(X,1)=" "
SET X=$EXTRACT(X,2,$LENGTH(X))
End DoDot:1
IF $EXTRACT(X,1)'=" "
QUIT
+3 FOR
Begin DoDot:1
+4 IF $EXTRACT(X,$LENGTH(X))=" "
SET X=$EXTRACT(X,1,$LENGTH(X)-1)
End DoDot:1
IF $EXTRACT(X,$LENGTH(X))'=" "
QUIT
+5 QUIT X
