- 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 Feb 19, 2025@00:05:23 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
