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

XDRDUP.m

Go to the documentation of this file.
  1. XDRDUP ;SF-IRMFO/IHS/OHPRD/JCM - COMPARES TWO RECORDS TO SEE IF DUP OF EACH OTHER; [ 08/13/92 09:50 AM ] ;04/30/2001 10:35
  1. ;;7.3;TOOLKIT;**23,46,49,56**;Apr 25, 1995
  1. ;;
  1. START ;
  1. K % S XDRQFLG=0
  1. I '$D(XDRCD)!('$D(XDRCD2)) S XDRERR=7 D ^XDREMSG G END
  1. I '$D(XDRDSCOR) D ^XDRDSCOR G:XDRQFLG END
  1. F %="MAX","PDT" S XDRDSCOR(%)=0
  1. S:$D(XDRDSCOR("VDT%")) XDRDSCOR("VDT")=0
  1. D VALUE I $D(XDRCD2)'>1 Q
  1. ; sites are requesting to merge test patients, REMing next line
  1. ;I XDRFL=2,$E(XDRCD2(2,XDRCD2,.09,"I"),1,5)="00000" Q
  1. D MAIN
  1. END D EOJ
  1. Q
  1. ;
  1. MAIN ;
  1. F XDRDUPFL=0:0 S XDRDUPFL=$O(XDRDSCOR("DR",XDRDUPFL)) Q:'XDRDUPFL D DIQ1
  1. K XDRDUPFL
  1. I $D(XDRCD2)'>0 S ^XTMP("XDRERR",2,XDRDTYPE,"NO DATA",XDRCD2)="" Q
  1. S XDRD("DUPSCORE")=0
  1. F XDRDTO=0:0 S XDRDTO=$O(XDRDTEST(XDRDTO)) Q:'XDRDTO!(XDRQFLG) D TEST
  1. K XDRDTO F %=0:0 S %=$O(XDRCD2(%)) Q:'% K XDRCD2(%)
  1. K %
  1. S XDRDSCOR("PDT")="."_XDRDSCOR("PDT%")*XDRDSCOR("MAX")
  1. S:$D(XDRDSCOR("VDT%")) XDRDSCOR("VDT")="."_XDRDSCOR("VDT%")*XDRDSCOR("MAX")
  1. I XDRDSCOR("MAX")>0 D
  1. . N J1,J2
  1. . S J1=+$J(XDRD("DUPSCORE")/XDRDSCOR("MAX"),1,2)
  1. . S (^(J1),J2)=$G(^TMP("XDRDUPSC",XDRFL,XDRDTYPE,J1))+1
  1. . I J1>.6 S ^TMP("XDRDUPS1",XDRFL,XDRDTYPE,J1,J2)=XDRCD_U_XDRCD2
  1. I '$D(XDRD("NOADD")),XDRD("DUPSCORE")'<XDRDSCOR("PDT"),'$D(XDRDCOMP) D ^XDRDADD
  1. MAINX Q
  1. ;
  1. DIQ1 ;
  1. S DIC=XDRDUPFL,DIQ(0)="I",DR=XDRDSCOR("DR",XDRDUPFL)
  1. I '$D(XDRCD(XDRDUPFL)) S DA=XDRCD,DIQ="XDRCD" D EN^DIQ1 K DA,D0
  1. S DA=XDRCD2,DIQ="XDRCD2" D EN^DIQ1 K DIC,DR,DIQ,DA,D0
  1. Q
  1. ;
  1. TEST ;
  1. S XDRD("TEST ROUTINE")=$S($P($P(XDRDTEST(XDRDTO),U,3),"-",2)]"":$P($P(XDRDTEST(XDRDTO),U,3),"-")_"^"_$P($P(XDRDTEST(XDRDTO),U,3),"-",2),1:U_$P(XDRDTEST(XDRDTO),U,3))
  1. S X=$P(XDRD("TEST ROUTINE"),U,2) X ^%ZOSF("TEST") K X I '$T S XDRERR=8 D ^XDREMSG G TESTX
  1. S XDRD("TEST SCORE")=0
  1. D @XDRD("TEST ROUTINE")
  1. S XDRDUP("TEST SCORE",XDRDTO)=XDRD("TEST SCORE")
  1. S XDRD("DUPSCORE")=XDRD("DUPSCORE")+(XDRD("TEST SCORE"))
  1. S:+XDRD("TEST SCORE")'=0 XDRDSCOR("MAX")=XDRDSCOR("MAX")+($P(XDRDTEST(XDRDTO),U,6))
  1. TESTX K XDRD("TEST ROUTINE")
  1. Q
  1. ;
  1. EN ; EP - Called by XDRDADJ,XDRDPDTI
  1. ;
  1. N XDRDTYPE
  1. S XDRDTYPE="BASIC"
  1. K XDRCD,XDRCD2
  1. S XDRCD=+$P(^VA(15,XDRDPDA,0),U)
  1. S XDRCD2=+$P(^VA(15,XDRDPDA,0),U,2)
  1. S XDRFL=$O(^VA(15.1,"AGL",$P($P(^VA(15,XDRDPDA,0),U),";",2),0))
  1. I 'XDRFL S XDRERR=6 D ^XDREMSG G ENX
  1. S:XDRFL XDRD(0)=^VA(15.1,XDRFL,0)
  1. D START
  1. ENX Q
  1. ;
  1. EOJ ;
  1. I $D(XDRDPDA),'$D(XDRDPDTI) K XDRFL,XDRDSCOR,XDRDTEST,XDRD,XDRQFLG,XDRCD,XDRCD2
  1. Q
  1. VALUE ;
  1. S DA=XDRCD2 K XDRCD2 S XDRCD2=DA
  1. F XDRI=0:0 S XDRI=$O(XDRDSCOR("DR",XDRI)) Q:XDRI'>0 D
  1. . S DIC=XDRI,DA=XDRCD2,DIQ(0)="I",DIQ="XX",DR=XDRDSCOR("DR",XDRI)
  1. . K XX
  1. . D EN^DIQ1
  1. . M XDRCD2=XX K XX,DA,DIC,DR,DIQ
  1. Q