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
;;7.3;TOOLKIT;**23,46,49,56**;Apr 25, 1995
;;
START ;
K % S XDRQFLG=0
I '$D(XDRCD)!('$D(XDRCD2)) S XDRERR=7 D ^XDREMSG G END
I '$D(XDRDSCOR) D ^XDRDSCOR G:XDRQFLG END
F %="MAX","PDT" S XDRDSCOR(%)=0
S:$D(XDRDSCOR("VDT%")) XDRDSCOR("VDT")=0
D VALUE I $D(XDRCD2)'>1 Q
; sites are requesting to merge test patients, REMing next line
;I XDRFL=2,$E(XDRCD2(2,XDRCD2,.09,"I"),1,5)="00000" Q
D MAIN
END D EOJ
Q
;
MAIN ;
F XDRDUPFL=0:0 S XDRDUPFL=$O(XDRDSCOR("DR",XDRDUPFL)) Q:'XDRDUPFL D DIQ1
K XDRDUPFL
I $D(XDRCD2)'>0 S ^XTMP("XDRERR",2,XDRDTYPE,"NO DATA",XDRCD2)="" Q
S XDRD("DUPSCORE")=0
F XDRDTO=0:0 S XDRDTO=$O(XDRDTEST(XDRDTO)) Q:'XDRDTO!(XDRQFLG) D TEST
K XDRDTO F %=0:0 S %=$O(XDRCD2(%)) Q:'% K XDRCD2(%)
K %
S XDRDSCOR("PDT")="."_XDRDSCOR("PDT%")*XDRDSCOR("MAX")
S:$D(XDRDSCOR("VDT%")) XDRDSCOR("VDT")="."_XDRDSCOR("VDT%")*XDRDSCOR("MAX")
I XDRDSCOR("MAX")>0 D
. N J1,J2
. S J1=+$J(XDRD("DUPSCORE")/XDRDSCOR("MAX"),1,2)
. S (^(J1),J2)=$G(^TMP("XDRDUPSC",XDRFL,XDRDTYPE,J1))+1
. I J1>.6 S ^TMP("XDRDUPS1",XDRFL,XDRDTYPE,J1,J2)=XDRCD_U_XDRCD2
I '$D(XDRD("NOADD")),XDRD("DUPSCORE")'<XDRDSCOR("PDT"),'$D(XDRDCOMP) D ^XDRDADD
MAINX Q
;
DIQ1 ;
S DIC=XDRDUPFL,DIQ(0)="I",DR=XDRDSCOR("DR",XDRDUPFL)
I '$D(XDRCD(XDRDUPFL)) S DA=XDRCD,DIQ="XDRCD" D EN^DIQ1 K DA,D0
S DA=XDRCD2,DIQ="XDRCD2" D EN^DIQ1 K DIC,DR,DIQ,DA,D0
Q
;
TEST ;
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))
S X=$P(XDRD("TEST ROUTINE"),U,2) X ^%ZOSF("TEST") K X I '$T S XDRERR=8 D ^XDREMSG G TESTX
S XDRD("TEST SCORE")=0
D @XDRD("TEST ROUTINE")
S XDRDUP("TEST SCORE",XDRDTO)=XDRD("TEST SCORE")
S XDRD("DUPSCORE")=XDRD("DUPSCORE")+(XDRD("TEST SCORE"))
S:+XDRD("TEST SCORE")'=0 XDRDSCOR("MAX")=XDRDSCOR("MAX")+($P(XDRDTEST(XDRDTO),U,6))
TESTX K XDRD("TEST ROUTINE")
Q
;
EN ; EP - Called by XDRDADJ,XDRDPDTI
;
N XDRDTYPE
S XDRDTYPE="BASIC"
K XDRCD,XDRCD2
S XDRCD=+$P(^VA(15,XDRDPDA,0),U)
S XDRCD2=+$P(^VA(15,XDRDPDA,0),U,2)
S XDRFL=$O(^VA(15.1,"AGL",$P($P(^VA(15,XDRDPDA,0),U),";",2),0))
I 'XDRFL S XDRERR=6 D ^XDREMSG G ENX
S:XDRFL XDRD(0)=^VA(15.1,XDRFL,0)
D START
ENX Q
;
EOJ ;
I $D(XDRDPDA),'$D(XDRDPDTI) K XDRFL,XDRDSCOR,XDRDTEST,XDRD,XDRQFLG,XDRCD,XDRCD2
Q
VALUE ;
S DA=XDRCD2 K XDRCD2 S XDRCD2=DA
F XDRI=0:0 S XDRI=$O(XDRDSCOR("DR",XDRI)) Q:XDRI'>0 D
. S DIC=XDRI,DA=XDRCD2,DIQ(0)="I",DIQ="XX",DR=XDRDSCOR("DR",XDRI)
. K XX
. D EN^DIQ1
. M XDRCD2=XX K XX,DA,DIC,DR,DIQ
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXDRDUP 2727 printed Dec 13, 2024@02:39:17 Page 2
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
+2 ;;
START ;
+1 KILL %
SET XDRQFLG=0
+2 IF '$DATA(XDRCD)!('$DATA(XDRCD2))
SET XDRERR=7
DO ^XDREMSG
GOTO END
+3 IF '$DATA(XDRDSCOR)
DO ^XDRDSCOR
if XDRQFLG
GOTO END
+4 FOR %="MAX","PDT"
SET XDRDSCOR(%)=0
+5 if $DATA(XDRDSCOR("VDT%"))
SET XDRDSCOR("VDT")=0
+6 DO VALUE
IF $DATA(XDRCD2)'>1
QUIT
+7 ; sites are requesting to merge test patients, REMing next line
+8 ;I XDRFL=2,$E(XDRCD2(2,XDRCD2,.09,"I"),1,5)="00000" Q
+9 DO MAIN
END DO EOJ
+1 QUIT
+2 ;
MAIN ;
+1 FOR XDRDUPFL=0:0
SET XDRDUPFL=$ORDER(XDRDSCOR("DR",XDRDUPFL))
if 'XDRDUPFL
QUIT
DO DIQ1
+2 KILL XDRDUPFL
+3 IF $DATA(XDRCD2)'>0
SET ^XTMP("XDRERR",2,XDRDTYPE,"NO DATA",XDRCD2)=""
QUIT
+4 SET XDRD("DUPSCORE")=0
+5 FOR XDRDTO=0:0
SET XDRDTO=$ORDER(XDRDTEST(XDRDTO))
if 'XDRDTO!(XDRQFLG)
QUIT
DO TEST
+6 KILL XDRDTO
FOR %=0:0
SET %=$ORDER(XDRCD2(%))
if '%
QUIT
KILL XDRCD2(%)
+7 KILL %
+8 SET XDRDSCOR("PDT")="."_XDRDSCOR("PDT%")*XDRDSCOR("MAX")
+9 if $DATA(XDRDSCOR("VDT%"))
SET XDRDSCOR("VDT")="."_XDRDSCOR("VDT%")*XDRDSCOR("MAX")
+10 IF XDRDSCOR("MAX")>0
Begin DoDot:1
+11 NEW J1,J2
+12 SET J1=+$JUSTIFY(XDRD("DUPSCORE")/XDRDSCOR("MAX"),1,2)
+13 SET (^(J1),J2)=$GET(^TMP("XDRDUPSC",XDRFL,XDRDTYPE,J1))+1
+14 IF J1>.6
SET ^TMP("XDRDUPS1",XDRFL,XDRDTYPE,J1,J2)=XDRCD_U_XDRCD2
End DoDot:1
+15 IF '$DATA(XDRD("NOADD"))
IF XDRD("DUPSCORE")'<XDRDSCOR("PDT")
IF '$DATA(XDRDCOMP)
DO ^XDRDADD
MAINX QUIT
+1 ;
DIQ1 ;
+1 SET DIC=XDRDUPFL
SET DIQ(0)="I"
SET DR=XDRDSCOR("DR",XDRDUPFL)
+2 IF '$DATA(XDRCD(XDRDUPFL))
SET DA=XDRCD
SET DIQ="XDRCD"
DO EN^DIQ1
KILL DA,D0
+3 SET DA=XDRCD2
SET DIQ="XDRCD2"
DO EN^DIQ1
KILL DIC,DR,DIQ,DA,D0
+4 QUIT
+5 ;
TEST ;
+1 SET XDRD("TEST ROUTINE")=$SELECT($PIECE($PIECE(XDRDTEST(XDRDTO),U,3),"-",2)]"":$PIECE($PIECE(XDRDTEST(XDRDTO),U,3),"-")_"^"_$PIECE($PIECE(XDRDTEST(XDRDTO),U,3),"-",2),1:U_$PIECE(XDRDTEST(XDRDTO),U,3))
+2 SET X=$PIECE(XDRD("TEST ROUTINE"),U,2)
XECUTE ^%ZOSF("TEST")
KILL X
IF '$TEST
SET XDRERR=8
DO ^XDREMSG
GOTO TESTX
+3 SET XDRD("TEST SCORE")=0
+4 DO @XDRD("TEST ROUTINE")
+5 SET XDRDUP("TEST SCORE",XDRDTO)=XDRD("TEST SCORE")
+6 SET XDRD("DUPSCORE")=XDRD("DUPSCORE")+(XDRD("TEST SCORE"))
+7 if +XDRD("TEST SCORE")'=0
SET XDRDSCOR("MAX")=XDRDSCOR("MAX")+($PIECE(XDRDTEST(XDRDTO),U,6))
TESTX KILL XDRD("TEST ROUTINE")
+1 QUIT
+2 ;
EN ; EP - Called by XDRDADJ,XDRDPDTI
+1 ;
+2 NEW XDRDTYPE
+3 SET XDRDTYPE="BASIC"
+4 KILL XDRCD,XDRCD2
+5 SET XDRCD=+$PIECE(^VA(15,XDRDPDA,0),U)
+6 SET XDRCD2=+$PIECE(^VA(15,XDRDPDA,0),U,2)
+7 SET XDRFL=$ORDER(^VA(15.1,"AGL",$PIECE($PIECE(^VA(15,XDRDPDA,0),U),";",2),0))
+8 IF 'XDRFL
SET XDRERR=6
DO ^XDREMSG
GOTO ENX
+9 if XDRFL
SET XDRD(0)=^VA(15.1,XDRFL,0)
+10 DO START
ENX QUIT
+1 ;
EOJ ;
+1 IF $DATA(XDRDPDA)
IF '$DATA(XDRDPDTI)
KILL XDRFL,XDRDSCOR,XDRDTEST,XDRD,XDRQFLG,XDRCD,XDRCD2
+2 QUIT
VALUE ;
+1 SET DA=XDRCD2
KILL XDRCD2
SET XDRCD2=DA
+2 FOR XDRI=0:0
SET XDRI=$ORDER(XDRDSCOR("DR",XDRI))
if XDRI'>0
QUIT
Begin DoDot:1
+3 SET DIC=XDRI
SET DA=XDRCD2
SET DIQ(0)="I"
SET DIQ="XX"
SET DR=XDRDSCOR("DR",XDRI)
+4 KILL XX
+5 DO EN^DIQ1
+6 MERGE XDRCD2=XX
KILL XX,DA,DIC,DR,DIQ
End DoDot:1
+7 QUIT
