- 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 Jan 18, 2025@03:40:24 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