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

ABSPECP1.m

Go to the documentation of this file. 
  1. ABSPECP1 ; IHS/FCS/DRS - printing for PCS ;  [ 10/09/2002  8:01 AM ]
  1.  ;;1.0;PHARMACY POINT OF SALE;**3,12,17,23,42,44,49**;JUN 21, 2001;Build 38
  1.  ;
  1.  ;---------------------------------
  1.  ;IHS/SD/lwj 10/08/02  NCPDP 5.1 changes
  1.  ; With 5.1 the segments, fields, and field identifiers changed.
  1.  ; This routine had to be adjusted to account for the differences
  1.  ; between a 5.1 and 3.2 claims.  Changes made where needed.
  1.  ;---------------------------------
  1.  ;IHS/SD/lwj 3/11/05 patch 12 need to add the DUR segment to
  1.  ; the claim and response portions of the receipt
  1.  ;---------------------------------
  1.  ;IHS/SD/RLT - 05/01/06 - Patch 17
  1.  ; Allow for double zeros in fields 440 and 441.
  1.  ; Fix the displaying of multiple DUR sets.
  1.  ;---------------------------------
  1.  ;IHS/SD/RLT - 08/03/07 - 10/18/07 - Patch 23
  1.  ; Diagnois Code
  1.  Q
  1. TEST K TMP D FILEMAN("TMP",255)
  1.  ;O 51:("TMP.OUT":"W") U 51 ZW TMP C 51
  1.  Q
  1. FILEMAN(DEST,IEN,FIELDS,RX,RXFIELDS)     ;EP - from ABSPECP0 and ABSPOS6E
  1.  ; generalized FileMan fetch for pharm e-claims and responses
  1.  ; DEST = destination (closed ref, used in @DEST@(subs) format)
  1.  ;   if global, it must be ^TMP or ^UTILITY
  1.  ; FILE = file number (9002313.02 or 9002313.03)
  1.  ; IEN as usual;  FIELDS = the DR string of field numbers
  1.  ; RX = prescription sub-entry; RXFIELDS = the DR string for it
  1.  ; FIELDS, RX, RXFIELDS optional; they default to all RXs,all fields
  1.  ; Returns @DEST@("C",field)=value    for fields in the claim
  1.  ;         @DEST@("C",field,"RX",rx,field)=value
  1.  ;         @DEST@("R" similarly
  1.  ;    where "field" is field name (not field number)
  1.  K ^UTILITY("DIQ1",$J)
  1.  N FILE S FILE=9002313.02 D FM1
  1.  S FILE=9002313.03,IEN=$O(^ABSPR("B",IEN,""),-1) ; last resp
  1.  I IEN D
  1.  .D FM1
  1.  D FORMAT
  1.  Q
  1. FORMAT ; ^UTILITY("DIQ1",$J,file,DA,field,*)->@TMP@(...)
  1.  ;------------------------
  1.  ;IHS/SD/lwj 10/08/02  NCPDP 5.1 changes
  1.  ; added the NCPDP field to decipher the version - this will help
  1.  ; in the data translation
  1.  ;-------------------------
  1.  N SRC S SRC="^UTILITY(""DIQ1"",$J)"
  1.  N EFORMAT,INSURER,FILE,DA,FIELD
  1.  N NCPDP51               ;IHS/SD/lwj 10/08/02  NCPDP 5.1 change
  1.  S NCPDP51=0             ;IHS/SD/lwj 10/08/02  NCPDP 5.1 change
  1.  N RXSEQ                 ;IHS/SD/lwj 6/13/05 need to know the rx seq
  1.  S RXSEQ=1               ;IHS/SD/lwj 6/13/05 default it to one
  1.  S DA=$O(@SRC@(9002313.02,0))
  1.  S INSURER=$G(@SRC@(9002313.02,DA,.02,"I"))
  1.  I INSURER S EFORMAT=$P($G(^ABSPEI(INSURER,100)),U)
  1.  E  S EFORMAT=0
  1.  I ('EFORMAT),$G(^ABSP(9002313.99,1,"ABSPICNV"))'=1 W "Internal error - no FORMAT for INSURER=",INSURER,! Q
  1.  ;
  1.  S:$G(@SRC@(9002313.02,DA,102,"I"))=51 NCPDP51=1
  1.  ;IHS/OIT/CASSEVERN/RAN - 02/10/2011 - Patch 42 Temporary change to allow printing of D.0 receipts as if they were 5.1 Receipts 
  1.  S:$G(@SRC@(9002313.02,DA,102,"I"))="D0" NCPDP51=1
  1.  ;
  1.  ;ZW EFORMAT
  1.  S FILE="" F  S FILE=$O(@SRC@(FILE)) Q:'FILE  D
  1.  .S DA=""  F  S DA=$O(@SRC@(FILE,DA)) Q:'DA  D
  1.  ..N FIELD S FIELD="" F  S FIELD=$O(@SRC@(FILE,DA,FIELD)) Q:'FIELD  D
  1.  ...I EFORMAT,'$$INCLUDE(EFORMAT,FILE,FIELD) D  Q
  1.  ....;W "FORMAT+n^",$T(+0)," excludes EFORMAT=",EFORMAT,", FIELD=",FIELD,!
  1.  ...;IHS/SD/lwj 6/13/05 patch 12 need to know the rx sequence
  1.  ...S:((FILE=9002313.0301)&(FIELD=.01)) RXSEQ=DA
  1.  ...D FMTFIELD
  1.  Q
  1. INCLUDE(EFORMAT,FILE,FIELD)  ; is the field part of this protocol?
  1.  ; returns 1 or 10 or 20 or 30 or 40 maybe with ^ID appended
  1.  ;--------------------------------
  1.  ;IHS/SD/lwj 10/08/02   NCPDP 5.1 changes - need to include all
  1.  ; the new segments
  1.  ;
  1.  ;--------------------------------
  1.  ;
  1.  N START,END
  1.  S START=10,END=40
  1.  I NCPDP51 S START=100,END=230
  1.  ;
  1.  I FILE=9002313.03 Q 1 ; always yes for response fields
  1.  I FILE=9002313.0301 Q 1 ; always yes for response fields
  1.  I FILE=9002313.1101 Q 1 ; IHS/SD/lwj 3/11/05 patch 12 DUR resp segment
  1.  I FIELD<101!(FIELD>600) Q 1 ; yes for fields outside protocol range
  1.  N FIELDIEN S FIELDIEN=$O(^ABSPF(9002313.91,"B",FIELD,0))
  1.  I FIELDIEN="" Q 0 ; should never happen?
  1.  ;IHS/OIT/CASSEVER/RAN 03/24/2011 patch 42 Get rid of references to formats for new method of claims processing
  1.  I $P($G(^ABSP(9002313.99,1,"ABSPICNV")),"^",1)=1 Q "110^"_$$FIELDID(FIELD)
  1.  ;
  1.  ;IHS/SD/lwj 10/08/02  NCPDP 5.1 nxt line remarked out, following added
  1.  ;N I,FIND S FIND=0 F I=10,20,30,40 D  Q:$G(FIND)
  1.  N I,FIND S FIND=0 F I=START:10:END D  Q:$G(FIND)
  1.  .N J S J=0
  1.  .F  S J=$O(^ABSPF(9002313.92,EFORMAT,I,J)) Q:'J  D  Q:$G(FIND)
  1.  ..I $P(^ABSPF(9002313.92,EFORMAT,I,J,0),U,2)=FIELDIEN D
  1.  ...S FIND=I
  1.  ...S FIND=FIND_U_$$FIELDID(FIELD)
  1.  Q FIND
  1. FIELDID(FIELD)     ; the two character field ID, given the external field #
  1.  ;--------------------------------------
  1.  ;IHS/SD/lwj 10/08/02  NCPDP 5.1 changes
  1.  ; With 5.1 all the fields will have a field identifier, except for the
  1.  ; header segment.  Must adjust this routine to account for that.
  1.  ; (NCPDP51 is defined in the FORMAT subroutine and is based on fld 102)
  1.  ;
  1.  ;--------------------------------------
  1.  N ID
  1.  N FIELDIEN S FIELDIEN=$O(^ABSPF(9002313.91,"B",FIELD,0))
  1.  I FIELDIEN="" Q ""
  1.  ;
  1.  S:'NCPDP51 ID=$P(^ABSPF(9002313.91,FIELDIEN,0),U,2)
  1.  S:NCPDP51 ID=$P($G(^ABSPF(9002313.91,FIELDIEN,5)),U)
  1.  ;
  1.  ;IHS/SD/lwj 10/08/02 NCPDP 5.1 nxt line remarked out - following added
  1.  ;Q $P(^ABSPF(9002313.91,FIELDIEN,0),U,2)
  1.  Q ID
  1.  ;
  1. ISVARFLD(EFORMAT,FILE,FIELD) ; is it a variable length field?
  1.  ;---------------------------------
  1.  ;IHS/SD/lwj 10/08/02  NCPDP 5.1 changes
  1.  ; if we are working with a 5.1 format, and it's any segment other
  1.  ; than 100, return the field id.
  1.  ;---------------------------------
  1.  ; returns 2-char field ID if it is
  1.  N X S X=$$INCLUDE(EFORMAT,FILE,FIELD)
  1.  Q:(NCPDP51)&(X>100) $P(X,U,2)    ;IHS/SD/lwj 10/08/02 NCPDP 5.1
  1.  I +X=20!(+X=40) Q $P(X,U,2)
  1.  E  Q ""
  1. FMTFIELD ; given FILE,DA,FIELD,@SRC@(FILE,DA,FIELD,"E" and "I"), set @TMP
  1.  ; given INSURER and EFORMAT, too
  1.  ; Fetch the INT and EXT values
  1.  ;-----------------------------------------
  1.  ;IHS/SD/lwj 10/08/02 NCPDP 5.1 changes
  1.  ; needed to format a couple of the newer field a little different
  1.  ;-----------------------------------------
  1.  ;
  1.  N INT S INT=$G(@SRC@(FILE,DA,FIELD,"I"))
  1.  N EXT S EXT=$G(@SRC@(FILE,DA,FIELD,"E"))
  1.  ; If it's a variable field, remove the field ID
  1.  N VARFIELD
  1.  ;
  1.  ;IHS/SD/lwj 10/08/02 NCPDP 5.1 fields need more formatting
  1.  N CKFLD,FLDLST
  1.  ;IHS/SD/lwj 3/11/05 patch 12, need to format 412 (disp fee)
  1.  ;nxt line remrkd out, following added
  1.  ;S FLDLST=",409,448,449,477,480,481,482,483,487,558,562,566,"
  1.  ;S FLDLST=",409,412,448,449,477,480,481,482,483,487,558,562,566,"
  1.  ;IHS/OIT/SCR 12/05/08 patch 28 t4 need to format 438 (Incentive amount)
  1.  S FLDLST=",409,412,448,449,477,480,481,482,483,487,558,562,566,438,"
  1.  I FIELD=524 S VARFIELD="FO"  ; have to hardcode response cases
  1.  E  S VARFIELD=$$ISVARFLD(EFORMAT,FILE,FIELD)
  1.  I VARFIELD]"" D
  1.  .I $E(INT,1,2)=VARFIELD S INT=$E(INT,3,$L(INT))
  1.  .I $E(EXT,1,2)=VARFIELD S EXT=$E(EXT,3,$L(EXT))
  1.  ;I FIELD=422 ZW VARFIELD,EFORMAT,FILE,FIELD,INT,EXT
  1.  ; Trailing spaces, leading zeroes
  1.  F  Q:$E(EXT,$L(EXT))'=" "  S EXT=$E(EXT,1,$L(EXT)-1)
  1.  ;IHS/SD/RLT - 05/01/06 - Patch 17
  1.  ;Allow for double zeros in fields 440 and 441
  1.  ;I FIELD'=407,FIELD'=302 D
  1.  ;Patch 23 added 492 below
  1.  ;OIT/CAS/RCS 10022012 - Patch 44, added fields 101, 104, 301, 303 and 110
  1.  ; /IHS/OIT/RAM 03 OCT 17 ; CR09769 - P49 - REMOVE ZERO SUPPRESSION FROM REC REPORT OF DUR / NDC FIELD 476
  1.  I FIELD'=407,FIELD'=302,FIELD'=440,FIELD'=441,FIELD'=492,FIELD'=101,FIELD'=104,FIELD'=301,FIELD'=110,FIELD'=303,FIELD'=476 D
  1.  .F  Q:$E(EXT)'=0  Q:$L(EXT)=1  S EXT=$E(EXT,2,$L(EXT))
  1.  I FIELD=426!(FIELD=430) D  ; for some reason they're missed
  1.  .S EXT="$"_$J($$DFF2EXT^ABSPECFM(EXT),7,2)
  1.  ;
  1.  ;IHS/SD/lWJ 10/08/02 NCPDP 5.1 some more signed fields
  1.  S CKFLD=","_FIELD_","
  1.  S:FLDLST[CKFLD EXT="$"_$J($$DFF2EXT^ABSPECFM(EXT),7,2)
  1.  ;
  1.  ;IHS/SD/lwj 3/11/05 format .01 fld for claim DUR
  1.  S:((FIELD=.01)&(FILE=9002313.1001)) EXT=$E(EXT,3,$L(EXT))
  1.  ;
  1.  ; Format .01 fld for claim DIAG                     Patch 23
  1.  S:((FIELD=.01)&(FILE=9002313.0701)) EXT=$E(EXT,3,$L(EXT))
  1.  ;
  1.  I FIELD=103 S EXT=$$TCODE^ABSPECP2(EXT)
  1.  ; Get the field name
  1.  N FLDNAME S FLDNAME=$P(^DD(FILE,FIELD,0),U)
  1.  ; If it's a date field that didn't get formatted, format it
  1.  I FLDNAME["Date",EXT?8N D
  1.  .N Y S Y=EXT-17000000 X ^DD("DD") S EXT=Y
  1.  ; Other enumerated fields
  1.  ;IHS/SD/lwj 10/08/02 NCPDP 5.1 field now include "Patient"
  1.  I FLDNAME="Patient Relationship Code" D
  1.  .S EXT=$S(EXT=1:"Cardholder",EXT=2:"Spouse",EXT=3:"Child",EXT=4:"Other Dependent",1:EXT)
  1.  I FLDNAME="Compound Code" D
  1.  .S EXT=$S(EXT=1:"Not a compound",EXT=2:"Compound",1:EXT)
  1.  I FLDNAME="Dispense As Written" S EXT=$$DAW^ABSPECP2(EXT)
  1.  I FLDNAME="Basis of Reimb Determination" S EXT=$$REIMB^ABSPECP2(EXT)
  1.  I FLDNAME="Diagnosis Code Count" S FLDNAME="DIAG Count"         ;Patch 23
  1.  ; Store it
  1.  I EXT="",'$$INCLUDE(EFORMAT,FILE,FIELD) Q
  1.  I FILE=9002313.02 D
  1.  .S @DEST@("C",FLDNAME)=EXT
  1.  E  I FILE=9002313.0201 D
  1.  .S @DEST@("C",FLDNAME,"RX",DA)=EXT
  1.  E  I FILE=9002313.1001 D  ;IHS/SD/lwj 3/11/05 patch 12 clm DUR
  1.  .;IHS/SD/RLT - 05/01/06 - Patch 17
  1.  .;Fix displaying of multiple DUR sets
  1.  .;S @DEST@("C","DUR entry "_DA_": "_FLDNAME,"RX",DA)=EXT
  1.  .S @DEST@("C","DUR entry "_DA_": "_FLDNAME,"RX",RXSEQ)=EXT
  1.  E  I FILE=9002313.0701 D                                        ;Patch 23
  1.  .S @DEST@("C","DIAG entry "_DA_": "_FLDNAME,"RX",RXSEQ)=EXT     ;Patch 23
  1.  E  I FILE=9002313.03 D
  1.  .S @DEST@("R",FLDNAME)=EXT
  1.  E  I FILE=9002313.0301 D
  1.  .I FLDNAME="Additional Message Information" S FLDNAME="Message (more)"
  1.  .S @DEST@("R",FLDNAME,"RX",DA)=EXT
  1.  E  I FILE=9002313.1101 D  ;IHS/SD/lwj 3/11/05 patch 12 DUR resp
  1.  .S @DEST@("R","DUR Resp "_DA_" "_FLDNAME,"RX",RXSEQ)=EXT
  1.  E  D IMPOSS^ABSPOSUE("P","TI",,,"FMTFIELD",$T(+0))
  1.  Q
  1. FM1 N DIC,DR,DA,DIQ,SUBFILE
  1.  I '$D(FIELDS) S FIELDS=".01:99999999"
  1.  I '$D(RX)
  1.  I '$D(RXFIELDS) S RXFIELDS=".01:99999999"
  1.  ; Safety - make sure if DEST is global, it's probably a scratch global
  1.  I DEST?1"^".E I DEST'?1"^TMP("1E.E,DEST'?1"^UTILITY("1E.E D IMPOSS^ABSPOSUE("P","TI","Bad DEST",DEST,"FM1",$T(+0))
  1.  D FETCH ; gives ^UTILITY("DIQ1",$J,file,DA,field,"E") and ^("I")
  1.  Q
  1. FETCH ;
  1.  I '$D(RX) N RX S RX=0 D  Q
  1.  .; RX not yet determined:  recurse
  1.  .N GLO S GLO="^ABSP"_$S(FILE=9002313.02:"C",FILE=9002313.03:"R")
  1.  .N SUB S SUB=$S(FILE=9002313.02:400,FILE=9002313.03:1000)
  1.  .F  S RX=$O(@GLO@(FILE,IEN,SUB,RX)) Q:'RX  D
  1.  ..D 2
  1. 2 ; with RX determined
  1.  I FILE=9002313.03 D  ; Reject Code(s) done manually
  1.  .N X S X=0 F  S X=$O(^ABSPR(IEN,1000,RX,511,X)) Q:'X  D
  1.  ..;ZW X W ^(X,0),!
  1.  ..N Y S Y=^ABSPR(IEN,1000,RX,511,X,0),Y=$P(Y,U)
  1.  ..N Z S Z=$O(^ABSPF(9002313.93,"B",Y,0))
  1.  ..;W Y," -> ",Z,!
  1.  ..I Z,$D(^ABSPF(9002313.93,Z,0)) S Z=$P(^(0),U,2)
  1.  ..S @DEST@("R","Reject Code","RX",RX,$S(Y?1"0"1N:+Y,1:Y))=Y_" "_Z
  1.  ..;ZW @DEST@("R","Reject Code","RX") R ">>",%,!
  1.  .;Preferred Product data sent back
  1.  .N X S X=0 F  S X=$O(^ABSPR(IEN,1000,RX,551.01,X)) Q:'X  D
  1.  ..N Y S Y=$G(^ABSPR(IEN,1000,RX,551.01,X,1)) I Y="" Q
  1.  ..N Z S Z=$P(Y,"^",2)_" "_$P(Y,"^",5)
  1.  ..S @DEST@("R","Preferred Product","RX",RX,X)=Z
  1.  .;Additional Message Information sent back
  1.  .N X S X=0 F  S X=$O(^ABSPR(IEN,1000,RX,526,X)) Q:'X  D
  1.  ..N Y S Y=$G(^ABSPR(IEN,1000,RX,526,X,0)) I Y="" Q
  1.  ..S @DEST@("R","Additional Information","RX",RX,X)=Y
  1.  S DIC=FILE,DA=IEN,DR=FIELDS,DIQ(0)="IEN"
  1.  S SUBFILE=FILE+.0001 ; as it happens to work out
  1.  S DA(SUBFILE)=RX
  1.  S DR(SUBFILE)=RXFIELDS
  1.  D EN^DIQ1
  1.  ;
  1.  ;IHS/SD/lwj 3/11/05 patch 12 retrieve the claim and resp DUR
  1.  D:FILE=9002313.02 SETCDUR   ;retrieve the claim DUR info
  1.  D:FILE=9002313.03 SETRDUR   ;retrieve the response DUR info
  1.  ;
  1.  ;
  1.  ;IHS/SD/RLT - 08/03/07 - Patch 23
  1.  ; Diagnois Code information
  1.  D:FILE=9002313.02 SETCDIAG   ;retrieve the claim DIAG info
  1.  ;
  1.  Q
  1. SETCDUR ;------------------------------------------------------------
  1.  ;IHS/SD/LWJ 3/11/05 patch 12
  1.  ; set fields needed to retrieve DUR information from the claim
  1.  ;------------------------------------------------------------
  1.  N DURCNT
  1.  ;
  1.  S DURCNT=0
  1.  S DR(9002313.0201)=473.01
  1.  S DR(9002313.1001)=".01;439;440;441;474;475;476"  ;fields
  1.  ;
  1.  F  S DURCNT=$O(^ABSPC(IEN,400,RX,473.01,DURCNT)) Q:DURCNT=""  D
  1.  . S DA(9002313.1001)=DURCNT
  1.  . S DIQ(0)="IEN"
  1.  . D EN^DIQ1
  1.  ;
  1.  Q
  1. SETRDUR ;----------------------------------------------------------------
  1.  ;IHS/SD/lwj 3/11/05 patch 12
  1.  ; set fields needed to retrieve DUR information from the response
  1.  ;----------------------------------------------------------------
  1.  N DURCNT
  1.  ;
  1.  S DURCNT=0
  1.  S DR(9002313.0301)=567.01    ;DUR multiple
  1.  S DR(9002313.1101)=".01;439;528;529;530;531;532;533;544"  ;fields
  1.  ;
  1.  F  S DURCNT=$O(^ABSPR(IEN,1000,RX,567.01,DURCNT)) Q:DURCNT=""  D
  1.  . S DA(9002313.1101)=DURCNT
  1.  . S DIQ(0)="IEN"
  1.  . D EN^DIQ1
  1.  ;
  1.  Q
  1. SETCDIAG ;
  1.  ;IHS/SD/RLT - 08/03/07 - 10/18/07 - Patch 23
  1.  ; set Diagnosis Code information from the claim
  1.  ;
  1.  N DIAGCNT
  1.  ;
  1.  S DIAGCNT=0
  1.  S DR(9002313.0201)=491.01
  1.  S DR(9002313.0701)=".01;492;424"  ;fields
  1.  ;
  1.  F  S DIAGCNT=$O(^ABSPC(IEN,400,RX,491.01,DIAGCNT)) Q:'+DIAGCNT  D
  1.  . S DA(9002313.0701)=DIAGCNT
  1.  . S DIQ(0)="IEN"
  1.  . D EN^DIQ1
  1.  ;
  1.  Q