BAREDPZ1 ; IHS/SD/LSL - AHCCCS IMPORT ROUTINE ;
;;1.8;IHS ACCOUNTS RECEIVABLE;;OCT 26, 2005
;
; IHS/SD/LSL - 06/26/2002 - V1.6 Patch 2 - NOIS XXX-0602-200032
; Modified to be FM22 compliant
;
; IHS/SD/LSL - 03/17/2003 - V1.7 Patch 1 - IM10293
; If AHCCCS doesn't send a bill number I modified PAYAMT
; to look for NO BILL NUMBER IN FILE instead of crashing with
; <SBSCR>*XECUTE*NEW+65^DICN
;
; IHS/SD/LSL - 02/09/2004 - V1.7 Patch 5 - IM12514
; Denial codes for proprietary AHCCCS ERA not working properly
;
; *********************************************************************
Q
;
SEP ;EP Set seperators
S S="~",E="`",SE=" " ;SE is 2 spaces used in the CC seg Reason Element
Q
; *********************************************************************
;
DT ;EP Conversion of date to readable format
S X=$E(X,5,6)_"/"_$E(X,7,8)_"/"_$E(X,1,4)
S %DT="X"
D ^%DT,DD^%DT
S X=Y
Q
; *********************************************************************
;
PAYAMT ;Load Claim data
W:'(COUNT#10) "."
W:'(COUNT#100) " ",COUNT,!
S COUNT=COUNT+1
K DIC,DR,DA,DIE
S DIC=$$DIC^XBDIQ1(90056.0205)
S DIC(0)="XL"
S DIC("P")="90056.0205A"
S X=$P(VBILNM,"-")
W !,X,?15,VBILNM
I X="" D ; LSL 03/17/0/3
. W "NO BILL NUMBER IN FILE"
. S X="NO BILL"
S DA(1)=IMPDA
K DD,DO,D0
D FILE^DICN
S CLMDA=+Y
S DA=+Y
S DIE=DIC
K DIC
K DR
S DR=".04///^S X=VPAYAMT;.05///^S X=VBILAMT"
D ^DIE
S PAT=VPATLN_","_VPATFN_" "_VPATMN
S DR=".06///^S X=PAT;.08///^S X=VDOSB;.09///^S X=VDOSE"
D ^DIE
S ADJDA=0
Q
; *********************************************************************
;
ADJREA ;EP Process reason and amount into claim impda,clmda
S VADJAMT=VBILAMT-VPAYAMT
I '$L(VADJREA) Q
S VADJCAT=$E(VADJCAT)
I VADJCAT="A" Q
I VADJCAT'="R" D Q
. S VADJREA=VADJCAT_" | "_$P(VADJREA,SE,2)
. D SET1ADJ
; process reason code(s)
S XXX=$P(VADJREA,": ",2)
I '$F(XXX,SE) D Q
. S X=XXX
. D CLMCODE^BAREDP02
. S VADJREA=X
. D SET1ADJ
F I=1:1 S X=$P(XXX,SE,I) Q:'$L(X) D
. S:I>1 VADJAMT=0 ; assign amt to the 1st reason only
. D CLMCODE^BAREDP02 ; lookup reason in Claim Level Reasons table
. S VADJREA=X
. D SET1ADJ
Q
; *********************************************************************
;
SET1ADJ ; set one adjustment X|reason, AMT
S ADJDA=ADJDA+1
K DIE,DR,DA,X,DIC
S DA(2)=IMPDA
S DA(1)=CLMDA
S X=ADJDA
S DIC=$$DIC^XBDIQ1(90056.0208)
S DIC("P")="90056.0208A"
S DIC(0)="EXL"
S DIC("DR")=".02///^S X=VADJAMT;.03////^S X=VADJREA"
D ^DIC
Q
; *********************************************************************
;
CHKNUM ;EP Enter Check mumber into Import
K DIE,DR,DA
S DIE=$$DIC^XBDIQ1(90056.02)
S DA=IMPDA
S DR=".09////^S X=VCHKNUM"
D ^DIE
;
ECHECK ;
Q
; *********************************************************************
;
LOAD ;EP Scan all AHCCCS imports loaded for new reason codes and stuff them
; into the Claim Level Reason Codes table for mapping.
EN ;
S FDA=0
F S FDA=$O(^BAREDI("I",2917,FDA)) Q:FDA'>0 D FILE
Q
; *********************************************************************
;
FILE ;
S FDA0=^BAREDI("I",2917,FDA,0)
I $P(FDA0,U,3)'=4 Q
W !,FDA0
D REASON
Q
; *********************************************************************
;
REASON ;
F L=1:1 Q:'$D(^BAREDI("I",2917,FDA,15,L)) S X=^(L,0) D
. I '(L#100) W "."
. I $E(X,1,2)="PN" D PN
Q
; *********************************************************************
;
PN ;
S CODE=$P(X,"`",2)
S REA=$P(X,"`",3)
I '$D(^BAREDI("1T",4,40,"B",CODE)) D
. W !,CODE,?10,REA
. S ^PWTMP("AHC",CODE)=REA
Q
; *********************************************************************
;
PUT ; FILE NEW INTO CLAIM LEVEL MULTIPLE
S CODE=""
F S CODE=$O(^PWTMP("AHC",CODE)) Q:CODE="" D SET
Q
; *********************************************************************
;
SET ;
K DIC,DR,DA
S X=CODE
S REA=^PWTMP("AHC",CODE)
S DA(1)=4
W !,CODE,?10,REA
Q
; *********************************************************************
;
END ;
Q
; *********************************************************************
;
AHCCCS ;EP enter new table entries for AHCCCS
;;
Q
; *********************************************************************
;
MAP ;EP repoint the distributed tabled reason pointers to the new ones installed
Q
; *********************************************************************
;
1001 ;;BAD DEBT/COLLECTION AGENCY^3^WO
1002 ;;CODING ERROR^4^NONPAY
1003 ;;RX PROCESSING FEE^3^WO^123
1004 ;;OTHER TPL^4^NONPAY
1005 ;;MISSING DATA^4^NONPAY
1006 ;;INCORRECT PROVIDER TYPE^4^NONPAY
1007 ;;MISSING FIELD^4^NONPAY
1008 ;;DOCUMENTATION REQUIRED^4^NONPAY
BAREDPZ1 ; IHS/SD/LSL - AHCCCS IMPORT ROUTINE ;
+1 ;;1.8;IHS ACCOUNTS RECEIVABLE;;OCT 26, 2005
+2 ;
+3 ; IHS/SD/LSL - 06/26/2002 - V1.6 Patch 2 - NOIS XXX-0602-200032
+4 ; Modified to be FM22 compliant
+5 ;
+6 ; IHS/SD/LSL - 03/17/2003 - V1.7 Patch 1 - IM10293
+7 ; If AHCCCS doesn't send a bill number I modified PAYAMT
+8 ; to look for NO BILL NUMBER IN FILE instead of crashing with
+9 ; <SBSCR>*XECUTE*NEW+65^DICN
+10 ;
+11 ; IHS/SD/LSL - 02/09/2004 - V1.7 Patch 5 - IM12514
+12 ; Denial codes for proprietary AHCCCS ERA not working properly
+13 ;
+14 ; *********************************************************************
+15 QUIT
+16 ;
SEP ;EP Set seperators
+1 ;SE is 2 spaces used in the CC seg Reason Element
SET S="~"
SET E="`"
SET SE=" "
+2 QUIT
+3 ; *********************************************************************
+4 ;
DT ;EP Conversion of date to readable format
+1 SET X=$EXTRACT(X,5,6)_"/"_$EXTRACT(X,7,8)_"/"_$EXTRACT(X,1,4)
+2 SET %DT="X"
+3 DO ^%DT
DO DD^%DT
+4 SET X=Y
+5 QUIT
+6 ; *********************************************************************
+7 ;
PAYAMT ;Load Claim data
+1 IF '(COUNT#10)
WRITE "."
+2 IF '(COUNT#100)
WRITE " ",COUNT,!
+3 SET COUNT=COUNT+1
+4 KILL DIC,DR,DA,DIE
+5 SET DIC=$$DIC^XBDIQ1(90056.0205)
+6 SET DIC(0)="XL"
+7 SET DIC("P")="90056.0205A"
+8 SET X=$PIECE(VBILNM,"-")
+9 WRITE !,X,?15,VBILNM
+10 ; LSL 03/17/0/3
IF X=""
Begin DoDot:1
+11 WRITE "NO BILL NUMBER IN FILE"
+12 SET X="NO BILL"
End DoDot:1
+13 SET DA(1)=IMPDA
+14 KILL DD,DO,D0
+15 DO FILE^DICN
+16 SET CLMDA=+Y
+17 SET DA=+Y
+18 SET DIE=DIC
+19 KILL DIC
+20 KILL DR
+21 SET DR=".04///^S X=VPAYAMT;.05///^S X=VBILAMT"
+22 DO ^DIE
+23 SET PAT=VPATLN_","_VPATFN_" "_VPATMN
+24 SET DR=".06///^S X=PAT;.08///^S X=VDOSB;.09///^S X=VDOSE"
+25 DO ^DIE
+26 SET ADJDA=0
+27 QUIT
+28 ; *********************************************************************
+29 ;
ADJREA ;EP Process reason and amount into claim impda,clmda
+1 SET VADJAMT=VBILAMT-VPAYAMT
+2 IF '$LENGTH(VADJREA)
QUIT
+3 SET VADJCAT=$EXTRACT(VADJCAT)
+4 IF VADJCAT="A"
QUIT
+5 IF VADJCAT'="R"
Begin DoDot:1
+6 SET VADJREA=VADJCAT_" | "_$PIECE(VADJREA,SE,2)
+7 DO SET1ADJ
End DoDot:1
QUIT
+8 ; process reason code(s)
+9 SET XXX=$PIECE(VADJREA,": ",2)
+10 IF '$FIND(XXX,SE)
Begin DoDot:1
+11 SET X=XXX
+12 DO CLMCODE^BAREDP02
+13 SET VADJREA=X
+14 DO SET1ADJ
End DoDot:1
QUIT
+15 FOR I=1:1
SET X=$PIECE(XXX,SE,I)
IF '$LENGTH(X)
QUIT
Begin DoDot:1
+16 ; assign amt to the 1st reason only
IF I>1
SET VADJAMT=0
+17 ; lookup reason in Claim Level Reasons table
DO CLMCODE^BAREDP02
+18 SET VADJREA=X
+19 DO SET1ADJ
End DoDot:1
+20 QUIT
+21 ; *********************************************************************
+22 ;
SET1ADJ ; set one adjustment X|reason, AMT
+1 SET ADJDA=ADJDA+1
+2 KILL DIE,DR,DA,X,DIC
+3 SET DA(2)=IMPDA
+4 SET DA(1)=CLMDA
+5 SET X=ADJDA
+6 SET DIC=$$DIC^XBDIQ1(90056.0208)
+7 SET DIC("P")="90056.0208A"
+8 SET DIC(0)="EXL"
+9 SET DIC("DR")=".02///^S X=VADJAMT;.03////^S X=VADJREA"
+10 DO ^DIC
+11 QUIT
+12 ; *********************************************************************
+13 ;
CHKNUM ;EP Enter Check mumber into Import
+1 KILL DIE,DR,DA
+2 SET DIE=$$DIC^XBDIQ1(90056.02)
+3 SET DA=IMPDA
+4 SET DR=".09////^S X=VCHKNUM"
+5 DO ^DIE
+6 ;
ECHECK ;
+1 QUIT
+2 ; *********************************************************************
+3 ;
LOAD ;EP Scan all AHCCCS imports loaded for new reason codes and stuff them
+1 ; into the Claim Level Reason Codes table for mapping.
EN ;
+1 SET FDA=0
+2 FOR
SET FDA=$ORDER(^BAREDI("I",2917,FDA))
IF FDA'>0
QUIT
DO FILE
+3 QUIT
+4 ; *********************************************************************
+5 ;
FILE ;
+1 SET FDA0=^BAREDI("I",2917,FDA,0)
+2 IF $PIECE(FDA0,U,3)'=4
QUIT
+3 WRITE !,FDA0
+4 DO REASON
+5 QUIT
+6 ; *********************************************************************
+7 ;
REASON ;
+1 FOR L=1:1
IF '$DATA(^BAREDI("I",2917,FDA,15,L))
QUIT
SET X=^(L,0)
Begin DoDot:1
+2 IF '(L#100)
WRITE "."
+3 IF $EXTRACT(X,1,2)="PN"
DO PN
End DoDot:1
+4 QUIT
+5 ; *********************************************************************
+6 ;
PN ;
+1 SET CODE=$PIECE(X,"`",2)
+2 SET REA=$PIECE(X,"`",3)
+3 IF '$DATA(^BAREDI("1T",4,40,"B",CODE))
Begin DoDot:1
+4 WRITE !,CODE,?10,REA
+5 SET ^PWTMP("AHC",CODE)=REA
End DoDot:1
+6 QUIT
+7 ; *********************************************************************
+8 ;
PUT ; FILE NEW INTO CLAIM LEVEL MULTIPLE
+1 SET CODE=""
+2 FOR
SET CODE=$ORDER(^PWTMP("AHC",CODE))
IF CODE=""
QUIT
DO SET
+3 QUIT
+4 ; *********************************************************************
+5 ;
SET ;
+1 KILL DIC,DR,DA
+2 SET X=CODE
+3 SET REA=^PWTMP("AHC",CODE)
+4 SET DA(1)=4
+5 WRITE !,CODE,?10,REA
+6 QUIT
+7 ; *********************************************************************
+8 ;
END ;
+1 QUIT
+2 ; *********************************************************************
+3 ;
AHCCCS ;EP enter new table entries for AHCCCS
+1 ;;
+2 QUIT
+3 ; *********************************************************************
+4 ;
MAP ;EP repoint the distributed tabled reason pointers to the new ones installed
+1 QUIT
+2 ; *********************************************************************
+3 ;
1001 ;;BAD DEBT/COLLECTION AGENCY^3^WO
1002 ;;CODING ERROR^4^NONPAY
1003 ;;RX PROCESSING FEE^3^WO^123
1004 ;;OTHER TPL^4^NONPAY
1005 ;;MISSING DATA^4^NONPAY
1006 ;;INCORRECT PROVIDER TYPE^4^NONPAY
1007 ;;MISSING FIELD^4^NONPAY
1008 ;;DOCUMENTATION REQUIRED^4^NONPAY
