Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BPMVER

BPMVER.m

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