source: WorldVistAEHR/trunk/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XDRDADD.m@ 789

Last change on this file since 789 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.9 KB
Line 
1XDRDADD ;SF-IRMFO/IHS/OHPRD/JCM - ADDS RECORDS TO DUPLICATE RECORD FILE ;2/20/97 10:41
2 ;;7.3;TOOLKIT;**23**;Apr 25, 1995
3 ;;
4START ;
5 D INIT ; Sets up the duplicate percentile score and FR and TO DFN's
6 I '$D(XDRDPDA) D ADD I 1 ; Adds entrys during background search
7 E D EDIT
8END D EOJ ; Cleans up variables
9 Q ;End of routine
10 ;
11INIT ;
12 S XDRDADD("DUPSCORE%")=XDRD("DUPSCORE")/XDRDSCOR("MAX")
13 S XDRDADD("DUPSCORE%")=$J(XDRDADD("DUPSCORE%"),1,2)
14 S XDRDADD("DUPSCORE%")=$S(XDRDADD("DUPSCORE%")<0:0,XDRDADD("DUPSCORE%")<1:$E(XDRDADD("DUPSCORE%"),3,4),1:100)
15 S XDRDADD("FR")=$S(XDRCD<XDRCD2:XDRCD,1:XDRCD2)
16 S XDRDADD("TO")=$S(XDRDADD("FR")=XDRCD:XDRCD2,1:XDRCD)
17 I $D(XDRDSCOR("VDT")) S XDRDADD("STATUS")=$S(XDRD("DUPSCORE")'<XDRDSCOR("VDT"):"V",1:"P")
18 E S XDRDADD("STATUS")="P"
19 Q
20 ;
21ADD ;
22 ;ADD TO DUPLICATE RECORD FILE
23 S DIC="^VA(15,",DIC(0)="L",X=XDRDADD("FR")_";"_$P(XDRGL,U,2),DLAYGO=15
24 S XDRDADDX=XDRDADD("TO")_";"_$P(XDRGL,U,2)
25 S DIC("DR")=".02////^S X=XDRDADDX"_";.03////"_XDRDADD("STATUS")
26 S:XDRDADD("STATUS")="V" DIC("DR")=DIC("DR")_";.04////2"
27 S DIC("DR")=DIC("DR")_";.06////"_DT
28 S DIC("DR")=DIC("DR")_";.15////"_XDRDSCOR("MAX")_";.17////"_XDRDSCOR("PDT%")_";.18////"_XDRD("DUPSCORE")_";.19////"_XDRDADD("DUPSCORE%")
29 S:$D(XDRDSCOR("VDT%")) DIC("DR")=DIC("DR")_";.16////"_XDRDSCOR("VDT%")
30 D
31 . N I,X1,X2,X3
32 . S X1=X_U_XDRDADDX,X2=XDRDADDX_U_X
33 . 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
34 S Y=-1 I $D(X) D FILE^DICN
35 K DIC,DR,X,DLAYGO
36 Q:Y'>0 S DIE="^VA(15,",(XDRDPDA,DA)=+Y
37 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
38 ;I XDRDADD("STATUS")="V" D MERGE ; MODIFIED 1/12/96 JLI TO PREVENT AUTO MERGE
39 D
40 . N DA,DIE,DR
41 . S DA=XDRFL,DIE="^VA(15.1,"
42 . S DR=".12///"_($P(^VA(15.1,XDRFL,0),U,12)+1)
43 . D ^DIE
44ADDX K DIE,DR,DA,XDRDORD,XDRDADDX,XDRDPDA
45 Q
46MERGE Q
47 S XDRMPAIR=XDRDADD("FR")_"^"_XDRDADD("TO"),XDRM("AUTO")=""
48 S XDRMPDA=XDRDPDA
49 D EN^XDRMAIN
50MERGEX K XDRM,XDRMPAIR
51 Q
52EDIT ;
53 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
54 S DIE="^VA(15,",DA=XDRDPDA
55 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%")
56 D ^DIE K DIE,DA,DR
57 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
58 K XDRDORD
59 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
60 K XDRDORD
61 Q
62IDO 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
63 D @XDRDRTN K XDRDRTN
64 Q
65EOJ ;
66 K XDRDADD,X,Y
67 Q
Note: See TracBrowser for help on using the repository browser.