BPMVER ; IHS/OIT/LJF - IHS CODE FOR VERIFY DUPLICATE FUNCTION
;;1.0;IHS PATIENT MERGE;;MAR 01, 2010
;
OVERWRIT(BPMFILE,BPMN,BPMFLDS) ;EP - called by CHK1^XDRRMRG1
; stuffs overwrite selections when selected and for correct patient file
; VA code only stuff for file 2 and only if pair is marked as verified now
NEW BPMIEN,BPMFDA,BPMIENS,I
S BPMIEN=$$FIND1^DIC(15.03,","_BPMN_",","X",BPMFILE) ;is file already in subfile?
;
; if not, add it
I BPMIEN'>0 D
. S BPMIEN="+1,"_BPMN_","
. S BPMIENS(1)=BPMFILE
. S BPMFDA(15.03,BPMIEN,.01)=BPMFILE ;stuff file number
. S BPMFDA(15.03,BPMIEN,.02)=2 ;stuff reverse merge
. D UPDATE^DIE("S","BPMFDA","BPMIENS")
. S BPMIEN=BPMIENS(1)
;
; now loop thru overwrite fields and stuff them under file number
S BPMIEN="+1,"_BPMIEN_","_BPMN_","
S I=0 F S I=$O(BPMFLDS(I)) Q:I'>0 D
. K BPMFDA,BPMIENS
. S BPMIENS(1)=I
. S BPMFDA(15.031,BPMIEN,.01)=I
. D UPDATE^DIE("S","BPMFDA","BPMIENS")
Q
;
SHOWVER ; EP - display verified duplicate pair with merge direction and overwrite fields
NEW DIC,XDRFILE,XDRGLB,DFNFR,DFNTO,XDRDA,DIR,FR,TO,L,FLDS,BY,IOP,BPMFLD,AUPNLK
S XDRFILE=$$FILE^XDRDPICK() Q:XDRFILE'>0 S XDRGLB=$G(^DIC(XDRFILE,0,"GL")) Q:XDRGLB=""
F D Q:XDRDA'>0
. S DIC="^VA(15,",DIC(0)="AEQZ",DIC("S")="I $P(^VA(15,+Y,0),U,5)<2,$P(^(0),U,3)=""V"""
. S DIC("A")="Select VERIFIED Pair: "
. S AUPNLK("ALL")=1 ;allow lookup of inactive patients
. W !! D ^DIC S XDRDA=+Y Q:XDRDA<0
. S X=^VA(15,XDRDA,0)
. I $P($G(^VA(15,XDRDA,2,1,0)),U,5)=2 S DFNTO=+X,DFNFR=+$P(X,U,2)
. E S DFNFR=+X,DFNTO=+$P(X,U,2)
. ;
. S DIC=15,L=0,FLDS="[BPM VERIFIED DISPLAY]",BY="@.001"
. S (FR,TO)=XDRDA,IOP="HOME"
. D EN1^DIP
. ;
. S DIR(0)="Y",DIR("A")="Do you wish to review demographic data",DIR("B")="YES"
. D ^DIR K DIR Q:Y'=1 W @IOF
. ;
. F XDRFILE=2,9000001 D SHOW^XDRDSHOW(XDRFILE,DFNFR,DFNTO,.BPMFLD,0) Q:$D(DIRUT)
. K FILREC1,FILREC2,FLD,NAME,NDIFFS,NLIN,NOD1,NOD2,NODE,PACKAGE,PIECE,XDRA ;kill variables left over from VA call
Q
;
DINUM ;EP - Check for possible overwrite data in DINUM'ed files
; Called by option BPM OVERWRITE CHECK
;
NEW BPMPFILE,XDRGLB,BPMDA,AUPNLK,X,DIC,DFNFR,DFNTO,PACKAGE
NEW BPMFL,XDRGL,PRIFILE,XDRDA,DFNTOX,DFNFRX,XDRFILE,FILEDIC,XDRY,REVIEW,OVERWRIT,FOUND
; select verified patient pair
S BPMPFILE=$$FILE^XDRDPICK() Q:BPMPFILE'>0 S XDRGLB=$G(^DIC(BPMPFILE,0,"GL")) Q:XDRGLB=""
F D Q:BPMDA'>0
. S DIC="^VA(15,",DIC(0)="AEQZ",DIC("S")="I $P(^VA(15,+Y,0),U,5)<2,$P(^(0),U,3)=""V"""
. S DIC("A")="Select VERIFIED Pair: "
. S AUPNLK("ALL")=1 ;allow lookup of inactive patients
. W !! D ^DIC S BPMDA=+Y Q:BPMDA<0
. S X=^VA(15,BPMDA,0)
. I $P($G(^VA(15,BPMDA,2,1,0)),U,5)=2 S DFNTO=+X,DFNFR=+$P(X,U,2)
. E S DFNFR=+X,DFNTO=+$P(X,U,2)
. ;
. ; loop through RPMS files, find DINUM'ed ones & check data
. W !!,"SEARCHING, please wait . . ."
. S BPMFND=0 ;flag to track if any overwrite data found for any file
. S BPMFL=0 F S BPMFL=$O(^DD(BPMFL)) Q:'BPMFL D
. . Q:BPMFL=9000001 ;skip IHS Patient file
. . Q:BPMFL=9000003.3 ;skip DW Audit file
. . Q:$P($G(^DD(BPMFL,.01,0)),U,5)'["DINUM" ;skip files not DINUM'ed
. . S X=$P($G(^DD(BPMFL,.01,0)),2)
. . I (X'["P2")&(X'["P9000001") Q ;skip if not pointer to VA Patient or Patient
. . Q:X["P200" ;skip if pointing to file 200
. . Q:$P($G(^DIC(BPMFL,0)),U)="" ;skip if not top level of file
. . ;
. . ; set variables needed by VA code
. . K OVERWRIT ;flag to track if overwrite data found for this file
. . S XDRGL=$P($P($G(^VA(15,BPMDA,0)),U),";",2) Q:XDRGL="" S XDRGL=U_XDRGL S PRIFILE=+$P(@(XDRGL_"0)"),U,2)
. . S XDRDA=BPMDA,DFNTOX=DFNTO,DFNFRX=DFNFR
. . S PACKAGE=$G(^DD(BPMFL,0,"VRPK"))_" ("_$P($G(^DIC(BPMFL,0)),U)_")"
. . S XDRFILE=BPMFL,FILEDIC=^DIC(XDRFILE,0,"GL")_"DFN)"
. . I XDRFILE=63 S NAMIEN1=$$LABIEN^XDRRMRG2(XDRFILE,DFNFR),NAMIEN2=$$LABIEN^XDRRMRG2(XDRFILE,DFNTO)
. . N DIR ;could be left over from other options; SHOW doesn't check for it
. . S XDRY="S",REVIEW=1 D SHOW^XDRDSHOW(XDRFILE,DFNFR,DFNTO,.OVERWRIT,REVIEW)
. . I $D(OVERWRIT) S BPMFND=1 D OVERWRIT^BPMVER(XDRFILE,XDRDA,.OVERWRIT) K OVERWRIT
. ;
. I BPMFND=0 W !!,"NO NEW DATA OVERWRITES SET" D PAUSE^BPMU
Q
BPMVER ; IHS/OIT/LJF - IHS CODE FOR VERIFY DUPLICATE FUNCTION
+1 ;;1.0;IHS PATIENT MERGE;;MAR 01, 2010
+2 ;
OVERWRIT(BPMFILE,BPMN,BPMFLDS) ;EP - called by CHK1^XDRRMRG1
+1 ; stuffs overwrite selections when selected and for correct patient file
+2 ; VA code only stuff for file 2 and only if pair is marked as verified now
+3 NEW BPMIEN,BPMFDA,BPMIENS,I
+4 ;is file already in subfile?
SET BPMIEN=$$FIND1^DIC(15.03,","_BPMN_",","X",BPMFILE)
+5 ;
+6 ; if not, add it
+7 IF BPMIEN'>0
Begin DoDot:1
+8 SET BPMIEN="+1,"_BPMN_","
+9 SET BPMIENS(1)=BPMFILE
+10 ;stuff file number
SET BPMFDA(15.03,BPMIEN,.01)=BPMFILE
+11 ;stuff reverse merge
SET BPMFDA(15.03,BPMIEN,.02)=2
+12 DO UPDATE^DIE("S","BPMFDA","BPMIENS")
+13 SET BPMIEN=BPMIENS(1)
End DoDot:1
+14 ;
+15 ; now loop thru overwrite fields and stuff them under file number
+16 SET BPMIEN="+1,"_BPMIEN_","_BPMN_","
+17 SET I=0
FOR
SET I=$ORDER(BPMFLDS(I))
IF I'>0
QUIT
Begin DoDot:1
+18 KILL BPMFDA,BPMIENS
+19 SET BPMIENS(1)=I
+20 SET BPMFDA(15.031,BPMIEN,.01)=I
+21 DO UPDATE^DIE("S","BPMFDA","BPMIENS")
End DoDot:1
+22 QUIT
+23 ;
SHOWVER ; EP - display verified duplicate pair with merge direction and overwrite fields
+1 NEW DIC,XDRFILE,XDRGLB,DFNFR,DFNTO,XDRDA,DIR,FR,TO,L,FLDS,BY,IOP,BPMFLD,AUPNLK
+2 SET XDRFILE=$$FILE^XDRDPICK()
IF XDRFILE'>0
QUIT
SET XDRGLB=$GET(^DIC(XDRFILE,0,"GL"))
IF XDRGLB=""
QUIT
+3 FOR
Begin DoDot:1
+4 SET DIC="^VA(15,"
SET DIC(0)="AEQZ"
SET DIC("S")="I $P(^VA(15,+Y,0),U,5)<2,$P(^(0),U,3)=""V"""
+5 SET DIC("A")="Select VERIFIED Pair: "
+6 ;allow lookup of inactive patients
SET AUPNLK("ALL")=1
+7 WRITE !!
DO ^DIC
SET XDRDA=+Y
IF XDRDA<0
QUIT
+8 SET X=^VA(15,XDRDA,0)
+9 IF $PIECE($GET(^VA(15,XDRDA,2,1,0)),U,5)=2
SET DFNTO=+X
SET DFNFR=+$PIECE(X,U,2)
+10 IF '$TEST
SET DFNFR=+X
SET DFNTO=+$PIECE(X,U,2)
+11 ;
+12 SET DIC=15
SET L=0
SET FLDS="[BPM VERIFIED DISPLAY]"
SET BY="@.001"
+13 SET (FR,TO)=XDRDA
SET IOP="HOME"
+14 DO EN1^DIP
+15 ;
+16 SET DIR(0)="Y"
SET DIR("A")="Do you wish to review demographic data"
SET DIR("B")="YES"
+17 DO ^DIR
KILL DIR
IF Y'=1
QUIT
WRITE @IOF
+18 ;
+19 FOR XDRFILE=2,9000001
DO SHOW^XDRDSHOW(XDRFILE,DFNFR,DFNTO,.BPMFLD,0)
IF $DATA(DIRUT)
QUIT
+20 ;kill variables left over from VA call
KILL FILREC1,FILREC2,FLD,NAME,NDIFFS,NLIN,NOD1,NOD2,NODE,PACKAGE,PIECE,XDRA
End DoDot:1
IF XDRDA'>0
QUIT
+21 QUIT
+22 ;
DINUM ;EP - Check for possible overwrite data in DINUM'ed files
+1 ; Called by option BPM OVERWRITE CHECK
+2 ;
+3 NEW BPMPFILE,XDRGLB,BPMDA,AUPNLK,X,DIC,DFNFR,DFNTO,PACKAGE
+4 NEW BPMFL,XDRGL,PRIFILE,XDRDA,DFNTOX,DFNFRX,XDRFILE,FILEDIC,XDRY,REVIEW,OVERWRIT,FOUND
+5 ; select verified patient pair
+6 SET BPMPFILE=$$FILE^XDRDPICK()
IF BPMPFILE'>0
QUIT
SET XDRGLB=$GET(^DIC(BPMPFILE,0,"GL"))
IF XDRGLB=""
QUIT
+7 FOR
Begin DoDot:1
+8 SET DIC="^VA(15,"
SET DIC(0)="AEQZ"
SET DIC("S")="I $P(^VA(15,+Y,0),U,5)<2,$P(^(0),U,3)=""V"""
+9 SET DIC("A")="Select VERIFIED Pair: "
+10 ;allow lookup of inactive patients
SET AUPNLK("ALL")=1
+11 WRITE !!
DO ^DIC
SET BPMDA=+Y
IF BPMDA<0
QUIT
+12 SET X=^VA(15,BPMDA,0)
+13 IF $PIECE($GET(^VA(15,BPMDA,2,1,0)),U,5)=2
SET DFNTO=+X
SET DFNFR=+$PIECE(X,U,2)
+14 IF '$TEST
SET DFNFR=+X
SET DFNTO=+$PIECE(X,U,2)
+15 ;
+16 ; loop through RPMS files, find DINUM'ed ones & check data
+17 WRITE !!,"SEARCHING, please wait . . ."
+18 ;flag to track if any overwrite data found for any file
SET BPMFND=0
+19 SET BPMFL=0
FOR
SET BPMFL=$ORDER(^DD(BPMFL))
IF 'BPMFL
QUIT
Begin DoDot:2
+20 ;skip IHS Patient file
IF BPMFL=9000001
QUIT
+21 ;skip DW Audit file
IF BPMFL=9000003.3
QUIT
+22 ;skip files not DINUM'ed
IF $PIECE($GET(^DD(BPMFL,.01,0)),U,5)'["DINUM"
QUIT
+23 SET X=$PIECE($GET(^DD(BPMFL,.01,0)),2)
+24 ;skip if not pointer to VA Patient or Patient
IF (X'["P2")&(X'["P9000001")
QUIT
+25 ;skip if pointing to file 200
IF X["P200"
QUIT
+26 ;skip if not top level of file
IF $PIECE($GET(^DIC(BPMFL,0)),U)=""
QUIT
+27 ;
+28 ; set variables needed by VA code
+29 ;flag to track if overwrite data found for this file
KILL OVERWRIT
+30 SET XDRGL=$PIECE($PIECE($GET(^VA(15,BPMDA,0)),U),";",2)
IF XDRGL=""
QUIT
SET XDRGL=U_XDRGL
SET PRIFILE=+$PIECE(@(XDRGL_"0)"),U,2)
+31 SET XDRDA=BPMDA
SET DFNTOX=DFNTO
SET DFNFRX=DFNFR
+32 SET PACKAGE=$GET(^DD(BPMFL,0,"VRPK"))_" ("_$PIECE($GET(^DIC(BPMFL,0)),U)_")"
+33 SET XDRFILE=BPMFL
SET FILEDIC=^DIC(XDRFILE,0,"GL")_"DFN)"
+34 IF XDRFILE=63
SET NAMIEN1=$$LABIEN^XDRRMRG2(XDRFILE,DFNFR)
SET NAMIEN2=$$LABIEN^XDRRMRG2(XDRFILE,DFNTO)
+35 ;could be left over from other options; SHOW doesn't check for it
NEW DIR
+36 SET XDRY="S"
SET REVIEW=1
DO SHOW^XDRDSHOW(XDRFILE,DFNFR,DFNTO,.OVERWRIT,REVIEW)
+37 IF $DATA(OVERWRIT)
SET BPMFND=1
DO OVERWRIT^BPMVER(XDRFILE,XDRDA,.OVERWRIT)
KILL OVERWRIT
End DoDot:2
+38 ;
+39 IF BPMFND=0
WRITE !!,"NO NEW DATA OVERWRITES SET"
DO PAUSE^BPMU
End DoDot:1
IF BPMDA'>0
QUIT
+40 QUIT
