BPSOSSG ;BHAM ISC/SD/lwj/FLS - Special gets for formats ;06/01/2004
;;1.0;E CLAIMS MGMT ENGINE;**1,5,10,11,20,24,28**;JUN 2004;Build 22
;;Per VA Directive 6402, this routine should not be modified.
;
Q
;
FLD420 ; Submission Clarification Code
; place fields 354 and 420 into BPS CLAIMS
; called by SET CODE in BPS NCPDPD FIELD DEFS for field 420
;
Q:'$G(BPS(9002313.0201)) ; must have entry IEN
;
N BPSCNTR,CNT,FDA,MSG,FLDIEN,SCC,I
K BPS(9002313.0354) ; results from UPDATE^DIE
S FLDIEN=$O(^BPSF(9002313.91,"B",420,"")) ;Get IEN for field 420 from NCPDP BPS FIELD DEFS
; Are there overrides?
I $G(FLDIEN),$D(BPS("OVERRIDE","RX",BPS(9002313.0201),FLDIEN)) D
. K BPS("RX",BPS(9002313.0201),"Submission Clarif Code")
. S SCC=BPS("OVERRIDE","RX",BPS(9002313.0201),FLDIEN)
. F I=1:1:3 S BPS("RX",BPS(9002313.0201),"Submission Clarif Code",I)=$P(SCC,"~",I)
Q:'$O(BPS("RX",BPS(9002313.0201),"Submission Clarif Code",0)) ; no values found
S (CNT,BPSCNTR)=0
F S CNT=$O(BPS("RX",BPS(9002313.0201),"Submission Clarif Code",CNT)) Q:'CNT D
.I BPS("RX",BPS(9002313.0201),"Submission Clarif Code",CNT)="" Q
.S BPSCNTR=BPSCNTR+1 ; ien for (#354.01) SUBMISSION CLARIFICATION MLTPL
.S FDA(9002313.02354,"+"_BPSCNTR_","_BPS(9002313.0201)_","_BPS(9002313.02)_",",.01)=BPSCNTR
.; 420-DK Submission Clarification Code
.S FDA(9002313.02354,"+"_BPSCNTR_","_BPS(9002313.0201)_","_BPS(9002313.02)_",",420)="DK"_$$NFF^BPSECFM(BPS("RX",BPS(9002313.0201),"Submission Clarif Code",CNT),2)
;
I BPSCNTR D UPDATE^DIE("","FDA","BPS(9002313.0354)","MSG")
I $D(MSG) D Q ; if error, log it and quit
.D LOG2CLM^BPSOSL(BPS(9002313.02),$T(+0)_"-Failed to update NCPDP field 420")
.D LOGARAY2^BPSOSL(BPS(9002313.02),"MSG")
;
; 354-NX Submission Clarification Code Count
I BPSCNTR S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),350),U,4)="NX"_$$NFF^BPSECFM(BPSCNTR,1)
;
Q
;
FLD439 ;Reason for service code
;Called by SET logic in BPS NCPDP Field DEFS for field 439
;DUR is newed/set in BPSOSHF
S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,2)=BPS("X")
Q
;
FLD440 ;Professional Service Code
;Called by set logic in BPS NCPDP Field DEFS for field 440
;DUR is newed/set in BPSOSHF
S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,3)=BPS("X")
Q
;
FLD441 ;Result of Service Code
;Called by SET logic in BPS NCPDP Field DEFS for field 441
;DUR is newed/set in BPSOSHF
S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,4)=BPS("X")
Q
;
FLD473 ;DUR/PPS code counter - called from SET logic in BPS NCPDP Field Defs
;DUR is newed/set in BPSOSHF
S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,1)=BPS("X")
S ^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,"B",BPS("X"),DUR)=""
S ^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,0)="^9002313.1001A^"_DUR_"^"_DUR
Q
;
FLD474 ;DUR/PPS level of effort - called from set logic in BPS NCPDP Field
;DUR is newed/set in BPSOSHF
S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,5)=BPS("X")
Q
;
FLD475 ;DUR Co-agent ID Qualifier - called from set logic in BPS NCPDP Field
;DUR is newed/set in BPSOSHF
S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,6)=""
Q
;
FLD476 ;DUR Co-agent ID - called from set logic in BPS NCPDP Field
;DUR is newed/set in BPSOSHF
S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,7)=""
Q
;
FLD480 ; Other Amount Claimed Submitted field
; Called by set logic in BPS NCPDP Field DEFS for field 480
; Sets fields 478, 479, and 480 into BPS Claims
; 478-H7 Other Amount Claimed Count
; 479-H8 Other Amount Claimed Submitted Qualifier
; 480-H9 Other Amount Claimed Submitted
;
Q:'$G(BPS(9002313.02)) ; must have BPS Claims IEN
Q:'$G(BPS(9002313.0201)) ; must have Transaction subfile IEN
Q:'$O(BPS("RX",BPS(9002313.0201),"Other Amt Value",0)) ; nothing to do
;
N BPSCNTR,CNT,FDA,MSG
K BPS(9002313.0601) ; results from UPDATE^DIE
S (CNT,BPSCNTR)=0
F S CNT=$O(BPS("RX",BPS(9002313.0201),"Other Amt Value",CNT)) Q:'CNT D
. I +BPS("RX",BPS(9002313.0201),"Other Amt Value",CNT)=0 Q
. S BPSCNTR=BPSCNTR+1 ; ien for "PRICING REPEATING FIELDS SUB-FIELD^^480^3"
. S FDA(9002313.0601,"+"_BPSCNTR_","_BPS(9002313.0201)_","_BPS(9002313.02)_",",.01)=BPSCNTR
. S FDA(9002313.0601,"+"_BPSCNTR_","_BPS(9002313.0201)_","_BPS(9002313.02)_",",479)="H8"_$$ANFF^BPSECFM($G(BPS("RX",BPS(9002313.0201),"Other Amt Qual",CNT)),2)
. S FDA(9002313.0601,"+"_BPSCNTR_","_BPS(9002313.0201)_","_BPS(9002313.02)_",",480)="H9"_$$DFF^BPSECFM($G(BPS("RX",BPS(9002313.0201),"Other Amt Value",CNT)),8)
;
I BPSCNTR D UPDATE^DIE("","FDA","BPS(9002313.0601)","MSG")
I $D(MSG) D Q
. D LOG2CLM^BPSOSL(BPS(9002313.02),$T(+0)_"-Failed to update NCPDP field 480 and/or 479")
. D LOGARAY2^BPSOSL(BPS(9002313.02),"MSG")
; 478-H7 Other Amount Claimed Submitted Count
I BPSCNTR S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),470),U,8)="H7"_$$NFF^BPSECFM(BPSCNTR,1)
;
Q
;
FLDD02 ; Total Prescribed Quantity Remaining field (D02-KW)
; called by SET CODE in BPS NCPDP Field DEFS for field 2202 (D02-KW)
;
I '$G(BPS(9002313.02)) S BPS(9002313.02)=$G(BPS02)
Q:'$G(BPS(9002313.02)) ; must have BPS Claims IEN
Q:'$G(BPS(9002313.0201)) ; must have Transaction subfile IEN
;
N I,PREVFILLS,REFILLS,RTS,RXIEN,TOTALDISP,TOTALQTY,QTY
;
S REFILLS=$G(BPS("RX",BPS(9002313.0201),"# Refills"))
S QTY=$G(BPS("RX",BPS(9002313.0201),"Quantity"))
S TOTALQTY=QTY*(REFILLS+1) ; Total quantity for the prescription
S PREVFILLS=$G(BPS("RX",BPS(9002313.0201),"Refill #"))
;
; Determine if any previous fills were returned to stock.
S RXIEN=$G(BPS("RX",BPS(9002313.0201),"RX IEN"))
S RTS=0
I RXIEN S I=0 D
. F S I=$O(^PSRX(RXIEN,"RTS",I)) Q:'I S RTS=RTS+1
;
; Subtract and return to stock fills (RTS) from the number of previous fills (PREVFILLS).
S TOTALDISP=(PREVFILLS-RTS)*QTY ; Total dispensed for all previous fills
; D02-KW Total Prescribed Quantity Remaining
S BPS("X")=TOTALQTY-TOTALDISP
S $P(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),"D00"),U,2)="KW"_$$NFF^BPSECFM(BPS("X"),10)
Q
;
EMPL ;Get employer info
; This by GET logic in BPS NCPDP Field Defs for field 315 (Employer Name)
; DMB 11/13/2006 - It makes some sense to only set these fields if
; they exist on the payer sheet. However, it assumes that the
; employer name field will always be before the other fields and
; that the other fields will not exist without the Employer Name
; field. For now, leave this be as these fields are on the
; Worker's Comp segment, which we do not do. We may want to evaluate
; if we were to ever add the Worker's Comp segment
Q:'$G(BPS("Patient","IEN"))
D GETS^DIQ(2,BPS("Patient","IEN"),".3111;.3112;.3113;.3115;.3116;.3117;.3118;.3119","","EMPL")
S BPS("Employer","Name")=EMPL(2,BPS("Patient","IEN")_",",.3111)
S:EMPL(2,BPS("Patient","IEN")_",",.3111)=""&(EMPL(2,BPS("Patient","IEN")_",",.3112)'="") BPS("Employer","Name")=EMPL(2,BPS("Patient","IEN")_",",.3112)
S BPS("Employer","Address")=EMPL(2,BPS("Patient","IEN")_",",.3113)
S BPS("Employer","City")=EMPL(2,BPS("Patient","IEN")_",",.3116)
S BPS("Employer","State")=EMPL(2,BPS("Patient","IEN")_",",.3117)
I BPS("Employer","State")'="" D
. S STATEIEN="",STATEIEN=$O(^DIC(5,"B",BPS("Employer","State"),STATEIEN)),BPS("Employer","State")=$P($G(^DIC(5,STATEIEN,0)),"^",2)
S BPS("Employer","Zip Code")=EMPL(2,BPS("Patient","IEN")_",",.3118)
S BPS("Employer","Phone")=EMPL(2,BPS("Patient","IEN")_",",.3119)
K EMPL,STATEIEN
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSOSSG 7686 printed Apr 09, 2024@20:58:30 Page 2
BPSOSSG ;BHAM ISC/SD/lwj/FLS - Special gets for formats ;06/01/2004
+1 ;;1.0;E CLAIMS MGMT ENGINE;**1,5,10,11,20,24,28**;JUN 2004;Build 22
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
FLD420 ; Submission Clarification Code
+1 ; place fields 354 and 420 into BPS CLAIMS
+2 ; called by SET CODE in BPS NCPDPD FIELD DEFS for field 420
+3 ;
+4 ; must have entry IEN
if '$GET(BPS(9002313.0201))
QUIT
+5 ;
+6 NEW BPSCNTR,CNT,FDA,MSG,FLDIEN,SCC,I
+7 ; results from UPDATE^DIE
KILL BPS(9002313.0354)
+8 ;Get IEN for field 420 from NCPDP BPS FIELD DEFS
SET FLDIEN=$ORDER(^BPSF(9002313.91,"B",420,""))
+9 ; Are there overrides?
+10 IF $GET(FLDIEN)
IF $DATA(BPS("OVERRIDE","RX",BPS(9002313.0201),FLDIEN))
Begin DoDot:1
+11 KILL BPS("RX",BPS(9002313.0201),"Submission Clarif Code")
+12 SET SCC=BPS("OVERRIDE","RX",BPS(9002313.0201),FLDIEN)
+13 FOR I=1:1:3
SET BPS("RX",BPS(9002313.0201),"Submission Clarif Code",I)=$PIECE(SCC,"~",I)
End DoDot:1
+14 ; no values found
if '$ORDER(BPS("RX",BPS(9002313.0201),"Submission Clarif Code",0))
QUIT
+15 SET (CNT,BPSCNTR)=0
+16 FOR
SET CNT=$ORDER(BPS("RX",BPS(9002313.0201),"Submission Clarif Code",CNT))
if 'CNT
QUIT
Begin DoDot:1
+17 IF BPS("RX",BPS(9002313.0201),"Submission Clarif Code",CNT)=""
QUIT
+18 ; ien for (#354.01) SUBMISSION CLARIFICATION MLTPL
SET BPSCNTR=BPSCNTR+1
+19 SET FDA(9002313.02354,"+"_BPSCNTR_","_BPS(9002313.0201)_","_BPS(9002313.02)_",",.01)=BPSCNTR
+20 ; 420-DK Submission Clarification Code
+21 SET FDA(9002313.02354,"+"_BPSCNTR_","_BPS(9002313.0201)_","_BPS(9002313.02)_",",420)="DK"_$$NFF^BPSECFM(BPS("RX",BPS(9002313.0201),"Submission Clarif Code",CNT),2)
End DoDot:1
+22 ;
+23 IF BPSCNTR
DO UPDATE^DIE("","FDA","BPS(9002313.0354)","MSG")
+24 ; if error, log it and quit
IF $DATA(MSG)
Begin DoDot:1
+25 DO LOG2CLM^BPSOSL(BPS(9002313.02),$TEXT(+0)_"-Failed to update NCPDP field 420")
+26 DO LOGARAY2^BPSOSL(BPS(9002313.02),"MSG")
End DoDot:1
QUIT
+27 ;
+28 ; 354-NX Submission Clarification Code Count
+29 IF BPSCNTR
SET $PIECE(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),350),U,4)="NX"_$$NFF^BPSECFM(BPSCNTR,1)
+30 ;
+31 QUIT
+32 ;
FLD439 ;Reason for service code
+1 ;Called by SET logic in BPS NCPDP Field DEFS for field 439
+2 ;DUR is newed/set in BPSOSHF
+3 SET $PIECE(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,2)=BPS("X")
+4 QUIT
+5 ;
FLD440 ;Professional Service Code
+1 ;Called by set logic in BPS NCPDP Field DEFS for field 440
+2 ;DUR is newed/set in BPSOSHF
+3 SET $PIECE(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,3)=BPS("X")
+4 QUIT
+5 ;
FLD441 ;Result of Service Code
+1 ;Called by SET logic in BPS NCPDP Field DEFS for field 441
+2 ;DUR is newed/set in BPSOSHF
+3 SET $PIECE(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,4)=BPS("X")
+4 QUIT
+5 ;
FLD473 ;DUR/PPS code counter - called from SET logic in BPS NCPDP Field Defs
+1 ;DUR is newed/set in BPSOSHF
+2 SET $PIECE(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,1)=BPS("X")
+3 SET ^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,"B",BPS("X"),DUR)=""
+4 SET ^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,0)="^9002313.1001A^"_DUR_"^"_DUR
+5 QUIT
+6 ;
FLD474 ;DUR/PPS level of effort - called from set logic in BPS NCPDP Field
+1 ;DUR is newed/set in BPSOSHF
+2 SET $PIECE(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,5)=BPS("X")
+3 QUIT
+4 ;
FLD475 ;DUR Co-agent ID Qualifier - called from set logic in BPS NCPDP Field
+1 ;DUR is newed/set in BPSOSHF
+2 SET $PIECE(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,6)=""
+3 QUIT
+4 ;
FLD476 ;DUR Co-agent ID - called from set logic in BPS NCPDP Field
+1 ;DUR is newed/set in BPSOSHF
+2 SET $PIECE(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),473.01,DUR,0),U,7)=""
+3 QUIT
+4 ;
FLD480 ; Other Amount Claimed Submitted field
+1 ; Called by set logic in BPS NCPDP Field DEFS for field 480
+2 ; Sets fields 478, 479, and 480 into BPS Claims
+3 ; 478-H7 Other Amount Claimed Count
+4 ; 479-H8 Other Amount Claimed Submitted Qualifier
+5 ; 480-H9 Other Amount Claimed Submitted
+6 ;
+7 ; must have BPS Claims IEN
if '$GET(BPS(9002313.02))
QUIT
+8 ; must have Transaction subfile IEN
if '$GET(BPS(9002313.0201))
QUIT
+9 ; nothing to do
if '$ORDER(BPS("RX",BPS(9002313.0201),"Other Amt Value",0))
QUIT
+10 ;
+11 NEW BPSCNTR,CNT,FDA,MSG
+12 ; results from UPDATE^DIE
KILL BPS(9002313.0601)
+13 SET (CNT,BPSCNTR)=0
+14 FOR
SET CNT=$ORDER(BPS("RX",BPS(9002313.0201),"Other Amt Value",CNT))
if 'CNT
QUIT
Begin DoDot:1
+15 IF +BPS("RX",BPS(9002313.0201),"Other Amt Value",CNT)=0
QUIT
+16 ; ien for "PRICING REPEATING FIELDS SUB-FIELD^^480^3"
SET BPSCNTR=BPSCNTR+1
+17 SET FDA(9002313.0601,"+"_BPSCNTR_","_BPS(9002313.0201)_","_BPS(9002313.02)_",",.01)=BPSCNTR
+18 SET FDA(9002313.0601,"+"_BPSCNTR_","_BPS(9002313.0201)_","_BPS(9002313.02)_",",479)="H8"_$$ANFF^BPSECFM($GET(BPS("RX",BPS(9002313.0201),"Other Amt Qual",CNT)),2)
+19 SET FDA(9002313.0601,"+"_BPSCNTR_","_BPS(9002313.0201)_","_BPS(9002313.02)_",",480)="H9"_$$DFF^BPSECFM($GET(BPS("RX",BPS(9002313.0201),"Other Amt Value",CNT)),8)
End DoDot:1
+20 ;
+21 IF BPSCNTR
DO UPDATE^DIE("","FDA","BPS(9002313.0601)","MSG")
+22 IF $DATA(MSG)
Begin DoDot:1
+23 DO LOG2CLM^BPSOSL(BPS(9002313.02),$TEXT(+0)_"-Failed to update NCPDP field 480 and/or 479")
+24 DO LOGARAY2^BPSOSL(BPS(9002313.02),"MSG")
End DoDot:1
QUIT
+25 ; 478-H7 Other Amount Claimed Submitted Count
+26 IF BPSCNTR
SET $PIECE(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),470),U,8)="H7"_$$NFF^BPSECFM(BPSCNTR,1)
+27 ;
+28 QUIT
+29 ;
FLDD02 ; Total Prescribed Quantity Remaining field (D02-KW)
+1 ; called by SET CODE in BPS NCPDP Field DEFS for field 2202 (D02-KW)
+2 ;
+3 IF '$GET(BPS(9002313.02))
SET BPS(9002313.02)=$GET(BPS02)
+4 ; must have BPS Claims IEN
if '$GET(BPS(9002313.02))
QUIT
+5 ; must have Transaction subfile IEN
if '$GET(BPS(9002313.0201))
QUIT
+6 ;
+7 NEW I,PREVFILLS,REFILLS,RTS,RXIEN,TOTALDISP,TOTALQTY,QTY
+8 ;
+9 SET REFILLS=$GET(BPS("RX",BPS(9002313.0201),"# Refills"))
+10 SET QTY=$GET(BPS("RX",BPS(9002313.0201),"Quantity"))
+11 ; Total quantity for the prescription
SET TOTALQTY=QTY*(REFILLS+1)
+12 SET PREVFILLS=$GET(BPS("RX",BPS(9002313.0201),"Refill #"))
+13 ;
+14 ; Determine if any previous fills were returned to stock.
+15 SET RXIEN=$GET(BPS("RX",BPS(9002313.0201),"RX IEN"))
+16 SET RTS=0
+17 IF RXIEN
SET I=0
Begin DoDot:1
+18 FOR
SET I=$ORDER(^PSRX(RXIEN,"RTS",I))
if 'I
QUIT
SET RTS=RTS+1
End DoDot:1
+19 ;
+20 ; Subtract and return to stock fills (RTS) from the number of previous fills (PREVFILLS).
+21 ; Total dispensed for all previous fills
SET TOTALDISP=(PREVFILLS-RTS)*QTY
+22 ; D02-KW Total Prescribed Quantity Remaining
+23 SET BPS("X")=TOTALQTY-TOTALDISP
+24 SET $PIECE(^BPSC(BPS(9002313.02),400,BPS(9002313.0201),"D00"),U,2)="KW"_$$NFF^BPSECFM(BPS("X"),10)
+25 QUIT
+26 ;
EMPL ;Get employer info
+1 ; This by GET logic in BPS NCPDP Field Defs for field 315 (Employer Name)
+2 ; DMB 11/13/2006 - It makes some sense to only set these fields if
+3 ; they exist on the payer sheet. However, it assumes that the
+4 ; employer name field will always be before the other fields and
+5 ; that the other fields will not exist without the Employer Name
+6 ; field. For now, leave this be as these fields are on the
+7 ; Worker's Comp segment, which we do not do. We may want to evaluate
+8 ; if we were to ever add the Worker's Comp segment
+9 if '$GET(BPS("Patient","IEN"))
QUIT
+10 DO GETS^DIQ(2,BPS("Patient","IEN"),".3111;.3112;.3113;.3115;.3116;.3117;.3118;.3119","","EMPL")
+11 SET BPS("Employer","Name")=EMPL(2,BPS("Patient","IEN")_",",.3111)
+12 if EMPL(2,BPS("Patient","IEN")_",",.3111)=""&(EMPL(2,BPS("Patient","IEN")_",",.3112)'="")
SET BPS("Employer","Name")=EMPL(2,BPS("Patient","IEN")_",",.3112)
+13 SET BPS("Employer","Address")=EMPL(2,BPS("Patient","IEN")_",",.3113)
+14 SET BPS("Employer","City")=EMPL(2,BPS("Patient","IEN")_",",.3116)
+15 SET BPS("Employer","State")=EMPL(2,BPS("Patient","IEN")_",",.3117)
+16 IF BPS("Employer","State")'=""
Begin DoDot:1
+17 SET STATEIEN=""
SET STATEIEN=$ORDER(^DIC(5,"B",BPS("Employer","State"),STATEIEN))
SET BPS("Employer","State")=$PIECE($GET(^DIC(5,STATEIEN,0)),"^",2)
End DoDot:1
+18 SET BPS("Employer","Zip Code")=EMPL(2,BPS("Patient","IEN")_",",.3118)
+19 SET BPS("Employer","Phone")=EMPL(2,BPS("Patient","IEN")_",",.3119)
+20 KILL EMPL,STATEIEN
+21 QUIT
+22 ;
