APCDDUPP.m

APCDDUPP ; IHS/CMI/LAB - find and delete duplicate visits ;

 ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 ;

 ;

 W !!,"This routine will find all visits that have duplicate primary providers"

 W !,"and delete one of the primary provider entries.",!!

 D EN^XBVK("APCD")

 ;

GETDATES ;

DATES ;

 S (APCDBD,APCDED,APCDSD)=""

 K DIR W ! S DIR(0)="DO^::EXP",DIR("A")="Enter Beginning Visit Date"

 D ^DIR Q:Y<1  S APCDBD=Y

 K DIR S DIR(0)="DO^::EXP",DIR("A")="Enter Ending Visit Date"

 D ^DIR Q:Y<1  S APCDED=Y

 ;

 I APCDED<APCDBD D  G DATES

 . W !!,$C(7),"Sorry, Ending Visit Date MUST not be earlier than Beginning Visit Date."

 S APCDSD=$$FMADD^XLFDT(APCDBD,-1)_".9999"

 ;

 S DIR(0)="Y",DIR("A")="Do you want to continue",DIR("B")="N" KILL DA D ^DIR KILL DIR

 I 'Y D EOJ Q

 ;

PROCESS ;

 S APCDCNT=0

 F  S APCDSD=$O(^AUPNVSIT("B",APCDSD)) Q:APCDSD=""!($P(APCDSD,".")>APCDED)  D

 .;W "+"

 .S APCDV=0 F  S APCDV=$O(^AUPNVSIT("B",APCDSD,APCDV)) Q:APCDV'=+APCDV  D CHECK

 .Q

 W !!,"A total of ",APCDCNT," duplicate primary providers were deleted."

 D EOJ

 Q

 ;

EOJ ;

 D EN^XBVK("APCD")

 D ^XBFMK

 D KILL^AUPNPAT

 K AUPNVSIT

 Q

CHECK ;

 Q:$P(^AUPNVSIT(APCDV,0),U,11)  ;deleted visit, do not check

 Q:'$P(^AUPNVSIT(APCDV,0),U,9)  ;no dependent entries so don't bother

 ;loop through V PROVIDER and check for duplicate primary providers

 K APCDPRV  ;array of primary providers

 S APCDP=0 F  S APCDP=$O(^AUPNVPRV("AD",APCDV,APCDP)) Q:APCDP'=+APCDP  D

 .Q:'$D(^AUPNVPRV(APCDP,0))  ;bad xref

 .Q:$P(^AUPNVPRV(APCDP,0),U,4)'="P"  ;not primary so don't bother

 .S X=$P(^AUPNVPRV(APCDP,0),U)  ;provider pointer

 .I $D(APCDPRV(X)) D DELETE Q  ;already have this one so delete it

 .S APCDPRV(X)=""

 .Q

 Q

DELETE ;

 W !,"Deleting provider ",$P(^VA(200,X,0),U)," from visit: "

 W !?10,"Patient: ",$$VAL^XBDIQ1(9000010,APCDV,.05),"  visit date: ",$$VAL^XBDIQ1(9000010,APCDV,.01)

 S APCDCNT=APCDCNT+1

 S DA=APCDP,DIK="^AUPNVPRV(" D ^DIK D ^XBFMK

 S AUPNVSIT=APCDV D MOD^AUPNVSIT K AUPNVSIT

 Q

APCDDUPP  ; IHS/CMI/LAB - find and delete duplicate visits ;

 +1       ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 +2       ;

 +3       ;

 +4        WRITE !!,"This routine will find all visits that have duplicate primary providers"

 +5        WRITE !,"and delete one of the primary provider entries.",!!

 +6        DO EN^XBVK("APCD")

 +7       ;

GETDATES  ;

