Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ABSPECFM

ABSPECFM.m

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