BARADJRA.m

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

 ;;1.8;IHS ACCOUNTS RECEIVABLE;;OCT 26, 2005

 ;

 ; IHS/SD/LSL - 10/06/2003 - V1.7 Patch 4

 ;     For HIPAA compliance.  Modify description of AR Adjustment

 ;     to be more descriptive.

 ;

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

 Q

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

ENTRY ; EP

 ; Edit entries into A/R Table Entry File (Adj Reasons)

 ;L +^BARTBL

 L +^BARTBL:5 S X=$T

 I 'X D  Q

 . W *7,!!,"Cannot update HIPAA Standard Adjustment Reasons at this time."

 . W !,"Contact ITSC Support to obtain instructions for updating"

 . W !,"HIPAA Standard Adjustments after this install is complete."

 . W !!,"....continuing this KIDS installation."

 . D EOP^BARUTL(1)

 S BARD=";;"

 S BARCNT=0

 F  D EN2 Q:BARTYPE="END"

 L -^BARTBL

 D ^BARVKL0

 Q

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

EN2 ;

 S BARCNT=BARCNT+1

 S BARTYPE=$P($T(@1+BARCNT),BARD,2,3)

 Q:BARTYPE="END"

 S BARTAG=$P(BARTYPE,BARD)

 S BARRTN=$P(BARTYPE,BARD,2)

 S BARCNT2=0

 F  D TYPE Q:BARVALUE="END"

 Q

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

TYPE ;

 S BARCNT2=BARCNT2+1

 S BARVALUE=$P($T(@BARTAG+BARCNT2^@BARRTN),BARD,2,5)

 Q:BARVALUE="END"

 K DIC,DA,X,Y,DIE,DR

 S DIE="^BARTBL("

 S DA=$P(BARVALUE,BARD)

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

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

 D ^DIE

 Q

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

 ;; LINE TAG ;; ROUTINE

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

1 ;;

 ;;DEDUCT;;BARADJRB

 ;;COPAY;;BARADJRB

 ;;PENDING;;BARADJRC

 ;;NONPYMT;;BARADJRD

 ;;PENALTY;;BARADJRB

 ;;GENINFO;;BARADJRB

 ;;GRPALLOW;;BARADJRB

 ;;WRITEOFF;;BARADJRB

 ;;REFUND;;BARADJRB

 ;;END

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

 +1       ;;1.8;IHS ACCOUNTS RECEIVABLE;;OCT 26, 2005

 +2       ;

 +3       ; IHS/SD/LSL - 10/06/2003 - V1.7 Patch 4

 +4       ;     For HIPAA compliance.  Modify description of AR Adjustment

 +5       ;     to be more descriptive.

 +6       ;

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

 +8        QUIT 

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

ENTRY     ; EP

 +1       ; Edit entries into A/R Table Entry File (Adj Reasons)

 +2       ;L +^BARTBL

 +3        LOCK +^BARTBL:5

           SET X=$TEST

 +4        IF 'X

               Begin DoDot:1

 +5                WRITE *7,!!,"Cannot update HIPAA Standard Adjustment Reasons at this time."

 +6                WRITE !,"Contact ITSC Support to obtain instructions for updating"

 +7                WRITE !,"HIPAA Standard Adjustments after this install is complete."

 +8                WRITE !!,"....continuing this KIDS installation."

 +9                DO EOP^BARUTL(1)

               End DoDot:1

               QUIT 

 +10       SET BARD=";;"

 +11       SET BARCNT=0

 +12       FOR 

               DO EN2

               IF BARTYPE="END"

                   QUIT 

 +13       LOCK -^BARTBL

 +14       DO ^BARVKL0

 +15       QUIT 

 +16      ; ********************************************************************

EN2       ;

 +1        SET BARCNT=BARCNT+1

 +2        SET BARTYPE=$PIECE($TEXT(@1+BARCNT),BARD,2,3)

 +3        IF BARTYPE="END"

               QUIT 

 +4        SET BARTAG=$PIECE(BARTYPE,BARD)

 +5        SET BARRTN=$PIECE(BARTYPE,BARD,2)

 +6        SET BARCNT2=0

 +7        FOR 

               DO TYPE

               IF BARVALUE="END"

                   QUIT 

 +8        QUIT 

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

TYPE      ;

 +1        SET BARCNT2=BARCNT2+1

 +2        SET BARVALUE=$PIECE($TEXT(@BARTAG+BARCNT2^@BARRTN),BARD,2,5)

 +3        IF BARVALUE="END"

               QUIT 

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

 +5        SET DIE="^BARTBL("

 +6        SET DA=$PIECE(BARVALUE,BARD)

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

 +8        SET DR=DR_";2////^S X=$P(BARVALUE,BARD,3)"

 +9        DO ^DIE

 +10       QUIT 

 +11      ; *********************************************************************

 +12      ;; LINE TAG ;; ROUTINE

 +13      ; *********************************************************************

1         ;;

 +1       ;;DEDUCT;;BARADJRB

 +2       ;;COPAY;;BARADJRB

 +3       ;;PENDING;;BARADJRC

 +4       ;;NONPYMT;;BARADJRD

 +5       ;;PENALTY;;BARADJRB

 +6       ;;GENINFO;;BARADJRB

 +7       ;;GRPALLOW;;BARADJRB

 +8       ;;WRITEOFF;;BARADJRB

 +9       ;;REFUND;;BARADJRB

 +10      ;;END