BPMMRG.m

BPMMRG ; IHS/OIT/LJF - IHS CODE CALLED BY MERGE FUNCTION

 ;;1.0;IHS PATIENT MERGE;;MAR 01, 2010

 ;

 Q

PKG ;EP; check to make sure Package file is clean before merge runs

 ; Called by XDRMERG0

 NEW IEN,DIK,DA

 S IEN=0

 F  S IEN=$O(^DIC(9.4,IEN)) Q:'IEN  D

 . Q:$$GET1^DIQ(9.4,IEN,.01)="IHS PATIENT MERGE"

 . K ^DIC(9.4,IEN,20)

 ;

 ;now clean up ANRG xref

 K ^DIC(9.4,"AMRG")

 NEW DIK S DIK="^DIC(9.4,DA(1),20,",DIK(1)=".01^AMRG"

 S DA(1)=0

 F  S DA(1)=$O(^DIC(9.4,DA(1))) Q:'DA(1)  D ENALL^DIK

 ;

 Q

 ;

DWAUD(ARRAY) ;EP; remove DW Audit entries for all FROM patients in batch

 ; called by DQ^XDRMERG0

 NEW FROM,DA,DIK

 S FROM=0 F  S FROM=$O(@ARRAY@(FROM)) Q:FROM'>0  D

 . S DA=FROM,DIK="^AUPNDWAF(" D ^DIK

 Q

 ;

VISITS(BPMRY) ;EP ; flag all visits to be repointed before merge runs

 ; insures visits are re-exported with new patient pointer

 ; called by EN^BPMXDRV

 NEW FROM,VST,AUPNVSIT

 S FROM=0 F  S FROM=$O(@BPMRY@(FROM)) Q:'FROM  D

 . S VST=0 F  S VST=$O(^AUPNVSIT("AC",FROM,VST)) Q:'VST  D

 . . S AUPNVSIT=VST D MOD^AUPNVSIT

 Q

 ;

ENDMRG(XDRFR,BPMTO,I) ;EP; perform end of merge steps

 ; called by CLOSEIT^XDRMERG

 ;IHS/PAO/AEF 03/06/2006

 D UPD(BPMTO) ;update 'UPDATE' fields in IHS Patient file for TO patient

 ; leave stub in ^AUPNPAT for FROM patient

 I I="^AUPNPAT(" D

 . S ^AUPNPAT(XDRFR,0)=XDRFR

 . S ^AUPNPAT(XDRFR,-9)=BPMTO

 . ; END IHS/PAO/AEF

 . ;

 . ; and set DELETE flag in DW Audit file

 . S ^AUPNDWAF(XDRFR,0)=XDRFR_U_DT,$P(^AUPNDWAF(XDRFR,0),U,13)=1

 . S ^AUPNDWAF("B",XDRFR,XDRFR)=""

 ;

 Q

 ;

UPD(DA) ;IHS/PAO/AEF

 ;----- SET 'DATE OF LAST UPDATE' AND 'USER-LAST UPDATE' FIELDS

 N DIE,DIR,X,Y

 S DIE="^AUPNPAT("

 S DR=".16////"_$G(DT)_";.12////"_$G(DUZ)

 D ^DIE

 Q

 ;

HSUM ;EP; print health summaries for verified or merged pairs

 ; Called by option BPM HS PRINT VERIFIED

 NEW BPMHST,BPMSTAT,SCREEN,DIC,Y,X,BPMREC1,BPMREC2

 S BPMHST=$O(^GMT(142,"B","BPM MERGE",0))

 I BPMHST<1 W !!,"  Merge Health Summary Type not installed.  Contact site manager" D PAUSE^BPMU Q

 ;

 ;select type of pairs wanted

 ;   Verified-Not Ready, Verified-Ready or Merged

 S BPMSTAT=$$READ^BPMU("SO^1:VERIFIED, NOT READY TO MERGE;2:VERIFIED, READY TO MERGE;3:MERGED","Select TYPE OF PAIRS")

 Q:BPMSTAT<1

 I BPMSTAT=1 S SCREEN="I $P(^VA(15,Y,0),U,3)=""V"",$P(^(0),U,5)=0"

 I BPMSTAT=2 S SCREEN="I $P(^VA(15,Y,0),U,3)=""V"",$P(^(0),U,5)=1"

 I BPMSTAT=3 S SCREEN="I $P(^VA(15,Y,0),U,5)=2"

 ;

 ;Lookup Patient Pairs based on screen

 NEW AUPNLK S AUPNLK("ALL")=1

 S DIC=15,DIC(0)="AEMQZ",DIC("A")="Select PATIENT:  ",DIC("S")=SCREEN D ^DIC Q:Y<1

 S BPMREC1=+$$GET1^DIQ(15,+Y,.01,"I")  ;record1 patient

 S BPMREC2=+$$GET1^DIQ(15,+Y,.02,"I")  ;record2 patient

 ;

 ;Ask for printer

 D ZIS^BPMU("QP","HSQUE^BPMMRG","Merge Health Summaries","BPMREC1;BPMREC2;BPMHST")

 D KILL^AUPNPAT

 D HOME^%ZIS

 Q

 ;

