XDRDADD ;SF-IRMFO/IHS/OHPRD/JCM - ADDS RECORDS TO DUPLICATE RECORD FILE ;2/20/97 10:41
;;7.3;TOOLKIT;**23**;Apr 25, 1995
;;
START ;
D INIT ; Sets up the duplicate percentile score and FR and TO DFN's
I '$D(XDRDPDA) D ADD I 1 ; Adds entrys during background search
E D EDIT
END D EOJ ; Cleans up variables
Q ;End of routine
;
INIT ;
S XDRDADD("DUPSCORE%")=XDRD("DUPSCORE")/XDRDSCOR("MAX")
S XDRDADD("DUPSCORE%")=$J(XDRDADD("DUPSCORE%"),1,2)
S XDRDADD("DUPSCORE%")=$S(XDRDADD("DUPSCORE%")<0:0,XDRDADD("DUPSCORE%")<1:$E(XDRDADD("DUPSCORE%"),3,4),1:100)
S XDRDADD("FR")=$S(XDRCD<XDRCD2:XDRCD,1:XDRCD2)
S XDRDADD("TO")=$S(XDRDADD("FR")=XDRCD:XDRCD2,1:XDRCD)
I $D(XDRDSCOR("VDT")) S XDRDADD("STATUS")=$S(XDRD("DUPSCORE")'<XDRDSCOR("VDT"):"V",1:"P")
E S XDRDADD("STATUS")="P"
Q
;
ADD ;
;ADD TO DUPLICATE RECORD FILE
S DIC="^VA(15,",DIC(0)="L",X=XDRDADD("FR")_";"_$P(XDRGL,U,2),DLAYGO=15
S XDRDADDX=XDRDADD("TO")_";"_$P(XDRGL,U,2)
S DIC("DR")=".02////^S X=XDRDADDX"_";.03////"_XDRDADD("STATUS")
S:XDRDADD("STATUS")="V" DIC("DR")=DIC("DR")_";.04////2"
S DIC("DR")=DIC("DR")_";.06////"_DT
S DIC("DR")=DIC("DR")_";.15////"_XDRDSCOR("MAX")_";.17////"_XDRDSCOR("PDT%")_";.18////"_XDRD("DUPSCORE")_";.19////"_XDRDADD("DUPSCORE%")
S:$D(XDRDSCOR("VDT%")) DIC("DR")=DIC("DR")_";.16////"_XDRDSCOR("VDT%")
D
. N I,X1,X2,X3
. S X1=X_U_XDRDADDX,X2=XDRDADDX_U_X
. 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
S Y=-1 I $D(X) D FILE^DICN
K DIC,DR,X,DLAYGO
Q:Y'>0 S DIE="^VA(15,",(XDRDPDA,DA)=+Y
F XDRDORD=0:0 S XDRDORD=$O(XDRDTEST(XDRDORD)) Q:'XDRDORD S DR="2101///"_$P(XDRDTEST(XDRDORD),U),DR(2,15.02101)=".02////"_XDRDUP("TEST SCORE",XDRDORD) D ^DIE K DR
;I XDRDADD("STATUS")="V" D MERGE ; MODIFIED 1/12/96 JLI TO PREVENT AUTO MERGE
D
. N DA,DIE,DR
. S DA=XDRFL,DIE="^VA(15.1,"
. S DR=".12///"_($P(^VA(15.1,XDRFL,0),U,12)+1)
. D ^DIE
ADDX K DIE,DR,DA,XDRDORD,XDRDADDX,XDRDPDA
Q
MERGE Q
S XDRMPAIR=XDRDADD("FR")_"^"_XDRDADD("TO"),XDRM("AUTO")=""
S XDRMPDA=XDRDPDA
D EN^XDRMAIN
MERGEX K XDRM,XDRMPAIR
Q
EDIT ;
NEW D,D0,DA,DB,DC,DE,DG,DH,DI,DIC,DICR,DIE,DIEL,DIFLD,DIG,DIH,DIK,DINAME,DIP,DIU,DIV,DIW,DK,DL,DM,DOV,DP,DQ,DR,DSC,DU,DV,DW,DXS,X,Y
S DIE="^VA(15,",DA=XDRDPDA
S DR=".15////"_XDRDSCOR("MAX")_";.17////"_XDRDSCOR("PDT%")_";.18////"_XDRD("DUPSCORE")_";.19////"_XDRDADD("DUPSCORE%") I $D(XDRDSCOR("VDT%")) S:$D(XDRDSCOR("VDT%")) DR=DR_";.16////"_XDRDSCOR("VDT%")
D ^DIE K DIE,DA,DR
F XDRDORD=0:0 S XDRDORD=$O(^VA(15,XDRDPDA,21,0)) Q:'XDRDORD S DA=XDRDORD,DA(1)=XDRDPDA,DIK="^VA(15,"_DA(1)_",21," S XDRDRTN="^DIK" D IDO K DA,DIK
K XDRDORD
F XDRDORD=0:0 S XDRDORD=$O(XDRDTEST(XDRDORD)) Q:'XDRDORD S DR="2101///"_$P(XDRDTEST(XDRDORD),U),DR(2,15.02101)=".02////"_$P(XDRDTEST(XDRDORD),U,7),DIE="^VA(15,",DA=XDRDPDA,XDRDRTN="^DIE" D IDO K DIE,DA,DR
K XDRDORD
Q
IDO NEW D,D0,DB,DC,DE,DG,DH,DI,DIC,DICR,DIEL,DIFLD,DIG,DIH,DINAME,DIP,DIU,DIV,DIW,DK,DL,DM,DOV,DP,DQ,DSC,DU,DV,DW,DXS,X,Y
D @XDRDRTN K XDRDRTN
Q
EOJ ;
K XDRDADD,X,Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXDRDADD 3082 printed Oct 16, 2024@18:39:32 Page 2
XDRDADD ;SF-IRMFO/IHS/OHPRD/JCM - ADDS RECORDS TO DUPLICATE RECORD FILE ;2/20/97 10:41
+1 ;;7.3;TOOLKIT;**23**;Apr 25, 1995
+2 ;;
START ;
+1 ; Sets up the duplicate percentile score and FR and TO DFN's
DO INIT
+2 ; Adds entrys during background search
IF '$DATA(XDRDPDA)
DO ADD
IF 1
+3 IF '$TEST
DO EDIT
END ; Cleans up variables
DO EOJ
+1 ;End of routine
QUIT
+2 ;
INIT ;
+1 SET XDRDADD("DUPSCORE%")=XDRD("DUPSCORE")/XDRDSCOR("MAX")
+2 SET XDRDADD("DUPSCORE%")=$JUSTIFY(XDRDADD("DUPSCORE%"),1,2)
+3 SET XDRDADD("DUPSCORE%")=$SELECT(XDRDADD("DUPSCORE%")<0:0,XDRDADD("DUPSCORE%")<1:$EXTRACT(XDRDADD("DUPSCORE%"),3,4),1:100)
+4 SET XDRDADD("FR")=$SELECT(XDRCD<XDRCD2:XDRCD,1:XDRCD2)
+5 SET XDRDADD("TO")=$SELECT(XDRDADD("FR")=XDRCD:XDRCD2,1:XDRCD)
+6 IF $DATA(XDRDSCOR("VDT"))
SET XDRDADD("STATUS")=$SELECT(XDRD("DUPSCORE")'<XDRDSCOR("VDT"):"V",1:"P")
+7 IF '$TEST
SET XDRDADD("STATUS")="P"
+8 QUIT
+9 ;
ADD ;
+1 ;ADD TO DUPLICATE RECORD FILE
+2 SET DIC="^VA(15,"
SET DIC(0)="L"
SET X=XDRDADD("FR")_";"_$PIECE(XDRGL,U,2)
SET DLAYGO=15
+3 SET XDRDADDX=XDRDADD("TO")_";"_$PIECE(XDRGL,U,2)
+4 SET DIC("DR")=".02////^S X=XDRDADDX"_";.03////"_XDRDADD("STATUS")
+5 if XDRDADD("STATUS")="V"
SET DIC("DR")=DIC("DR")_";.04////2"
+6 SET DIC("DR")=DIC("DR")_";.06////"_DT
+7 SET DIC("DR")=DIC("DR")_";.15////"_XDRDSCOR("MAX")_";.17////"_XDRDSCOR("PDT%")_";.18////"_XDRD("DUPSCORE")_";.19////"_XDRDADD("DUPSCORE%")
+8 if $DATA(XDRDSCOR("VDT%"))
SET DIC("DR")=DIC("DR")_";.16////"_XDRDSCOR("VDT%")
+9 Begin DoDot:1
+10 NEW I,X1,X2,X3
+11 SET X1=X_U_XDRDADDX
SET X2=XDRDADDX_U_X
+12 FOR I=0:0
SET I=$ORDER(^VA(15,"B",X,I))
if I'>0
QUIT
SET X3=$PIECE($GET(^VA(15,I,0)),U,1,2)
IF X3=X1!(X3=X2)
KILL X
QUIT
End DoDot:1
+13 SET Y=-1
IF $DATA(X)
DO FILE^DICN
+14 KILL DIC,DR,X,DLAYGO
+15 if Y'>0
QUIT
SET DIE="^VA(15,"
SET (XDRDPDA,DA)=+Y
+16 FOR XDRDORD=0:0
SET XDRDORD=$ORDER(XDRDTEST(XDRDORD))
if 'XDRDORD
QUIT
SET DR="2101///"_$PIECE(XDRDTEST(XDRDORD),U)
SET DR(2,15.02101)=".02////"_XDRDUP("TEST SCORE",XDRDORD)
DO ^DIE
KILL DR
+17 ;I XDRDADD("STATUS")="V" D MERGE ; MODIFIED 1/12/96 JLI TO PREVENT AUTO MERGE
+18 Begin DoDot:1
+19 NEW DA,DIE,DR
+20 SET DA=XDRFL
SET DIE="^VA(15.1,"
+21 SET DR=".12///"_($PIECE(^VA(15.1,XDRFL,0),U,12)+1)
+22 DO ^DIE
End DoDot:1
ADDX KILL DIE,DR,DA,XDRDORD,XDRDADDX,XDRDPDA
+1 QUIT
MERGE QUIT
+1 SET XDRMPAIR=XDRDADD("FR")_"^"_XDRDADD("TO")
SET XDRM("AUTO")=""
+2 SET XDRMPDA=XDRDPDA
+3 DO EN^XDRMAIN
MERGEX KILL XDRM,XDRMPAIR
+1 QUIT
EDIT ;
+1 NEW D,D0,DA,DB,DC,DE,DG,DH,DI,DIC,DICR,DIE,DIEL,DIFLD,DIG,DIH,DIK,DINAME,DIP,DIU,DIV,DIW,DK,DL,DM,DOV,DP,DQ,DR,DSC,DU,DV,DW,DXS,X,Y
+2 SET DIE="^VA(15,"
SET DA=XDRDPDA
+3 SET DR=".15////"_XDRDSCOR("MAX")_";.17////"_XDRDSCOR("PDT%")_";.18////"_XDRD("DUPSCORE")_";.19////"_XDRDADD("DUPSCORE%")
IF $DATA(XDRDSCOR("VDT%"))
if $DATA(XDRDSCOR("VDT%"))
SET DR=DR_";.16////"_XDRDSCOR("VDT%")
+4 DO ^DIE
KILL DIE,DA,DR
+5 FOR XDRDORD=0:0
SET XDRDORD=$ORDER(^VA(15,XDRDPDA,21,0))
if 'XDRDORD
QUIT
SET DA=XDRDORD
SET DA(1)=XDRDPDA
SET DIK="^VA(15,"_DA(1)_",21,"
SET XDRDRTN="^DIK"
DO IDO
KILL DA,DIK
+6 KILL XDRDORD
+7 FOR XDRDORD=0:0
SET XDRDORD=$ORDER(XDRDTEST(XDRDORD))
if 'XDRDORD
QUIT
SET DR="2101///"_$PIECE(XDRDTEST(XDRDORD),U)
SET DR(2,15.02101)=".02////"_$PIECE(XDRDTEST(XDRDORD),U,7)
SET DIE="^VA(15,"
SET DA=XDRDPDA
SET XDRDRTN="^DIE"
DO IDO
KILL DIE,DA,DR
+8 KILL XDRDORD
+9 QUIT
IDO NEW D,D0,DB,DC,DE,DG,DH,DI,DIC,DICR,DIEL,DIFLD,DIG,DIH,DINAME,DIP,DIU,DIV,DIW,DK,DL,DM,DOV,DP,DQ,DSC,DU,DV,DW,DXS,X,Y
+1 DO @XDRDRTN
KILL XDRDRTN
+2 QUIT
EOJ ;
+1 KILL XDRDADD,X,Y
+2 QUIT
