Routine: BARMPAS5

BARMPAS5  ;IHS/SD/PKD - Patient Account Statement ;

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

 ;P.OTT NEW ROUTINE APR 2013 CALLED FROM BARFX001

 ;re-indexing old staments in ^XTMP('BARPAS' is needed

 ;due to PAS sorting introduced in P23

FIXPAS ;

 L +^TMP($J,"BARPAS_REINDEX"):600

 I '$T W !,"Cannot get lock on ^TMP($J,'BARPAS_REINDEX') - cannot reindex." Q

 S BARCNT=0

 S BARFILE="BARPAS" F  S BARFILE=$O(^XTMP(BARFILE)) Q:BARFILE=""  Q:BARFILE'["BARPAS"  D

 . S BARCNT=BARCNT+1 W !,BARCNT,". ",BARFILE

 . S BARSRTBY=$G(^XTMP(BARFILE,0,"SORTBY"),-1)

 . I BARSRTBY<0 D REINDEX(BARFILE) Q

 . I BARSRTBY>1 D DELETE(BARFILE) Q

 . W "  file is ok - no re-indexing needed"

 L -^TMP($J,"BARPAS_REINDEX")

REINDEX(BARFILE) ;

 D DOIT

DOIT ;

 K ^TMP($J,"BARPAS_REINDEX")

 L +^XTMP(BARFILE):360 E  W !,"CANNOT GET LOCK OF ^XTMP(",BARFILE QUIT

 W !,"FILE ",BARFILE," WILL BE NOW RE-INDEXED"

 M ^TMP($J,"BARPAS_REINDEX",BARFILE,0)=^XTMP(BARFILE,0)

 S BARLOC=0 F  S BARLOC=$O(^XTMP(BARFILE,BARLOC)) Q:+BARLOC=0  D

 . M ^TMP($J,"BARPAS_REINDEX",BARFILE,BARLOC,0,"BARFILE")=^XTMP(BARFILE,BARLOC)

 . ;;;M ^TMP($J,"BARPAS_REINDEX",BARFILE,BARLOC)=^XTMP(BARFILE,BARLOC)

 S ^TMP($J,"BARPAS_REINDEX",BARFILE,0,"SORTBY")=0

 S ^TMP($J,"BARPAS_REINDEX",BARFILE,0,"REINDEXED")=$H

 K ^XTMP(BARFILE)

 M ^XTMP(BARFILE)=^TMP($J,"BARPAS_REINDEX",BARFILE)

 K ^TMP($J,"BARPAS_REINDEX",BARFILE)

 L -^XTMP(BARFILE)

 W "  ....  DONE"

DELETE(BARFILE) ;

 W !,"FILE ",BARFILE," WILL BE REMOVED. HAS INVALID SORTING ORDER: ",BARSRTBY

 K ^XTMP(BARFILE)

TEST ;TEST - NO RE-NDEXING

 W !,"THIS IS A TEST RUN TO SIMULATE RE-IDEXING."

 W !,"NO CHANGES IN ^XTMP WILL BE DONE."

 S BARCNT=0

 S BARFILE="BARPAS" F  S BARFILE=$O(^XTMP(BARFILE)) Q:BARFILE=""  Q:BARFILE'["BARPAS"  D

 . S BARCNT=BARCNT+1 W !,BARCNT,". ",BARFILE

 . S BARSRTBY=$G(^XTMP(BARFILE,0,"SORTBY"),-1) ;P.OTT

 . I BARSRTBY<0 D  Q

 . . W !,"FILE ",BARFILE," SHOULD BE NOW RE-INDEXED" ;R ASD

 . I BARSRTBY>1 D  Q

 . . W !,"FILE ",BARFILE," SHOULD BE NOW RE-INDEXED" ;R ASD

 . W " NO ADJUSTMENT NEEDED"

 W !,"ALL DONE"

BARMPAS5  ;IHS/SD/PKD - Patient Account Statement ;

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

 +2       ;P.OTT NEW ROUTINE APR 2013 CALLED FROM BARFX001

 +3       ;re-indexing old staments in ^XTMP('BARPAS' is needed

 +4       ;due to PAS sorting introduced in P23

 +5       ;

 +6        QUIT

FIXPAS    ;

 +1        LOCK +^TMP($JOB,"BARPAS_REINDEX"):600

 +2        IF '$TEST

               WRITE !,"Cannot get lock on ^TMP($J,'BARPAS_REINDEX') - cannot reindex."

               QUIT

 +3        SET BARCNT=0

 +4        SET BARFILE="BARPAS"

FOR

               SET BARFILE=$ORDER(^XTMP(BARFILE))

               IF BARFILE=""

                   QUIT

               IF BARFILE'["BARPAS"

                   QUIT

               Begin DoDot:1

 +5                SET BARCNT=BARCNT+1

                   WRITE !,BARCNT,". ",BARFILE

 +6                SET BARSRTBY=$GET(^XTMP(BARFILE,0,"SORTBY"),-1)

 +7                IF BARSRTBY<0

                       DO REINDEX(BARFILE)

                       QUIT

 +8                IF BARSRTBY>1

                       DO DELETE(BARFILE)

                       QUIT

 +9                WRITE "  file is ok - no re-indexing needed"

               End DoDot:1

 +10       LOCK -^TMP($JOB,"BARPAS_REINDEX")

 +11       QUIT

REINDEX(BARFILE) ;

 +1        DO DOIT

 +2        QUIT

DOIT      ;

 +1        KILL ^TMP($JOB,"BARPAS_REINDEX")

 +2        LOCK +^XTMP(BARFILE):360

          IF '$TEST

               WRITE !,"CANNOT GET LOCK OF ^XTMP(",BARFILE

               QUIT

 +3        WRITE !,"FILE ",BARFILE," WILL BE NOW RE-INDEXED"

 +4        MERGE ^TMP($JOB,"BARPAS_REINDEX",BARFILE,0)=^XTMP(BARFILE,0)

 +5        SET BARLOC=0

FOR

               SET BARLOC=$ORDER(^XTMP(BARFILE,BARLOC))

               IF +BARLOC=0

                   QUIT

               Begin DoDot:1

 +6                MERGE ^TMP($JOB,"BARPAS_REINDEX",BARFILE,BARLOC,0,"BARFILE")=^XTMP(BARFILE,BARLOC)

 +7       ;;;M ^TMP($J,"BARPAS_REINDEX",BARFILE,BARLOC)=^XTMP(BARFILE,BARLOC)

               End DoDot:1

 +8        SET ^TMP($JOB,"BARPAS_REINDEX",BARFILE,0,"SORTBY")=0

 +9        SET ^TMP($JOB,"BARPAS_REINDEX",BARFILE,0,"REINDEXED")=$HOROLOG

 +10       KILL ^XTMP(BARFILE)

 +11       MERGE ^XTMP(BARFILE)=^TMP($JOB,"BARPAS_REINDEX",BARFILE)

 +12       KILL ^TMP($JOB,"BARPAS_REINDEX",BARFILE)

 +13       LOCK -^XTMP(BARFILE)

 +14       WRITE "  ....  DONE"

 +15       QUIT

DELETE(BARFILE) ;

 +1        WRITE !,"FILE ",BARFILE," WILL BE REMOVED. HAS INVALID SORTING ORDER: ",BARSRTBY

 +2        KILL ^XTMP(BARFILE)

 +3        QUIT

TEST      ;TEST - NO RE-NDEXING

 +1        WRITE !,"THIS IS A TEST RUN TO SIMULATE RE-IDEXING."

 +2        WRITE !,"NO CHANGES IN ^XTMP WILL BE DONE."

 +3        SET BARCNT=0

 +4        SET BARFILE="BARPAS"

FOR

               SET BARFILE=$ORDER(^XTMP(BARFILE))

               IF BARFILE=""

                   QUIT

               IF BARFILE'["BARPAS"

                   QUIT

               Begin DoDot:1

 +5                SET BARCNT=BARCNT+1

                   WRITE !,BARCNT,". ",BARFILE

 +6       ;P.OTT

                   SET BARSRTBY=$GET(^XTMP(BARFILE,0,"SORTBY"),-1)

 +7                IF BARSRTBY<0

                       Begin DoDot:2

 +8       ;R ASD

                           WRITE !,"FILE ",BARFILE," SHOULD BE NOW RE-INDEXED"

                       End DoDot:2

                       QUIT

 +9                IF BARSRTBY>1

                       Begin DoDot:2

 +10      ;R ASD

                           WRITE !,"FILE ",BARFILE," SHOULD BE NOW RE-INDEXED"

                       End DoDot:2

                       QUIT

 +11               WRITE " NO ADJUSTMENT NEEDED"

               End DoDot:1

 +12       WRITE !,"ALL DONE"

 +13       QUIT

BARMPAS5.m