HSQUE ;EP; loop thru pair and print health summaries (VA type)

 ; Called by HSUM^BPMMRG (see above)

 ; variables BPMREC1, BPMREC2 & BPMHST set by ZTLOAD if queued

 NEW BPMI

 F BPMI=BPMREC1,BPMREC2 D ENX^GMTSDVR(BPMI,BPMHST)

 D KILL^AUPNPAT K HRCN

 D ^%ZISC

 Q

 ;

FIX ;EP; clean up process stopped by error

 ;Called by BPM RESET LOST MERGE option

 N BPMI,DIE,DA,DR,DIR,BPMC

 S (BPMC,BPMI)=0 F  S BPMI=$O(^VA(15.2,BPMI)) Q:BPMI'>0  I $P(^(BPMI,0),U,4)="A" D

 . S BPMC=BPMC+1

 . S DIR(0)="Y",DIR("A")="Do you want to reset "_$P(^VA(15.2,BPMI,0),U)

 . D ^DIR K DIR I Y'>0 Q

 . S DIE="^VA(15.2,",DA=BPMI,DR=".04///U;.09///1" D ^DIE

 . K DIE,DR

 I BPMC=0 W !!,"No lost merge processes were found.",!! D PAUSE^BPMU

 Q

BPMMRG    ; IHS/OIT/LJF - IHS CODE CALLED BY MERGE FUNCTION

 +1       ;;1.0;IHS PATIENT MERGE;;MAR 01, 2010

 +2       ;

 +3        QUIT 

PKG       ;EP; check to make sure Package file is clean before merge runs

 +1       ; Called by XDRMERG0

 +2        NEW IEN,DIK,DA

 +3        SET IEN=0

 +4        FOR 

               SET IEN=$ORDER(^DIC(9.4,IEN))

               IF 'IEN

                   QUIT 

               Begin DoDot:1

 +5                IF $$GET1^DIQ(9.4,IEN,.01)="IHS PATIENT MERGE"

                       QUIT 

 +6                KILL ^DIC(9.4,IEN,20)

               End DoDot:1

 +7       ;

 +8       ;now clean up ANRG xref

 +9        KILL ^DIC(9.4,"AMRG")

 +10       NEW DIK

           SET DIK="^DIC(9.4,DA(1),20,"

           SET DIK(1)=".01^AMRG"

 +11       SET DA(1)=0

 +12       FOR 

               SET DA(1)=$ORDER(^DIC(9.4,DA(1)))

               IF 'DA(1)

                   QUIT 

               DO ENALL^DIK

 +13      ;

 +14       QUIT 

 +15      ;

DWAUD(ARRAY) ;EP; remove DW Audit entries for all FROM patients in batch

 +1       ; called by DQ^XDRMERG0

 +2        NEW FROM,DA,DIK

 +3        SET FROM=0

           FOR 

               SET FROM=$ORDER(@ARRAY@(FROM))

               IF FROM'>0

                   QUIT 

               Begin DoDot:1

 +4                SET DA=FROM

                   SET DIK="^AUPNDWAF("

                   DO ^DIK

               End DoDot:1

 +5        QUIT 

 +6       ;

VISITS(BPMRY) ;EP ; flag all visits to be repointed before merge runs

 +1       ; insures visits are re-exported with new patient pointer

 +2       ; called by EN^BPMXDRV

 +3        NEW FROM,VST,AUPNVSIT

 +4        SET FROM=0

           FOR 

               SET FROM=$ORDER(@BPMRY@(FROM))

               IF 'FROM

                   QUIT 

               Begin DoDot:1

 +5                SET VST=0

                   FOR 

                       SET VST=$ORDER(^AUPNVSIT("AC",FROM,VST))

                       IF 'VST

                           QUIT 

                       Begin DoDot:2

 +6                        SET AUPNVSIT=VST

                           DO MOD^AUPNVSIT

                       End DoDot:2

               End DoDot:1

 +7        QUIT 

 +8       ;

ENDMRG(XDRFR,BPMTO,I) ;EP; perform end of merge steps

 +1       ; called by CLOSEIT^XDRMERG

 +2       ;IHS/PAO/AEF 03/06/2006

 +3       ;update 'UPDATE' fields in IHS Patient file for TO patient

           DO UPD(BPMTO)

 +4       ; leave stub in ^AUPNPAT for FROM patient

 +5        IF I="^AUPNPAT("

               Begin DoDot:1

 +6                SET ^AUPNPAT(XDRFR,0)=XDRFR

 +7                SET ^AUPNPAT(XDRFR,-9)=BPMTO

 +8       ; END IHS/PAO/AEF

 +9       ;

 +10      ; and set DELETE flag in DW Audit file

 +11               SET ^AUPNDWAF(XDRFR,0)=XDRFR_U_DT

                   SET $PIECE(^AUPNDWAF(XDRFR,0),U,13)=1

 +12               SET ^AUPNDWAF("B",XDRFR,XDRFR)=""

               End DoDot:1

 +13      ;

 +14       QUIT 

 +15      ;

