BPS23PRE ;AITC/CKB - Pre-install routine for BPS*1*23 ;2/21/2017
;;1.0;E CLAIMS MGMT ENGINE;**23**;JUN 2004;Build 44
;;Per VA Directive 6402, this routine should not be modified.
;
; MCCF EDI TAS ePharmacy Iteration 1 - BPS*1*23 patch pre-install
Q
;
EN ; Entry Point for pre-install
D MES^XPDUTL(" Starting pre-install for BPS*1*23")
;
; Update Reject codes explanations in file #9002313.93
D REJECTS
;
; Update Result of Service Codes explanations in file #9002313.22
D SVCCODE
;
; Update Clarification (file #9002313.25) and Other Payer Amount Paid Qualifier
; codes (file #9002313.2) with new descriptions
D UPDCCQC
;
EX ; Exit point
D MES^XPDUTL(" Finished pre-install of BPS*1*23")
Q
;
REJECTS ; Update Reject Codes with new explanations
N LINE,DATA,NUM,NAME,DA,DIE,DR,CNT
D MES^XPDUTL(" - Updating BPS NCPDP REJECT CODES")
S CNT=0
F LINE=1:1 S DATA=$P($T(URJCT+LINE),";;",2,99) Q:DATA="" D
. S DIE=9002313.93,NUM=$P(DATA,";",1)
. S DA=$O(^BPSF(DIE,"B",NUM,""))
. I 'DA D MES^XPDUTL(" - No IEN found for entry "_NUM) Q
. S NAME=$P(DATA,";",2),DR=".02////^S X=NAME",CNT=CNT+1
. D ^DIE
D MES^XPDUTL(" - "_CNT_" entries updated")
D MES^XPDUTL(" - Done with BPS NCPDP REJECT CODES")
D MES^XPDUTL(" ")
Q
;
URJCT ; Updated reject explanations
;;01;M/I IIN Number
;;299;Reported Adjudicated Program Type Is Not Used For This Transaction Code
;;708;PDMP: M/I Reported Adjudicated Program Type
;;820;Info Reporting Trans Mtchd to Rev/Rej Clm not Submitted Part D IIN PCN
;;821;Info Reporting Trans Mtchd to Pd Clm Not Submitted Part D IIN PCN
;;A1;ID Submitted Is Associated With An Excluded Prescriber
;;ZS;M/I Reported Adjudicated Program Type
;;
;
SVCCODE ; Update Result of Service Codes with new explanations
N LINE,CODE,NUM,DESC,DA,DIE,DR,CNT
D MES^XPDUTL(" - Updating BPS NCPDP RESULT OF SERVICE CODES")
S CNT=0
F LINE=1:1 S CODE=$P($T(UPDSVC+LINE),";;",2,99) Q:CODE="" D
. S DIE=9002313.22,NUM=$P(CODE,";",1)
. S DA=$O(^BPS(DIE,"B",NUM,""))
. I 'DA D MES^XPDUTL(" - No IEN found for entry "_NUM) Q
. S DESC=$P(CODE,";",2),DR="1////^S X=DESC",CNT=CNT+1
. D ^DIE
D MES^XPDUTL(" - "_CNT_" entries updated")
D MES^XPDUTL(" - Done with BPS NCPDP RESULT OF SERVICE CODES")
D MES^XPDUTL(" ")
Q
;
UPDSVC ; Updated Result of Service Code explanations
;;1A;DISPENSED AS IS, FALSE POSITIVE
;;1B;DISPENSED PRESCRIPTION AS IS
;;1C;DISPENSED, WITH DIFFERENT DOSE
;;1D;DISPENSED, WITH DIFFERENT DIRECTIONS
;;1E;DISPENSED, WITH DIFFERENT DRUG
;;1F;DISPENSED, WITH DIFFERENT QUANTITY
;;1G;DISPENSED, WITH PRESCRIBER APPROVAL
;;1K;DISPENSED WITH DIFFERENT DOSAGE FORM
;;2A;PRESCRIPTION NOT DISPENSED
;;2B;NOT DISPENSED, DIRECTIONS CLARIFIED
;;
;
UPDCCQC ;
;Update Clarification codes with new descriptions
N LINE,CODE,NUM,DESC,DA,DIE,DR,CNT
D MES^XPDUTL(" - Updating BPS NCPDP CLARIFICATION CODES")
S CNT=0
F LINE=1:1 S CODE=$P($T(UCC+LINE),";;",2,99) Q:CODE="" D
. S DIE=9002313.25,NUM=$P(CODE,";",1)
. S DA=$O(^BPS(DIE,"B",NUM,""))
. I 'DA D MES^XPDUTL(" - No IEN found for entry "_NUM) Q
. S DESC=$P(CODE,";",2),DR=".02////^S X=DESC",CNT=CNT+1
. D ^DIE
D MES^XPDUTL(" - "_CNT_" entries updated")
D MES^XPDUTL(" - Done with BPS NCPDP CLARIFICATION CODES")
D MES^XPDUTL(" ")
;
;Update Other Payer Amount Paid Qualifier codes with new description
N LINE,CODE,NUM,DESC,DA,DIE,DR,CNT
D MES^XPDUTL(" - Updating BPS NCPDP OTHER PAYER AMT PAID QUAL FILE")
S CNT=0
F LINE=1:1 S CODE=$P($T(UQC+LINE),";;",2,99) Q:CODE="" D
. S DIE=9002313.2,NUM=$P(CODE,";",1)
. S DA=$O(^BPS(DIE,"B",NUM,""))
. I 'DA D MES^XPDUTL(" - No IEN found for entry "_NUM) Q
. S DESC=$P(CODE,";",2),DR=".02////^S X=DESC",CNT=CNT+1
. D ^DIE
D MES^XPDUTL(" - "_CNT_" entries updated")
D MES^XPDUTL(" - Done with BPS NCPDP OTHER PAYER AMT PAID QUAL FILE")
D MES^XPDUTL(" ")
Q
;
UCC ; Updated Clarification Code explanations
;;47;SHORTENED DAYS SUPPLY DISPENSED
;;48;DISPENSED SUBSEQUENT TO A SHORTENED DAYS SUPPLY DISPENSING
;;
;
UQC ; Updated Other Payer Amount Paid Qualifier explanations
;;10;PERCENTAGE TAX
;;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPS23PRE 4194 printed Sep 23, 2025@19:26:38 Page 2
BPS23PRE ;AITC/CKB - Pre-install routine for BPS*1*23 ;2/21/2017
+1 ;;1.0;E CLAIMS MGMT ENGINE;**23**;JUN 2004;Build 44
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; MCCF EDI TAS ePharmacy Iteration 1 - BPS*1*23 patch pre-install
+5 QUIT
+6 ;
EN ; Entry Point for pre-install
+1 DO MES^XPDUTL(" Starting pre-install for BPS*1*23")
+2 ;
+3 ; Update Reject codes explanations in file #9002313.93
+4 DO REJECTS
+5 ;
+6 ; Update Result of Service Codes explanations in file #9002313.22
+7 DO SVCCODE
+8 ;
+9 ; Update Clarification (file #9002313.25) and Other Payer Amount Paid Qualifier
+10 ; codes (file #9002313.2) with new descriptions
+11 DO UPDCCQC
+12 ;
EX ; Exit point
+1 DO MES^XPDUTL(" Finished pre-install of BPS*1*23")
+2 QUIT
+3 ;
REJECTS ; Update Reject Codes with new explanations
+1 NEW LINE,DATA,NUM,NAME,DA,DIE,DR,CNT
+2 DO MES^XPDUTL(" - Updating BPS NCPDP REJECT CODES")
+3 SET CNT=0
+4 FOR LINE=1:1
SET DATA=$PIECE($TEXT(URJCT+LINE),";;",2,99)
if DATA=""
QUIT
Begin DoDot:1
+5 SET DIE=9002313.93
SET NUM=$PIECE(DATA,";",1)
+6 SET DA=$ORDER(^BPSF(DIE,"B",NUM,""))
+7 IF 'DA
DO MES^XPDUTL(" - No IEN found for entry "_NUM)
QUIT
+8 SET NAME=$PIECE(DATA,";",2)
SET DR=".02////^S X=NAME"
SET CNT=CNT+1
+9 DO ^DIE
End DoDot:1
+10 DO MES^XPDUTL(" - "_CNT_" entries updated")
+11 DO MES^XPDUTL(" - Done with BPS NCPDP REJECT CODES")
+12 DO MES^XPDUTL(" ")
+13 QUIT
+14 ;
URJCT ; Updated reject explanations
+1 ;;01;M/I IIN Number
+2 ;;299;Reported Adjudicated Program Type Is Not Used For This Transaction Code
+3 ;;708;PDMP: M/I Reported Adjudicated Program Type
+4 ;;820;Info Reporting Trans Mtchd to Rev/Rej Clm not Submitted Part D IIN PCN
+5 ;;821;Info Reporting Trans Mtchd to Pd Clm Not Submitted Part D IIN PCN
+6 ;;A1;ID Submitted Is Associated With An Excluded Prescriber
+7 ;;ZS;M/I Reported Adjudicated Program Type
+8 ;;
+9 ;
SVCCODE ; Update Result of Service Codes with new explanations
+1 NEW LINE,CODE,NUM,DESC,DA,DIE,DR,CNT
+2 DO MES^XPDUTL(" - Updating BPS NCPDP RESULT OF SERVICE CODES")
+3 SET CNT=0
+4 FOR LINE=1:1
SET CODE=$PIECE($TEXT(UPDSVC+LINE),";;",2,99)
if CODE=""
QUIT
Begin DoDot:1
+5 SET DIE=9002313.22
SET NUM=$PIECE(CODE,";",1)
+6 SET DA=$ORDER(^BPS(DIE,"B",NUM,""))
+7 IF 'DA
DO MES^XPDUTL(" - No IEN found for entry "_NUM)
QUIT
+8 SET DESC=$PIECE(CODE,";",2)
SET DR="1////^S X=DESC"
SET CNT=CNT+1
+9 DO ^DIE
End DoDot:1
+10 DO MES^XPDUTL(" - "_CNT_" entries updated")
+11 DO MES^XPDUTL(" - Done with BPS NCPDP RESULT OF SERVICE CODES")
+12 DO MES^XPDUTL(" ")
+13 QUIT
+14 ;
UPDSVC ; Updated Result of Service Code explanations
+1 ;;1A;DISPENSED AS IS, FALSE POSITIVE
+2 ;;1B;DISPENSED PRESCRIPTION AS IS
+3 ;;1C;DISPENSED, WITH DIFFERENT DOSE
+4 ;;1D;DISPENSED, WITH DIFFERENT DIRECTIONS
+5 ;;1E;DISPENSED, WITH DIFFERENT DRUG
+6 ;;1F;DISPENSED, WITH DIFFERENT QUANTITY
+7 ;;1G;DISPENSED, WITH PRESCRIBER APPROVAL
+8 ;;1K;DISPENSED WITH DIFFERENT DOSAGE FORM
+9 ;;2A;PRESCRIPTION NOT DISPENSED
+10 ;;2B;NOT DISPENSED, DIRECTIONS CLARIFIED
+11 ;;
+12 ;
UPDCCQC ;
+1 ;Update Clarification codes with new descriptions
+2 NEW LINE,CODE,NUM,DESC,DA,DIE,DR,CNT
+3 DO MES^XPDUTL(" - Updating BPS NCPDP CLARIFICATION CODES")
+4 SET CNT=0
+5 FOR LINE=1:1
SET CODE=$PIECE($TEXT(UCC+LINE),";;",2,99)
if CODE=""
QUIT
Begin DoDot:1
+6 SET DIE=9002313.25
SET NUM=$PIECE(CODE,";",1)
+7 SET DA=$ORDER(^BPS(DIE,"B",NUM,""))
+8 IF 'DA
DO MES^XPDUTL(" - No IEN found for entry "_NUM)
QUIT
+9 SET DESC=$PIECE(CODE,";",2)
SET DR=".02////^S X=DESC"
SET CNT=CNT+1
+10 DO ^DIE
End DoDot:1
+11 DO MES^XPDUTL(" - "_CNT_" entries updated")
+12 DO MES^XPDUTL(" - Done with BPS NCPDP CLARIFICATION CODES")
+13 DO MES^XPDUTL(" ")
+14 ;
+15 ;Update Other Payer Amount Paid Qualifier codes with new description
+16 NEW LINE,CODE,NUM,DESC,DA,DIE,DR,CNT
+17 DO MES^XPDUTL(" - Updating BPS NCPDP OTHER PAYER AMT PAID QUAL FILE")
+18 SET CNT=0
+19 FOR LINE=1:1
SET CODE=$PIECE($TEXT(UQC+LINE),";;",2,99)
if CODE=""
QUIT
Begin DoDot:1
+20 SET DIE=9002313.2
SET NUM=$PIECE(CODE,";",1)
+21 SET DA=$ORDER(^BPS(DIE,"B",NUM,""))
+22 IF 'DA
DO MES^XPDUTL(" - No IEN found for entry "_NUM)
QUIT
+23 SET DESC=$PIECE(CODE,";",2)
SET DR=".02////^S X=DESC"
SET CNT=CNT+1
+24 DO ^DIE
End DoDot:1
+25 DO MES^XPDUTL(" - "_CNT_" entries updated")
+26 DO MES^XPDUTL(" - Done with BPS NCPDP OTHER PAYER AMT PAID QUAL FILE")
+27 DO MES^XPDUTL(" ")
+28 QUIT
+29 ;
UCC ; Updated Clarification Code explanations
+1 ;;47;SHORTENED DAYS SUPPLY DISPENSED
+2 ;;48;DISPENSED SUBSEQUENT TO A SHORTENED DAYS SUPPLY DISPENSING
+3 ;;
+4 ;
UQC ; Updated Other Payer Amount Paid Qualifier explanations
+1 ;;10;PERCENTAGE TAX
+2 ;;
+3 ;
