BPS23PRE.m

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 ---BPS23PRE   4194     printed  Feb 18, 2025@23:16:52                                                                                                                                                                                                    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       ;