DATES     ;

 +1        SET (APCDBD,APCDED,APCDSD)=""

 +2        KILL DIR

           WRITE !

           SET DIR(0)="DO^::EXP"

           SET DIR("A")="Enter Beginning Visit Date"

 +3        DO ^DIR

           IF Y<1

               QUIT 

           SET APCDBD=Y

 +4        KILL DIR

           SET DIR(0)="DO^::EXP"

           SET DIR("A")="Enter Ending Visit Date"

 +5        DO ^DIR

           IF Y<1

               QUIT 

           SET APCDED=Y

 +6       ;

 +7        IF APCDED<APCDBD

               Begin DoDot:1

 +8                WRITE !!,$CHAR(7),"Sorry, Ending Visit Date MUST not be earlier than Beginning Visit Date."

               End DoDot:1

               GOTO DATES

 +9        SET APCDSD=$$FMADD^XLFDT(APCDBD,-1)_".9999"

 +10      ;

 +11       SET DIR(0)="Y"

           SET DIR("A")="Do you want to continue"

           SET DIR("B")="N"

           KILL DA

           DO ^DIR

           KILL DIR

 +12       IF 'Y

               DO EOJ

               QUIT 

 +13      ;

PROCESS   ;

 +1        SET APCDCNT=0

 +2        FOR 

               SET APCDSD=$ORDER(^AUPNVSIT("B",APCDSD))

               IF APCDSD=""!($PIECE(APCDSD,".")>APCDED)

                   QUIT 

               Begin DoDot:1

 +3       ;W "+"

 +4                SET APCDV=0

                   FOR 

                       SET APCDV=$ORDER(^AUPNVSIT("B",APCDSD,APCDV))

                       IF APCDV'=+APCDV

                           QUIT 

                       DO CHECK

 +5                QUIT 

               End DoDot:1

 +6        WRITE !!,"A total of ",APCDCNT," duplicate primary providers were deleted."

 +7        DO EOJ

 +8        QUIT 

 +9       ;

EOJ       ;

 +1        DO EN^XBVK("APCD")

 +2        DO ^XBFMK

 +3        DO KILL^AUPNPAT

 +4        KILL AUPNVSIT

 +5        QUIT 

CHECK     ;

 +1       ;deleted visit, do not check

           IF $PIECE(^AUPNVSIT(APCDV,0),U,11)

               QUIT 

 +2       ;no dependent entries so don't bother

           IF '$PIECE(^AUPNVSIT(APCDV,0),U,9)

               QUIT 

 +3       ;loop through V PROVIDER and check for duplicate primary providers

 +4       ;array of primary providers

           KILL APCDPRV

 +5        SET APCDP=0

           FOR 

               SET APCDP=$ORDER(^AUPNVPRV("AD",APCDV,APCDP))

               IF APCDP'=+APCDP

                   QUIT 

               Begin DoDot:1

 +6       ;bad xref

                   IF '$DATA(^AUPNVPRV(APCDP,0))

                       QUIT 

 +7       ;not primary so don't bother

                   IF $PIECE(^AUPNVPRV(APCDP,0),U,4)'="P"

                       QUIT 

 +8       ;provider pointer

                   SET X=$PIECE(^AUPNVPRV(APCDP,0),U)

 +9       ;already have this one so delete it

                   IF $DATA(APCDPRV(X))

                       DO DELETE

                       QUIT 

 +10               SET APCDPRV(X)=""

 +11               QUIT 

               End DoDot:1

 +12       QUIT 

DELETE    ;

 +1        WRITE !,"Deleting provider ",$PIECE(^VA(200,X,0),U)," from visit: "

 +2        WRITE !?10,"Patient: ",$$VAL^XBDIQ1(9000010,APCDV,.05),"  visit date: ",$$VAL^XBDIQ1(9000010,APCDV,.01)

 +3        SET APCDCNT=APCDCNT+1

 +4        SET DA=APCDP

           SET DIK="^AUPNVPRV("

           DO ^DIK

           DO ^XBFMK

 +5        SET AUPNVSIT=APCDV

           DO MOD^AUPNVSIT

           KILL AUPNVSIT

 +6        QUIT