Routine: BARADJR1

BARADJR1 ; IHS/SD/LSL - REPORT OF STANDARD ADJUSTMENT REASON CODES

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

 ;P.OTTIS NEW ROUTINE MAR 2013

 ;P.OTTIS added 'RPMS Code' field

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

EN ;

 NEW FILENAME,IO,PATH

 W !!!,"Will create List of Standard claim adjustment reasons"

 W !,"into a comma delimited file. Use Excel to read / print the list.",!

 S FILENAME="STND_CLAIM_ADJ_REASONS_LIST.CSV"

 S DIR(0)="F"

 S DIR("A")="Enter the directory path for the report"

 S PATH=$P($G(^BAR(90052.06,DUZ(2),DUZ(2),0)),U,17)

 S DIR("B")=PATH

 S DIR("?")="For example enter '/usr/mydir/'"

 D ^DIR

 K DIR

 Q:$D(DIRUT)

 K POP

 D OPEN^%ZISH("FILE",PATH,FILENAME,"W")

 Q:$G(POP)

 U IO D MAIN

 D CLOSE^%ZISH("FILE")

 W !!,"Done: List stored in file: ",PATH,"/",FILENAME

MAIN ;^BARADJ(42,0)="42^Charges exceed our fee schedule or maximum allowable amount^4^21"

 NEW BAR04,BARCRLF,BARD01,BARD02,BARD03,BARD04,BARDAT0,BARHDR,BARIEN,BARIENX,BARPTR2,BARPTR3,BARSEP

 S BARSEP=",",BARCRLF=$C(13,10),Q=$C(34)

 ;S BARHDR="STANDARD ADJUSTMENT CODE,SHORT DESCRIPTION,RPMS ADJUSTMENT CATEGORY,RPMS ADJUSTMENT TYPE" ;OLD CODE

 S BARHDR="STANDARD ADJUSTMENT CODE,SHORT DESCRIPTION,RPMS ADJUSTMENT CATEGORY,RPMS CODE,RPMS ADJUSTMENT TYPE" ;NEW CODE

 W BARHDR,BARCRLF

 S BARIENX="" F  S BARIENX=$O(^BARADJ("B",BARIENX)) Q:BARIENX=""  S BARIEN=$O(^BARADJ("B",BARIENX,"")) D 2

