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
Q
; ********************************************************************
;
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"
Q
; ********************************************************************
;
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
Q
; ********************************************************************
CHNGREA ; EP
; Change category of these reasons to Non-Payment
S BARD=";;"
S BARCNT=0
F D CHNGREA2 Q:BARVALUE="END"
Q
; ********************************************************************
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
Q
; ********************************************************************
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"
Q
; ********************************************************************
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
Q
; ********************************************************************
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
Q
; ********************************************************************
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
Q
; ********************************************************************
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
Q
; ********************************************************************
MODIFY ; EP
; Change PENDING to NON PAYMENT
S BARD=";;"
S BARCNT=0
F D MODIFY2 Q:BARVALUE="END"
Q
; *********************************************************************
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
Q
;
; *********************************************************************
; 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
