BPSOSU9 ;BHAM ISC/FCS/DRS/FLS - copied for ECME ;03/07/08 10:41
;;1.0;E CLAIMS MGMT ENGINE;**1,7**;JUN 2004;Build 46
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;----------------------------------------------------------------------
;Standard W and String Formatting Functions
;----------------------------------------------------------------------
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSOSU9 3051 printed Nov 22, 2024@17:02:26 Page 2
BPSOSU9 ;BHAM ISC/FCS/DRS/FLS - copied for ECME ;03/07/08 10:41
+1 ;;1.0;E CLAIMS MGMT ENGINE;**1,7**;JUN 2004;Build 46
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;----------------------------------------------------------------------
+5 ;Standard W and String Formatting Functions
+6 ;----------------------------------------------------------------------
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
