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