source: WorldVistAEHR/trunk/r/E_CLAIMS_MGMT_ENGINE-BPS/BPSECFM.m@ 1006

Last change on this file since 1006 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.7 KB
Line 
1BPSECFM ;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
14NFF(X,L) ;EP -
15 Q $E($TR($J("",L-$L(X))," ","0")_X,1,L)
16 ;----------------------------------------------------------------------
17 ;Signed Numeric Field Format
18DFF(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
30DFF2EXT(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
40ANFF(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
50DTF1(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
62NDCF(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
74RJZF(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
79RJBF(X,L) ;EP -
80 Q $E($J("",L-$L(X))_X,1,L)
81 ;----------------------------------------------------------------------
82 ;STRIP TEXT of all non-numerics
83STRIPN(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 ;
102TRANREJ(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 ;----------------------------------------------------------------------
116TRANSCD(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 ;----------------------------------------------------------------------
Note: See TracBrowser for help on using the repository browser.