Routine: BARADJR7

BARADJR7 ; IHS/SD/LSL - CREATE ENTRY IN A/R EDI STND CLAIM ADJ REASON ;

 ;;1.8;IHS ACCOUNTS RECEIVABLE**22**;;OCT 26, 2005;Build 38

 ; IHS/SD/SDR - v1.8 p22 - updated SARs

 ; *********************************************************************

EN ; EP

 D RPMSREA                   ; Create RPMS Reasons

 D STND                      ; Create new StanJdard Adj

 D CLAIM                     ; Create new Claim Status Codes

 D ^BARVKL0

 ; ********************************************************************

RPMSREA ;

 ; Create new Adjustment Reasons in A/R TABLE ENTRY

 S BARD=";;"

 S BARCNT=0

 D BMES^XPDUTL("Adding New Adjustment Reasons to A/R Table Entry file...")

 F  D RPMSREA2 Q:BARVALUE="END"

 ; ********************************************************************

RPMSREA2 ;

 S BARCNT=BARCNT+1

 S BARVALUE=$P($T(@1+BARCNT),BARD,2,4)

 Q:BARVALUE="END"

 K DIC,DA,X,Y

 S DIC="^BARTBL("

 S DIC(0)="LZE"

 S DINUM=$P(BARVALUE,BARD)

 S X=$P(BARVALUE,BARD,2)

 S DIC("DR")="2////^S X=$P(BARVALUE,BARD,3)"

 K DD,DO

 D MES^XPDUTL($P(BARVALUE,BARD)_"  "_$P(BARVALUE,BARD,2))

 D FILE^DICN

 ; ********************************************************************

CHNGREA ; EP

 ; Change category of these reasons to Non-Payment

 S BARD=";;"

 S BARCNT=0

 F  D CHNGREA2 Q:BARVALUE="END"

 ; ********************************************************************

CHNGREA2 ;

 S BARCNT=BARCNT+1

 S BARVALUE=$P($T(@4+BARCNT),BARD,3)

 Q:BARVALUE="END"

 K DIC,DA,X,Y,DIE

 S DIE="^BARTBL("

 S DA=BARVALUE

 S DR="2////^S X=4"

 D ^DIE

 ; ********************************************************************

STND ;

 ; Create entries in A/R EDI STND CLAIM ADJ REASONS to accomodate

 ; Standard codes added between 6/02 and 9/03.

 S BARD=";;"

 S BARCNT=0

 D BMES^XPDUTL("Updating Standard Adjustment Reasons in A/R EDI STND CLAIM ADJ REASONS file...")

 F  D STND2 Q:BARVALUE="END"

 ; ********************************************************************

STND2 ;

 S BARCNT=BARCNT+1

 S BARVALUE=$P($T(@2+BARCNT),BARD,2,6)

 Q:BARVALUE="END"

STND3 ;

 ;look for existing entry

 K DIC,DA,X,Y

 S DIC="^BARADJ("

 S DIC(0)="M"

 S X=$P(BARVALUE,BARD)

 D ^DIC

 I +Y>0 D  Q  ;if existing entry found - edit it

 .D MES^XPDUTL($P(BARVALUE,BARD)_$S($L($P(BARVALUE,BARD))=2:"   ",$L($P(BARVALUE,BARD))=1:"    ",1:"  ")_$E($P(BARVALUE,BARD,2),1,65))

 .K DIC,DIE

 .S DIE="^BARADJ("

 .S DA=+Y

 .S DR=".02///^S X=$P(BARVALUE,BARD,2)"              ; Short Desc

 .S DR=DR_";.03////^S X=$P(BARVALUE,BARD,3)"   ; RPMS Cat

 .S DR=DR_";.04////^S X=$P(BARVALUE,BARD,4)"   ; RPMS Type

 .S DR=DR_";101///^S X=$P(BARVALUE,BARD,5)"    ; Long Desc

 .D ^DIE

 ;create new entry if none found

 K DIC,DA,X,Y

 S DIC="^BARADJ("

 S DIC(0)="LZE"

 S X=$P(BARVALUE,BARD)                                     ; Stnd Code

 S DIC("DR")=".02///^S X=$P(BARVALUE,BARD,2)"              ; Short Desc

 S DIC("DR")=DIC("DR")_";.03////^S X=$P(BARVALUE,BARD,3)"   ; RPMS Cat

 S DIC("DR")=DIC("DR")_";.04////^S X=$P(BARVALUE,BARD,4)"   ; RPMS Type

 S DIC("DR")=DIC("DR")_";101///^S X=$P(BARVALUE,BARD,5)"    ; Long Desc

 K DD,DO

 D MES^XPDUTL($P(BARVALUE,BARD)_$S($L($P(BARVALUE,BARD))=2:"   ",$L($P(BARVALUE,BARD))=1:"    ",1:"  ")_$E($P(BARVALUE,BARD,2),1,65))

 D FILE^DICN

 ; ********************************************************************

