ABSPECFM ; IHS/FCS/DRS - JWS 04:09 PM 28 May 1996 ; [ 09/04/2002 1:55 PM ]
;;1.0;PHARMACY POINT OF SALE;**3,9,47**;JUN 21, 2001;Build 38
;----------------------------------------------------------------------
;----------------------------------------------------------------------
;NCPDP Field Format Functions
; These are all $$ functions called from lots of places.
;--------------------------------------------------------
; IHS/SD/lwj 8/28/02 NCPDP 5.1 changes
; Added a new subroutine to translate the rejection code
; Added a new subroutine to translate the reason for service code
; Used for AdvancePCS certification process
;--------------------------------------------------------
; IHS/SD/lwj 1/05/04 new conversion routine added
; Added a new subroutine to translate signed numeric
; to a 4 digit decimal value (for percentage sales tax
; rate paid)
;--------------------------------------------------------
;Numeric Format Function
NFF(X,L) ;EP -
Q $E($TR($J("",L-$L(X))," ","0")_X,1,L)
;----------------------------------------------------------------------
;Signed Numeric Field Format
DFF(X,L) ;
N FNUMBER,DOLLAR,CENTS,SVALUE
Q:X="" $TR($J("",L)," ","0")
S DOLLAR=+$TR($P(X,".",1),"-","")
S CENTS=$E($P(X,".",2),1,2)
S:$L(CENTS)=0 CENTS="00"
S:$L(CENTS)=1 CENTS=CENTS_"0"
S SVALUE=$S(X<0:"}JKLMNOPQR",1:"{ABCDEFGHI")
S $E(CENTS,2)=$E(SVALUE,$E(CENTS,2)+1)
Q $E($TR($J("",L-$L(DOLLAR_CENTS))," ","0")_DOLLAR_CENTS,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
;OIT/CAS/RCS 04/21/14 Patch 47 Make sure strings only contain Upper case characters
ANFF(X,L) ;EP
S X=$TR(X,"abcdefghijklmnopqrstuvwyxz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
Q $E(X_$J("",L-$L(X)),1,L)
;----------------------------------------------------------------------
;Numerics Field Format
; DUPLICATE TAGS! commented out this one
; The other one appears to zero fill.
; NFF(X,L)
; Q $E(X_$J("",L-$L(X)),1,L)
;----------------------------------------------------------------------
;Convert FileManager date into CCYYMMDD format
DTF1(X) ;EP -
N Y,%DT
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 -
I X?11N Q X ; no reformatting needed
N Y,I
F I=1:1:3 S Y(I)=$P(X,"-",I)
Q $$RJZF(Y(1),5)_$$RJZF(Y(2),4)_$$RJZF(Y(3),2)
;----------------------------------------------------------------------
;Right justify and zero fill X in a string of length L
;OIT/CAS/RCS 04/21/14 Patch 47 Make sure strings only contain Upper case characters
RJZF(X,L) ;
S X=$TR(X,"abcdefghijklmnopqrstuvwyxz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
Q $E($TR($J("",L-$L(X))," ","0")_X,1,L)
;----------------------------------------------------------------------
;Right justify and blank fill X in a string of length L
;OIT/CAS/RCS 04/21/14 Patch 47 Make sure strings only contain Upper case characters
RJBF(X,L) ;EP -
S X=$TR(X,"abcdefghijklmnopqrstuvwyxz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
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
;----------------------------------------------------------------------
;IHS/SD/lwj 8/28/02 NCPDP 5.1 changes
; For the certification process with AdvancePCS, they require that the
; reject explanation appear with the rejection code. The following
; Additionally, they require that within the DUR segment, the
; description for the reason for service code also appear (fld 439).
; To accomodate this requirement, the following subroutines were
; created to act as an output transform for the reject codes and the
; reason for service code. These routine will not currently be used
; any where else, but will be kept in the software in case they are
; needed.
;
TRANREJ(REJCD) ;EP - REJCD will be the incoming rejection code
;
N REJECT,REJIEN
;
S REJIEN=0
S REJIEN=$O(^ABSPF(9002313.93,"B",REJCD,REJIEN)) ;find record
S:$D(REJIEN) REJECT=$P($G(^ABSPF(9002313.93,REJIEN,0)),U,2)
S:'$D(REJECT) REJECT="Description not found for rejection code"
S REJECT=REJCD_" ("_REJECT_" )"
S REJECT=$$ANFF(REJECT,50)
;
Q REJECT
;----------------------------------------------------------------------
TRANSCD(SRVCD) ;EP - SRCCD will be the incoming reason for service code
;
N SCDIEN,SCDESC
;
S SCDIEN=0
S SCDIEN=$O(^ABSPF(9002313.82439,"B",SRVCD,SCDIEN)) ;find record
S:$D(SCDIEN) SCDESC=$P($G(^ABSPF(9002313.82439,SCDIEN,0)),U,2)
S:'$D(SCDESC) SCDESC="Description not found for service code"
S SCDESC=SRVCD_" ("_SCDESC_" )"
S SCDESC=$$ANFF(SCDESC,50)
;
Q SCDESC
;----------------------------------------------------------------------
;Converts Signed Numeric Field to Decimal Value (4 decimal places)
; IHS/SD/lwj 01/05/04 added in patch 9 to compensate for fields with
; 4 decimal places, such as the percentage sales tax rate paid (fld 560)
DFF4EXT(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*.0001
I "}JKLMNOPQR"[LCHAR S X=X*-1
Q $J(+X,$L(+X),2)
;----------------------------------------------------------------------
ABSPECFM ; IHS/FCS/DRS - JWS 04:09 PM 28 May 1996 ; [ 09/04/2002 1:55 PM ]
+1 ;;1.0;PHARMACY POINT OF SALE;**3,9,47**;JUN 21, 2001;Build 38
+2 ;----------------------------------------------------------------------
+3 ;----------------------------------------------------------------------
+4 ;NCPDP Field Format Functions
+5 ; These are all $$ functions called from lots of places.
+6 ;--------------------------------------------------------
+7 ; IHS/SD/lwj 8/28/02 NCPDP 5.1 changes
+8 ; Added a new subroutine to translate the rejection code
+9 ; Added a new subroutine to translate the reason for service code
+10 ; Used for AdvancePCS certification process
+11 ;--------------------------------------------------------
+12 ; IHS/SD/lwj 1/05/04 new conversion routine added
+13 ; Added a new subroutine to translate signed numeric
+14 ; to a 4 digit decimal value (for percentage sales tax
+15 ; rate paid)
+16 ;--------------------------------------------------------
+17 ;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
DFF(X,L) ;
+1 NEW FNUMBER,DOLLAR,CENTS,SVALUE
+2 IF X=""
QUIT $TRANSLATE($JUSTIFY("",L)," ","0")
+3 SET DOLLAR=+$TRANSLATE($PIECE(X,".",1),"-","")
+4 SET CENTS=$EXTRACT($PIECE(X,".",2),1,2)
+5 IF $LENGTH(CENTS)=0
SET CENTS="00"
+6 IF $LENGTH(CENTS)=1
SET CENTS=CENTS_"0"
+7 SET SVALUE=$SELECT(X<0:"}JKLMNOPQR",1:"{ABCDEFGHI")
+8 SET $EXTRACT(CENTS,2)=$EXTRACT(SVALUE,$EXTRACT(CENTS,2)+1)
+9 QUIT $EXTRACT($TRANSLATE($JUSTIFY("",L-$LENGTH(DOLLAR_CENTS))," ","0")_DOLLAR_CENTS,1,L)
+10 ;----------------------------------------------------------------------
+11 ;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
+10 ;OIT/CAS/RCS 04/21/14 Patch 47 Make sure strings only contain Upper case characters
ANFF(X,L) ;EP
+1 SET X=$TRANSLATE(X,"abcdefghijklmnopqrstuvwyxz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 QUIT $EXTRACT(X_$JUSTIFY("",L-$LENGTH(X)),1,L)
+3 ;----------------------------------------------------------------------
+4 ;Numerics Field Format
+5 ; DUPLICATE TAGS! commented out this one
+6 ; The other one appears to zero fill.
+7 ; NFF(X,L)
+8 ; Q $E(X_$J("",L-$L(X)),1,L)
+9 ;----------------------------------------------------------------------
+10 ;Convert FileManager date into CCYYMMDD format
DTF1(X) ;EP -
+1 NEW Y,%DT
+2 SET X=$PIECE(X,".",1)
+3 IF X=""
QUIT "00000000"
+4 SET Y=X
DO DD^%DT
+5 SET X=Y
SET %DT="X"
DO ^%DT
+6 IF Y=-1
QUIT "00000000"
+7 SET X=Y+17000000
+8 QUIT X
+9 ;----------------------------------------------------------------------
+10 ;Reformats NDC number
NDCF(X) ;EP -
+1 ; no reformatting needed
IF X?11N
QUIT X
+2 NEW Y,I
+3 FOR I=1:1:3
SET Y(I)=$PIECE(X,"-",I)
+4 QUIT $$RJZF(Y(1),5)_$$RJZF(Y(2),4)_$$RJZF(Y(3),2)
+5 ;----------------------------------------------------------------------
+6 ;Right justify and zero fill X in a string of length L
+7 ;OIT/CAS/RCS 04/21/14 Patch 47 Make sure strings only contain Upper case characters
RJZF(X,L) ;
+1 SET X=$TRANSLATE(X,"abcdefghijklmnopqrstuvwyxz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 QUIT $EXTRACT($TRANSLATE($JUSTIFY("",L-$LENGTH(X))," ","0")_X,1,L)
+3 ;----------------------------------------------------------------------
+4 ;Right justify and blank fill X in a string of length L
+5 ;OIT/CAS/RCS 04/21/14 Patch 47 Make sure strings only contain Upper case characters
RJBF(X,L) ;EP -
+1 SET X=$TRANSLATE(X,"abcdefghijklmnopqrstuvwyxz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 QUIT $EXTRACT($JUSTIFY("",L-$LENGTH(X))_X,1,L)
+3 ;----------------------------------------------------------------------
+4 ;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 ;IHS/SD/lwj 8/28/02 NCPDP 5.1 changes
+9 ; For the certification process with AdvancePCS, they require that the
+10 ; reject explanation appear with the rejection code. The following
+11 ; Additionally, they require that within the DUR segment, the
+12 ; description for the reason for service code also appear (fld 439).
+13 ; To accomodate this requirement, the following subroutines were
+14 ; created to act as an output transform for the reject codes and the
+15 ; reason for service code. These routine will not currently be used
+16 ; any where else, but will be kept in the software in case they are
+17 ; needed.
+18 ;
TRANREJ(REJCD) ;EP - REJCD will be the incoming rejection code
+1 ;
+2 NEW REJECT,REJIEN
+3 ;
+4 SET REJIEN=0
+5 ;find record
SET REJIEN=$ORDER(^ABSPF(9002313.93,"B",REJCD,REJIEN))
+6 IF $DATA(REJIEN)
SET REJECT=$PIECE($GET(^ABSPF(9002313.93,REJIEN,0)),U,2)
+7 IF '$DATA(REJECT)
SET REJECT="Description not found for rejection code"
+8 SET REJECT=REJCD_" ("_REJECT_" )"
+9 SET REJECT=$$ANFF(REJECT,50)
+10 ;
+11 QUIT REJECT
+12 ;----------------------------------------------------------------------
TRANSCD(SRVCD) ;EP - SRCCD will be the incoming reason for service code
+1 ;
+2 NEW SCDIEN,SCDESC
+3 ;
+4 SET SCDIEN=0
+5 ;find record
SET SCDIEN=$ORDER(^ABSPF(9002313.82439,"B",SRVCD,SCDIEN))
+6 IF $DATA(SCDIEN)
SET SCDESC=$PIECE($GET(^ABSPF(9002313.82439,SCDIEN,0)),U,2)
+7 IF '$DATA(SCDESC)
SET SCDESC="Description not found for service code"
+8 SET SCDESC=SRVCD_" ("_SCDESC_" )"
+9 SET SCDESC=$$ANFF(SCDESC,50)
+10 ;
+11 QUIT SCDESC
+12 ;----------------------------------------------------------------------
+13 ;Converts Signed Numeric Field to Decimal Value (4 decimal places)
+14 ; IHS/SD/lwj 01/05/04 added in patch 9 to compensate for fields with
+15 ; 4 decimal places, such as the percentage sales tax rate paid (fld 560)
DFF4EXT(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*.0001
+6 IF "}JKLMNOPQR"[LCHAR
SET X=X*-1
+7 QUIT $JUSTIFY(+X,$LENGTH(+X),2)
+8 ;----------------------------------------------------------------------
