Routine: BCH10P10

BCH10P10 ;IHS/CMI/LAB - PATCH 10 [ 07/25/00  8:09 AM ]

 ;;1.0;IHS RPMS CHR SYSTEM;**10**;OCT 28, 1996

 ;reflag all records dated after April 1, 2000 for re-export

 ;fix icd code in seizure disorder

 S DA=$O(^BCHTPROB("B","SEIZURE DISORDER",0))

 I DA S DIE="^BCHTPROB(",DR=".04///780.39" D ^DIE

 D ^XBFMK

 W !!,"Reflagging CHR Records for export...Hold on a moment..."

 NEW D,R,E

 S R=0,E=0 F  S R=$O(^BCHSITE(R)) Q:R'=+R  I $P($G(^BCHSITE(R,99)),U) S E=1

Q:E

 S D=3000331.9999

 F  S D=$O(^BCHR("B",D)) Q:D'=+D  D

 .S R=0 F  S R=$O(^BCHR("B",D,R)) Q:R'=+R  D

 ..Q:'$D(^BCHR(R,0))

 ..S E=$P(^BCHR(R,0),U,17)

 ..I E]"",$D(^BCHR("AEX",E,R)) Q  ;already in xref

 ..S ^BCHR("AEX",DT,R)=""  ;set back in export xref

..Q

.Q

 S R=0 F  S R=$O(^BCHSITE(R)) Q:R'=+R  S $P(^BCHSITE(R,99),U)=1

BCH10P10  ;IHS/CMI/LAB - PATCH 10 [ 07/25/00  8:09 AM ]

 +1       ;;1.0;IHS RPMS CHR SYSTEM;**10**;OCT 28, 1996

 +2       ;

 +3       ;

 +4       ;reflag all records dated after April 1, 2000 for re-export

 +5       ;fix icd code in seizure disorder

 +6        SET DA=$ORDER(^BCHTPROB("B","SEIZURE DISORDER",0))

 +7        IF DA

               SET DIE="^BCHTPROB("

               SET DR=".04///780.39"

               DO ^DIE

 +8        DO ^XBFMK

 +9        WRITE !!,"Reflagging CHR Records for export...Hold on a moment..."

 +10       NEW D,R,E

 +11       SET R=0

           SET E=0

FOR

               SET R=$ORDER(^BCHSITE(R))

               IF R'=+R

                   QUIT

               IF $PIECE($GET(^BCHSITE(R,99)),U)

                   SET E=1

 +12       IF E

               QUIT

 +13       SET D=3000331.9999

 +14       FOR

               SET D=$ORDER(^BCHR("B",D))

               IF D'=+D

                   QUIT

               Begin DoDot:1

 +15               SET R=0

FOR

                       SET R=$ORDER(^BCHR("B",D,R))

                       IF R'=+R

                           QUIT

                       Begin DoDot:2

 +16                       IF '$DATA(^BCHR(R,0))

                               QUIT

 +17                       SET E=$PIECE(^BCHR(R,0),U,17)

 +18      ;already in xref

                           IF E]""

                               IF $DATA(^BCHR("AEX",E,R))

                                   QUIT

 +19      ;set back in export xref

                           SET ^BCHR("AEX",DT,R)=""

 +20                       QUIT

                       End DoDot:2

 +21               QUIT

               End DoDot:1

 +22       SET R=0

FOR

               SET R=$ORDER(^BCHSITE(R))

               IF R'=+R

                   QUIT

               SET $PIECE(^BCHSITE(R,99),U)=1

 +23       QUIT

BCH10P10.m