CLAIM ;

 ; Populate A/R EDI CLAIM STATUS CODES to accomodate new codes added

 ; between 6/02 and 9/03. Inactivate necessary codes.

 S BARCNT=0

 F  D CLAIM2 Q:BARVALUE="END"

 S BARCNT=0

 F BARVALUE=8,10,11,13,14,28,69,70 D CLAIM3

 ; ********************************************************************

CLAIM2 ;

 S BARCNT=BARCNT+1

 S BARVALUE=$P($T(@3+BARCNT),BARD,2,4)

 Q:BARVALUE="END"

 K DIC,DA,X,Y

 S DIC="^BARECSC("

 S DIC(0)="LZE"

 S X=$P(BARVALUE,BARD)                        ;Status Cd

 S DIC("DR")="11///^S X=$P(BARVALUE,BARD,2)"  ;Description

 K DD,DO

 D FILE^DICN

 ; ********************************************************************

CLAIM3 ;

 K DIC,DA,X,Y

 S DIC="^BARECSC("

 S DIC(0)="XZQ"

 S X=BARVALUE

 K DD,DO

 D ^DIC

 Q:+Y<1

 K DA,DIE,DR

 S DA=+Y

 S DIE=DIC

 S DR=".02///Y"

 D ^DIE

 ; ********************************************************************

MODIFY ; EP

 ; Change PENDING to NON PAYMENT

 S BARD=";;"

 S BARCNT=0

 F  D MODIFY2 Q:BARVALUE="END"

 ; *********************************************************************

MODIFY2 ;

 S BARCNT=BARCNT+1

 S BARVALUE=$P($T(@4+BARCNT),BARD,2)

 Q:BARVALUE="END"

 K DIC,DA,X,Y,DR

 S DIC="^BARADJ("

 S DIC(0)="Z"

 S X=$P(BARVALUE,BARD)  ;Stnd Code

 K DD,DO

 D ^DIC

 Q:'+Y

 S DIE=DIC

 S DA=+Y

 S DR=".03////^S X=4"

 D ^DIE

 ; *********************************************************************

 ; IEN;;NAME;;TABLE TYPE

 ; *********************************************************************

1 ;; A/R Table Entry file - Adds

 ;;966;;Proc/mod not comp, othr, NCCI;;4

 ;;975;;Legislative/Regulatory Penalty;;15

 ;;967;;Clm spans elig/inelg cov-PT;;4

 ;;968;;Clm spans elig/inelg cov-OTH;;4

 ;;969;;Clm spans elig/inelg cov-rebi;;4

 ;;END

 ; ********************************************************************

 ; STND CODE ;; SHORT DESC ;; RPMS CAT ;; RPMS TYP ;; LONG DESC

 ; ********************************************************************

