ABSPDB1D ; IHS/OIT/CASSevern/Pieran ran 1/19/2011 - Handling of outgoing NCPDP Billing "B1" Claims for D.0 (DURR,CLINICAL,COMPOUND, and COUPON segments)
;;1.0;PHARMACY POINT OF SALE;**42,49**;JUN 21, 2001;Build 38
DURRPPS ;EP CALLED FROM ABSPDB1 to set up DURR/PPS SEGMENT
Q:$D(SUPRESSG("DURR/PPS"))
N RECCNT,DUR
I ACTION["CLAIM" D
. Q:'$D(ABSP("RX",MEDN,"DUR"))
. S (RECCNT,DUR)=0
. F S DUR=$O(ABSP("RX",MEDN,"DUR",DUR)) Q:DUR="" D
. . S RECCNT=RECCNT+1
. . N FIELD
. . S RECORD=$G(RECORD)
. . F FIELD="111",473,439,440,441,474,475,476 D
. . . Q:$D(SUPRESF(FIELD))
. . . I (ACTION["CLAIM"),(FIELD'=111) D
. . . . D @(FIELD_"GET")
. . . . D @(FIELD_"FMT")
. . . . D @(FIELD_"SET")
. . . ELSE D APPEND(FIELD)
. S ^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),473.01,0)="^9002313.1001A^"_RECCNT_"^"_RECCNT
ELSE D
. D DURVALUE^ABSPECA1
. Q:'$D(ABSP(9002313.1001))
. D APPEND(111) ;Only field on segment that is not repeating
. S DUR=0
. F S DUR=$O(ABSP(9002313.1001,DUR)) Q:DUR="" D
. . F FIELD=.01,439,440,441,474,475,476 D
. . . Q:$D(SUPRESF(FIELD))
. . . S ABSP("X")=$G(ABSP(9002313.1001,DUR,FIELD,"I"))
. . . S:ABSP("X")'="" RECORD=RECORD_$C(28)_ABSP("X")
Q
;Segment identifier
111GET S ABSP("X")="08"
Q
111FMT S ABSP("X")=$$ANFF^ABSPECFM(ABSP("X"),2)
Q
111SET ;This isn't used for the 111 Field
Q
;DUR/PPS Code Counter
473GET I '$D(SPECIAL(473,DUR)) S ABSP("X")=$G(ABSP("RX",MEDN,"DUR",DUR,473))
ELSE X SPECIAL(473,DUR)
Q
473FMT S:ABSP("X")'="" ABSP("X")="7E"_$$ANFF^ABSPECFM($G(ABSP("X")),1)
Q
473SET D FLD473^ABSPOSSG
Q
;Reason for Service Code
439GET I '$D(SPECIAL(439,DUR)) S ABSP("X")=$G(ABSP("RX",MEDN,"DUR",DUR,439))
ELSE X SPECIAL(439,DUR)
Q
439FMT S:ABSP("X")'="" ABSP("X")="E4"_$$ANFF^ABSPECFM($G(ABSP("X")),2)
Q
439SET D FLD439^ABSPOSSG
Q
;Professional Service Code
440GET I '$D(SPECIAL(440,DUR)) S ABSP("X")=$G(ABSP("RX",MEDN,"DUR",DUR,440))
ELSE X SPECIAL(440,DUR)
Q
440FMT S:ABSP("X")'="" ABSP("X")="E5"_$$ANFF^ABSPECFM($G(ABSP("X")),2)
Q
440SET D FLD440^ABSPOSSG
Q
;Result of Service Coce
441GET I '$D(SPECIAL(441,DUR)) S ABSP("X")=$G(ABSP("RX",MEDN,"DUR",DUR,441))
ELSE X SPECIAL(441,DUR)
Q
441FMT S:ABSP("X")'="" ABSP("X")="E6"_$$ANFF^ABSPECFM($G(ABSP("X")),2)
Q
441SET D FLD441^ABSPOSSG
Q
;DUR/PPS Level of Effort
474GET I '$D(SPECIAL(474,DUR)) S ABSP("X")=$G(ABSP("RX",MEDN,"DUR",DUR,474))
ELSE X SPECIAL(474,DUR)
Q
474FMT S:ABSP("X")'="" ABSP("X")="8E"_$$ANFF^ABSPECFM($G(ABSP("X")),2)
Q
474SET D FLD474^ABSPOSSG
Q
;DUR Co-Agent ID Qualifier
475GET I '$D(SPECIAL(475,DUR)) S ABSP("X")=$G(ABSP("RX",MEDN,"DUR",DUR,475))
ELSE X SPECIAL(475,DUR)
Q
475FMT S:ABSP("X")'="" ABSP("X")="J9"_$$ANFF^ABSPECFM($G(ABSP("X")),2)
Q
475SET D FLD475^ABSPOSSG
Q
;DUR CO-Agent ID
476GET I '$D(SPECIAL(476,DUR)) S ABSP("X")=$G(ABSP("RX",MEDN,"DUR",DUR,476))
ELSE X SPECIAL(476,DUR)
Q
476FMT S:ABSP("X")'="" ABSP("X")="H6"_$$ANFF^ABSPECFM($G(ABSP("X")),19)
Q
476SET D FLD476^ABSPOSSG
Q
COUPON ;EP CALLED FROM ABSPDB1 to set up COUPON SEGMENT
Q:$D(SUPRESSG("Coupon"))
N FIELD
S RECORD=$G(RECORD)
F FIELD="111A",485,486,487 D
. Q:$D(SUPRESF(FIELD))
. I (ACTION["CLAIM"),(FIELD'=111) D
. . D @(FIELD_"GET")
. . D @(FIELD_"FMT")
. . D @(FIELD_"SET")
. ELSE D APPEND(FIELD)
Q
;Segment identifier
111AGET S ABSP("X")="09"
Q
111AFMT S ABSP("X")=$$ANFF^ABSPECFM(ABSP("X"),2)
Q
111ASET ;This isn't used for the 111 Field
Q
;Coupon Type
485GET I '$D(SPECIAL(485)) S ABSP("X")=""
ELSE X SPECIAL(485)
Q
485FMT S:ABSP("X")'="" ABSP("X")="KE"_$$ANFF^ABSPECFM($G(ABSP("X")),2)
Q
485SET ;Not Yet Implemented
Q
;Coupon Number
486GET I '$D(SPECIAL(486)) S ABSP("X")=""
ELSE X SPECIAL(486)
Q
486FMT S:ABSP("X")'="" ABSP("X")="ME"_$$ANFF^ABSPECFM($G(ABSP("X")),15)
Q
486SET ;Not Yet Implemented
Q
;Coupon Value Amount
487GET I '$D(SPECIAL(487)) S ABSP("X")=""
ELSE X SPECIAL(487)
Q
487FMT S:ABSP("X")'="" ABSP("X")="NE"_$$ANFF^ABSPECFM($G(ABSP("X")),6)
Q
487SET ;Not Yet Implemented
Q
COMPOUND ;EP CALLED FROM ABSPDB1 to set up COMPOUND SEGMENT
Q:$D(SUPRESSG("Compound"))
N FIELD
S RECORD=$G(RECORD)
F FIELD="111B",450,451,447,488,489,448,449,490,362,363 D
. Q:$D(SUPRESF(FIELD))
. I (ACTION["CLAIM"),(FIELD'=111) D
. . D @(FIELD_"GET")
. . D @(FIELD_"FMT")
. . D @(FIELD_"SET")
. ELSE D APPEND(FIELD)
Q
;Segment identifier
111BGET S ABSP("X")=10
Q
111BFMT S ABSP("X")=$$ANFF^ABSPECFM(ABSP("X"),2)
Q
111BSET ;This isn't used for the 111 Field
Q
;Compound Dosage Form Description Code
450GET I '$D(SPECIAL(450)) S ABSP("X")=$G(ABSP("Compound",ABSP(9002313.0201),"Dosage Form Desc"))
ELSE X SPECIAL(450)
Q
450FMT S:ABSP("X")'="" ABSP("X")="EF"_$$ANFF^ABSPECFM(ABSP("X"),2)
Q
450SET S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),440),U,10)=ABSP("X")
Q
;Compound Dispensing Unit Form Indicator
451GET I '$D(SPECIAL(451)) S ABSP("X")=$G(ABSP("Compound",ABSP(9002313.0201),"Disp Unit Form"))
ELSE X SPECIAL(451)
Q
451FMT S:ABSP("X")'="" ABSP("X")="EG"_$$NFF^ABSPECFM(ABSP("X"),1)
Q
451SET S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),450),U,1)=ABSP("X")
Q
;Compound Ingredient Compound Count
447GET I '$D(SPECIAL(447)) S ABSP("X")=$G(ABSP("Compound",ABSP(9002313.0201),"Ingred Component Cnt"))
ELSE X SPECIAL(447)
Q
447FMT S:ABSP("X")'="" ABSP("X")="EC"_$$NFF^ABSPECFM(ABSP("X"),2)
Q
447SET S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),440),U,7)=ABSP("X")
Q
;Compound Product ID Qualifier
488GET I '$D(SPECIAL(488)) S ABSP("X")=$G(ABSP("Compound","Product ID Qualifier"))
ELSE X SPECIAL(488)
Q
488FMT S:ABSP("X")'="" ABSP("X")="RE"_$$ANFF^ABSPECFM(ABSP("X"),2)
Q
488SET ;Not Yet Implemented
Q
;Compound Product ID
489GET I '$D(SPECIAL(489)) S ABSP("X")=$G(ABSP("Compound","Product ID"))
ELSE X SPECIAL(489)
Q
489FMT S:ABSP("X")'="" ABSP("X")="TE"_$$ANFF^ABSPECFM(ABSP("X"),19)
Q
489SET ;Not Yet Implemented
Q
;Compound Ingredient Quantity
448GET I '$D(SPECIAL(448)) S ABSP("X")=$G(ABSP("Coupound","Ingredient Quantity"))
ELSE X SPECIAL(448)
Q
448FMT S:ABSP("X")'="" ABSP("X")="ED"_$$DFF^ABSPECFM(ABSP("X"),10) ;Spec Says Length is 7?
Q
448SET ;Not Yet Implemented
Q
;Compound Ingredient Drug Cost
449GET I '$D(SPECIAL(449)) S ABSP("X")=$G(ABSP("Compound","Ingredient Drug Cost"))
ELSE X SPECIAL(449)
Q
449FMT S:ABSP("X")'="" ABSP("X")="EE"_$$DFF^ABSPEFCM(ABSP("X"),8) ;Spec says length is 6?
Q
449SET ;Not Yet Implemented
Q
;Compound Ingredient Basis of Cost Determination
490GET I '$D(SPECIAL(490)) S ABSP("X")=$G(ABSP("Compound","Ingred Basis of Cost"))
ELSE X SPECIAL(490)
Q
490FMT S:ABSP("X")'="" ABSP("X")="UE"_$$ANFF^ABSPECFM(ABSP("X"),2)
Q
490SET ;Not Yet Implemented
Q
;Compound Ingredient Modifier Code Count
362GET I '$D(SPECIAL(362)) S ABSP("X")=""
ELSE X SPECIAL(362)
Q
362FMT S:ABSP("X")'="" ABSP("X")="2G"_$$ANFF^ABSPECFM($G(ABSP("X")),2)
Q
362SET ;Not Yet Implemented
Q
;Compound Ingredient Modifier Code
363GET I '$D(SPECIAL(363)) S ABSP("X")=""
ELSE X SPECIAL(363)
Q
363FMT S:ABSP("X")'="" ABSP("X")="2H"_$$ANFF^ABSPECFM($G(ABSP("X")),2)
Q
363SET ;Not Yet Implemented
Q
CLINICAL ;EP CALLED FROM ABSPDB1 to set up CLINICAL SEGMENT
Q:$D(SUPRESSG("Clinical"))
N RECCNT,DIAG
I ACTION["CLAIM" D
. Q:'$D(ABSP("RX",MEDN,"DIAG"))
. ;Field 491 is only field on this segment that is not repeating do it first
. D 491GET
. D 491FMT
. D 491SET
. S (RECCNT,DIAG)=0
. F S DIAG=$O(ABSP("RX",MEDN,"DIAG",DIAG)) Q:'+DIAG D
. . S RECCNT=RECCNT+1
. . N FIELD
. . F FIELD="111C",492,424,493,494,495,496,497,499 D
. . . Q:$D(SUPRESF(FIELD))
. . . I (ACTION["CLAIM"),(FIELD'=111) D
. . . . D @(FIELD_"GET")
. . . . D @(FIELD_"FMT")
. . . . D @(FIELD_"SET")
. S ^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),491.01,0)="^9002313.0701A^"_RECCNT_"^"_RECCNT
ELSE D
. D DIAGVAL^ABSPECA1
. Q:'$D(ABSP(9002313.0701))
. D APPEND("111C") ;Only two non repeating fields (111, 491)
. S ABSP("X")=$G(ABSP(9002313.0701,0,491,"I"))
. S RECCNT=+$E(ABSP("X"),3,4)
. S RECORD=RECORD_$C(28)_ABSP("X")
. F DIAG=1:1:RECCNT D
. . F FIELD=492,424,493,494,495,496,497,499 D
. . . Q:$D(SUPRESF(FIELD))
. . . S ABSP("X")=$G(ABSP(9002313.0701,DIAG,FIELD,"I"))
. . . S:ABSP("X")'="" RECORD=RECORD_$C(28)_ABSP("X")
Q
;Segment identifier
111CGET S ABSP("X")=13
Q
111CFMT S ABSP("X")=$$ANFF^ABSPECFM(ABSP("X"),2)
Q
111CSET ;This isn't used for the 111 Field
Q
;Diagnosis Code Count
491GET I '$D(SPECIAL(491)) S ABSP("X")=$G(ABSP("RX",MEDN,"DIAG",0,491))
ELSE X SPECIAL(491)
Q
491FMT S:ABSP("X")'="" ABSP("X")="VE"_$$NFF^ABSPECFM(ABSP("X"),1)
Q
491SET D FLD491^ABSPOSSH
Q
;Diagnosis Code Qualifer
492GET I '$D(SPECIAL(492,DIAG)) S ABSP("X")=$G(ABSP("RX",MEDN,"DIAG",DIAG,492))
ELSE X SPECIAL(492,DIAG)
Q
492FMT S:ABSP("X")'="" ABSP("X")="WE"_$$ANFF^ABSPECFM(ABSP("X"),2)
Q
492SET D FLD492^ABSPOSSH
Q
;Diagnosis Code
424GET I '$D(SPECIAL(424,DIAG)) S ABSP("X")=$G(ABSP("RX",MEDN,"DIAG",DIAG,424))
ELSE X SPECIAL(424,DIAG)
Q
424FMT N INSIEN,REMOVE
I ABSP("X")'="",$E(ABSP("X"),$L(ABSP("X")))="." S ABSP("X")=$E(ABSP("X"),1,$L(ABSP("X")-1))
I ($D(SPECIAL(424))#10)=1 X SPECIAL(424) ; /IHS/OIT/RAM ; 28 SEP 17 ;P49-CR09768, ADD OVERALL FORMATTING CODE TO INSURER OVERRIDE SYSTEM.
S INSIEN=+$G(ABSP("Insurer","IEN")),REMOVE=0
S:INSIEN>0 REMOVE=+$P($G(^ABSPEI(INSIEN,"ICD10")),"^",2)
S:REMOVE ABSP("X")=$TR($G(ABSP("X")),".","")
S:ABSP("X")'="" ABSP("X")="DO"_$$ANFF^ABSPECFM($G(ABSP("X")),15)
Q
424SET D FLD424^ABSPOSSH
Q
;Clinical Information Counter
493GET I '$D(SPECIAL(493,DIAG)) S ABSP("X")=$G(ABSP("Clinical",ABSP(9002313.0201),"Information Cntr"))
ELSE X SPECIAL(493,DIAG)
Q
493FMT S:ABSP("X")'="" ABSP("X")="XE"_$$NFF^ABSPECFM(ABSP("X"),2)
Q
493SET S $P(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),490),U,3)=ABSP("X")
Q
;Measurement Date
494GET I '$D(SPECIAL(494,DIAG)) D
. S ABSP("X")=$G(ABSP("RX",MEDN,"DIAG",DIAG,494))
. S:ABSP("X")="" ABSP("X")=$G(ABSP("Clinical","Measurement Date"))
ELSE X SPECIAL(494,DIAG)
Q
494FMT S:ABSP("X")'="" ABSP("X")="ZE"_$$NFF^ABSPECFM(ABSP("X"),8)
Q
494SET ;Not Yet Implemented
Q
;Measurement Time
495GET I '$D(SPECIAL(495,DIAG)) D
. S ABSP("X")=$G(ABSP("RX",MEDN,"DIAG",DIAG,495))
. S:ABSP("X")="" ABSP("X")=$G(ABSP("Clinical","Measurement Time"))
ELSE X SPECIAL(495,DIAG)
Q
495FMT S:ABSP("X")'="" ABSP("X")="H1"_$$NFF^ABSPECFM(ABSP("X"),4)
Q
495SET ;Not Yet Implemented
Q
;Measurement Dimension
496GET I '$D(SPECIAL(496,DIAG)) D
. S ABSP("X")=$G(ABSP("RX",MEDN,"DIAG",DIAG,496))
. S:ABSP("X")="" ABSP("X")=$G(ABSP("Clinical","Measurement Dimension"))
ELSE X SPECIAL(496,DIAG)
Q
496FMT S:ABSP("X")'="" ABSP("X")="H2"_$$ANFF^ABSPECFM(ABSP("X"),2)
Q
496SET ;Not Yet Implemented
Q
;Measurement Unit
497GET I '$D(SPECIAL(497,DIAG)) D
. S ABSP("X")=$G(ABSP("RX",MEDN,"DIAG",DIAG,497))
. S:ABSP("X")="" ABSP("X")=$G(ABSP("Clinical","Measurement Unit"))
ELSE X SPECIAL(497,DIAG)
Q
497FMT S:ABSP("X")'="" ABSP("X")="H3"_$$ANFF^ABSPECFM(ABSP("X"),2)
Q
497SET ;Not Yet Implemented
Q
;Measurement Value
499GET I '$D(SPECIAL(499,DIAG)) D
. S ABSP("X")=$G(ABSP("RX",MEDN,"DIAG",DIAG,499))
. S:ABSP("X")="" ABSP("X")=$G(ABSP("Clinical","Measurement Value"))
ELSE X SPECIAL(499,DIAG)
Q
499FMT S:ABSP("X")'="" ABSP("X")="H4"_$$ANFF^ABSPECFM(ABSP("X"),15)
Q
499SET ;Not Yet Implemented
Q
APPEND(FIELD) ;This is where the record is built field by field
I FIELD["111" D
. D @(FIELD_"GET")
. D @(FIELD_"FMT")
. S RECORD=RECORD_$C(30,28)_"AM"_ABSP("X")
ELSE D
. I $G(ABSP(9002313.0201,IEN(9002313.01),FIELD,"I"))'="" S RECORD=RECORD_$C(28)_$G(ABSP(9002313.0201,IEN(9002313.01),FIELD,"I"))
. ELSE I $D(SPECIAL(FIELD)) D
. . X SPECIAL(FIELD)
. . D @(FIELD_"FMT")
. . S RECORD=RECORD_$C(28)_ABSP("X")
Q
ABSPDB1D ; IHS/OIT/CASSevern/Pieran ran 1/19/2011 - Handling of outgoing NCPDP Billing "B1" Claims for D.0 (DURR,CLINICAL,COMPOUND, and COUPON segments)
+1 ;;1.0;PHARMACY POINT OF SALE;**42,49**;JUN 21, 2001;Build 38
DURRPPS ;EP CALLED FROM ABSPDB1 to set up DURR/PPS SEGMENT
+1 IF $DATA(SUPRESSG("DURR/PPS"))
QUIT
+2 NEW RECCNT,DUR
+3 IF ACTION["CLAIM"
Begin DoDot:1
+4 IF '$DATA(ABSP("RX",MEDN,"DUR"))
QUIT
+5 SET (RECCNT,DUR)=0
+6 FOR
SET DUR=$ORDER(ABSP("RX",MEDN,"DUR",DUR))
IF DUR=""
QUIT
Begin DoDot:2
End DoDot:2
End DoDot:1
+7
*** ERROR ***
+8
*** ERROR ***
+9
*** ERROR ***
+10
*** ERROR ***
+11
*** ERROR ***
+12
*** ERROR ***
+13
*** ERROR ***
+14
*** ERROR ***
+15
*** ERROR ***
+16
*** ERROR ***
+17
*** ERROR ***
+18 IF '$TEST
Begin DoDot:1
+19 DO DURVALUE^ABSPECA1
+20 IF '$DATA(ABSP(9002313.1001))
QUIT
+21 ;Only field on segment that is not repeating
DO APPEND(111)
+22 SET DUR=0
+23 FOR
SET DUR=$ORDER(ABSP(9002313.1001,DUR))
IF DUR=""
QUIT
Begin DoDot:2
+24 FOR FIELD=.01,439,440,441,474,475,476
Begin DoDot:3
+25 IF $DATA(SUPRESF(FIELD))
QUIT
+26 SET ABSP("X")=$GET(ABSP(9002313.1001,DUR,FIELD,"I"))
+27 IF ABSP("X")'=""
SET RECORD=RECORD_$CHAR(28)_ABSP("X")
End DoDot:3
End DoDot:2
End DoDot:1
+28 QUIT
+29 ;Segment identifier
111GET SET ABSP("X")="08"
+1 QUIT
111FMT SET ABSP("X")=$$ANFF^ABSPECFM(ABSP("X"),2)
+1 QUIT
111SET ;This isn't used for the 111 Field
+1 QUIT
+2 ;DUR/PPS Code Counter
473GET IF '$DATA(SPECIAL(473,DUR))
SET ABSP("X")=$GET(ABSP("RX",MEDN,"DUR",DUR,473))
+1 IF '$TEST
XECUTE SPECIAL(473,DUR)
+2 QUIT
473FMT IF ABSP("X")'=""
SET ABSP("X")="7E"_$$ANFF^ABSPECFM($GET(ABSP("X")),1)
+1 QUIT
473SET DO FLD473^ABSPOSSG
+1 QUIT
+2 ;Reason for Service Code
439GET IF '$DATA(SPECIAL(439,DUR))
SET ABSP("X")=$GET(ABSP("RX",MEDN,"DUR",DUR,439))
+1 IF '$TEST
XECUTE SPECIAL(439,DUR)
+2 QUIT
439FMT IF ABSP("X")'=""
SET ABSP("X")="E4"_$$ANFF^ABSPECFM($GET(ABSP("X")),2)
+1 QUIT
439SET DO FLD439^ABSPOSSG
+1 QUIT
+2 ;Professional Service Code
440GET IF '$DATA(SPECIAL(440,DUR))
SET ABSP("X")=$GET(ABSP("RX",MEDN,"DUR",DUR,440))
+1 IF '$TEST
XECUTE SPECIAL(440,DUR)
+2 QUIT
440FMT IF ABSP("X")'=""
SET ABSP("X")="E5"_$$ANFF^ABSPECFM($GET(ABSP("X")),2)
+1 QUIT
440SET DO FLD440^ABSPOSSG
+1 QUIT
+2 ;Result of Service Coce
441GET IF '$DATA(SPECIAL(441,DUR))
SET ABSP("X")=$GET(ABSP("RX",MEDN,"DUR",DUR,441))
+1 IF '$TEST
XECUTE SPECIAL(441,DUR)
+2 QUIT
441FMT IF ABSP("X")'=""
SET ABSP("X")="E6"_$$ANFF^ABSPECFM($GET(ABSP("X")),2)
+1 QUIT
441SET DO FLD441^ABSPOSSG
+1 QUIT
+2 ;DUR/PPS Level of Effort
474GET IF '$DATA(SPECIAL(474,DUR))
SET ABSP("X")=$GET(ABSP("RX",MEDN,"DUR",DUR,474))
+1 IF '$TEST
XECUTE SPECIAL(474,DUR)
+2 QUIT
474FMT IF ABSP("X")'=""
SET ABSP("X")="8E"_$$ANFF^ABSPECFM($GET(ABSP("X")),2)
+1 QUIT
474SET DO FLD474^ABSPOSSG
+1 QUIT
+2 ;DUR Co-Agent ID Qualifier
475GET IF '$DATA(SPECIAL(475,DUR))
SET ABSP("X")=$GET(ABSP("RX",MEDN,"DUR",DUR,475))
+1 IF '$TEST
XECUTE SPECIAL(475,DUR)
+2 QUIT
475FMT IF ABSP("X")'=""
SET ABSP("X")="J9"_$$ANFF^ABSPECFM($GET(ABSP("X")),2)
+1 QUIT
475SET DO FLD475^ABSPOSSG
+1 QUIT
+2 ;DUR CO-Agent ID
476GET IF '$DATA(SPECIAL(476,DUR))
SET ABSP("X")=$GET(ABSP("RX",MEDN,"DUR",DUR,476))
+1 IF '$TEST
XECUTE SPECIAL(476,DUR)
+2 QUIT
476FMT IF ABSP("X")'=""
SET ABSP("X")="H6"_$$ANFF^ABSPECFM($GET(ABSP("X")),19)
+1 QUIT
476SET DO FLD476^ABSPOSSG
+1 QUIT
COUPON ;EP CALLED FROM ABSPDB1 to set up COUPON SEGMENT
+1 IF $DATA(SUPRESSG("Coupon"))
QUIT
+2 NEW FIELD
+3 SET RECORD=$GET(RECORD)
+4 FOR FIELD="111A",485,486,487
Begin DoDot:1
+5 IF $DATA(SUPRESF(FIELD))
QUIT
+6 IF (ACTION["CLAIM")
IF (FIELD'=111)
Begin DoDot:2
+7 DO @(FIELD_"GET")
+8 DO @(FIELD_"FMT")
+9 DO @(FIELD_"SET")
End DoDot:2
+10 IF '$TEST
DO APPEND(FIELD)
End DoDot:1
+11 QUIT
+12 ;Segment identifier
111AGET SET ABSP("X")="09"
+1 QUIT
111AFMT SET ABSP("X")=$$ANFF^ABSPECFM(ABSP("X"),2)
+1 QUIT
111ASET ;This isn't used for the 111 Field
+1 QUIT
+2 ;Coupon Type
485GET IF '$DATA(SPECIAL(485))
SET ABSP("X")=""
+1 IF '$TEST
XECUTE SPECIAL(485)
+2 QUIT
485FMT IF ABSP("X")'=""
SET ABSP("X")="KE"_$$ANFF^ABSPECFM($GET(ABSP("X")),2)
+1 QUIT
485SET ;Not Yet Implemented
+1 QUIT
+2 ;Coupon Number
486GET IF '$DATA(SPECIAL(486))
SET ABSP("X")=""
+1 IF '$TEST
XECUTE SPECIAL(486)
+2 QUIT
486FMT IF ABSP("X")'=""
SET ABSP("X")="ME"_$$ANFF^ABSPECFM($GET(ABSP("X")),15)
+1 QUIT
486SET ;Not Yet Implemented
+1 QUIT
+2 ;Coupon Value Amount
487GET IF '$DATA(SPECIAL(487))
SET ABSP("X")=""
+1 IF '$TEST
XECUTE SPECIAL(487)
+2 QUIT
487FMT IF ABSP("X")'=""
SET ABSP("X")="NE"_$$ANFF^ABSPECFM($GET(ABSP("X")),6)
+1 QUIT
487SET ;Not Yet Implemented
+1 QUIT
COMPOUND ;EP CALLED FROM ABSPDB1 to set up COMPOUND SEGMENT
+1 IF $DATA(SUPRESSG("Compound"))
QUIT
+2 NEW FIELD
+3 SET RECORD=$GET(RECORD)
+4 FOR FIELD="111B",450,451,447,488,489,448,449,490,362,363
Begin DoDot:1
+5 IF $DATA(SUPRESF(FIELD))
QUIT
+6 IF (ACTION["CLAIM")
IF (FIELD'=111)
Begin DoDot:2
+7 DO @(FIELD_"GET")
+8 DO @(FIELD_"FMT")
+9 DO @(FIELD_"SET")
End DoDot:2
+10 IF '$TEST
DO APPEND(FIELD)
End DoDot:1
+11 QUIT
+12 ;Segment identifier
111BGET SET ABSP("X")=10
+1 QUIT
111BFMT SET ABSP("X")=$$ANFF^ABSPECFM(ABSP("X"),2)
+1 QUIT
111BSET ;This isn't used for the 111 Field
+1 QUIT
+2 ;Compound Dosage Form Description Code
450GET IF '$DATA(SPECIAL(450))
SET ABSP("X")=$GET(ABSP("Compound",ABSP(9002313.0201),"Dosage Form Desc"))
+1 IF '$TEST
XECUTE SPECIAL(450)
+2 QUIT
450FMT IF ABSP("X")'=""
SET ABSP("X")="EF"_$$ANFF^ABSPECFM(ABSP("X"),2)
+1 QUIT
450SET SET $PIECE(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),440),U,10)=ABSP("X")
+1 QUIT
+2 ;Compound Dispensing Unit Form Indicator
451GET IF '$DATA(SPECIAL(451))
SET ABSP("X")=$GET(ABSP("Compound",ABSP(9002313.0201),"Disp Unit Form"))
+1 IF '$TEST
XECUTE SPECIAL(451)
+2 QUIT
451FMT IF ABSP("X")'=""
SET ABSP("X")="EG"_$$NFF^ABSPECFM(ABSP("X"),1)
+1 QUIT
451SET SET $PIECE(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),450),U,1)=ABSP("X")
+1 QUIT
+2 ;Compound Ingredient Compound Count
447GET IF '$DATA(SPECIAL(447))
SET ABSP("X")=$GET(ABSP("Compound",ABSP(9002313.0201),"Ingred Component Cnt"))
+1 IF '$TEST
XECUTE SPECIAL(447)
+2 QUIT
447FMT IF ABSP("X")'=""
SET ABSP("X")="EC"_$$NFF^ABSPECFM(ABSP("X"),2)
+1 QUIT
447SET SET $PIECE(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),440),U,7)=ABSP("X")
+1 QUIT
+2 ;Compound Product ID Qualifier
488GET IF '$DATA(SPECIAL(488))
SET ABSP("X")=$GET(ABSP("Compound","Product ID Qualifier"))
+1 IF '$TEST
XECUTE SPECIAL(488)
+2 QUIT
488FMT IF ABSP("X")'=""
SET ABSP("X")="RE"_$$ANFF^ABSPECFM(ABSP("X"),2)
+1 QUIT
488SET ;Not Yet Implemented
+1 QUIT
+2 ;Compound Product ID
489GET IF '$DATA(SPECIAL(489))
SET ABSP("X")=$GET(ABSP("Compound","Product ID"))
+1 IF '$TEST
XECUTE SPECIAL(489)
+2 QUIT
489FMT IF ABSP("X")'=""
SET ABSP("X")="TE"_$$ANFF^ABSPECFM(ABSP("X"),19)
+1 QUIT
489SET ;Not Yet Implemented
+1 QUIT
+2 ;Compound Ingredient Quantity
448GET IF '$DATA(SPECIAL(448))
SET ABSP("X")=$GET(ABSP("Coupound","Ingredient Quantity"))
+1 IF '$TEST
XECUTE SPECIAL(448)
+2 QUIT
448FMT ;Spec Says Length is 7?
IF ABSP("X")'=""
SET ABSP("X")="ED"_$$DFF^ABSPECFM(ABSP("X"),10)
+1 QUIT
448SET ;Not Yet Implemented
+1 QUIT
+2 ;Compound Ingredient Drug Cost
449GET IF '$DATA(SPECIAL(449))
SET ABSP("X")=$GET(ABSP("Compound","Ingredient Drug Cost"))
+1 IF '$TEST
XECUTE SPECIAL(449)
+2 QUIT
449FMT ;Spec says length is 6?
IF ABSP("X")'=""
SET ABSP("X")="EE"_$$DFF^ABSPEFCM(ABSP("X"),8)
+1 QUIT
449SET ;Not Yet Implemented
+1 QUIT
+2 ;Compound Ingredient Basis of Cost Determination
490GET IF '$DATA(SPECIAL(490))
SET ABSP("X")=$GET(ABSP("Compound","Ingred Basis of Cost"))
+1 IF '$TEST
XECUTE SPECIAL(490)
+2 QUIT
490FMT IF ABSP("X")'=""
SET ABSP("X")="UE"_$$ANFF^ABSPECFM(ABSP("X"),2)
+1 QUIT
490SET ;Not Yet Implemented
+1 QUIT
+2 ;Compound Ingredient Modifier Code Count
362GET IF '$DATA(SPECIAL(362))
SET ABSP("X")=""
+1 IF '$TEST
XECUTE SPECIAL(362)
+2 QUIT
362FMT IF ABSP("X")'=""
SET ABSP("X")="2G"_$$ANFF^ABSPECFM($GET(ABSP("X")),2)
+1 QUIT
362SET ;Not Yet Implemented
+1 QUIT
+2 ;Compound Ingredient Modifier Code
363GET IF '$DATA(SPECIAL(363))
SET ABSP("X")=""
+1 IF '$TEST
XECUTE SPECIAL(363)
+2 QUIT
363FMT IF ABSP("X")'=""
SET ABSP("X")="2H"_$$ANFF^ABSPECFM($GET(ABSP("X")),2)
+1 QUIT
363SET ;Not Yet Implemented
+1 QUIT
CLINICAL ;EP CALLED FROM ABSPDB1 to set up CLINICAL SEGMENT
+1 IF $DATA(SUPRESSG("Clinical"))
QUIT
+2 NEW RECCNT,DIAG
+3 IF ACTION["CLAIM"
Begin DoDot:1
+4 IF '$DATA(ABSP("RX",MEDN,"DIAG"))
QUIT
+5 ;Field 491 is only field on this segment that is not repeating do it first
+6 DO 491GET
+7 DO 491FMT
+8 DO 491SET
+9 SET (RECCNT,DIAG)=0
End DoDot:1
+10
*** ERROR ***
+11
*** ERROR ***
+12
*** ERROR ***
+13
*** ERROR ***
+14
*** ERROR ***
+15
*** ERROR ***
+16
*** ERROR ***
+17
*** ERROR ***
+18
*** ERROR ***
+19
*** ERROR ***
+20 IF '$TEST
Begin DoDot:1
+21 DO DIAGVAL^ABSPECA1
+22 IF '$DATA(ABSP(9002313.0701))
QUIT
+23 ;Only two non repeating fields (111, 491)
DO APPEND("111C")
+24 SET ABSP("X")=$GET(ABSP(9002313.0701,0,491,"I"))
+25 SET RECCNT=+$EXTRACT(ABSP("X"),3,4)
+26 SET RECORD=RECORD_$CHAR(28)_ABSP("X")
+27 FOR DIAG=1:1:RECCNT
Begin DoDot:2
+28 FOR FIELD=492,424,493,494,495,496,497,499
Begin DoDot:3
+29 IF $DATA(SUPRESF(FIELD))
QUIT
+30 SET ABSP("X")=$GET(ABSP(9002313.0701,DIAG,FIELD,"I"))
+31 IF ABSP("X")'=""
SET RECORD=RECORD_$CHAR(28)_ABSP("X")
End DoDot:3
End DoDot:2
End DoDot:1
+32 QUIT
+33 ;Segment identifier
111CGET SET ABSP("X")=13
+1 QUIT
111CFMT SET ABSP("X")=$$ANFF^ABSPECFM(ABSP("X"),2)
+1 QUIT
111CSET ;This isn't used for the 111 Field
+1 QUIT
+2 ;Diagnosis Code Count
491GET IF '$DATA(SPECIAL(491))
SET ABSP("X")=$GET(ABSP("RX",MEDN,"DIAG",0,491))
+1 IF '$TEST
XECUTE SPECIAL(491)
+2 QUIT
491FMT IF ABSP("X")'=""
SET ABSP("X")="VE"_$$NFF^ABSPECFM(ABSP("X"),1)
+1 QUIT
491SET DO FLD491^ABSPOSSH
+1 QUIT
+2 ;Diagnosis Code Qualifer
492GET IF '$DATA(SPECIAL(492,DIAG))
SET ABSP("X")=$GET(ABSP("RX",MEDN,"DIAG",DIAG,492))
+1 IF '$TEST
XECUTE SPECIAL(492,DIAG)
+2 QUIT
492FMT IF ABSP("X")'=""
SET ABSP("X")="WE"_$$ANFF^ABSPECFM(ABSP("X"),2)
+1 QUIT
492SET DO FLD492^ABSPOSSH
+1 QUIT
+2 ;Diagnosis Code
424GET IF '$DATA(SPECIAL(424,DIAG))
SET ABSP("X")=$GET(ABSP("RX",MEDN,"DIAG",DIAG,424))
+1 IF '$TEST
XECUTE SPECIAL(424,DIAG)
+2 QUIT
424FMT NEW INSIEN,REMOVE
+1 IF ABSP("X")'=""
IF $EXTRACT(ABSP("X"),$LENGTH(ABSP("X")))="."
SET ABSP("X")=$EXTRACT(ABSP("X"),1,$LENGTH(ABSP("X")-1))
+2 ; /IHS/OIT/RAM ; 28 SEP 17 ;P49-CR09768, ADD OVERALL FORMATTING CODE TO INSURER OVERRIDE SYSTEM.
IF ($DATA(SPECIAL(424))#10)=1
XECUTE SPECIAL(424)
+3 SET INSIEN=+$GET(ABSP("Insurer","IEN"))
SET REMOVE=0
+4 IF INSIEN>0
SET REMOVE=+$PIECE($GET(^ABSPEI(INSIEN,"ICD10")),"^",2)
+5 IF REMOVE
SET ABSP("X")=$TRANSLATE($GET(ABSP("X")),".","")
+6 IF ABSP("X")'=""
SET ABSP("X")="DO"_$$ANFF^ABSPECFM($GET(ABSP("X")),15)
+7 QUIT
424SET DO FLD424^ABSPOSSH
+1 QUIT
+2 ;Clinical Information Counter
493GET IF '$DATA(SPECIAL(493,DIAG))
SET ABSP("X")=$GET(ABSP("Clinical",ABSP(9002313.0201),"Information Cntr"))
+1 IF '$TEST
XECUTE SPECIAL(493,DIAG)
+2 QUIT
493FMT IF ABSP("X")'=""
SET ABSP("X")="XE"_$$NFF^ABSPECFM(ABSP("X"),2)
+1 QUIT
493SET SET $PIECE(^ABSPC(ABSP(9002313.02),400,ABSP(9002313.0201),490),U,3)=ABSP("X")
+1 QUIT
+2 ;Measurement Date
494GET IF '$DATA(SPECIAL(494,DIAG))
Begin DoDot:1
+1 SET ABSP("X")=$GET(ABSP("RX",MEDN,"DIAG",DIAG,494))
+2 IF ABSP("X")=""
SET ABSP("X")=$GET(ABSP("Clinical","Measurement Date"))
End DoDot:1
+3 IF '$TEST
XECUTE SPECIAL(494,DIAG)
+4 QUIT
494FMT IF ABSP("X")'=""
SET ABSP("X")="ZE"_$$NFF^ABSPECFM(ABSP("X"),8)
+1 QUIT
494SET ;Not Yet Implemented
+1 QUIT
+2 ;Measurement Time
495GET IF '$DATA(SPECIAL(495,DIAG))
Begin DoDot:1
+1 SET ABSP("X")=$GET(ABSP("RX",MEDN,"DIAG",DIAG,495))
+2 IF ABSP("X")=""
SET ABSP("X")=$GET(ABSP("Clinical","Measurement Time"))
End DoDot:1
+3 IF '$TEST
XECUTE SPECIAL(495,DIAG)
+4 QUIT
495FMT IF ABSP("X")'=""
SET ABSP("X")="H1"_$$NFF^ABSPECFM(ABSP("X"),4)
+1 QUIT
495SET ;Not Yet Implemented
+1 QUIT
+2 ;Measurement Dimension
496GET IF '$DATA(SPECIAL(496,DIAG))
Begin DoDot:1
+1 SET ABSP("X")=$GET(ABSP("RX",MEDN,"DIAG",DIAG,496))
+2 IF ABSP("X")=""
SET ABSP("X")=$GET(ABSP("Clinical","Measurement Dimension"))
End DoDot:1
+3 IF '$TEST
XECUTE SPECIAL(496,DIAG)
+4 QUIT
496FMT IF ABSP("X")'=""
SET ABSP("X")="H2"_$$ANFF^ABSPECFM(ABSP("X"),2)
+1 QUIT
496SET ;Not Yet Implemented
+1 QUIT
+2 ;Measurement Unit
497GET IF '$DATA(SPECIAL(497,DIAG))
Begin DoDot:1
+1 SET ABSP("X")=$GET(ABSP("RX",MEDN,"DIAG",DIAG,497))
+2 IF ABSP("X")=""
SET ABSP("X")=$GET(ABSP("Clinical","Measurement Unit"))
End DoDot:1
+3 IF '$TEST
XECUTE SPECIAL(497,DIAG)
+4 QUIT
497FMT IF ABSP("X")'=""
SET ABSP("X")="H3"_$$ANFF^ABSPECFM(ABSP("X"),2)
+1 QUIT
497SET ;Not Yet Implemented
+1 QUIT
+2 ;Measurement Value
499GET IF '$DATA(SPECIAL(499,DIAG))
Begin DoDot:1
+1 SET ABSP("X")=$GET(ABSP("RX",MEDN,"DIAG",DIAG,499))
+2 IF ABSP("X")=""
SET ABSP("X")=$GET(ABSP("Clinical","Measurement Value"))
End DoDot:1
+3 IF '$TEST
XECUTE SPECIAL(499,DIAG)
+4 QUIT
499FMT IF ABSP("X")'=""
SET ABSP("X")="H4"_$$ANFF^ABSPECFM(ABSP("X"),15)
+1 QUIT
499SET ;Not Yet Implemented
+1 QUIT
APPEND(FIELD) ;This is where the record is built field by field
+1 IF FIELD["111"
Begin DoDot:1
+2 DO @(FIELD_"GET")
+3 DO @(FIELD_"FMT")
+4 SET RECORD=RECORD_$CHAR(30,28)_"AM"_ABSP("X")
End DoDot:1
+5 IF '$TEST
Begin DoDot:1
+6 IF $GET(ABSP(9002313.0201,IEN(9002313.01),FIELD,"I"))'=""
SET RECORD=RECORD_$CHAR(28)_$GET(ABSP(9002313.0201,IEN(9002313.01),FIELD,"I"))
+7 IF '$TEST
IF $DATA(SPECIAL(FIELD))
Begin DoDot:2
+8 XECUTE SPECIAL(FIELD)
+9 DO @(FIELD_"FMT")
+10 SET RECORD=RECORD_$CHAR(28)_ABSP("X")
End DoDot:2
End DoDot:1
+11 QUIT