UPD(DA)   ;IHS/PAO/AEF

 +1       ;----- SET 'DATE OF LAST UPDATE' AND 'USER-LAST UPDATE' FIELDS

 +2        NEW DIE,DIR,X,Y

 +3        SET DIE="^AUPNPAT("

 +4        SET DR=".16////"_$GET(DT)_";.12////"_$GET(DUZ)

 +5        DO ^DIE

 +6        QUIT 

 +7       ;

HSUM      ;EP; print health summaries for verified or merged pairs

 +1       ; Called by option BPM HS PRINT VERIFIED

 +2        NEW BPMHST,BPMSTAT,SCREEN,DIC,Y,X,BPMREC1,BPMREC2

 +3        SET BPMHST=$ORDER(^GMT(142,"B","BPM MERGE",0))

 +4        IF BPMHST<1

               WRITE !!,"  Merge Health Summary Type not installed.  Contact site manager"

               DO PAUSE^BPMU

               QUIT 

 +5       ;

 +6       ;select type of pairs wanted

 +7       ;   Verified-Not Ready, Verified-Ready or Merged

 +8        SET BPMSTAT=$$READ^BPMU("SO^1:VERIFIED, NOT READY TO MERGE;2:VERIFIED, READY TO MERGE;3:MERGED","Select TYPE OF PAIRS")

 +9        IF BPMSTAT<1

               QUIT 

 +10       IF BPMSTAT=1

               SET SCREEN="I $P(^VA(15,Y,0),U,3)=""V"",$P(^(0),U,5)=0"

 +11       IF BPMSTAT=2

               SET SCREEN="I $P(^VA(15,Y,0),U,3)=""V"",$P(^(0),U,5)=1"

 +12       IF BPMSTAT=3

               SET SCREEN="I $P(^VA(15,Y,0),U,5)=2"

 +13      ;

 +14      ;Lookup Patient Pairs based on screen

 +15       NEW AUPNLK

           SET AUPNLK("ALL")=1

 +16       SET DIC=15

           SET DIC(0)="AEMQZ"

           SET DIC("A")="Select PATIENT:  "

           SET DIC("S")=SCREEN

           DO ^DIC

           IF Y<1

               QUIT 

 +17      ;record1 patient

           SET BPMREC1=+$$GET1^DIQ(15,+Y,.01,"I")

 +18      ;record2 patient

           SET BPMREC2=+$$GET1^DIQ(15,+Y,.02,"I")

 +19      ;

 +20      ;Ask for printer

 +21       DO ZIS^BPMU("QP","HSQUE^BPMMRG","Merge Health Summaries","BPMREC1;BPMREC2;BPMHST")

 +22       DO KILL^AUPNPAT

 +23       DO HOME^%ZIS

 +24       QUIT 

 +25      ;

HSQUE     ;EP; loop thru pair and print health summaries (VA type)

 +1       ; Called by HSUM^BPMMRG (see above)

 +2       ; variables BPMREC1, BPMREC2 & BPMHST set by ZTLOAD if queued

 +3        NEW BPMI

 +4        FOR BPMI=BPMREC1,BPMREC2

               DO ENX^GMTSDVR(BPMI,BPMHST)

 +5        DO KILL^AUPNPAT

           KILL HRCN

 +6        DO ^%ZISC

 +7        QUIT 

 +8       ;

FIX       ;EP; clean up process stopped by error

 +1       ;Called by BPM RESET LOST MERGE option

 +2        NEW BPMI,DIE,DA,DR,DIR,BPMC

 +3        SET (BPMC,BPMI)=0

           FOR 

               SET BPMI=$ORDER(^VA(15.2,BPMI))

               IF BPMI'>0

                   QUIT 

               IF $PIECE(^(BPMI,0),U,4)="A"

                   Begin DoDot:1

 +4                    SET BPMC=BPMC+1

 +5                    SET DIR(0)="Y"

                       SET DIR("A")="Do you want to reset "_$PIECE(^VA(15.2,BPMI,0),U)

 +6                    DO ^DIR

                       KILL DIR

                       IF Y'>0

                           QUIT 

 +7                    SET DIE="^VA(15.2,"

                       SET DA=BPMI

                       SET DR=".04///U;.09///1"

                       DO ^DIE

 +8                    KILL DIE,DR

                   End DoDot:1

 +9        IF BPMC=0

               WRITE !!,"No lost merge processes were found.",!!

               DO PAUSE^BPMU

 +10       QUIT