2 ;;

 ;;236;;Proc/proc+mod comb not compat w/oth proc/proc+mod, same day per NCCI;;4;;966;;Proc/mod not comp, othr, NCCI

 ;;237;;Legislated/Regulatory Penalty. Check Remark Codes;;15;;975;;Legislated/Regulatory Penalty. At least one Remark Code must be provided (may be comprised of either the NCPDP Reject Reason Code, or Remittance Advice Remark Code that is not an ALERT.)

 ;;238;;Clm spans eligible, inelig periods of coverage, may be the patient's resp;;4;;967;;Claim spans eligible and ineligible periods of coverage, this is the reduction for the ineligible period (use Group Code PR).

 ;;239;;Clm spans eligible, inelig periods of coverage.  Rebill separate clms;;4;;969;;Claim spans eligible and ineligible periods of coverage. Rebill separate claims.

 ;;END

 ; ********************************************************************

 ; CLAIM STATUS CODE ;; DESCRIPTION

 ; ********************************************************************

3 ;; - A/R EDI Claim Status Codes file - Adds

 ;;END

 ; ********************************************************************

 ; STANDARD CODE ;; RPMS REASON

 ; ********************************************************************

4 ;;A/R Table Entry file - Edits

 ;;END;;END

BARADJR7  ; IHS/SD/LSL - CREATE ENTRY IN A/R EDI STND CLAIM ADJ REASON ;

 +1       ;;1.8;IHS ACCOUNTS RECEIVABLE**22**;;OCT 26, 2005;Build 38

 +2       ; IHS/SD/SDR - v1.8 p22 - updated SARs

 +3       ;

 +4       ; *********************************************************************

EN        ; EP

 +1       ; Create RPMS Reasons

           DO RPMSREA

 +2       ; Create new StanJdard Adj

           DO STND

 +3       ; Create new Claim Status Codes

           DO CLAIM

 +4        DO ^BARVKL0

 +5        QUIT

 +6       ; ********************************************************************

 +7       ;

RPMSREA   ;

 +1       ; Create new Adjustment Reasons in A/R TABLE ENTRY

 +2        SET BARD=";;"

 +3        SET BARCNT=0

 +4        DO BMES^XPDUTL("Adding New Adjustment Reasons to A/R Table Entry file...")

 +5        FOR

               DO RPMSREA2

               IF BARVALUE="END"

                   QUIT

 +6        QUIT

 +7       ; ********************************************************************

 +8       ;

RPMSREA2  ;

 +1        SET BARCNT=BARCNT+1

 +2        SET BARVALUE=$PIECE($TEXT(@1+BARCNT),BARD,2,4)

 +3        IF BARVALUE="END"

               QUIT

 +4        KILL DIC,DA,X,Y

 +5        SET DIC="^BARTBL("

 +6        SET DIC(0)="LZE"

 +7        SET DINUM=$PIECE(BARVALUE,BARD)

 +8        SET X=$PIECE(BARVALUE,BARD,2)

 +9        SET DIC("DR")="2////^S X=$P(BARVALUE,BARD,3)"

 +10       KILL DD,DO

 +11       DO MES^XPDUTL($PIECE(BARVALUE,BARD)_"  "_$PIECE(BARVALUE,BARD,2))

 +12       DO FILE^DICN

 +13       QUIT

 +14      ; ********************************************************************

CHNGREA   ; EP

 +1       ; Change category of these reasons to Non-Payment

 +2        SET BARD=";;"

 +3        SET BARCNT=0

 +4        FOR

               DO CHNGREA2

               IF BARVALUE="END"

                   QUIT

 +5        QUIT

 +6       ; ********************************************************************

CHNGREA2  ;

 +1        SET BARCNT=BARCNT+1

 +2        SET BARVALUE=$PIECE($TEXT(@4+BARCNT),BARD,3)

 +3        IF BARVALUE="END"

               QUIT

 +4        KILL DIC,DA,X,Y,DIE

 +5        SET DIE="^BARTBL("

 +6        SET DA=BARVALUE

 +7        SET DR="2////^S X=4"

 +8        DO ^DIE

 +9        QUIT

 +10      ; ********************************************************************

STND      ;

 +1       ; Create entries in A/R EDI STND CLAIM ADJ REASONS to accomodate

 +2       ; Standard codes added between 6/02 and 9/03.

 +3        SET BARD=";;"

 +4        SET BARCNT=0

 +5        DO BMES^XPDUTL("Updating Standard Adjustment Reasons in A/R EDI STND CLAIM ADJ REASONS file...")

 +6        FOR

               DO STND2

               IF BARVALUE="END"

                   QUIT

 +7        QUIT

 +8       ; ********************************************************************

