BPSOSU9.m

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

WHEADER(TEXT,IOF,IOM) ;EP

 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 ---BPSOSU9   3051     printed  Mar 13, 2025@20:56:55                                                                                                                                                                                                     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

WHEADER(TEXT,IOF,IOM) ;EP

 +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