BPSECFM ;BHAM ISC/FCS/DRS/VA/DLF - NCPDP Field Format Functions ;3/12/08 13:01
;;1.0;E CLAIMS MGMT ENGINE;**1,7,10,11**;JUN 2004;Build 27
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;----------------------------------------------------------------------
;NCPDP Field Format Functions
; These are all $$ functions called from the FORMAT CODE/D0 FORMAT
; CODE fields of BPS NCPDP FIELD DEFS, output transforms, and from
; routines
;----------------------------------------------------------------------
;Numeric Format Function
NFF(X,L) ;EP -
Q $E($TR($J("",L-$L(X))," ","0")_X,1,L)
;----------------------------------------------------------------------
;Signed Numeric Field Format with variable length decimal places
DFF(X,L,P) ;
N INTEGER,DECIMAL,SVALUE
I $G(X)="" S X=0
I $G(P)="" S P=2 ;default value
S INTEGER=+$TR($P(X,".",1),"-","")
S DECIMAL=$E($P(X,".",2),1,P)
I $L(DECIMAL)<P D
. F S DECIMAL=DECIMAL_"0" Q:$L(DECIMAL)=P
S SVALUE=$S(X<0:"}JKLMNOPQR",1:"{ABCDEFGHI")
S $E(DECIMAL,P)=$E(SVALUE,$E(DECIMAL,P)+1)
Q $E($TR($J("",L-$L(INTEGER_DECIMAL))," ","0")_INTEGER_DECIMAL,1,L)
;----------------------------------------------------------------------
;Converts Signed Numeric Field to Decimal Value
DFF2EXT(X) ;EP -
N LCHAR
S LCHAR=$E(X,$L(X))
S X=$TR(X,"{ABCDEFGHI","0123456789")
S X=$TR(X,"}JKLMNOPQR","0123456789")
S X=X*.01
I "}JKLMNOPQR"[LCHAR S X=X*-1
Q $J(+X,$L(+X),2)
;----------------------------------------------------------------------
;Alpha-Numeric Field Format
ANFF(X,L) ;EP
S X=$$UP^XLFSTR(X) ;SLT, Phase 6-T12, D4
Q $E(X_$J("",L-$L(X)),1,L)
;----------------------------------------------------------------------
;Convert FileManager date into CCYYMMDD format
DTF1(X) ;EP -
N Y,%DT
;Q:X'["." X
S X=$P(X,".",1)
Q:X="" "00000000"
S Y=X D DD^%DT
S X=Y,%DT="X" D ^%DT
Q:Y=-1 "00000000"
S X=Y+17000000
Q X
;----------------------------------------------------------------------
;Reformats NDC number
NDCF(X) ;EP -
S X=$TR(X,"-","")
I X?11N Q X ; no reformatting needed
I $L(X)<11 F I=1:1:(11-$L(X)) S X="0"_X
I $L(X)>11 S X=$E(X,2,12)
S X=$E(X,1,5)_"-"_$E(X,6,9)_"-"_$E(X,10,11)
N Y,I
F I=1:1:3 S Y(I)=$P(X,"-",I)
S X=$$RJZF(Y(1),5)_$$RJZF(Y(2),4)_$$RJZF(Y(3),2)
Q X
;----------------------------------------------------------------------
;Right justify and zero fill X in a string of length L
RJZF(X,L) ;
I $L(X)<L Q $E($TR($J("",L-$L(X))," ","0")_X,1,L)
Q $E(X,$L(X)-L+1,$L(X))
;----------------------------------------------------------------------
;Right justify and blank fill X in a string of length L
RJBF(X,L) ;EP -
Q $E($J("",L-$L(X))_X,1,L)
;----------------------------------------------------------------------
;STRIP TEXT of all non-numerics
STRIPN(TEXT) ;
N NUM,I,CH
S NUM=""
F I=1:1:$L(TEXT) D
.S CH=$E(TEXT,I,I)
.S:CH?1N NUM=NUM_CH
Q NUM
;----------------------------------------------------------------------
; Format reject codes
; This is called by Output Transform in the BPS RESPONSE file and by
; BPSPRRX3
;
; REJCD is the incoming rejection code
TRANREJ(REJCD) ;EP - REJCD will be the incoming rejection code
;
I $G(REJCD)="" Q ""
N REJECT,REJIEN
;
S REJIEN=0
S REJIEN=$O(^BPSF(9002313.93,"B",REJCD,REJIEN)) ;find record
I REJIEN S REJECT=$P($G(^BPSF(9002313.93,REJIEN,0)),U,2)
E S REJECT="Description not found for rejection code"
S REJECT=REJCD_" ("_REJECT_")"
S REJECT=$$ANFF(REJECT,50)
;
Q REJECT
;----------------------------------------------------------------------
; Format Reason for Service Code field
; Called by Output Transform in BPS Response
; SRVCD is the incoming Service Code
TRANSCD(SRVCD) ;EP - SRVCD will be the incoming reason for service code
;
N SCDIEN,SCDESC
;
S SCDIEN=0
S SRVCD=$E(SRVCD,1,2)
S:$G(SRVCD)'="" SCDIEN=$O(^BPS(9002313.23,"B",SRVCD,SCDIEN)) ;find record
S:$G(SCDIEN) SCDESC=$P($G(^BPS(9002313.23,SCDIEN,0)),U,2)
S:$G(SCDESC)="" SCDESC="Description not found for service code"
S SCDESC=SRVCD_" ("_SCDESC_" )"
S SCDESC=$$ANFF(SCDESC,50)
;
Q SCDESC
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSECFM 4225 printed Sep 23, 2025@19:27:01 Page 2
BPSECFM ;BHAM ISC/FCS/DRS/VA/DLF - NCPDP Field Format Functions ;3/12/08 13:01
+1 ;;1.0;E CLAIMS MGMT ENGINE;**1,7,10,11**;JUN 2004;Build 27
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;----------------------------------------------------------------------
+5 ;NCPDP Field Format Functions
+6 ; These are all $$ functions called from the FORMAT CODE/D0 FORMAT
+7 ; CODE fields of BPS NCPDP FIELD DEFS, output transforms, and from
+8 ; routines
+9 ;----------------------------------------------------------------------
+10 ;Numeric Format Function
NFF(X,L) ;EP -
+1 QUIT $EXTRACT($TRANSLATE($JUSTIFY("",L-$LENGTH(X))," ","0")_X,1,L)
+2 ;----------------------------------------------------------------------
+3 ;Signed Numeric Field Format with variable length decimal places
DFF(X,L,P) ;
+1 NEW INTEGER,DECIMAL,SVALUE
+2 IF $GET(X)=""
SET X=0
+3 ;default value
IF $GET(P)=""
SET P=2
+4 SET INTEGER=+$TRANSLATE($PIECE(X,".",1),"-","")
+5 SET DECIMAL=$EXTRACT($PIECE(X,".",2),1,P)
+6 IF $LENGTH(DECIMAL)<P
Begin DoDot:1
+7 FOR
SET DECIMAL=DECIMAL_"0"
if $LENGTH(DECIMAL)=P
QUIT
End DoDot:1
+8 SET SVALUE=$SELECT(X<0:"}JKLMNOPQR",1:"{ABCDEFGHI")
+9 SET $EXTRACT(DECIMAL,P)=$EXTRACT(SVALUE,$EXTRACT(DECIMAL,P)+1)
+10 QUIT $EXTRACT($TRANSLATE($JUSTIFY("",L-$LENGTH(INTEGER_DECIMAL))," ","0")_INTEGER_DECIMAL,1,L)
+11 ;----------------------------------------------------------------------
+12 ;Converts Signed Numeric Field to Decimal Value
DFF2EXT(X) ;EP -
+1 NEW LCHAR
+2 SET LCHAR=$EXTRACT(X,$LENGTH(X))
+3 SET X=$TRANSLATE(X,"{ABCDEFGHI","0123456789")
+4 SET X=$TRANSLATE(X,"}JKLMNOPQR","0123456789")
+5 SET X=X*.01
+6 IF "}JKLMNOPQR"[LCHAR
SET X=X*-1
+7 QUIT $JUSTIFY(+X,$LENGTH(+X),2)
+8 ;----------------------------------------------------------------------
+9 ;Alpha-Numeric Field Format
ANFF(X,L) ;EP
+1 ;SLT, Phase 6-T12, D4
SET X=$$UP^XLFSTR(X)
+2 QUIT $EXTRACT(X_$JUSTIFY("",L-$LENGTH(X)),1,L)
+3 ;----------------------------------------------------------------------
+4 ;Convert FileManager date into CCYYMMDD format
DTF1(X) ;EP -
+1 NEW Y,%DT
+2 ;Q:X'["." X
+3 SET X=$PIECE(X,".",1)
+4 if X=""
QUIT "00000000"
+5 SET Y=X
DO DD^%DT
+6 SET X=Y
SET %DT="X"
DO ^%DT
+7 if Y=-1
QUIT "00000000"
+8 SET X=Y+17000000
+9 QUIT X
+10 ;----------------------------------------------------------------------
+11 ;Reformats NDC number
NDCF(X) ;EP -
+1 SET X=$TRANSLATE(X,"-","")
+2 ; no reformatting needed
IF X?11N
QUIT X
+3 IF $LENGTH(X)<11
FOR I=1:1:(11-$LENGTH(X))
SET X="0"_X
+4 IF $LENGTH(X)>11
SET X=$EXTRACT(X,2,12)
+5 SET X=$EXTRACT(X,1,5)_"-"_$EXTRACT(X,6,9)_"-"_$EXTRACT(X,10,11)
+6 NEW Y,I
+7 FOR I=1:1:3
SET Y(I)=$PIECE(X,"-",I)
+8 SET X=$$RJZF(Y(1),5)_$$RJZF(Y(2),4)_$$RJZF(Y(3),2)
+9 QUIT X
+10 ;----------------------------------------------------------------------
+11 ;Right justify and zero fill X in a string of length L
RJZF(X,L) ;
+1 IF $LENGTH(X)<L
QUIT $EXTRACT($TRANSLATE($JUSTIFY("",L-$LENGTH(X))," ","0")_X,1,L)
+2 QUIT $EXTRACT(X,$LENGTH(X)-L+1,$LENGTH(X))
+3 ;----------------------------------------------------------------------
+4 ;Right justify and blank fill X in a string of length L
RJBF(X,L) ;EP -
+1 QUIT $EXTRACT($JUSTIFY("",L-$LENGTH(X))_X,1,L)
+2 ;----------------------------------------------------------------------
+3 ;STRIP TEXT of all non-numerics
STRIPN(TEXT) ;
+1 NEW NUM,I,CH
+2 SET NUM=""
+3 FOR I=1:1:$LENGTH(TEXT)
Begin DoDot:1
+4 SET CH=$EXTRACT(TEXT,I,I)
+5 if CH?1N
SET NUM=NUM_CH
End DoDot:1
+6 QUIT NUM
+7 ;----------------------------------------------------------------------
+8 ; Format reject codes
+9 ; This is called by Output Transform in the BPS RESPONSE file and by
+10 ; BPSPRRX3
+11 ;
+12 ; REJCD is the incoming rejection code
TRANREJ(REJCD) ;EP - REJCD will be the incoming rejection code
+1 ;
+2 IF $GET(REJCD)=""
QUIT ""
+3 NEW REJECT,REJIEN
+4 ;
+5 SET REJIEN=0
+6 ;find record
SET REJIEN=$ORDER(^BPSF(9002313.93,"B",REJCD,REJIEN))
+7 IF REJIEN
SET REJECT=$PIECE($GET(^BPSF(9002313.93,REJIEN,0)),U,2)
+8 IF '$TEST
SET REJECT="Description not found for rejection code"
+9 SET REJECT=REJCD_" ("_REJECT_")"
+10 SET REJECT=$$ANFF(REJECT,50)
+11 ;
+12 QUIT REJECT
+13 ;----------------------------------------------------------------------
+14 ; Format Reason for Service Code field
+15 ; Called by Output Transform in BPS Response
+16 ; SRVCD is the incoming Service Code
TRANSCD(SRVCD) ;EP - SRVCD will be the incoming reason for service code
+1 ;
+2 NEW SCDIEN,SCDESC
+3 ;
+4 SET SCDIEN=0
+5 SET SRVCD=$EXTRACT(SRVCD,1,2)
+6 ;find record
if $GET(SRVCD)'=""
SET SCDIEN=$ORDER(^BPS(9002313.23,"B",SRVCD,SCDIEN))
+7 if $GET(SCDIEN)
SET SCDESC=$PIECE($GET(^BPS(9002313.23,SCDIEN,0)),U,2)
+8 if $GET(SCDESC)=""
SET SCDESC="Description not found for service code"
+9 SET SCDESC=SRVCD_" ("_SCDESC_" )"
+10 SET SCDESC=$$ANFF(SCDESC,50)
+11 ;
+12 QUIT SCDESC
+13 ;