STND2     ;

 +1        SET BARCNT=BARCNT+1

 +2        SET BARVALUE=$PIECE($TEXT(@2+BARCNT),BARD,2,6)

 +3        IF BARVALUE="END"

               QUIT

STND3     ;

 +1       ;look for existing entry

 +2        KILL DIC,DA,X,Y

 +3        SET DIC="^BARADJ("

 +4        SET DIC(0)="M"

 +5        SET X=$PIECE(BARVALUE,BARD)

 +6        DO ^DIC

 +7       ;if existing entry found - edit it

           IF +Y>0

               Begin DoDot:1

 +8                DO MES^XPDUTL($PIECE(BARVALUE,BARD)_$SELECT($LENGTH($PIECE(BARVALUE,BARD))=2:"   ",$LENGTH($PIECE(BARVALUE,BARD))=1:"    ",1:"  ")_$EXTRACT($PIECE(BARVALUE,BARD,2),1,65))

 +9                KILL DIC,DIE

 +10               SET DIE="^BARADJ("

 +11               SET DA=+Y

 +12      ; Short Desc

                   SET DR=".02///^S X=$P(BARVALUE,BARD,2)"

 +13      ; RPMS Cat

                   SET DR=DR_";.03////^S X=$P(BARVALUE,BARD,3)"

 +14      ; RPMS Type

                   SET DR=DR_";.04////^S X=$P(BARVALUE,BARD,4)"

 +15      ; Long Desc

                   SET DR=DR_";101///^S X=$P(BARVALUE,BARD,5)"

 +16               DO ^DIE

               End DoDot:1

               QUIT

 +17      ;create new entry if none found

 +18       KILL DIC,DA,X,Y

 +19       SET DIC="^BARADJ("

 +20       SET DIC(0)="LZE"

 +21      ; Stnd Code

           SET X=$PIECE(BARVALUE,BARD)

 +22      ; Short Desc

           SET DIC("DR")=".02///^S X=$P(BARVALUE,BARD,2)"

 +23      ; RPMS Cat

           SET DIC("DR")=DIC("DR")_";.03////^S X=$P(BARVALUE,BARD,3)"

 +24      ; RPMS Type

           SET DIC("DR")=DIC("DR")_";.04////^S X=$P(BARVALUE,BARD,4)"

 +25      ; Long Desc

           SET DIC("DR")=DIC("DR")_";101///^S X=$P(BARVALUE,BARD,5)"

 +26       KILL DD,DO

 +27       DO MES^XPDUTL($PIECE(BARVALUE,BARD)_$SELECT($LENGTH($PIECE(BARVALUE,BARD))=2:"   ",$LENGTH($PIECE(BARVALUE,BARD))=1:"    ",1:"  ")_$EXTRACT($PIECE(BARVALUE,BARD,2),1,65))

 +28       DO FILE^DICN

 +29       QUIT

 +30      ; ********************************************************************

CLAIM     ;

 +1       ; Populate A/R EDI CLAIM STATUS CODES to accomodate new codes added

 +2       ; between 6/02 and 9/03. Inactivate necessary codes.

 +3        SET BARCNT=0

 +4        FOR

               DO CLAIM2

               IF BARVALUE="END"

                   QUIT

 +5        SET BARCNT=0

 +6        FOR BARVALUE=8,10,11,13,14,28,69,70

               DO CLAIM3

 +7        QUIT

 +8       ; ********************************************************************

CLAIM2    ;

 +1        SET BARCNT=BARCNT+1

 +2        SET BARVALUE=$PIECE($TEXT(@3+BARCNT),BARD,2,4)

 +3        IF BARVALUE="END"

               QUIT

 +4        KILL DIC,DA,X,Y

 +5        SET DIC="^BARECSC("

 +6        SET DIC(0)="LZE"

 +7       ;Status Cd

           SET X=$PIECE(BARVALUE,BARD)

 +8       ;Description

           SET DIC("DR")="11///^S X=$P(BARVALUE,BARD,2)"

 +9        KILL DD,DO

 +10       DO FILE^DICN

 +11       QUIT

 +12      ; ********************************************************************

