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

XDRMADD.m

Go to the documentation of this file. 
  1. XDRMADD ;SF-IRMFO/IHS/OHPRD/JCM,JLI,REM -  USER CREATED VERIFIED DUPLICATE PAIR ENTRY ;27 Jul 2010  6:18 PM
  1.  ;;7.3;TOOLKIT;**23,113,124,125**;Apr 25, 1995;Build 2
  1.  ;;Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;;
  1.  N XDRFL,XDRCNTR
  1.  S XDRCNTR=0
  1. START ;
  1.  N XDRADFLG,XDRNOPT
  1.  K DIC
  1.  ; XT*7.3*113 - Setting of XDRNOPT flag, and checking for XDRFL'=2
  1.  ;   in this routine and in SCORE entry point, prevent option
  1.  ;   from using the duplicate record checking code on the PATIENT file.
  1.  ;   DUPLICATE RECORD entries can be added, but no checking is done.
  1.  S (XDRQFLG,XDRADFLG,XDRNOPT)=0
  1.  I '$D(XDRFL) D
  1.  . S DIC("A")="Add entries from which File: " D FILE^XDRDQUE Q:XDRQFLG  ;XT*7.3*124 stop UNDEF if Y=-1
  1.  . I XDRFL=2 W "* No potential duplicate threshold % check will be calculated for PATIENTS"
  1.  . Q
  1.  G:XDRQFLG END
  1.  D:XDRFL'=2
  1.  . S XDRDTYPE=$P(XDRD(0),U,5)
  1.  . Q:XDRDTYPE]""
  1.  . ;REM -8/20/96 when XDRDTYPE is null set it to basic.
  1.  . S $P(^VA(15.1,XDRFL,0),U,5)="b",XDRDTYPE="b"
  1.  . Q
  1.  S XDRGL=^DIC(XDRFL,0,"GL")
  1.  D:XDRCNTR>0  G:XDRQFLG END
  1.  . W ! K DIR S DIR(0)="Y",DIR("A")="Do you want to ADD another pair (Y/N)"
  1.  . D ^DIR K DIR S:$D(DIRUT)!('Y) XDRQFLG=1
  1.  . Q
  1.  S XDRCNTR=XDRCNTR+1
  1.  ; Skip duplicate record checking for patients
  1.  I XDRFL=2 D
  1.  . S (XDRDSCOR("MAX"),XDRDSCOR("PDT%"),XDRD("DUPSCORE"),XDRMADD("DUPSCORE%"))=0
  1.  . S XDRADFLG=1
  1.  I XDRFL'=2 D BYPASS G:XDRQFLG END
  1.  D LKUP G:XDRQFLG END
  1.  D CHECK G:XDRQFLG<0 START
  1.  ;
  1.  ; Added the following line to check the MPI DO NOT LINK file
  1.  ; (XT*7.3*125)
  1.  I XDRDFLG'>0,XDRFL=2 G:'$$DNLCHECK START
  1.  ;
  1.  I XDRFL'=2 D
  1.  . D ^XDRDSCOR S:XDRADFLG XDRDSCOR("PDT%")=0 ;REM -8/23/96 to bypass PDT%
  1.  . S XDRD("NOADD")="" D ^XDRDUP
  1.  . Q
  1.  K XDRDTYPE
  1.  D SCORE
  1.  I XDRFL'=2,XDRMADD("DUPSCORE%")<XDRDSCOR("PDT%") D  G START ; JLI 4/11/96
  1.  . W !!,$C(7),"This pair of patients has a duplicate percentage of only ",XDRMADD("DUPSCORE%"),"% which"
  1.  . W !,"is less than the minimal percentage for potential duplicates (",XDRDSCOR("PDT%"),"%)."
  1.  . W !!?30,"Patients not added!!!",!!
  1.  S XDRDA=+XDRDFLG I XDRDA'>0 D ADD
  1.  G:XDRQFLG START
  1.  D SHOW^XDRDPICK ; D MERGE ; CHANGED TO CURRENT VERIF METHOD, NOT MERGE 4/11/96  JLI
  1.  G START ; ADDED 4/11/96 JLI
  1. END D EOJ
  1.  Q
  1.  ;
  1. LKUP ;Looks up the records to add.
  1.  K XDRCD,XDRCD2
  1.  S DIC=XDRGL,DIC(0)="QEAM"
  1.  S DIC("S")="I '$D(^VA(15,""AFR"",$P(XDRGL,U,2),Y))"
  1.  S DIC("A")="Select "_$P(^DIC(XDRFL,0),U,1)_": "
  1.  D ^DIC K DIC,DA
  1.  I $D(DIRUT)!(Y=-1) S XDRQFLG=1 G LKUPX
  1.  S XDRCD=+Y
  1. LKUP2 S DIC=XDRGL,DIC(0)="QEAM"
  1.  S DIC("S")="I '$D(^VA(15,""AFR"",$P(XDRGL,U,2),Y))"
  1.  S DIC("A")="    Another  "_$P(^DIC(XDRFL,0),U,1)_": "
  1.  D ^DIC K DIC,DA
  1.  G:$D(DIRUT)!(Y=-1) LKUP
  1.  S XDRCD2=+Y
  1.  I XDRCD=XDRCD2 W !!,"Please do not try and merge the same patients together.",!! K XDRCD2 G LKUP2
  1.  S XDRMADD("REC1")=$S(XDRCD<XDRCD2:XDRCD,1:XDRCD2)
  1.  S XDRMADD("REC2")=$S(XDRMADD("REC1")=XDRCD:XDRCD2,1:XDRCD)
  1.  S XDRCD=XDRMADD("REC1"),XDRCD2=XDRMADD("REC2")
  1.  W !!,"You will be adding the following pair of records to the duplicate record file:",!
  1.  W !?5,"RECORD1:  ",$P(@(XDRGL_XDRCD_",0)"),U)
  1.  W !?5,"RECORD2:  ",$P(@(XDRGL_XDRCD2_",0)"),U)
  1.  W !! K DIR S DIR(0)="E" D ^DIR K DIR I $D(DIRUT) S XDRQFLG=1 Q
  1.  W "  Ok, continuing, hold on ...",!
  1.  ;W !!,"Hit return to continue " R XDRMADD("ANS"):DTIME W "  Okay, continuing, hold on ...",!
  1. LKUPX Q
  1.  ;
  1. CHECK ;
  1.  S XDRDFLG=0 F XDRDI="APOT","ANOT","AVDUP" I $D(^VA(15,XDRDI,$P(XDRGL,U,2),XDRCD_U_XDRCD2))!($D(^VA(15,XDRDI,$P(XDRGL,U,2),XDRCD2_U_XDRCD))) S XDRDFLG=-1 I XDRDI="APOT" D
  1.  . I $D(^VA(15,XDRDI,$P(XDRGL,U,2),XDRCD_U_XDRCD2)) S XDRDFLG=$O(^(XDRCD_U_XDRCD2,0)) Q
  1.  . S XDRDFLG=$O(^VA(15,XDRDI,$P(XDRGL,U,2),XDRCD2_U_XDRCD,0))
  1.  I XDRDFLG W !!,"They are already entered in Duplicate Record file.",!!
  1.  K XDRDI
  1.  Q
  1.  ;
  1. DNLCHECK() ; If patients are being selected for merge, check the MPI to
  1.  ; determine whether the records are marked as DO NOT LINK and
  1.  ; therefore should not be added to the DUPLICATE RECORD file.
  1.  ; Returns 1 if OK.
  1.  ; Created in XT*7.3*125
  1.  Q:XDRFL'=2 1
  1.  N X,XDRRES
  1.  ;
  1.  ; Quit if routine MPIFDNL or line tag DNLCHK does not exist
  1.  S X="MPIFDNL" X ^%ZOSF("TEST") Q:'$T 1
  1.  Q:$L($T(DNLCHK^MPIFDNL))=0 1
  1.  ;
  1.  ; Call $$DNLCHK^MPIFDNL to perform the check.
  1.  ; Returns 0 if check passed; Returns -1^error message if not
  1.  S XDRRES=$$DNLCHK^MPIFDNL(XDRCD,XDRCD2)
  1.  ;
  1.  ; If an error is returned, write the error message to the current
  1.  ; device and return 0
  1.  I $P(XDRRES,U)=-1 D  Q 0
  1.  . N X,DIWL,DIWR,DIWF
  1.  . K ^UTILITY($J,"W")
  1.  . S X=$P(XDRRES,U,2,999),DIWL=1,DIWR=IOM-1,DIWF="W"
  1.  . W !,$C(7)
  1.  . D ^DIWP,^DIWW
  1.  Q 1
  1.  ;
  1. SCORE ;
  1.  I XDRFL'=2 D
  1.  . S XDRMADD("DUPSCORE%")=$S($G(XDRDSCOR("MAX"))=0:0,1:(XDRD("DUPSCORE")/XDRDSCOR("MAX")))
  1.  . S XDRMADD("DUPSCORE%")=$J(XDRMADD("DUPSCORE%"),1,2)
  1.  . S XDRMADD("DUPSCORE%")=$S(XDRMADD("DUPSCORE%")<0:0,XDRMADD("DUPSCORE%")<1:$E(XDRMADD("DUPSCORE%"),3,4),1:100)
  1.  . Q
  1.  S XDRDFR=$S(XDRCD<XDRCD2:XDRCD,1:XDRCD2)
  1.  S XDRDTO=$S(XDRDFR=XDRCD:XDRCD2,1:XDRCD)
  1.  S XDRMADD("STATUS")="X"
  1.  Q
  1.  ;
  1. ADD ;
  1.  ;ADD TO DUPLICATE RECORD FILE
  1.  S XDRMAINI="MERGE" D ^XDRMAINI ;LAB/OHPRD ADDED THIS
  1.  S DIC="^VA(15,",DIC(0)="L",X=XDRDFR_";"_$P(XDRGL,U,2),DLAYGO=15
  1.  S XDRMADDX=XDRDTO_";"_$P(XDRGL,U,2)
  1.  S DIC("DR")=".02////^S X=XDRMADDX"_";.03////"_XDRMADD("STATUS")
  1.  ;S DIC("DR")=DIC("DR")_";.04//2" ;REM -10/2/96 this will be asked in XDRRMRG!
  1.  S DIC("DR")=DIC("DR")_";.03///P"_";.06////"_DT_";.09////"_DUZ
  1.  S DIC("DR")=DIC("DR")_";.15////"_XDRDSCOR("MAX")_";.17////"_XDRDSCOR("PDT%")_";.18////"_XDRD("DUPSCORE")_";.19////"_XDRMADD("DUPSCORE%")
  1.  S:$D(XDRDSCOR("VDT%")) DIC("DR")=DIC("DR")_";.16////"_XDRDSCOR("VDT%")
  1.  D
  1.  . N I,X1,X2,X3
  1.  . S X1=X_U_XDRMADDX,X2=XDRMADDX_U_X
  1.  . F I=0:0 S I=$O(^VA(15,"B",X,I)) Q:I'>0  S X3=$P($G(^VA(15,I,0)),U,1,2) I X3=X1!(X3=X2) K X Q
  1.  S Y=-1 I $D(X) D FILE^DICN
  1.  K DIC,DR,X,DLAYGO
  1.  I Y'>0 S XDRQFLG=1 K XDRCD,XDRCD2 G ADDX
  1.  S DIE="^VA(15,",(XDRDA,XDRMPDA,DA)=+Y ; ADDED XDRDA TO LIST 4/11/96 JLI
  1.  F XDRMORD=0:0 S XDRMORD=$O(XDRDTEST(XDRMORD)) Q:'XDRMORD  S DR="2101///"_$P(XDRDTEST(XDRMORD),U,1),DR(2,15.02101)=".02////"_XDRDUP("TEST SCORE",XDRMORD) D ^DIE K DR
  1. ADDX K DIE,DR,DA,XDRMORD,XDRMADDX,XDRDUP("TEST SCORE")
  1.  Q
  1.  ;
  1. MERGE Q  ;
  1.  S XDRMPAIR=XDRDFR_"^"_XDRDTO,XDRM("NOVERIFY")=""
  1.  D EN^XDRMAIN
  1. MERGEX K XDRM
  1.  Q
  1.  ;
  1. BYPASS ;REM -8/20/96 Add record directly into file 15, bypass threshold.
  1.  N X,XDRKEY
  1.  S (X,XDRKEY)=0 F  S X=$O(^VA(200,DUZ,51,"B",X)) Q:X'>0!(XDRKEY)  D
  1.  .I $$GET1^DIQ(19.1,X,.01)="XDRMGR" S XDRKEY=1 Q
  1.  Q:'XDRKEY
  1.  S DIR(0)="Y",DIR("A")="Do you want to bypass the potential duplicate threshold % check (Y/N)"
  1.  S DIR("??")="^W !!,""This will add the pair of records to the Duplicate Record file without checking the potential duplicate threshold %."""
  1.  D ^DIR K DIR S XDRADFLG=Y I $D(DTOUT)!($D(DUOUT)) S XDRQFLG=1 Q
  1.  I 'XDRADFLG W !!,*7,"Potential duplicate threshold % will NOT be bypassed!",!
  1.  I XDRADFLG D
  1.  .W !!,"This will add the pair of records directly into the Duplicate Record file."
  1.  .S DIR(0)="YO",DIR("A")="Are you sure you want to continue",DIR("B")="NO"
  1.  .D ^DIR K DIR S XDRADFLG=Y W ! I $D(DIRUT) S XDRQFLG=1 Q
  1.  .I 'XDRADFLG W *7,!!,"Potential duplicate threshold % will NOT be bypassed!",!
  1.  Q
  1.  ;
  1. EOJ ;
  1.  K XDRMADD,XDRMORD,XDRDFR,XDRDTO,X,Y,XDRCD,XDRCD2,XDRD,XDRFL,XDRGL
  1.  K XDRFL,XDRMPAIR,XDRMPDA,XDRQFLG,XDRDSCOR,XDRDTEST
  1.  Q