| [613] | 1 | BPSECFM ;BHAM ISC/FCS/DRS/VA/DLF - NCPDP Field Format Functions ;05/17/2004
|
|---|
| 2 | ;;1.0;E CLAIMS MGMT ENGINE;**1**;JUN 2004
|
|---|
| 3 | ;----------------------------------------------------------------------
|
|---|
| 4 | ;----------------------------------------------------------------------
|
|---|
| 5 | ;NCPDP Field Format Functions
|
|---|
| 6 | ; These are all $$ functions called from lots of places.
|
|---|
| 7 | ;--------------------------------------------------------
|
|---|
| 8 | ; IHS/SD/lwj 8/28/02 NCPDP 5.1 changes
|
|---|
| 9 | ; Added a new subroutine to translate the rejection code
|
|---|
| 10 | ; Added a new subroutine to translate the reason for service code
|
|---|
| 11 | ; Used for AdvancePCS certification process
|
|---|
| 12 | ;--------------------------------------------------------
|
|---|
| 13 | ;Numeric Format Function
|
|---|
| 14 | NFF(X,L) ;EP -
|
|---|
| 15 | Q $E($TR($J("",L-$L(X))," ","0")_X,1,L)
|
|---|
| 16 | ;----------------------------------------------------------------------
|
|---|
| 17 | ;Signed Numeric Field Format
|
|---|
| 18 | DFF(X,L) ;
|
|---|
| 19 | N FNUMBER,DOLLAR,CENTS,SVALUE
|
|---|
| 20 | Q:X="" $TR($J("",L)," ","0")
|
|---|
| 21 | S DOLLAR=+$TR($P(X,".",1),"-","")
|
|---|
| 22 | S CENTS=$E($P(X,".",2),1,2)
|
|---|
| 23 | S:$L(CENTS)=0 CENTS="00"
|
|---|
| 24 | S:$L(CENTS)=1 CENTS=CENTS_"0"
|
|---|
| 25 | S SVALUE=$S(X<0:"}JKLMNOPQR",1:"{ABCDEFGHI")
|
|---|
| 26 | S $E(CENTS,2)=$E(SVALUE,$E(CENTS,2)+1)
|
|---|
| 27 | Q $E($TR($J("",L-$L(DOLLAR_CENTS))," ","0")_DOLLAR_CENTS,1,L)
|
|---|
| 28 | ;----------------------------------------------------------------------
|
|---|
| 29 | ;Converts Signed Numeric Field to Decimal Value
|
|---|
| 30 | DFF2EXT(X) ;EP -
|
|---|
| 31 | N LCHAR
|
|---|
| 32 | S LCHAR=$E(X,$L(X))
|
|---|
| 33 | S X=$TR(X,"{ABCDEFGHI","0123456789")
|
|---|
| 34 | S X=$TR(X,"}JKLMNOPQR","0123456789")
|
|---|
| 35 | S X=X*.01
|
|---|
| 36 | I "}JKLMNOPQR"[LCHAR S X=X*-1
|
|---|
| 37 | Q $J(+X,$L(+X),2)
|
|---|
| 38 | ;----------------------------------------------------------------------
|
|---|
| 39 | ;Alpha-Numeric Field Format
|
|---|
| 40 | ANFF(X,L) ;EP
|
|---|
| 41 | Q $E(X_$J("",L-$L(X)),1,L)
|
|---|
| 42 | ;----------------------------------------------------------------------
|
|---|
| 43 | ;Numerics Field Format
|
|---|
| 44 | ; DUPLICATE TAGS! commented out this one
|
|---|
| 45 | ; The other one appears to zero fill.
|
|---|
| 46 | ; NFF(X,L)
|
|---|
| 47 | ; Q $E(X_$J("",L-$L(X)),1,L)
|
|---|
| 48 | ;----------------------------------------------------------------------
|
|---|
| 49 | ;Convert FileManager date into CCYYMMDD format
|
|---|
| 50 | DTF1(X) ;EP -
|
|---|
| 51 | N Y,%DT
|
|---|
| 52 | ;Q:X'["." X
|
|---|
| 53 | S X=$P(X,".",1)
|
|---|
| 54 | Q:X="" "00000000"
|
|---|
| 55 | S Y=X D DD^%DT
|
|---|
| 56 | S X=Y,%DT="X" D ^%DT
|
|---|
| 57 | Q:Y=-1 "00000000"
|
|---|
| 58 | S X=Y+17000000
|
|---|
| 59 | Q X
|
|---|
| 60 | ;----------------------------------------------------------------------
|
|---|
| 61 | ;Reformats NDC number
|
|---|
| 62 | NDCF(X) ;EP -
|
|---|
| 63 | S X=$TR(X,"-","")
|
|---|
| 64 | I X?11N Q X ; no reformatting needed
|
|---|
| 65 | I $L(X)<11 F I=1:1:(11-$L(X)) S X="0"_X
|
|---|
| 66 | I $L(X)>11 S X=$E(X,2,12)
|
|---|
| 67 | S X=$E(X,1,5)_"-"_$E(X,6,9)_"-"_$E(X,10,11)
|
|---|
| 68 | N Y,I
|
|---|
| 69 | F I=1:1:3 S Y(I)=$P(X,"-",I)
|
|---|
| 70 | S X=$$RJZF(Y(1),5)_$$RJZF(Y(2),4)_$$RJZF(Y(3),2)
|
|---|
| 71 | Q X
|
|---|
| 72 | ;----------------------------------------------------------------------
|
|---|
| 73 | ;Right justify and zero fill X in a string of length L
|
|---|
| 74 | RJZF(X,L) ;
|
|---|
| 75 | I $L(X)<L Q $E($TR($J("",L-$L(X))," ","0")_X,1,L)
|
|---|
| 76 | Q $E(X,$L(X)-L+1,$L(X))
|
|---|
| 77 | ;----------------------------------------------------------------------
|
|---|
| 78 | ;Right justify and blank fill X in a string of length L
|
|---|
| 79 | RJBF(X,L) ;EP -
|
|---|
| 80 | Q $E($J("",L-$L(X))_X,1,L)
|
|---|
| 81 | ;----------------------------------------------------------------------
|
|---|
| 82 | ;STRIP TEXT of all non-numerics
|
|---|
| 83 | STRIPN(TEXT) ;
|
|---|
| 84 | N NUM,I,CH
|
|---|
| 85 | S NUM=""
|
|---|
| 86 | F I=1:1:$L(TEXT) D
|
|---|
| 87 | .S CH=$E(TEXT,I,I)
|
|---|
| 88 | .S:CH?1N NUM=NUM_CH
|
|---|
| 89 | Q NUM
|
|---|
| 90 | ;----------------------------------------------------------------------
|
|---|
| 91 | ;IHS/SD/lwj 8/28/02 NCPDP 5.1 changes
|
|---|
| 92 | ; For the certification process with AdvancePCS, they require that the
|
|---|
| 93 | ; reject explanation appear with the rejection code. The following
|
|---|
| 94 | ; Additionally, they require that within the DUR segment, the
|
|---|
| 95 | ; description for the reason for service code also appear (fld 439).
|
|---|
| 96 | ; To accomodate this requirement, the following subroutines were
|
|---|
| 97 | ; created to act as an output transform for the reject codes and the
|
|---|
| 98 | ; reason for service code. These routine will not currently be used
|
|---|
| 99 | ; any where else, but will be kept in the software in case they are
|
|---|
| 100 | ; needed.
|
|---|
| 101 | ;
|
|---|
| 102 | TRANREJ(REJCD) ;EP - REJCD will be the incoming rejection code
|
|---|
| 103 | ;
|
|---|
| 104 | I $G(REJCD)="" Q ""
|
|---|
| 105 | N REJECT,REJIEN
|
|---|
| 106 | ;
|
|---|
| 107 | S REJIEN=0
|
|---|
| 108 | S REJIEN=$O(^BPSF(9002313.93,"B",REJCD,REJIEN)) ;find record
|
|---|
| 109 | I REJIEN S REJECT=$P($G(^BPSF(9002313.93,REJIEN,0)),U,2)
|
|---|
| 110 | E S REJECT="Description not found for rejection code"
|
|---|
| 111 | S REJECT=REJCD_" ("_REJECT_")"
|
|---|
| 112 | S REJECT=$$ANFF(REJECT,50)
|
|---|
| 113 | ;
|
|---|
| 114 | Q REJECT
|
|---|
| 115 | ;----------------------------------------------------------------------
|
|---|
| 116 | TRANSCD(SRVCD) ;EP - SRCCD will be the incoming reason for service code
|
|---|
| 117 | ;
|
|---|
| 118 | N SCDIEN,SCDESC
|
|---|
| 119 | ;
|
|---|
| 120 | S SCDIEN=0
|
|---|
| 121 | S SRVCD=$E(SRVCD,1,2)
|
|---|
| 122 | S:$G(SRVCD)'="" SCDIEN=$O(^BPSF(9002313.82439,"B",SRVCD,SCDIEN)) ;find record
|
|---|
| 123 | S:$G(SCDIEN) SCDESC=$P($G(^BPSF(9002313.82439,SCDIEN,0)),U,2)
|
|---|
| 124 | S:$G(SCDESC)="" SCDESC="Description not found for service code"
|
|---|
| 125 | S SCDESC=SRVCD_" ("_SCDESC_" )"
|
|---|
| 126 | S SCDESC=$$ANFF(SCDESC,50)
|
|---|
| 127 | ;
|
|---|
| 128 | Q SCDESC
|
|---|
| 129 | ;----------------------------------------------------------------------
|
|---|
