BPSOSCD ;BHAM ISC/FCS/DRS/DLF - Set BPS() "RX" nodes for current medication ;06/01/2004
;;1.0;E CLAIMS MGMT ENGINE;**1,3,2,5,7,8,10,11,15,19,20,23,24,27**;JUN 2004;Build 15
;;Per VA Directive 6402, this routine should not be modified.
;
; reference to $$ACPHONE^IBNCPDPI supported by DBIA 4721
; reference to $$MADD^XUAF4 supported by DBIA 2171
; reference to $$GET1^DIQ(200,field) supported by DBIA 10060
; reference to $$GET1^DIQ(5,field) supported by DBIA 10056
; reference to PSS^PSO59 supported by DBIA 4827
; reference to $$SITE^VASITE supported by DBIA 10112
;
Q
;
;MEDINFO, Set BPS("RX)" nodes for current medication
; Called from BPSOSCA for every transaction in the multiple
; IEN59 = IEN in BPS TRANSACTION (#9002313.59)
; IEN5902 = IEN for Insurance multiple of BPS Transactions
; MEDN = Index number of medication being processed
; BPS array shared by all of the BPSOSC* routines, created in BPSOSCA
; VAINFO created in BPSOSCB
MEDINFO(IEN59,IEN5902,MEDN) ;
; Verify Parameters
I $G(IEN59)="" Q
I $G(IEN5902)="" Q
I $G(MEDN)="" Q
;
N %,BPS0,DRUGIEN,IENS,J,NDC,NPI,OSITEIEN,PRICING,PROVIEN,RTN,RXI,RXIEN,RXRFIEN,VANATURE,VAOIEN,X,ADFEE
;
;RXIEN=Rx IEN, RXRFIEN=Fill Number, IENS=FileMan style IENS
S BPS0=$G(^BPST(IEN59,1)),RXIEN=$P(BPS0,U,11),RXRFIEN=$P(BPS0,U,1),IENS=IEN5902_","_IEN59_","
;
S RTN=$T(+0) ; for log
; Get any user-entered overrides stored in BPS NCPDP OVERRIDES
D OVERRIDE(IEN59,MEDN)
;
; Retrieve DUR values
D DURVALUE(IEN59,MEDN)
;
; Build COB array for secondary claims
I $$COB59^BPSUTIL2(IEN59)>1 D COB(IEN59,MEDN)
;
; Basic RX info
S BPS("RX",MEDN,"IEN59")=IEN59
S BPS("RX",MEDN,"RX IEN")=RXIEN
S BPS("RX",MEDN,"RX Number")=RXIEN
;
; Stop if the transaction code is "E1" and there is no Prescription IEN
I BPS("Transaction Code")="E1",RXIEN="" Q
;
; Get Provider Info
S PROVIEN=+$$RXAPI1^BPSUTIL1(RXIEN,4,"I")
S BPS("RX",MEDN,"Prescriber IEN")=PROVIEN
I PROVIEN'="" D
.S X=$$GET1^DIQ(200,PROVIEN,.01)
.D NAMECOMP^XLFNAME(.X)
.S BPS("RX",MEDN,"Prescriber Last Name")=X("FAMILY")
.S BPS("RX",MEDN,"Prescriber First Name")=X("GIVEN") ; NCPDP field 364-2J
.S BPS("RX",MEDN,"Prescriber Middle Name")=X("MIDDLE") ; NCPDP field E12-0F
.S BPS("RX",MEDN,"Prescriber Phone #")=$$ACPHONE^IBNCPDPI ; DBIA 4721, Agent Cashier Phone Number
.S BPS("RX",MEDN,"Prescriber Billing Location")=""
.S NPI=$$NPI^BPSNPI("Individual_ID",+PROVIEN)
.I NPI<0 S NPI=""
.S BPS("RX",MEDN,"Prescriber NPI")=$P(NPI,U)
.S BPS("RX",MEDN,"Primary Care Provider NPI")=$P(NPI,U)
.S BPS("RX",MEDN,"Provider NPI")=$P(NPI,U)
.;
.S BPS("RX",MEDN,"Prescriber DEA")=$$GET1^DIQ(200,PROVIEN,53.2) ; NCPDP field D01-KV
.S X=$$PRVADRS(IEN59,PROVIEN) ; provide address info
.S BPS("RX",MEDN,"Prescriber Street Address")=$P(X,U)_$S($P(X,U,5)]"":" ",1:"")_$P(X,U,5) ; NCPDP field 365-2K
.S BPS("RX",MEDN,"Prescriber Street Address Line 1")=$P(X,U) ; NCPDP field B27-7U
.S BPS("RX",MEDN,"Prescriber Street Address Line 2")=$P(X,U,5) ; NCPDP field B28-8U
.S BPS("RX",MEDN,"Prescriber City Address")=$P(X,U,2) ; NCPDP field 366-2M
.S BPS("RX",MEDN,"Prescriber State/Province Address")=$P(X,U,3) ; NCPDP field 367-2N
.S BPS("RX",MEDN,"Prescriber Zip/Postal Zone")=$TR($P(X,U,4)," -") ; NCPDP field 368-2P
.S BPS("RX",MEDN,"Prescriber Country")=$$COUNTRY($P(X,U,3),$P(X,U,6)) ;NCPDP field B42-3C
;
; Stop if Eligibility as we do not need any of the claim data below
I BPS("Transaction Code")="E1" Q
;
; Basic Prescription Info
S BPS("RX",MEDN,"Date Written")=$$RXAPI1^BPSUTIL1(RXIEN,1,"I")
; SLT - BPS*1.0*11
; if the RX Issue Date is in the future, set it to the current date
I BPS("RX",MEDN,"Date Written")>DT S BPS("RX",MEDN,"Date Written")=DT
S BPS("RX",MEDN,"New/Refill")=$S(RXRFIEN="":"N",1:"R")
S BPS("RX",MEDN,"# Refills")=$$RXAPI1^BPSUTIL1(RXIEN,9,"I")
S BPS("RX",MEDN,"Refill #")=+RXRFIEN
S BPS("RX",MEDN,"Pharmacy Service Type")="01" ; 147-U7 Pharmacy Service Type, 1=Community/Retail Pharmacy Services
;
; PreAuth and Prior Authorization
; #1.09 Prior Authorization Number, #1.15 Prior Auth Type Code
S X=$G(^BPST(IEN59,1))
S BPS("RX",MEDN,"Preauth #")=$P(X,U,15)_$P(X,U,9)
S BPS("Claim",MEDN,"Prior Auth Type")=$P(X,U,15)
S BPS("Claim",MEDN,"Prior Auth Num Sub")=$P(X,U,9)
;
; delay reason code not sent unless user specifies a code
S BPS("Claim",MEDN,"Delay Reason Code")="" ; 357-NV Delay Reason Code
;
; Calculate date/time for Time of Service 678-Y6 - BPS*1*15
; using SUBMIT REQUEST DATE TIME field #17 from earliest transmission log entry
N FDTIME,IEN57 S IEN57=$O(^BPSTL("B",IEN59,0)) I IEN57 S FDTIME=$P($G(^BPSTL(IEN57,0)),U,13)
; Otherwise use current time
I $G(FDTIME)="" S FDTIME=$$NOW^XLFDT
; Save time as HHMMSS
S BPS("Claim",MEDN,"Time of Service")=$$LJ^XLFSTR($P(FDTIME,".",2),6,0) ; 678-Y6 Time of Service
;
; NDC = NDC number drug, try transaction 1st, if null get it from Rx/refill
S BPS("RX",MEDN,"Product ID Qualifier")="03"
S NDC=$P(^BPST(IEN59,1),U,2)
I NDC="" S NDC=$$GETNDC^PSONDCUT(RXIEN,RXRFIEN) D LOG^BPSOSL(IEN59,RTN_"-NDC sent as "_NDC)
S BPS("RX",MEDN,"NDC")=NDC
;
; Prescription Data dependent on original vs. refill
D:'RXRFIEN ; 1st fill
.S BPS("RX",MEDN,"Days Supply")=$$RXAPI1^BPSUTIL1(RXIEN,8,"I")
.S BPS("RX",MEDN,"DAW")=$$RXAPI1^BPSUTIL1(RXIEN,81,"I")
.;Use FINISHING PERSON field as pharmacist identifier for Initials and ID - BPS*1*15 - DBIA 10112 for $$SITE
.S BPS("Provider",MEDN,"Pharmacist Initials")=$$GET1^DIQ(200,+$$RXAPI1^BPSUTIL1(RXIEN,38,"I"),1)
.S BPS("Provider",MEDN,"Pharmacist ID")=$P($$SITE^VASITE,U,3)_$$RJ^XLFSTR(+$$RXAPI1^BPSUTIL1(RXIEN,38,"I"),15,0)
D:RXRFIEN ; refill
.S BPS("RX",MEDN,"Days Supply")=$$RXSUBF1^BPSUTIL1(RXIEN,52,52.1,RXRFIEN,1.1,"I")
.S BPS("RX",MEDN,"DAW")=$$RXSUBF1^BPSUTIL1(RXIEN,52,52.1,RXRFIEN,81,"I")
.;Use FILLING PERSON field as pharmacist identifier for Initials and ID - BPS*1*15 - DBIA 10112 for $$SITE
.S BPS("Provider",MEDN,"Pharmacist Initials")=$$GET1^DIQ(200,+$$RXSUBF1^BPSUTIL1(RXIEN,52,52.1,RXRFIEN,19,"I"),1)
.S BPS("Provider",MEDN,"Pharmacist ID")=$P($$SITE^VASITE,U,3)_$$RJ^XLFSTR(+$$RXSUBF1^BPSUTIL1(RXIEN,52,52.1,RXRFIEN,19,"I"),15,0)
;
; Origin Code, VAOIEN=PLACER ORDER # from file 52, VANATURE=NATURE OF ORDER in sub-file 100.008
S VAOIEN=+$$RXAPI1^BPSUTIL1(RXIEN,39.3,"I"),VANATURE=$$GET1^DIQ(100.008,"1,"_VAOIEN_",","12")
S BPS("RX",MEDN,"Origin Code")=$S(VANATURE="AUTO":2,VANATURE["ELECTRONIC":3,VANATURE="DUPLICATE":0,VANATURE["TELEPHONE":2,1:1)
;
; NCPDP field 420-DK Submission Clarification Code, default to "01" for vD.0
; note: this is a multiple (#9002313.02354), additional codes may be added by other routines
S %=$P($G(^BPST(IEN59,12)),U,3),BPS("RX",MEDN,"Submission Clarif Code",1)=$S(%]"":%,1:"01")
;
; Drug Info
S DRUGIEN=$$RXAPI1^BPSUTIL1(RXIEN,6,"I")
D:DRUGIEN'=""
.S BPS("RX",MEDN,"Drug IEN")=DRUGIEN
.S BPS("RX",MEDN,"Drug Name")=$$DRUGDIE^BPSUTIL1(DRUGIEN,.01,"E")
;
; Pricing Info
S PRICING=$G(^BPST(IEN59,5))
S BPS("RX",MEDN,"Quantity")=$P(PRICING,U)
S BPS("RX",MEDN,"Unit Price")=$P(PRICING,U,2)
S BPS("RX",MEDN,"Unit of Measure")=$P(PRICING,U,8)
S BPS("RX",MEDN,"Basis of Cost Determination")=$G(VAINFO(9002313.59902,IENS,902.13,"I"))
S BPS("RX",MEDN,"Usual & Customary")=$G(VAINFO(9002313.59902,IENS,902.14,"I"))
S BPS("RX",MEDN,"Gross Amount Due")=$G(VAINFO(9002313.59902,IENS,902.15,"I"))
S BPS("RX",MEDN,"Ingredient Cost")=$G(VAINFO(9002313.59902,IENS,902.2,"I"))
S BPS("RX",MEDN,"Dispensing Fee")=$G(VAINFO(9002313.59902,IENS,902.12,"I"))
S ADFEE=+$G(VAINFO(9002313.59902,IENS,902.16,"I"))
I ADFEE'=0 D
. S BPS("RX",MEDN,"Other Amt Qual",1)="04"
. S BPS("RX",MEDN,"Other Amt Value",1)=ADFEE
;
Q
;
; OVERRIDE - Retrieve OVERRIDE nodes and put into BPS array
; They will be fetched from BPS("OVERRIDE"
; during low-level construction of the actual encoded claim packet.
; BPS("OVERRIDE",field)=value for fields 101-401
; BPS("OVERRIDE","RX",MEDN,field) for med #N, fields 402+
; Note that if you have multiple transactions bundled, the
; union of overrides from 101-401 apply to all; and if there's a
; conflict, the last one overwrites the previous ones.
OVERRIDE(IEN59,MEDN) ;
N IEN511,RETVAL
S IEN511=$P(^BPST(IEN59,1),U,13) Q:'IEN511
S RETVAL=$$GET511^BPSOSO2(IEN511,"BPS(""OVERRIDE"")","BPS(""OVERRIDE"",""RX"","_MEDN_")")
Q
;
; DURVALUE - Will read in the DUR data from the DUR multiple
; in BPS Transactions and store the values into BPS("RX",MEDN,DUR,....)
; NOTE - unlike most values, these fields are stored by their
; field number. Since they are repeating, it will ease the
; retrieval of them, when we populate the claim.
DURVALUE(IEN59,MEDN) ;
N DUR,DCNT,DURREC
;
S (DUR,DCNT)=0
F S DCNT=$O(^BPST(IEN59,13,DCNT)) Q:'DCNT D
.S DURREC=$G(^BPST(IEN59,13,DCNT,0))
.I DURREC="" Q
.S DUR=DUR+1
.S BPS("RX",MEDN,"DUR",DUR,473)=DUR ;473-7E DUR/PPS Code Counter
.S BPS("RX",MEDN,"DUR",DUR,439)=$P(DURREC,U,3) ;439-E4 Reason For Service Code
.S BPS("RX",MEDN,"DUR",DUR,440)=$P(DURREC,U,2) ;440-E5 Professional Service Code
.S BPS("RX",MEDN,"DUR",DUR,441)=$P(DURREC,U,4) ;441-E6 Result of Service Code
.S BPS("RX",MEDN,"DUR",DUR,474)="" ;474-8E DUR/PPS Level Of Effort
.Q:$G(BPS("NCPDP","Version"))'=51 ; fields 475&476 not used in vD.0
.S BPS("RX",MEDN,"DUR",DUR,475)="" ;475-J9 DUR Co-Agent ID Qualifier
.S BPS("RX",MEDN,"DUR",DUR,476)="" ;476-H6 DUR Co-Agent ID
;
Q
;
COB(IEN59,MEDN) ; process the COB fields and build the COB array
; Code for Benefit Stages multiple not implemented yet (except by
; certification)
;
; build array of COB secondary claim data from the BPS Transaction file - esg - 6/16/10
N COBPIEN,APDIEN,REJIEN,DATA
K BPS("RX",MEDN,"OTHER PAYER")
;
; Field 337-4C COB OTHER PAYMENTS COUNT (9002313.59,1204) moved into [1] below
S BPS("RX",MEDN,"OTHER PAYER",0)=$P($G(^BPST(IEN59,12)),U,4)
;
S COBPIEN=0 F S COBPIEN=$O(^BPST(IEN59,14,COBPIEN)) Q:'COBPIEN D
. ; Note that this will set pieces 1-7 and 11. Piece 9 is reserved for
. ; Benefit Stage Count and is set by the certification code
. S BPS("RX",MEDN,"OTHER PAYER",COBPIEN,0)=$G(^BPST(IEN59,14,COBPIEN,0))
. ;
. ; retrieve data from other payer amount paid multiple
. S APDIEN=0 F S APDIEN=$O(^BPST(IEN59,14,COBPIEN,1,APDIEN)) Q:'APDIEN D
.. S DATA=$G(^BPST(IEN59,14,COBPIEN,1,APDIEN,0))
.. S BPS("RX",MEDN,"OTHER PAYER",COBPIEN,"P",APDIEN,0)=$P(DATA,"^",1)_"^"_$$GET1^DIQ(9002313.2,$P(DATA,"^",2),.01)
.. S BPS("RX",MEDN,"OTHER PAYER",COBPIEN,"PP",APDIEN,0)=$P(DATA,"^",3)
.. I +$P(DATA,"^",3) S $P(BPS("RX",MEDN,"OTHER PAYER",COBPIEN,"PP",APDIEN,0),"^",2)="06"
.. Q
. ;
. ; retrieve data from other payer reject multiple
. S REJIEN=0 F S REJIEN=$O(^BPST(IEN59,14,COBPIEN,2,REJIEN)) Q:'REJIEN D
.. S BPS("RX",MEDN,"OTHER PAYER",COBPIEN,"R",REJIEN,0)=$G(^BPST(IEN59,14,COBPIEN,2,REJIEN,0))
Q
;
PRVADRS(IEN59,PRVIEN) ; site address for a provider
; returns "street address^city^st^zip"
; IEN59=BPS TRANSACTION (#9002313.59) ien
; PRVIEN=provider IEN in NEW PERSON file (#200)
;
I '$G(IEN59) Q ""
I '$G(PRVIEN) Q ""
;
N BPSND,F,IPTR,IEN,OPSITE,PRVADDR,PRVNVA,RSLT,AD2
S RSLT=""
;
S PRVNVA=+$$GET1^DIQ(200,PRVIEN_",",53.91,"I") ; NON-VA PRESCRIBER
;
; if false, it's a VA prescriber - address data found in file 4 for the VA pharmacy
I 'PRVNVA D G PRVADX
.S OPSITE=$P($G(^BPST(IEN59,1)),U,4) ; OUTPATIENT SITE ptr
.Q:'OPSITE
.S BPSND="BPS59" K ^TMP($J,BPSND)
.D PSS^PSO59(OPSITE,"",BPSND)
.S IPTR=$P($G(^TMP($J,BPSND,OPSITE,101)),U) ; INSTITUTION ptr
.S:IPTR RSLT=$$MADD^XUAF4(IPTR)_U_$$GET1^DIQ(4,IPTR_",",4.02)_U_$$GET1^DIQ(4,IPTR_",",4.04,"I")
.K ^TMP($J,BPSND)
;
; Non-VA prescriber - address data found in file 200
F F=.111,.112,.113,.114,.115,.116 S PRVADDR(F)=$$GET1^DIQ(200,PRVIEN_",",F)
; Get State info
S PRVADDR(.115,"ABBR")="",IEN=$$GET1^DIQ(200,PRVIEN_",",.115,"I"),PRVADDR(.115,"ABBR")=$$GET1^DIQ(5,+IEN_",",1)
; Build Address Line 2
S AD2=PRVADDR(.112) I PRVADDR(.113)]"" S AD2=AD2_$S(AD2]"":" ",1:"")_PRVADDR(.113)
; Build result string
S RSLT=PRVADDR(.111)_U_PRVADDR(.114)_U_PRVADDR(.115,"ABBR")_U_PRVADDR(.116)_U_AD2_U_IEN
;
PRVADX ;
Q RSLT
;
COUNTRY(STATE,IEN) ;
; Convert STATE abbreviation into a ISO-3166-1 country code
; Input:
; STATE: State Abbreviation
; Output: ISO-3166-1 Country Code
;
I $G(STATE)="" Q ""
I '$G(IEN) Q ""
I ",BC,MB,NB,NF,NS,NT,ON,PE,QC,SK,YT,CANAD,NU,"[(","_STATE_",") Q "CA" ; Canada
I STATE="FG"!(STATE="EU")!(STATE="UN") Q "" ; Foreign Country, Europe, Unknown
I STATE="AS" Q "AS" ; American Samoa
I STATE="FM" Q "FM" ; Federated States of Micronesia
I STATE="GU" Q "GU" ; Guam
I STATE="MH" Q "MH" ; Marshall Islands
I STATE="MP" Q "MP" ; Northern Mariana Islands
I STATE="MX" Q "MX" ; Mexico
I STATE="PH" Q "PH" ; Philippines
I STATE="PR" Q "PR" ; Puerto Rico
I STATE="PW" Q "PW" ; Palau
I STATE="VI" Q "VI" ; Virgin Islands
I $$GET1^DIQ(5,IEN_",",2.2,"I")=1 Q "US"
Q ""
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSOSCD 13287 printed Sep 23, 2025@19:27:49 Page 2
BPSOSCD ;BHAM ISC/FCS/DRS/DLF - Set BPS() "RX" nodes for current medication ;06/01/2004
+1 ;;1.0;E CLAIMS MGMT ENGINE;**1,3,2,5,7,8,10,11,15,19,20,23,24,27**;JUN 2004;Build 15
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; reference to $$ACPHONE^IBNCPDPI supported by DBIA 4721
+5 ; reference to $$MADD^XUAF4 supported by DBIA 2171
+6 ; reference to $$GET1^DIQ(200,field) supported by DBIA 10060
+7 ; reference to $$GET1^DIQ(5,field) supported by DBIA 10056
+8 ; reference to PSS^PSO59 supported by DBIA 4827
+9 ; reference to $$SITE^VASITE supported by DBIA 10112
+10 ;
+11 QUIT
+12 ;
+13 ;MEDINFO, Set BPS("RX)" nodes for current medication
+14 ; Called from BPSOSCA for every transaction in the multiple
+15 ; IEN59 = IEN in BPS TRANSACTION (#9002313.59)
+16 ; IEN5902 = IEN for Insurance multiple of BPS Transactions
+17 ; MEDN = Index number of medication being processed
+18 ; BPS array shared by all of the BPSOSC* routines, created in BPSOSCA
+19 ; VAINFO created in BPSOSCB
MEDINFO(IEN59,IEN5902,MEDN) ;
+1 ; Verify Parameters
+2 IF $GET(IEN59)=""
QUIT
+3 IF $GET(IEN5902)=""
QUIT
+4 IF $GET(MEDN)=""
QUIT
+5 ;
+6 NEW %,BPS0,DRUGIEN,IENS,J,NDC,NPI,OSITEIEN,PRICING,PROVIEN,RTN,RXI,RXIEN,RXRFIEN,VANATURE,VAOIEN,X,ADFEE
+7 ;
+8 ;RXIEN=Rx IEN, RXRFIEN=Fill Number, IENS=FileMan style IENS
+9 SET BPS0=$GET(^BPST(IEN59,1))
SET RXIEN=$PIECE(BPS0,U,11)
SET RXRFIEN=$PIECE(BPS0,U,1)
SET IENS=IEN5902_","_IEN59_","
+10 ;
+11 ; for log
SET RTN=$TEXT(+0)
+12 ; Get any user-entered overrides stored in BPS NCPDP OVERRIDES
+13 DO OVERRIDE(IEN59,MEDN)
+14 ;
+15 ; Retrieve DUR values
+16 DO DURVALUE(IEN59,MEDN)
+17 ;
+18 ; Build COB array for secondary claims
+19 IF $$COB59^BPSUTIL2(IEN59)>1
DO COB(IEN59,MEDN)
+20 ;
+21 ; Basic RX info
+22 SET BPS("RX",MEDN,"IEN59")=IEN59
+23 SET BPS("RX",MEDN,"RX IEN")=RXIEN
+24 SET BPS("RX",MEDN,"RX Number")=RXIEN
+25 ;
+26 ; Stop if the transaction code is "E1" and there is no Prescription IEN
+27 IF BPS("Transaction Code")="E1"
IF RXIEN=""
QUIT
+28 ;
+29 ; Get Provider Info
+30 SET PROVIEN=+$$RXAPI1^BPSUTIL1(RXIEN,4,"I")
+31 SET BPS("RX",MEDN,"Prescriber IEN")=PROVIEN
+32 IF PROVIEN'=""
Begin DoDot:1
+33 SET X=$$GET1^DIQ(200,PROVIEN,.01)
+34 DO NAMECOMP^XLFNAME(.X)
+35 SET BPS("RX",MEDN,"Prescriber Last Name")=X("FAMILY")
+36 ; NCPDP field 364-2J
SET BPS("RX",MEDN,"Prescriber First Name")=X("GIVEN")
+37 ; NCPDP field E12-0F
SET BPS("RX",MEDN,"Prescriber Middle Name")=X("MIDDLE")
+38 ; DBIA 4721, Agent Cashier Phone Number
SET BPS("RX",MEDN,"Prescriber Phone #")=$$ACPHONE^IBNCPDPI
+39 SET BPS("RX",MEDN,"Prescriber Billing Location")=""
+40 SET NPI=$$NPI^BPSNPI("Individual_ID",+PROVIEN)
+41 IF NPI<0
SET NPI=""
+42 SET BPS("RX",MEDN,"Prescriber NPI")=$PIECE(NPI,U)
+43 SET BPS("RX",MEDN,"Primary Care Provider NPI")=$PIECE(NPI,U)
+44 SET BPS("RX",MEDN,"Provider NPI")=$PIECE(NPI,U)
+45 ;
+46 ; NCPDP field D01-KV
SET BPS("RX",MEDN,"Prescriber DEA")=$$GET1^DIQ(200,PROVIEN,53.2)
+47 ; provide address info
SET X=$$PRVADRS(IEN59,PROVIEN)
+48 ; NCPDP field 365-2K
SET BPS("RX",MEDN,"Prescriber Street Address")=$PIECE(X,U)_$SELECT($PIECE(X,U,5)]"":" ",1:"")_$PIECE(X,U,5)
+49 ; NCPDP field B27-7U
SET BPS("RX",MEDN,"Prescriber Street Address Line 1")=$PIECE(X,U)
+50 ; NCPDP field B28-8U
SET BPS("RX",MEDN,"Prescriber Street Address Line 2")=$PIECE(X,U,5)
+51 ; NCPDP field 366-2M
SET BPS("RX",MEDN,"Prescriber City Address")=$PIECE(X,U,2)
+52 ; NCPDP field 367-2N
SET BPS("RX",MEDN,"Prescriber State/Province Address")=$PIECE(X,U,3)
+53 ; NCPDP field 368-2P
SET BPS("RX",MEDN,"Prescriber Zip/Postal Zone")=$TRANSLATE($PIECE(X,U,4)," -")
+54 ;NCPDP field B42-3C
SET BPS("RX",MEDN,"Prescriber Country")=$$COUNTRY($PIECE(X,U,3),$PIECE(X,U,6))
End DoDot:1
+55 ;
+56 ; Stop if Eligibility as we do not need any of the claim data below
+57 IF BPS("Transaction Code")="E1"
QUIT
+58 ;
+59 ; Basic Prescription Info
+60 SET BPS("RX",MEDN,"Date Written")=$$RXAPI1^BPSUTIL1(RXIEN,1,"I")
+61 ; SLT - BPS*1.0*11
+62 ; if the RX Issue Date is in the future, set it to the current date
+63 IF BPS("RX",MEDN,"Date Written")>DT
SET BPS("RX",MEDN,"Date Written")=DT
+64 SET BPS("RX",MEDN,"New/Refill")=$SELECT(RXRFIEN="":"N",1:"R")
+65 SET BPS("RX",MEDN,"# Refills")=$$RXAPI1^BPSUTIL1(RXIEN,9,"I")
+66 SET BPS("RX",MEDN,"Refill #")=+RXRFIEN
+67 ; 147-U7 Pharmacy Service Type, 1=Community/Retail Pharmacy Services
SET BPS("RX",MEDN,"Pharmacy Service Type")="01"
+68 ;
+69 ; PreAuth and Prior Authorization
+70 ; #1.09 Prior Authorization Number, #1.15 Prior Auth Type Code
+71 SET X=$GET(^BPST(IEN59,1))
+72 SET BPS("RX",MEDN,"Preauth #")=$PIECE(X,U,15)_$PIECE(X,U,9)
+73 SET BPS("Claim",MEDN,"Prior Auth Type")=$PIECE(X,U,15)
+74 SET BPS("Claim",MEDN,"Prior Auth Num Sub")=$PIECE(X,U,9)
+75 ;
+76 ; delay reason code not sent unless user specifies a code
+77 ; 357-NV Delay Reason Code
SET BPS("Claim",MEDN,"Delay Reason Code")=""
+78 ;
+79 ; Calculate date/time for Time of Service 678-Y6 - BPS*1*15
+80 ; using SUBMIT REQUEST DATE TIME field #17 from earliest transmission log entry
+81 NEW FDTIME,IEN57
SET IEN57=$ORDER(^BPSTL("B",IEN59,0))
IF IEN57
SET FDTIME=$PIECE($GET(^BPSTL(IEN57,0)),U,13)
+82 ; Otherwise use current time
+83 IF $GET(FDTIME)=""
SET FDTIME=$$NOW^XLFDT
+84 ; Save time as HHMMSS
+85 ; 678-Y6 Time of Service
SET BPS("Claim",MEDN,"Time of Service")=$$LJ^XLFSTR($PIECE(FDTIME,".",2),6,0)
+86 ;
+87 ; NDC = NDC number drug, try transaction 1st, if null get it from Rx/refill
+88 SET BPS("RX",MEDN,"Product ID Qualifier")="03"
+89 SET NDC=$PIECE(^BPST(IEN59,1),U,2)
+90 IF NDC=""
SET NDC=$$GETNDC^PSONDCUT(RXIEN,RXRFIEN)
DO LOG^BPSOSL(IEN59,RTN_"-NDC sent as "_NDC)
+91 SET BPS("RX",MEDN,"NDC")=NDC
+92 ;
+93 ; Prescription Data dependent on original vs. refill
+94 ; 1st fill
if 'RXRFIEN
Begin DoDot:1
+95 SET BPS("RX",MEDN,"Days Supply")=$$RXAPI1^BPSUTIL1(RXIEN,8,"I")
+96 SET BPS("RX",MEDN,"DAW")=$$RXAPI1^BPSUTIL1(RXIEN,81,"I")
+97 ;Use FINISHING PERSON field as pharmacist identifier for Initials and ID - BPS*1*15 - DBIA 10112 for $$SITE
+98 SET BPS("Provider",MEDN,"Pharmacist Initials")=$$GET1^DIQ(200,+$$RXAPI1^BPSUTIL1(RXIEN,38,"I"),1)
+99 SET BPS("Provider",MEDN,"Pharmacist ID")=$PIECE($$SITE^VASITE,U,3)_$$RJ^XLFSTR(+$$RXAPI1^BPSUTIL1(RXIEN,38,"I"),15,0)
End DoDot:1
+100 ; refill
if RXRFIEN
Begin DoDot:1
+101 SET BPS("RX",MEDN,"Days Supply")=$$RXSUBF1^BPSUTIL1(RXIEN,52,52.1,RXRFIEN,1.1,"I")
+102 SET BPS("RX",MEDN,"DAW")=$$RXSUBF1^BPSUTIL1(RXIEN,52,52.1,RXRFIEN,81,"I")
+103 ;Use FILLING PERSON field as pharmacist identifier for Initials and ID - BPS*1*15 - DBIA 10112 for $$SITE
+104 SET BPS("Provider",MEDN,"Pharmacist Initials")=$$GET1^DIQ(200,+$$RXSUBF1^BPSUTIL1(RXIEN,52,52.1,RXRFIEN,19,"I"),1)
+105 SET BPS("Provider",MEDN,"Pharmacist ID")=$PIECE($$SITE^VASITE,U,3)_$$RJ^XLFSTR(+$$RXSUBF1^BPSUTIL1(RXIEN,52,52.1,RXRFIEN,19,"I"),15,0)
End DoDot:1
+106 ;
+107 ; Origin Code, VAOIEN=PLACER ORDER # from file 52, VANATURE=NATURE OF ORDER in sub-file 100.008
+108 SET VAOIEN=+$$RXAPI1^BPSUTIL1(RXIEN,39.3,"I")
SET VANATURE=$$GET1^DIQ(100.008,"1,"_VAOIEN_",","12")
+109 SET BPS("RX",MEDN,"Origin Code")=$SELECT(VANATURE="AUTO":2,VANATURE["ELECTRONIC":3,VANATURE="DUPLICATE":0,VANATURE["TELEPHONE":2,1:1)
+110 ;
+111 ; NCPDP field 420-DK Submission Clarification Code, default to "01" for vD.0
+112 ; note: this is a multiple (#9002313.02354), additional codes may be added by other routines
+113 SET %=$PIECE($GET(^BPST(IEN59,12)),U,3)
SET BPS("RX",MEDN,"Submission Clarif Code",1)=$SELECT(%]"":%,1:"01")
+114 ;
+115 ; Drug Info
+116 SET DRUGIEN=$$RXAPI1^BPSUTIL1(RXIEN,6,"I")
+117 if DRUGIEN'=""
Begin DoDot:1
+118 SET BPS("RX",MEDN,"Drug IEN")=DRUGIEN
+119 SET BPS("RX",MEDN,"Drug Name")=$$DRUGDIE^BPSUTIL1(DRUGIEN,.01,"E")
End DoDot:1
+120 ;
+121 ; Pricing Info
+122 SET PRICING=$GET(^BPST(IEN59,5))
+123 SET BPS("RX",MEDN,"Quantity")=$PIECE(PRICING,U)
+124 SET BPS("RX",MEDN,"Unit Price")=$PIECE(PRICING,U,2)
+125 SET BPS("RX",MEDN,"Unit of Measure")=$PIECE(PRICING,U,8)
+126 SET BPS("RX",MEDN,"Basis of Cost Determination")=$GET(VAINFO(9002313.59902,IENS,902.13,"I"))
+127 SET BPS("RX",MEDN,"Usual & Customary")=$GET(VAINFO(9002313.59902,IENS,902.14,"I"))
+128 SET BPS("RX",MEDN,"Gross Amount Due")=$GET(VAINFO(9002313.59902,IENS,902.15,"I"))
+129 SET BPS("RX",MEDN,"Ingredient Cost")=$GET(VAINFO(9002313.59902,IENS,902.2,"I"))
+130 SET BPS("RX",MEDN,"Dispensing Fee")=$GET(VAINFO(9002313.59902,IENS,902.12,"I"))
+131 SET ADFEE=+$GET(VAINFO(9002313.59902,IENS,902.16,"I"))
+132 IF ADFEE'=0
Begin DoDot:1
+133 SET BPS("RX",MEDN,"Other Amt Qual",1)="04"
+134 SET BPS("RX",MEDN,"Other Amt Value",1)=ADFEE
End DoDot:1
+135 ;
+136 QUIT
+137 ;
+138 ; OVERRIDE - Retrieve OVERRIDE nodes and put into BPS array
+139 ; They will be fetched from BPS("OVERRIDE"
+140 ; during low-level construction of the actual encoded claim packet.
+141 ; BPS("OVERRIDE",field)=value for fields 101-401
+142 ; BPS("OVERRIDE","RX",MEDN,field) for med #N, fields 402+
+143 ; Note that if you have multiple transactions bundled, the
+144 ; union of overrides from 101-401 apply to all; and if there's a
+145 ; conflict, the last one overwrites the previous ones.
OVERRIDE(IEN59,MEDN) ;
+1 NEW IEN511,RETVAL
+2 SET IEN511=$PIECE(^BPST(IEN59,1),U,13)
if 'IEN511
QUIT
+3 SET RETVAL=$$GET511^BPSOSO2(IEN511,"BPS(""OVERRIDE"")","BPS(""OVERRIDE"",""RX"","_MEDN_")")
+4 QUIT
+5 ;
+6 ; DURVALUE - Will read in the DUR data from the DUR multiple
+7 ; in BPS Transactions and store the values into BPS("RX",MEDN,DUR,....)
+8 ; NOTE - unlike most values, these fields are stored by their
+9 ; field number. Since they are repeating, it will ease the
+10 ; retrieval of them, when we populate the claim.
DURVALUE(IEN59,MEDN) ;
+1 NEW DUR,DCNT,DURREC
+2 ;
+3 SET (DUR,DCNT)=0
+4 FOR
SET DCNT=$ORDER(^BPST(IEN59,13,DCNT))
if 'DCNT
QUIT
Begin DoDot:1
+5 SET DURREC=$GET(^BPST(IEN59,13,DCNT,0))
+6 IF DURREC=""
QUIT
+7 SET DUR=DUR+1
+8 ;473-7E DUR/PPS Code Counter
SET BPS("RX",MEDN,"DUR",DUR,473)=DUR
+9 ;439-E4 Reason For Service Code
SET BPS("RX",MEDN,"DUR",DUR,439)=$PIECE(DURREC,U,3)
+10 ;440-E5 Professional Service Code
SET BPS("RX",MEDN,"DUR",DUR,440)=$PIECE(DURREC,U,2)
+11 ;441-E6 Result of Service Code
SET BPS("RX",MEDN,"DUR",DUR,441)=$PIECE(DURREC,U,4)
+12 ;474-8E DUR/PPS Level Of Effort
SET BPS("RX",MEDN,"DUR",DUR,474)=""
+13 ; fields 475&476 not used in vD.0
if $GET(BPS("NCPDP","Version"))'=51
QUIT
+14 ;475-J9 DUR Co-Agent ID Qualifier
SET BPS("RX",MEDN,"DUR",DUR,475)=""
+15 ;476-H6 DUR Co-Agent ID
SET BPS("RX",MEDN,"DUR",DUR,476)=""
End DoDot:1
+16 ;
+17 QUIT
+18 ;
COB(IEN59,MEDN) ; process the COB fields and build the COB array
+1 ; Code for Benefit Stages multiple not implemented yet (except by
+2 ; certification)
+3 ;
+4 ; build array of COB secondary claim data from the BPS Transaction file - esg - 6/16/10
+5 NEW COBPIEN,APDIEN,REJIEN,DATA
+6 KILL BPS("RX",MEDN,"OTHER PAYER")
+7 ;
+8 ; Field 337-4C COB OTHER PAYMENTS COUNT (9002313.59,1204) moved into [1] below
+9 SET BPS("RX",MEDN,"OTHER PAYER",0)=$PIECE($GET(^BPST(IEN59,12)),U,4)
+10 ;
+11 SET COBPIEN=0
FOR
SET COBPIEN=$ORDER(^BPST(IEN59,14,COBPIEN))
if 'COBPIEN
QUIT
Begin DoDot:1
+12 ; Note that this will set pieces 1-7 and 11. Piece 9 is reserved for
+13 ; Benefit Stage Count and is set by the certification code
+14 SET BPS("RX",MEDN,"OTHER PAYER",COBPIEN,0)=$GET(^BPST(IEN59,14,COBPIEN,0))
+15 ;
+16 ; retrieve data from other payer amount paid multiple
+17 SET APDIEN=0
FOR
SET APDIEN=$ORDER(^BPST(IEN59,14,COBPIEN,1,APDIEN))
if 'APDIEN
QUIT
Begin DoDot:2
+18 SET DATA=$GET(^BPST(IEN59,14,COBPIEN,1,APDIEN,0))
+19 SET BPS("RX",MEDN,"OTHER PAYER",COBPIEN,"P",APDIEN,0)=$PIECE(DATA,"^",1)_"^"_$$GET1^DIQ(9002313.2,$PIECE(DATA,"^",2),.01)
+20 SET BPS("RX",MEDN,"OTHER PAYER",COBPIEN,"PP",APDIEN,0)=$PIECE(DATA,"^",3)
+21 IF +$PIECE(DATA,"^",3)
SET $PIECE(BPS("RX",MEDN,"OTHER PAYER",COBPIEN,"PP",APDIEN,0),"^",2)="06"
+22 QUIT
End DoDot:2
+23 ;
+24 ; retrieve data from other payer reject multiple
+25 SET REJIEN=0
FOR
SET REJIEN=$ORDER(^BPST(IEN59,14,COBPIEN,2,REJIEN))
if 'REJIEN
QUIT
Begin DoDot:2
+26 SET BPS("RX",MEDN,"OTHER PAYER",COBPIEN,"R",REJIEN,0)=$GET(^BPST(IEN59,14,COBPIEN,2,REJIEN,0))
End DoDot:2
End DoDot:1
+27 QUIT
+28 ;
PRVADRS(IEN59,PRVIEN) ; site address for a provider
+1 ; returns "street address^city^st^zip"
+2 ; IEN59=BPS TRANSACTION (#9002313.59) ien
+3 ; PRVIEN=provider IEN in NEW PERSON file (#200)
+4 ;
+5 IF '$GET(IEN59)
QUIT ""
+6 IF '$GET(PRVIEN)
QUIT ""
+7 ;
+8 NEW BPSND,F,IPTR,IEN,OPSITE,PRVADDR,PRVNVA,RSLT,AD2
+9 SET RSLT=""
+10 ;
+11 ; NON-VA PRESCRIBER
SET PRVNVA=+$$GET1^DIQ(200,PRVIEN_",",53.91,"I")
+12 ;
+13 ; if false, it's a VA prescriber - address data found in file 4 for the VA pharmacy
+14 IF 'PRVNVA
Begin DoDot:1
+15 ; OUTPATIENT SITE ptr
SET OPSITE=$PIECE($GET(^BPST(IEN59,1)),U,4)
+16 if 'OPSITE
QUIT
+17 SET BPSND="BPS59"
KILL ^TMP($JOB,BPSND)
+18 DO PSS^PSO59(OPSITE,"",BPSND)
+19 ; INSTITUTION ptr
SET IPTR=$PIECE($GET(^TMP($JOB,BPSND,OPSITE,101)),U)
+20 if IPTR
SET RSLT=$$MADD^XUAF4(IPTR)_U_$$GET1^DIQ(4,IPTR_",",4.02)_U_$$GET1^DIQ(4,IPTR_",",4.04,"I")
+21 KILL ^TMP($JOB,BPSND)
End DoDot:1
GOTO PRVADX
+22 ;
+23 ; Non-VA prescriber - address data found in file 200
+24 FOR F=.111,.112,.113,.114,.115,.116
SET PRVADDR(F)=$$GET1^DIQ(200,PRVIEN_",",F)
+25 ; Get State info
+26 SET PRVADDR(.115,"ABBR")=""
SET IEN=$$GET1^DIQ(200,PRVIEN_",",.115,"I")
SET PRVADDR(.115,"ABBR")=$$GET1^DIQ(5,+IEN_",",1)
+27 ; Build Address Line 2
+28 SET AD2=PRVADDR(.112)
IF PRVADDR(.113)]""
SET AD2=AD2_$SELECT(AD2]"":" ",1:"")_PRVADDR(.113)
+29 ; Build result string
+30 SET RSLT=PRVADDR(.111)_U_PRVADDR(.114)_U_PRVADDR(.115,"ABBR")_U_PRVADDR(.116)_U_AD2_U_IEN
+31 ;
PRVADX ;
+1 QUIT RSLT
+2 ;
COUNTRY(STATE,IEN) ;
+1 ; Convert STATE abbreviation into a ISO-3166-1 country code
+2 ; Input:
+3 ; STATE: State Abbreviation
+4 ; Output: ISO-3166-1 Country Code
+5 ;
+6 IF $GET(STATE)=""
QUIT ""
+7 IF '$GET(IEN)
QUIT ""
+8 ; Canada
IF ",BC,MB,NB,NF,NS,NT,ON,PE,QC,SK,YT,CANAD,NU,"[(","_STATE_",")
QUIT "CA"
+9 ; Foreign Country, Europe, Unknown
IF STATE="FG"!(STATE="EU")!(STATE="UN")
QUIT ""
+10 ; American Samoa
IF STATE="AS"
QUIT "AS"
+11 ; Federated States of Micronesia
IF STATE="FM"
QUIT "FM"
+12 ; Guam
IF STATE="GU"
QUIT "GU"
+13 ; Marshall Islands
IF STATE="MH"
QUIT "MH"
+14 ; Northern Mariana Islands
IF STATE="MP"
QUIT "MP"
+15 ; Mexico
IF STATE="MX"
QUIT "MX"
+16 ; Philippines
IF STATE="PH"
QUIT "PH"
+17 ; Puerto Rico
IF STATE="PR"
QUIT "PR"
+18 ; Palau
IF STATE="PW"
QUIT "PW"
+19 ; Virgin Islands
IF STATE="VI"
QUIT "VI"
+20 IF $$GET1^DIQ(5,IEN_",",2.2,"I")=1
QUIT "US"
+21 QUIT ""