2 D  ;S BARIEN=0 F  S BARIEN=$O(^BARADJ(BARIEN)) Q:BARIEN=""  D

 . S BARDAT0=$G(^BARADJ(BARIEN,0)) I BARDAT0="" Q

 . S BAR04=$G(^BARADJ(BARIEN,1))

 . S BARD01=$P(BARDAT0,"^",1)

 . S BARD02=$P(BARDAT0,"^",2)

 . S BARPTR2=$P(BARDAT0,"^",3) ;BAR(90052.01

 . S BARPTR3=$P(BARDAT0,"^",4) ;BAR(90052.02

 . S BARD03=$P($G(^BAR(90052.01,BARPTR2,0)),"^")

 . S BARD04=$P($G(^BARTBL(BARPTR3,0)),"^")

 . ;W Q,BARD01,Q,BARSEP,Q,BARD02,Q,BARSEP,Q,BARD03,Q,BARSEP,Q,BARD04,Q,BARCRLF ;OLD CODE

 . W Q,BARD01,Q,BARSEP,Q,BARD02,Q,BARSEP,Q,BARD03,Q,BARSEP,Q,BARPTR3,Q,BARSEP,Q,BARD04,Q,BARCRLF

BARADJR1  ; IHS/SD/LSL - REPORT OF STANDARD ADJUSTMENT REASON CODES

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

 +2       ;P.OTTIS NEW ROUTINE MAR 2013

 +3       ;P.OTTIS added 'RPMS Code' field

 +4       ;

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

 +6        QUIT

EN        ;

 +1        NEW FILENAME,IO,PATH

 +2        WRITE !!!,"Will create List of Standard claim adjustment reasons"

 +3        WRITE !,"into a comma delimited file. Use Excel to read / print the list.",!

 +4        SET FILENAME="STND_CLAIM_ADJ_REASONS_LIST.CSV"

 +5        SET DIR(0)="F"

 +6        SET DIR("A")="Enter the directory path for the report"

 +7        SET PATH=$PIECE($GET(^BAR(90052.06,DUZ(2),DUZ(2),0)),U,17)

 +8        SET DIR("B")=PATH

 +9        SET DIR("?")="For example enter '/usr/mydir/'"

 +10       DO ^DIR

 +11       KILL DIR

 +12       IF $DATA(DIRUT)

               QUIT

 +13       KILL POP

 +14       DO OPEN^%ZISH("FILE",PATH,FILENAME,"W")

 +15       IF $GET(POP)

               QUIT

 +16       USE IO

           DO MAIN

 +17       DO CLOSE^%ZISH("FILE")

 +18       WRITE !!,"Done: List stored in file: ",PATH,"/",FILENAME

 +19       QUIT

MAIN      ;^BARADJ(42,0)="42^Charges exceed our fee schedule or maximum allowable amount^4^21"

 +1        NEW BAR04,BARCRLF,BARD01,BARD02,BARD03,BARD04,BARDAT0,BARHDR,BARIEN,BARIENX,BARPTR2,BARPTR3,BARSEP

 +2        SET BARSEP=","

           SET BARCRLF=$CHAR(13,10)

           SET Q=$CHAR(34)

 +3       ;S BARHDR="STANDARD ADJUSTMENT CODE,SHORT DESCRIPTION,RPMS ADJUSTMENT CATEGORY,RPMS ADJUSTMENT TYPE" ;OLD CODE

 +4       ;NEW CODE

           SET BARHDR="STANDARD ADJUSTMENT CODE,SHORT DESCRIPTION,RPMS ADJUSTMENT CATEGORY,RPMS CODE,RPMS ADJUSTMENT TYPE"

 +5        WRITE BARHDR,BARCRLF

 +6        SET BARIENX=""

FOR

               SET BARIENX=$ORDER(^BARADJ("B",BARIENX))

               IF BARIENX=""

                   QUIT

               SET BARIEN=$ORDER(^BARADJ("B",BARIENX,""))

               DO 2

 +7        QUIT

2         ;S BARIEN=0 F  S BARIEN=$O(^BARADJ(BARIEN)) Q:BARIEN=""  D

           Begin DoDot:1

 +1            SET BARDAT0=$GET(^BARADJ(BARIEN,0))

               IF BARDAT0=""

                   QUIT

 +2            SET BAR04=$GET(^BARADJ(BARIEN,1))

 +3            SET BARD01=$PIECE(BARDAT0,"^",1)

 +4            SET BARD02=$PIECE(BARDAT0,"^",2)

 +5       ;BAR(90052.01

               SET BARPTR2=$PIECE(BARDAT0,"^",3)

 +6       ;BAR(90052.02

               SET BARPTR3=$PIECE(BARDAT0,"^",4)

 +7            SET BARD03=$PIECE($GET(^BAR(90052.01,BARPTR2,0)),"^")

 +8            SET BARD04=$PIECE($GET(^BARTBL(BARPTR3,0)),"^")

 +9       ;W Q,BARD01,Q,BARSEP,Q,BARD02,Q,BARSEP,Q,BARD03,Q,BARSEP,Q,BARD04,Q,BARCRLF ;OLD CODE

 +10           WRITE Q,BARD01,Q,BARSEP,Q,BARD02,Q,BARSEP,Q,BARD03,Q,BARSEP,Q,BARPTR3,Q,BARSEP,Q,BARD04,Q,BARCRLF

           End DoDot:1

 +11       QUIT

BARADJR1.m