XDRMAINI ;SF-IRMFO/IHS/OHPRD/JCM - INITIALIZATION ROUTINE FOR XDRMAIN; [ 10/19/92 10:25 AM ] ;1/22/97 10:48
;;7.3;TOOLKIT;**23**;Apr 25, 1995
;;
;
START ;
S XDRQFLG=0
D:'$D(XDRFL) FILE
G:XDRQFLG END
I XDRMAINI="DUP" D DUP I 1
E D MERGE
K XDRMAINI
END Q
;
FILE ;
K DIC("B")
S DIC("A")=$S(XDRMAINI="DUP":"Select file to be checked for duplicates: ",'$D(XDRM("NOVERIFY")):"Select file to verify potential duplicates: ",1:"Select file to merge ready to merge duplicates: ")
S DIC="^VA(15.1,",DIC(0)="QEAZ" D ^DIC K DIC
I Y=-1 S XDRQFLG=1 G FILEX
S XDRFL=$P(Y(0),U,1) K Y
FILEX Q
;
DUP ;
I '$D(^VA(15.1,XDRFL,0)) S XDRERR=6 D ^XDREMSG G DUPX
S XDRD(0)=^VA(15.1,XDRFL,0)
I $D(XDRDNSTA) D STATUS G:XDRQFLG DUPX
S XDRCD=$S($P(^VA(15.1,XDRFL,0),U,8):$P(^VA(15.1,XDRFL,0),U,8),1:0)
S XDRDCNT=$S($P(^VA(15.1,XDRFL,0),U,7):$P(^VA(15.1,XDRFL,0),U,7),1:0)
S XDRGL=^DIC(XDRFL,0,"GL")
S XDRD("COLLECTION ROUTINE")=$S($P($P(XDRD(0),U,9),"-",2)]"":$P($P(XDRD(0),U,9),"-")_"^"_$P($P(XDRD(0),U,9),"-",2),1:U_$P(XDRD(0),U,9))
I '$D(XDRD("DMAILGRP")),$D(XDRD(0)),$P(XDRD(0),U,11),$D(^XMB(3.8,$P(XDRD(0),U,11),1,"B")) F XDRI=0:0 S XDRI=$O(^XMB(3.8,$P(XDRD(0),U,11),1,"B",XDRI)) Q:'XDRI S XDRD("DMAILGRP",XDRI)=""
K XDRI
D ^XDRDSCOR ; Sets up Duplicate Test Scores
DUPX Q
;
STATUS ;
I $P(XDRD(0),U,2)="c",XDRDNSTA="h" S XDRQFLG=1 G STATUSX
K DIE,DA
S DIE=15.1,DA=$P(XDRD(0),U,1)
S DR=".02////"_XDRDNSTA
I XDRDNSTA="r",'$D(XDRDPDTI) S DR=DR_";.03///"_$$NOW^XLFDT()_";.04///@" K ^XTMP("XDRERR",XDRFL) S ^XTMP("XDRERR",0)=($$FMADD^XLFDT(DT,30))_U_DT
S $P(^VA(15.1,XDRFL,3),U)=""
I $P(XDRD(0),U,2)="c"!($P(XDRD(0),U,2)=""),XDRDNSTA="r",'$D(XDRDPDTI) S DR=DR_";.05////"_XDRDTYPE_";.07///@;.08///@;.1///@;.12///@"
D ^DIE K DIE,DA,D0,DR
S:XDRDNSTA="h" XDRQFLG=1
STATUSX Q
;
MERGE ;
I '$D(^VA(15.1,XDRFL,0)) S XDRERR=6 D ^XDREMSG G MERGEX
S XDRM(0)=^VA(15.1,XDRFL,0),XDRGL=^DIC(XDRFL,0,"GL")
I $O(^VA(15.1,XDRFL,12,0)) S XDRM("TOP FILE")=XDRFL F XDRI=0:0 S XDRI=$O(^(XDRI)) Q:'XDRI S XDRM("DINUMS",XDRI)=""
I '$D(XDRM("AUTO")),$P(XDRM(0),U,25) S XDRM("NON-INTERACTIVE")=""
S:$D(XDRM("AUTO")) (XDRM("NON-INTERACTIVE"),XDRM("NOTALK"),XDRM("NOVERIFY"))=""
S:'$D(XDRMPAIR) XDRMPAIR=0
S XDRM("PRE-MERGE")=$S($P($P(XDRM(0),U,27),"-",2)]"":$P($P(XDRM(0),U,27),"-")_"^"_$P($P(XDRM(0),U,27),"-",2),$P(XDRM(0),U,27)]"":U_$P(XDRM(0),U,27),1:"")
I XDRM("PRE-MERGE")]"" S X=$P(XDRM("PRE-MERGE"),U,2) D TEST I '$T S XDRERR=9 D ^XDREMSG G MERGEX
S XDRM("POST-MERGE")=$S($P($P(XDRM(0),U,28),"-",2)]"":$P($P(XDRM(0),U,28),"-")_"^"_$P($P(XDRM(0),U,28),"-",2),$P(XDRM(0),U,28)]"":U_$P(XDRM(0),U,28),1:"")
I XDRM("POST-MERGE")]"" S X=$P(XDRM("POST-MERGE"),U,2) D TEST I '$T S XDRERR=10 D ^XDREMSG G MERGEX
I $P(XDRM(0),U,17)]"" S XDRM("VERIFY-MSG")=$S($P($P(XDRM(0),U,17),"-",2)]"":$P($P(XDRM(0),U,17),"-")_"^"_$P($P(XDRM(0),U,17),"-",2),1:U_$P(XDRM(0),U,17))
I $D(XDRM("VERIFY-MSG")) S X=$P(XDRM("VERIFY-MSG"),U,2) D TEST I '$T S XDRERR=11 D ^XDREMSG G MERGEX
I $P(XDRM(0),U,33)]"" S XDRM("MD-IT")=$S($P($P(XDRM(0),U,33),"-",2)]"":$P($P(XDRM(0),U,33),"-")_"^"_$P($P(XDRM(0),U,33),"-",2),1:U_$P(XDRM(0),U,33))
I $D(XDRM("MD-IT")) S X=$P(XDRM("MD-IT"),U,2) D TEST I '$T S XDRERR=11 D ^XDREMSG G MERGEX
I $P(XDRM(0),U,31)]"" S XDRM("MERGE-MSG")=$S($P($P(XDRM(0),U,31),"-",2)]"":$P($P(XDRM(0),U,31),"-")_"^"_$P($P(XDRM(0),U,31),"-",2),1:U_$P(XDRM(0),U,31)) I 1
I $D(XDRM("MERGE-MSG")) S X=$P(XDRM("MERGE-MSG"),U,2) D TEST I '$T S XDRERR=12 D ^XDREMSG G MERGEX
I '$D(XDRM("NOVERIFY")) S XDRM("GL")="^VA(15,""APOT"","_""""_$P(XDRGL,U,2)_""""_",XDRMPAIR)"
I $O(^VA(15.1,XDRFL,12,0))&($P(XDRM(0),U,25)) S XDRERR=13 D ^XDREMSG G MERGEX
D MAILGRP
MERGEX Q
;
TEST ;
X ^%ZOSF("TEST") K X
Q
;
MAILGRP ;
I '$D(XDRM("VERIFY-MSG")),'$D(XDRM("VMAILGRP")),$D(XDRM(0)),$P(XDRM(0),U,16),$D(^XMB(3.8,$P(XDRM(0),U,16),1,"B")) F XDRI=0:0 S XDRI=$O(^XMB(3.8,$P(XDRM(0),U,16),1,"B",XDRI)) Q:'XDRI S XDRM("VMAILGRP",XDRI)=""
I '$D(XDRM("MERGE-MSG")),'$D(XDRM("MMAILGRP")),$D(XDRM(0)),$P(XDRM(0),U,29),$D(^XMB(3.8,$P(XDRM(0),U,29),1,"B")) F XDRI=0:0 S XDRI=$O(^XMB(3.8,$P(XDRM(0),U,29),1,"B",XDRI)) Q:'XDRI S XDRM("MMAILGRP",XDRI)=""
I '$D(XDRD("DMAILGRP")),$D(XDRM(0)),$P(XDRM(0),U,11),$D(^XMB(3.8,$P(XDRM(0),U,11),1,"B")) F XDRI=0:0 S XDRI=$O(^XMB(3.8,$P(XDRM(0),U,11),1,"B",XDRI)) Q:'XDRI S XDRD("DMAILGRP",XDRI)=""
K XDRI
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXDRMAINI 4403 printed Dec 13, 2024@02:39:27 Page 2
XDRMAINI ;SF-IRMFO/IHS/OHPRD/JCM - INITIALIZATION ROUTINE FOR XDRMAIN; [ 10/19/92 10:25 AM ] ;1/22/97 10:48
+1 ;;7.3;TOOLKIT;**23**;Apr 25, 1995
+2 ;;
+3 ;
START ;
+1 SET XDRQFLG=0
+2 if '$DATA(XDRFL)
DO FILE
+3 if XDRQFLG
GOTO END
+4 IF XDRMAINI="DUP"
DO DUP
IF 1
+5 IF '$TEST
DO MERGE
+6 KILL XDRMAINI
END QUIT
+1 ;
FILE ;
+1 KILL DIC("B")
+2 SET DIC("A")=$SELECT(XDRMAINI="DUP":"Select file to be checked for duplicates: ",'$DATA(XDRM("NOVERIFY")):"Select file to verify potential duplicates: ",1:"Select file to merge ready to merge duplicates: ")
+3 SET DIC="^VA(15.1,"
SET DIC(0)="QEAZ"
DO ^DIC
KILL DIC
+4 IF Y=-1
SET XDRQFLG=1
GOTO FILEX
+5 SET XDRFL=$PIECE(Y(0),U,1)
KILL Y
FILEX QUIT
+1 ;
DUP ;
+1 IF '$DATA(^VA(15.1,XDRFL,0))
SET XDRERR=6
DO ^XDREMSG
GOTO DUPX
+2 SET XDRD(0)=^VA(15.1,XDRFL,0)
+3 IF $DATA(XDRDNSTA)
DO STATUS
if XDRQFLG
GOTO DUPX
+4 SET XDRCD=$SELECT($PIECE(^VA(15.1,XDRFL,0),U,8):$PIECE(^VA(15.1,XDRFL,0),U,8),1:0)
+5 SET XDRDCNT=$SELECT($PIECE(^VA(15.1,XDRFL,0),U,7):$PIECE(^VA(15.1,XDRFL,0),U,7),1:0)
+6 SET XDRGL=^DIC(XDRFL,0,"GL")
+7 SET XDRD("COLLECTION ROUTINE")=$SELECT($PIECE($PIECE(XDRD(0),U,9),"-",2)]"":$PIECE($PIECE(XDRD(0),U,9),"-")_"^"_$PIECE($PIECE(XDRD(0),U,9),"-",2),1:U_$PIECE(XDRD(0),U,9))
+8 IF '$DATA(XDRD("DMAILGRP"))
IF $DATA(XDRD(0))
IF $PIECE(XDRD(0),U,11)
IF $DATA(^XMB(3.8,$PIECE(XDRD(0),U,11),1,"B"))
FOR XDRI=0:0
SET XDRI=$ORDER(^XMB(3.8,$PIECE(XDRD(0),U,11),1,"B",XDRI))
if 'XDRI
QUIT
SET XDRD("DMAILGRP",XDRI)=""
+9 KILL XDRI
+10 ; Sets up Duplicate Test Scores
DO ^XDRDSCOR
DUPX QUIT
+1 ;
STATUS ;
+1 IF $PIECE(XDRD(0),U,2)="c"
IF XDRDNSTA="h"
SET XDRQFLG=1
GOTO STATUSX
+2 KILL DIE,DA
+3 SET DIE=15.1
SET DA=$PIECE(XDRD(0),U,1)
+4 SET DR=".02////"_XDRDNSTA
+5 IF XDRDNSTA="r"
IF '$DATA(XDRDPDTI)
SET DR=DR_";.03///"_$$NOW^XLFDT()_";.04///@"
KILL ^XTMP("XDRERR",XDRFL)
SET ^XTMP("XDRERR",0)=($$FMADD^XLFDT(DT,30))_U_DT
+6 SET $PIECE(^VA(15.1,XDRFL,3),U)=""
+7 IF $PIECE(XDRD(0),U,2)="c"!($PIECE(XDRD(0),U,2)="")
IF XDRDNSTA="r"
IF '$DATA(XDRDPDTI)
SET DR=DR_";.05////"_XDRDTYPE_";.07///@;.08///@;.1///@;.12///@"
+8 DO ^DIE
KILL DIE,DA,D0,DR
+9 if XDRDNSTA="h"
SET XDRQFLG=1
STATUSX QUIT
+1 ;
MERGE ;
+1 IF '$DATA(^VA(15.1,XDRFL,0))
SET XDRERR=6
DO ^XDREMSG
GOTO MERGEX
+2 SET XDRM(0)=^VA(15.1,XDRFL,0)
SET XDRGL=^DIC(XDRFL,0,"GL")
+3 IF $ORDER(^VA(15.1,XDRFL,12,0))
SET XDRM("TOP FILE")=XDRFL
FOR XDRI=0:0
SET XDRI=$ORDER(^(XDRI))
if 'XDRI
QUIT
SET XDRM("DINUMS",XDRI)=""
+4 IF '$DATA(XDRM("AUTO"))
IF $PIECE(XDRM(0),U,25)
SET XDRM("NON-INTERACTIVE")=""
+5 if $DATA(XDRM("AUTO"))
SET (XDRM("NON-INTERACTIVE"),XDRM("NOTALK"),XDRM("NOVERIFY"))=""
+6 if '$DATA(XDRMPAIR)
SET XDRMPAIR=0
+7 SET XDRM("PRE-MERGE")=$SELECT($PIECE($PIECE(XDRM(0),U,27),"-",2)]"":$PIECE($PIECE(XDRM(0),U,27),"-")_"^"_$PIECE($PIECE(XDRM(0),U,27),"-",2),$PIECE(XDRM(0),U,27)]"":U_$PIECE(XDRM(0),U,27),1:"")
+8 IF XDRM("PRE-MERGE")]""
SET X=$PIECE(XDRM("PRE-MERGE"),U,2)
DO TEST
IF '$TEST
SET XDRERR=9
DO ^XDREMSG
GOTO MERGEX
+9 SET XDRM("POST-MERGE")=$SELECT($PIECE($PIECE(XDRM(0),U,28),"-",2)]"":$PIECE($PIECE(XDRM(0),U,28),"-")_"^"_$PIECE($PIECE(XDRM(0),U,28),"-",2),$PIECE(XDRM(0),U,28)]"":U_$PIECE(XDRM(0),U,28),1:"")
+10 IF XDRM("POST-MERGE")]""
SET X=$PIECE(XDRM("POST-MERGE"),U,2)
DO TEST
IF '$TEST
SET XDRERR=10
DO ^XDREMSG
GOTO MERGEX
+11 IF $PIECE(XDRM(0),U,17)]""
SET XDRM("VERIFY-MSG")=$SELECT($PIECE($PIECE(XDRM(0),U,17),"-",2)]"":$PIECE($PIECE(XDRM(0),U,17),"-")_"^"_$PIECE($PIECE(XDRM(0),U,17),"-",2),1:U_$PIECE(XDRM(0),U,17))
+12 IF $DATA(XDRM("VERIFY-MSG"))
SET X=$PIECE(XDRM("VERIFY-MSG"),U,2)
DO TEST
IF '$TEST
SET XDRERR=11
DO ^XDREMSG
GOTO MERGEX
+13 IF $PIECE(XDRM(0),U,33)]""
SET XDRM("MD-IT")=$SELECT($PIECE($PIECE(XDRM(0),U,33),"-",2)]"":$PIECE($PIECE(XDRM(0),U,33),"-")_"^"_$PIECE($PIECE(XDRM(0),U,33),"-",2),1:U_$PIECE(XDRM(0),U,33))
+14 IF $DATA(XDRM("MD-IT"))
SET X=$PIECE(XDRM("MD-IT"),U,2)
DO TEST
IF '$TEST
SET XDRERR=11
DO ^XDREMSG
GOTO MERGEX
+15 IF $PIECE(XDRM(0),U,31)]""
SET XDRM("MERGE-MSG")=$SELECT($PIECE($PIECE(XDRM(0),U,31),"-",2)]"":$PIECE($PIECE(XDRM(0),U,31),"-")_"^"_$PIECE($PIECE(XDRM(0),U,31),"-",2),1:U_$PIECE(XDRM(0),U,31))
IF 1
+16 IF $DATA(XDRM("MERGE-MSG"))
SET X=$PIECE(XDRM("MERGE-MSG"),U,2)
DO TEST
IF '$TEST
SET XDRERR=12
DO ^XDREMSG
GOTO MERGEX
+17 IF '$DATA(XDRM("NOVERIFY"))
SET XDRM("GL")="^VA(15,""APOT"","_""""_$PIECE(XDRGL,U,2)_""""_",XDRMPAIR)"
+18 IF $ORDER(^VA(15.1,XDRFL,12,0))&($PIECE(XDRM(0),U,25))
SET XDRERR=13
DO ^XDREMSG
GOTO MERGEX
+19 DO MAILGRP
MERGEX QUIT
+1 ;
TEST ;
+1 XECUTE ^%ZOSF("TEST")
KILL X
+2 QUIT
+3 ;
MAILGRP ;
+1 IF '$DATA(XDRM("VERIFY-MSG"))
IF '$DATA(XDRM("VMAILGRP"))
IF $DATA(XDRM(0))
IF $PIECE(XDRM(0),U,16)
IF $DATA(^XMB(3.8,$PIECE(XDRM(0),U,16),1,"B"))
FOR XDRI=0:0
SET XDRI=$ORDER(^XMB(3.8,$PIECE(XDRM(0),U,16),1,"B",XDRI))
if 'XDRI
QUIT
SET XDRM("VMAILGRP",XDRI)=""
+2 IF '$DATA(XDRM("MERGE-MSG"))
IF '$DATA(XDRM("MMAILGRP"))
IF $DATA(XDRM(0))
IF $PIECE(XDRM(0),U,29)
IF $DATA(^XMB(3.8,$PIECE(XDRM(0),U,29),1,"B"))
FOR XDRI=0:0
SET XDRI=$ORDER(^XMB(3.8,$PIECE(XDRM(0),U,29),1,"B",XDRI))
if 'XDRI
QUIT
SET XDRM("MMAILGRP",XDRI)=""
+3 IF '$DATA(XDRD("DMAILGRP"))
IF $DATA(XDRM(0))
IF $PIECE(XDRM(0),U,11)
IF $DATA(^XMB(3.8,$PIECE(XDRM(0),U,11),1,"B"))
FOR XDRI=0:0
SET XDRI=$ORDER(^XMB(3.8,$PIECE(XDRM(0),U,11),1,"B",XDRI))
if 'XDRI
QUIT
SET XDRD("DMAILGRP",XDRI)=""
+4 KILL XDRI
+5 QUIT
