source: WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DITM2.m@ 1042

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

initial load of WorldVistAEHR

File size: 2.6 KB
Line 
1DITM2 ;SFISC/JCM(OHPRD)-DOES COMPARE AND MERGE ;11/18/94 15:42
2 ;;22.0;VA FileMan;;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; See DITMDOC for documentation
6 ; Subfiles are not currently supported by the call to EN^DITM2
7 ; until DITC can handle them.
8 ;-------------------------------------------------------------------
9START ;
10EN ; Entry point
11 L +@(DITM("DIC")_$P(DITM("DIT(1)"),",",1)_")")
12 L +@(DITM("DIC")_$P(DITM("DIT(2)"),",",1)_")")
13 K DMSG,DIRUT
14 D:'$D(DITM("NON-INTERACTIVE")) DITC ; --->Sets up and calls DITC
15 I $D(DMSG)!($D(DIRUT)) S DITM("QFLG")="" G END
16 G:'$D(DITM("DIMERGE")) END
17 D:'$D(DITM("SUB FILE")) DIT0 ; --->Sets up and calls DIT0
18 D:$D(DITM("REPOINT"))&('$D(DITM("SUB FILE"))) REPOINT ;---->Merges
19 ;---------------->other files that affect patient merge
20 G:$D(DITM("QFLG")) END
21 D:$D(DITM("DELETE")) DELETE ;----->Deletes MERGED entry
22END L -@(DITM("DIC")_$P(DITM("DIT(1)"),",",1)_")")
23 L -@(DITM("DIC")_$P(DITM("DIT(2)"),",",1)_")")
24 D EOJ ;----------->Cleanup
25 Q ;-------------->End of routine
26 ;----------------------------------------------------------------------
27DITC ;
28 ;***Will need to add set up for subfiles when it works******
29 ;
30 K DFF,DIT,DIMERGE,DDIF,DDEF,DDSP
31 S DFF=DITM("DFF"),DIT(1)=DITM("DIT(1)"),DIT(2)=DITM("DIT(2)"),DIC=DITM("DIC")
32 S:$D(DITM("DIMERGE")) DIMERGE=1
33 S:$D(DITM("DDIF")) DDIF=DITM("DDIF")
34 S:$D(DITM("DDEF")) DDEF=DITM("DDEF")
35 S:$D(DITM("DDSP")) DDSP=1
36 D EN^DITC
37 K DFF,DIT,DIMERGE,DDIF,DDEF,DDSP
38 Q
39DIT0 ;
40 W:'$D(DITM("NOTALK")) !!,"I will now merge all subfiles in this file ...",!,"This may take some time, please be patient."
41 K DA
42 S (DIT("T"),DIT("F"))=DITM("DIC")
43 S (D0,DA("T"))=DITM("DIT(2)"),DA("F")=DITM("DIT(1)")
44 D EN^DIT0 K D0,DA,DIC,DIK,DIT
45 Q
46REPOINT ;
47 S DITMGMQF=0
48 S:$D(DITM("NON-INTERACTIVE")) DITMGMRG("NOTALK")=1
49 S:$D(DITM("PACKAGE")) DITMGMRG("PACKAGE")=DITM("PACKAGE")
50 W:'$D(DITM("NOTALK")) !!,"I will now repoint all files that point to this entry ...",!,"This may take some time, please be patient."
51 S DITMGMRG("FILE")=DITM("DFF"),DITMGMRG("FR")=DITM("DIT(1)"),DITMGMRG("TO")=DITM("DIT(2)")
52 S:$D(DITM("NOTALK")) DITMGMRG("NOTALK")=""
53 I $D(DITM("EXCLUDE")) F DITMI=0:0 S DITMI=$O(DITM("EXCLUDE",DITMI)) Q:'DITMI S DITMGMRG("EXCLUDE",DITMI)=""
54 D EN^DITMGMRG
55 K DITMGMRG,DITMGMQF,DITMI
56 Q
57DELETE ;
58 W:'$D(DITM("NOTALK")) !,"Deleting From entry"
59 I $D(DITM("SUB FILE")) D DELSUB G DELETEX
60 S DIK=DITM("DIC"),DA=DITM("DIT(1)") D ^DIK K DA,DIK
61DELETEX Q
62 ;
63DELSUB ;
64 S DA(1)=$P(DITM("DIT(1)"),",",1),DA=$P(DITM("DIT(1)"),",",2)
65 S DIK=DITM("DIC")_DA(1)_","_DITM("DSUB1")_"," D ^DIK K DA,DIK
66 Q
67EOJ ;
68 K DITM2,APMMD,DIC,X,Y
69 Q
Note: See TracBrowser for help on using the repository browser.