BAR50PZ1.m

BAR50PZ1 ; IHS/SD/LSL - AHCCCS IMPORT ROUTINE ;

 ;;1.8;IHS ACCOUNTS RECEIVABLE;**21**;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^BAR50P02

 . 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^BAR50P02 ; 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

BAR50PZ1  ; IHS/SD/LSL - AHCCCS IMPORT ROUTINE ;

 +1       ;;1.8;IHS ACCOUNTS RECEIVABLE;**21**;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^BAR50P02

 +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^BAR50P02

 +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