CLAIM3    ;

 +1        KILL DIC,DA,X,Y

 +2        SET DIC="^BARECSC("

 +3        SET DIC(0)="XZQ"

 +4        SET X=BARVALUE

 +5        KILL DD,DO

 +6        DO ^DIC

 +7        IF +Y<1

               QUIT

 +8        KILL DA,DIE,DR

 +9        SET DA=+Y

 +10       SET DIE=DIC

 +11       SET DR=".02///Y"

 +12       DO ^DIE

 +13       QUIT

 +14      ; ********************************************************************

MODIFY    ; EP

 +1       ; Change PENDING to NON PAYMENT

 +2        SET BARD=";;"

 +3        SET BARCNT=0

 +4        FOR

               DO MODIFY2

               IF BARVALUE="END"

                   QUIT

 +5        QUIT

 +6       ; *********************************************************************

MODIFY2   ;

 +1        SET BARCNT=BARCNT+1

 +2        SET BARVALUE=$PIECE($TEXT(@4+BARCNT),BARD,2)

 +3        IF BARVALUE="END"

               QUIT

 +4        KILL DIC,DA,X,Y,DR

 +5        SET DIC="^BARADJ("

 +6        SET DIC(0)="Z"

 +7       ;Stnd Code

           SET X=$PIECE(BARVALUE,BARD)

 +8        KILL DD,DO

 +9        DO ^DIC

 +10       IF '+Y

               QUIT

 +11      ;

 +12       SET DIE=DIC

 +13       SET DA=+Y

 +14       SET DR=".03////^S X=4"

 +15       DO ^DIE

 +16       QUIT

 +17      ;

 +18      ; *********************************************************************

 +19      ; IEN;;NAME;;TABLE TYPE

 +20      ; *********************************************************************

1         ;; A/R Table Entry file - Adds

 +1       ;;966;;Proc/mod not comp, othr, NCCI;;4

 +2       ;;975;;Legislative/Regulatory Penalty;;15

 +3       ;;967;;Clm spans elig/inelg cov-PT;;4

 +4       ;;968;;Clm spans elig/inelg cov-OTH;;4

 +5       ;;969;;Clm spans elig/inelg cov-rebi;;4

 +6       ;;END

 +7       ;

 +8       ; ********************************************************************

 +9       ; STND CODE ;; SHORT DESC ;; RPMS CAT ;; RPMS TYP ;; LONG DESC

 +10      ; ********************************************************************

2         ;;

 +1       ;;236;;Proc/proc+mod comb not compat w/oth proc/proc+mod, same day per NCCI;;4;;966;;Proc/mod not comp, othr, NCCI

 +2       ;;237;;Legislated/Regulatory Penalty. Check Remark Codes;;15;;975;;Legislated/Regulatory Penalty. At least one Remark Code must be provided (may be comprised of either the NCPDP Reject Reason Code, or Remittance Advice Remark Code that is not an

 ALERT.)

 +3       ;;238;;Clm spans eligible, inelig periods of coverage, may be the patient's resp;;4;;967;;Claim spans eligible and ineligible periods of coverage, this is the reduction for the ineligible period (use Group Code PR).

 +4       ;;239;;Clm spans eligible, inelig periods of coverage.  Rebill separate clms;;4;;969;;Claim spans eligible and ineligible periods of coverage. Rebill separate claims.

 +5       ;;END

 +6       ;

 +7       ; ********************************************************************

 +8       ; CLAIM STATUS CODE ;; DESCRIPTION

 +9       ; ********************************************************************

3         ;; - A/R EDI Claim Status Codes file - Adds

 +1       ;;END

 +2       ;

 +3       ; ********************************************************************

 +4       ; STANDARD CODE ;; RPMS REASON

 +5       ; ********************************************************************

4         ;;A/R Table Entry file - Edits

 +1       ;;END;;END

BARADJR7.m