XPDIA1 ;SFISC/RSD - Install Pre/Post Actions for Kernel files cont. ; Apr 15, 2022@08:55:53
;;8.0;KERNEL;**2,44,51,58,68,85,131,146,182,229,302,399,507,539,672,750,768**;Jul 10, 1995;Build 8
;Per VHA Directive 2004-038, this routine should not be modified.
Q
HLPF1 ;help frames file pre
K ^TMP($J,"XPD")
Q
HLPE1 ;entry pre
S ^TMP($J,"XPD",DA)="" K ^DIC(9.2,DA,1),^(2),^(3),^(10)
Q
HLPF2 ;file post
N DA,DIK,I,X,Y,Y0
;need to send error message, need to setup message
S DA=0,DIK=DIC F S DA=$O(^TMP($J,"XPD",DA)) Q:'DA D
.;repoint Related Frame (2;0)
.S I=0 F S I=$O(^DIC(9.2,DA,2,I)) Q:'I S Y0=$G(^(I,0)),Y=$$LK^XPDIA("^DIC(9.2)",$P(Y0,U,2)),$P(^DIC(9.2,DA,2,I,0),U,2)=Y
.;repoint OBJECT (10;0)
.S (I,X)=0 F S I=$O(^DIC(9.2,DA,10,I)) Q:'I S Y0=$G(^(I,0)) D
..S Y=$$LK^XPDIA("^MAG",$P(Y0,U)) S:Y $P(^DIC(9.2,DA,10,I,0),U)=Y,X=X+1_U_I
..K:'Y ^DIC(9.2,DA,10,I)
.I X S $P(^DIC(9.2,DA,10,0),U,3,4)=$P(X,U,2)_U_+X
.D IX1^DIK
K ^TMP($J,"XPD")
Q
HLPDEL ;help frame delete
N DA,DIK,XPDI,XPDJ
S XPDI=0
F S XPDI=$O(^TMP($J,"XPDEL",XPDI)),XPDJ=0 Q:'XPDI D
.S DIK="^DIC(9.2,XPDJ,2,"
.;check other frames that point to this one
.F S XPDJ=$O(^DIC(9.2,"AE",XPDI,XPDJ)) Q:'XPDJ S Z=$O(^(XPDJ,0)) D:Z
..K DA S DA=Z,DA(1)=XPDJ D ^DIK
.;delete this frame
.K DA S DA=XPDI,DIK="^DIC(9.2," D ^DIK
Q
BULE1 ;bulletin entry pre
N X,I S I=0
;save current Mail Groups (2)
I $G(^XMB(3.6,DA,2,0))]"" S X(0)=^(0) F S I=$O(^XMB(3.6,DA,2,I)) Q:'I S X(I)=$G(^(I,0))
K ^XMB(3.6,DA)
;after killing data, put back Mail Groups before data merge
I $D(X) S ^XMB(3.6,DA,2,0)=X(0),I=0 F S I=$O(X(I)) Q:'I S ^XMB(3.6,DA,2,I,0)=X(I)
Q
BULDEL ;del bulletins
D DELIEN^XPDUTL1(3.6,$G(%))
Q
MAILGF1 ;mail groups file pre
K ^TMP($J,"XPD")
Q
MAILGE1 ;mail group entry pre
N I,J
S ^TMP($J,"XPD",DA)=""
;save MEMBER GROUPS (5;0)
I $O(^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,5,0)) M ^TMP($J,"XPD",DA,5)=^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,5) K ^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,5)
;save MEMBER - REMOTE (6;0)
I $O(^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,6,0)) M ^TMP($J,"XPD",DA,6)=^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,6) K ^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,6)
;if there is a new Description, kill the old Description
K:$O(^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,2,0)) ^XMB(3.8,DA,2)
;I=current mail group, J=incoming mail group
S I=^XMB(3.8,DA,0),J=^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,0)
;save REFERENCE COUNT (0;4) & LAST REFERENCED (0;5)
S:$P(I,U,4) $P(J,U,4)=$P(I,U,4) S:$P(I,U,5) $P(J,U,5)=$P(I,U,5)
;check COORDINATOR (0;7), bring in one that was asked during install question
D
.;get the existing coordinator, and set it
.I $P(I,U,7) S $P(J,U,7)=$P(I,U,7)
.;check if there is a pre-question
.S %=$O(^XPD(9.7,XPDA,"QUES","B","XPM"_OLDA_"#1",0)) Q:'%
.;if they entered a coordinator, then set it
.I $G(^XPD(9.7,XPDA,"QUES",%,1)) S $P(J,U,7)=^(1)
S ^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,0)=J,I=$G(^XMB(3.8,DA,3))
;save ORGANIZER (3;1)
I $P(I,U) S $P(^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,3),U)=$P(I,U)
Q
MAILGF2 ;mail group file post
N DA,DIK,XPDMDA,XPDI,Y
S XPDMDA=0,DIK="^XMB(3.8,"
F S XPDMDA=$O(^TMP($J,"XPD",XPDMDA)) Q:'XPDMDA D
.;merge & repoint MEMBER GROUP (5;0)
.S XPDI=0
.F S XPDI=$O(^TMP($J,"XPD",XPDMDA,5,XPDI)) Q:'XPDI S Y=$P($G(^(XPDI,0)),U) D:Y]"" ADD^XPDIA(3.811,XPDMDA,Y)
.;merge & repoint MEMBER - REMOTE (6;0)
.S XPDI=0
.F S XPDI=$O(^TMP($J,"XPD",XPDMDA,6,XPDI)) Q:'XPDI S Y=$P($G(^(XPDI,0)),U) D:Y]"" ADD^XPDIA(3.812,XPDMDA,Y)
.S DA=XPDMDA D IX1^DIK
K ^TMP($J,"XPD")
Q
MAILGDEL(RT) ;Mail Group delete
D DELPTR^XPDUTL1(3.8,RT) ;Delete any pointer entries
D DELIEN^XPDUTL1(3.8,RT) ;Delete the entries
Q
HLAPF1 ;HL7 application parameter #771 file pre
K ^TMP($J,"XPD")
Q
HLAPE1 ;HL7 application parameter #771 entry pre
N I,J
S ^TMP($J,"XPD",DA)=""
S I=^HL(771,DA,0),J=^XTMP("XPDI",XPDA,"KRN",771,OLDA,0)
;save FACILITY NAME (0;3)
S:$P(I,U,3)]"" $P(J,U,3)=$P(I,U,3)
;repoint MAIL GROUP (0;4)
S:$P(J,U,4)]"" $P(J,U,4)=$$LK^XPDIA("^XMB(3.8)",$P(J,U,4))
;repoint COUNTRY CODE (0;7)
S:$P(J,U,7)]"" $P(J,U,7)=$$LK^XPDIA("^HL(779.004)",$P(J,U,7))
S ^XTMP("XPDI",XPDA,"KRN",771,OLDA,0)=J
;remove HL7 SEGMENT (SEG;0), HL7 MESSAGE (MSG;0)
K ^HL(771,DA,"SEG"),^("MSG")
Q
HLAPF2 ;HL7 application parameter #771 file post
N DA,DIK,XPDI,X,Y
S DA=0,DIK="^HL(771,"
F S DA=$O(^TMP($J,"XPD",DA)) Q:'DA D
.;repoint HL7 SEGMENT (SEG;0)
.S XPDI=0
.F S XPDI=$O(^HL(771,DA,"SEG",XPDI)) Q:'XPDI S Y=$P($G(^(XPDI,0)),U) D
..S X=$$LK^XPDIA("^HL(771.3)",$P(Y,U))
..I X]"" S $P(^HL(771,DA,"SEG",XPDI,0),U)=X Q
..K ^HL(771,DA,"SEG",XPDI)
.;repoint HL7 MESSAGE (MSG;0)
.S XPDI=0
.F S XPDI=$O(^HL(771,DA,"MSG",XPDI)) Q:'XPDI S Y=$P($G(^(XPDI,0)),U) D
..S X=$$LK^XPDIA("^HL(771.3)",$P(Y,U))
..I X]"" S $P(^HL(771,DA,"MSG",XPDI,0),U)=X Q
..K ^HL(771,DA,"MSG",XPDI)
.D IX1^DIK
K ^TMP($J,"XPD")
Q
HLLLPE ;HL7 lower level protocol #869.2 entry pre
N I,J,L,TMP,Y
S L=$P(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,0),U),I=0
;loop thru logical links and find those pointing to this llp
F S I=$O(^XTMP("XPDI",XPDA,"KRN",870,I)) Q:'I S J=$G(^(I,0)) D
. Q:$P(J,U,3)'=L
. ;save llp into tmp, get the llp type field
. M TMP=^XTMP("XPDI",XPDA,"KRN",869.2,OLDA) S Y=$P(TMP(0),U,2)
. K TMP(-1),TMP(0)
. M ^XTMP("XPDI",XPDA,"KRN",870,I)=TMP S $P(^(I,0),U,3)=Y
S I=$P(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,0),U,2)
;repoint LLP TYPE (0;2)
S:I]"" $P(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,0),U,2)=$$LK^XPDIA("^HLCS(869.1)",I)
S I=$P($G(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,100)),U)
;repoint MAIL GROUP (100;1)
S:I]"" $P(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,100),U)=$$LK^XPDIA("^XMB(3.8)",I)
;save HLLP DEVICE (200;1)
S I=$G(^HLCS(869.2,DA,200))
S:I $P(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,200),U)=$P(I,U)
;save X3.28 DEVICE (300;1)
S I=$G(^HLCS(869.2,DA,300))
S:I $P(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,300),U)=$P(I,U)
;save TCP/IP Start-up Node (400;6)
S I=$G(^HLCS(869.2,DA,400))
S:I $P(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,400),U,6)=$P(I,U,6)
Q
HLLLE ;HL7 logical link #870 entry pre
N I,J,K,L,Y
S I=^HLCS(870,DA,0),J=^XTMP("XPDI",XPDA,"KRN",870,OLDA,0)
;repoint INSTITUTION (0;2)
I $P(J,U,2)]"" S Y=$$LK^XPDIA("^DIC(4)",$P(J,U,2)) D:Y="" S $P(J,U,2)=Y
.D BMES^XPDUTL(" Couldn't resolve Institution "_$P(J,U,2)_" for Logical Link "_$P(^HLCS(870,DA,0),U))
;repoint LLP TYPE (0;3)
S:$P(J,U,3)]"" $P(J,U,3)=$$LK^XPDIA("^HLCS(869.1)",$P(J,U,3))
;repoint MAILMAN DOMAIN (0;7)
I $P(J,U,7)]"" S Y=$$LK^XPDIA("^DIC(4.2)",$P(J,U,7)) D:Y="" S $P(J,U,7)=Y
.D BMES^XPDUTL(" Couldn't resolve Domain "_$P(J,U,7)_" for Logical Link "_$P(^HLCS(870,DA,0),U))
;save node 0; pieces 4,5,6,7,9,10,11,12,16,19,21
F L=4:1:7,9:1:12,16,19,21 S:$P(I,U,L)]"" $P(J,U,L)=$P(I,U,L)
;set SHUTDOWN LLP (0;15) no for multi-listener and yes for all else
S Y=$P($G(^HLCS(870,DA,400)),U,3) S:Y]"" $P(J,U,15)=$S(Y="M":0,1:1)
S ^XTMP("XPDI",XPDA,"KRN",870,OLDA,0)=J
S I=$P($G(^XTMP("XPDI",XPDA,"KRN",870,OLDA,100)),U)
;repoint MAIL GROUP (100;1)
S:I]"" $P(^XTMP("XPDI",XPDA,"KRN",870,OLDA,100),U)=$$LK^XPDIA("^XMB(3.8)",I)
;save data from site on nodes 200,300,400,500
F L=200,300,400,500 S I=$G(^HLCS(870,DA,L)) D:I]""
. S J=$G(^XTMP("XPDI",XPDA,"KRN",870,OLDA,L)) Q:J=""
. ;check local data (I) and if exist set incomming data (J)
. F K=1:1:10 S Y=$P(I,U,K) S:Y]"" $P(J,U,K)=Y
. S ^XTMP("XPDI",XPDA,"KRN",870,OLDA,L)=J
;remove following values when a Test site (not a Production site)
D:$P($$PARAM^HLCS2,U,3)'="P"
. ;MAILMAN DOMAIN (0;7), DNS DOMAIN (0;8)
. S $P(^XTMP("XPDI",XPDA,"KRN",870,OLDA,0),U,7,8)="^"
. ;TCP/IP ADDRESS (400,1), IPV6 ADDRESS (500,1)
. S J=$G(^XTMP("XPDI",XPDA,"KRN",870,OLDA,400))
. S:J]"" $P(^XTMP("XPDI",XPDA,"KRN",870,OLDA,400),U)=""
. S J=$G(^XTMP("XPDI",XPDA,"KRN",870,OLDA,500))
. S:J]"" $P(^XTMP("XPDI",XPDA,"KRN",870,OLDA,500),U)=""
Q
KEYF1 ;SECURITY KEY file pre
K ^TMP($J,"XPD")
Q
KEYE1 ;SECURITY KEY file entry pre
S ^TMP($J,"XPD",DA)=""
Q
KEYF2 ;SECURITY KEY file post
N DA,DIK,I,X,Y,Y0
;Repoint fields
S DA=0,DIK=DIC
F S DA=$O(^TMP($J,"XPD",DA)) Q:'DA D
. ;Repoint SUBORDINATE (3)
. S I=0 F S I=$O(^DIC(19.1,DA,3,I)) Q:'I S Y0=$G(^(I,0)) D
. . S Y=$$LK^XPDIA("^DIC(19.1)",$P(Y0,U)) S:Y $P(^DIC(19.1,DA,3,I,0),U)=Y
. ;MUTUALLY EXCLUSIVE KEYS (5)
. S (I,X)=0 F S I=$O(^DIC(19.1,DA,5,I)) Q:'I S Y0=$G(^(I,0)) D
. . S Y=$$LK^XPDIA("^DIC(19.1)",$P(Y0,U)) S:Y $P(^DIC(19.1,DA,5,I,0),U)=Y
. D IX1^DIK
K ^TMP($J,"XPD")
Q
KEYDEL ;del security keys
N XPDI S XPDI=0
F S XPDI=$O(^TMP($J,"XPDEL",XPDI)) Q:'XPDI D DEL^XPDKEY(XPDI)
Q
LME1 ;List Templates entry pre
;kill old entry before data merge
K ^SD(409.61,DA)
Q
LMDEL ;del list manager templates
D DELIEN^XPDUTL1(409.61,$NA(^TMP($J,"XPDEL")))
Q
RPCDEL ;del Kernel RPC, file 8994
D DELIEN^XPDUTL1(8994,$G(%))
Q
RPCE1 ;RPC pre entry, file 8994
;kill Input parameters multiple, field #2
K ^XWB(8994,DA,2)
;kill Description field #1 ;p750
K ^XWB(8994,DA,1)
Q
CRC32PE ;pre entry for Kernel RPCs CRC32
;if there is a new Description, kill the old Description
K:$O(^XTMP("XPDI",XPDA,"KRN",8994.2,OLDA,1,0)) ^XWB(8994.2,DA,1)
Q
CRC32DEL ;del Kernel RPCs CRC32
D DELIEN^XPDUTL1(8994.2,$G(%))
Q
HLAPDEL(RT) ;del HL7 application parameter #771
D DELIEN^XPDUTL1(771,RT)
Q
HLLLDEL(RT) ;del HL7 logical link #870
N DA,DIK,XPDI,XPDJ,Y
S XPDI=0
;loop thru protocols, #101, get LL field, 770.7 (700;7)
F S XPDI=$O(^ORD(101,XPDI)) Q:'XPDI S Y=$P($G(^(XPDI,700)),U,7) D:Y
. Q:'$D(^TMP($J,"XPDEL",Y))
. K XPDJ S XPDJ(101,XPDI_",",770.7)="@"
. D FILE^DIE("","XPDJ")
;subscription, #774
F S XPDI=$O(TMP($J,"XPDEL",XPDI)) Q:'XPDI D:$D(^HLS(774,"C",XPDI))
. S XPDJ=0 F S XPDJ=$O(^HLS(774,"C",XPDI,XPDJ))
D DELIEN^XPDUTL1(870,RT)
Q
HLOE ;pre entry HLO application registry #779.2
N I,J,K,L,Y
S I=^HLD(779.2,DA,0),J=^XTMP("XPDI",XPDA,"KRN",779.2,OLDA,0)
;repoint APPLICATION SPECIFIC LISTENER (0;9)
I $P(J,U,9)]"" S Y=$$LK^XPDIA("^HLCS(870)",$P(J,U,9)) D:Y="" S $P(J,U,9)=Y
.D BMES^XPDUTL(" Couldn't resolve APPLICATION SPECIFIC LISTENER "_$P(J,U,2)_" HLO APPLICATION "_$P(I,U))
S ^XTMP("XPDI",XPDA,"KRN",779.2,OLDA,0)=J
;repoint Package File Link (2;1)
S J=$P($G(^XTMP("XPDI",XPDA,"KRN",779.2,OLDA,2)),U)
S:J]"" $P(^XTMP("XPDI",XPDA,"KRN",779.2,OLDA,2),U)=$$LK^XPDIA("^DIC(9.4)",J)
;save data from site on nodes 200,300,400
Q
HLODEL(RT) ;delete for HLO APPLICATION REGISTRY #779.2 ;p768
D DELIEN^XPDUTL1(779.2,RT)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXPDIA1 10632 printed Apr 09, 2024@21:07:50 Page 2
XPDIA1 ;SFISC/RSD - Install Pre/Post Actions for Kernel files cont. ; Apr 15, 2022@08:55:53
+1 ;;8.0;KERNEL;**2,44,51,58,68,85,131,146,182,229,302,399,507,539,672,750,768**;Jul 10, 1995;Build 8
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
HLPF1 ;help frames file pre
+1 KILL ^TMP($JOB,"XPD")
+2 QUIT
HLPE1 ;entry pre
+1 SET ^TMP($JOB,"XPD",DA)=""
KILL ^DIC(9.2,DA,1),^(2),^(3),^(10)
+2 QUIT
HLPF2 ;file post
+1 NEW DA,DIK,I,X,Y,Y0
+2 ;need to send error message, need to setup message
+3 SET DA=0
SET DIK=DIC
FOR
SET DA=$ORDER(^TMP($JOB,"XPD",DA))
if 'DA
QUIT
Begin DoDot:1
+4 ;repoint Related Frame (2;0)
+5 SET I=0
FOR
SET I=$ORDER(^DIC(9.2,DA,2,I))
if 'I
QUIT
SET Y0=$GET(^(I,0))
SET Y=$$LK^XPDIA("^DIC(9.2)",$PIECE(Y0,U,2))
SET $PIECE(^DIC(9.2,DA,2,I,0),U,2)=Y
+6 ;repoint OBJECT (10;0)
+7 SET (I,X)=0
FOR
SET I=$ORDER(^DIC(9.2,DA,10,I))
if 'I
QUIT
SET Y0=$GET(^(I,0))
Begin DoDot:2
+8 SET Y=$$LK^XPDIA("^MAG",$PIECE(Y0,U))
if Y
SET $PIECE(^DIC(9.2,DA,10,I,0),U)=Y
SET X=X+1_U_I
+9 if 'Y
KILL ^DIC(9.2,DA,10,I)
End DoDot:2
+10 IF X
SET $PIECE(^DIC(9.2,DA,10,0),U,3,4)=$PIECE(X,U,2)_U_+X
+11 DO IX1^DIK
End DoDot:1
+12 KILL ^TMP($JOB,"XPD")
+13 QUIT
HLPDEL ;help frame delete
+1 NEW DA,DIK,XPDI,XPDJ
+2 SET XPDI=0
+3 FOR
SET XPDI=$ORDER(^TMP($JOB,"XPDEL",XPDI))
SET XPDJ=0
if 'XPDI
QUIT
Begin DoDot:1
+4 SET DIK="^DIC(9.2,XPDJ,2,"
+5 ;check other frames that point to this one
+6 FOR
SET XPDJ=$ORDER(^DIC(9.2,"AE",XPDI,XPDJ))
if 'XPDJ
QUIT
SET Z=$ORDER(^(XPDJ,0))
if Z
Begin DoDot:2
+7 KILL DA
SET DA=Z
SET DA(1)=XPDJ
DO ^DIK
End DoDot:2
+8 ;delete this frame
+9 KILL DA
SET DA=XPDI
SET DIK="^DIC(9.2,"
DO ^DIK
End DoDot:1
+10 QUIT
BULE1 ;bulletin entry pre
+1 NEW X,I
SET I=0
+2 ;save current Mail Groups (2)
+3 IF $GET(^XMB(3.6,DA,2,0))]""
SET X(0)=^(0)
FOR
SET I=$ORDER(^XMB(3.6,DA,2,I))
if 'I
QUIT
SET X(I)=$GET(^(I,0))
+4 KILL ^XMB(3.6,DA)
+5 ;after killing data, put back Mail Groups before data merge
+6 IF $DATA(X)
SET ^XMB(3.6,DA,2,0)=X(0)
SET I=0
FOR
SET I=$ORDER(X(I))
if 'I
QUIT
SET ^XMB(3.6,DA,2,I,0)=X(I)
+7 QUIT
BULDEL ;del bulletins
+1 DO DELIEN^XPDUTL1(3.6,$GET(%))
+2 QUIT
MAILGF1 ;mail groups file pre
+1 KILL ^TMP($JOB,"XPD")
+2 QUIT
MAILGE1 ;mail group entry pre
+1 NEW I,J
+2 SET ^TMP($JOB,"XPD",DA)=""
+3 ;save MEMBER GROUPS (5;0)
+4 IF $ORDER(^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,5,0))
MERGE ^TMP($JOB,"XPD",DA,5)=^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,5)
KILL ^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,5)
+5 ;save MEMBER - REMOTE (6;0)
+6 IF $ORDER(^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,6,0))
MERGE ^TMP($JOB,"XPD",DA,6)=^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,6)
KILL ^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,6)
+7 ;if there is a new Description, kill the old Description
+8 if $ORDER(^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,2,0))
KILL ^XMB(3.8,DA,2)
+9 ;I=current mail group, J=incoming mail group
+10 SET I=^XMB(3.8,DA,0)
SET J=^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,0)
+11 ;save REFERENCE COUNT (0;4) & LAST REFERENCED (0;5)
+12 if $PIECE(I,U,4)
SET $PIECE(J,U,4)=$PIECE(I,U,4)
if $PIECE(I,U,5)
SET $PIECE(J,U,5)=$PIECE(I,U,5)
+13 ;check COORDINATOR (0;7), bring in one that was asked during install question
+14 Begin DoDot:1
+15 ;get the existing coordinator, and set it
+16 IF $PIECE(I,U,7)
SET $PIECE(J,U,7)=$PIECE(I,U,7)
+17 ;check if there is a pre-question
+18 SET %=$ORDER(^XPD(9.7,XPDA,"QUES","B","XPM"_OLDA_"#1",0))
if '%
QUIT
+19 ;if they entered a coordinator, then set it
+20 IF $GET(^XPD(9.7,XPDA,"QUES",%,1))
SET $PIECE(J,U,7)=^(1)
End DoDot:1
+21 SET ^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,0)=J
SET I=$GET(^XMB(3.8,DA,3))
+22 ;save ORGANIZER (3;1)
+23 IF $PIECE(I,U)
SET $PIECE(^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,3),U)=$PIECE(I,U)
+24 QUIT
MAILGF2 ;mail group file post
+1 NEW DA,DIK,XPDMDA,XPDI,Y
+2 SET XPDMDA=0
SET DIK="^XMB(3.8,"
+3 FOR
SET XPDMDA=$ORDER(^TMP($JOB,"XPD",XPDMDA))
if 'XPDMDA
QUIT
Begin DoDot:1
+4 ;merge & repoint MEMBER GROUP (5;0)
+5 SET XPDI=0
+6 FOR
SET XPDI=$ORDER(^TMP($JOB,"XPD",XPDMDA,5,XPDI))
if 'XPDI
QUIT
SET Y=$PIECE($GET(^(XPDI,0)),U)
if Y]""
DO ADD^XPDIA(3.811,XPDMDA,Y)
+7 ;merge & repoint MEMBER - REMOTE (6;0)
+8 SET XPDI=0
+9 FOR
SET XPDI=$ORDER(^TMP($JOB,"XPD",XPDMDA,6,XPDI))
if 'XPDI
QUIT
SET Y=$PIECE($GET(^(XPDI,0)),U)
if Y]""
DO ADD^XPDIA(3.812,XPDMDA,Y)
+10 SET DA=XPDMDA
DO IX1^DIK
End DoDot:1
+11 KILL ^TMP($JOB,"XPD")
+12 QUIT
MAILGDEL(RT) ;Mail Group delete
+1 ;Delete any pointer entries
DO DELPTR^XPDUTL1(3.8,RT)
+2 ;Delete the entries
DO DELIEN^XPDUTL1(3.8,RT)
+3 QUIT
HLAPF1 ;HL7 application parameter #771 file pre
+1 KILL ^TMP($JOB,"XPD")
+2 QUIT
HLAPE1 ;HL7 application parameter #771 entry pre
+1 NEW I,J
+2 SET ^TMP($JOB,"XPD",DA)=""
+3 SET I=^HL(771,DA,0)
SET J=^XTMP("XPDI",XPDA,"KRN",771,OLDA,0)
+4 ;save FACILITY NAME (0;3)
+5 if $PIECE(I,U,3)]""
SET $PIECE(J,U,3)=$PIECE(I,U,3)
+6 ;repoint MAIL GROUP (0;4)
+7 if $PIECE(J,U,4)]""
SET $PIECE(J,U,4)=$$LK^XPDIA("^XMB(3.8)",$PIECE(J,U,4))
+8 ;repoint COUNTRY CODE (0;7)
+9 if $PIECE(J,U,7)]""
SET $PIECE(J,U,7)=$$LK^XPDIA("^HL(779.004)",$PIECE(J,U,7))
+10 SET ^XTMP("XPDI",XPDA,"KRN",771,OLDA,0)=J
+11 ;remove HL7 SEGMENT (SEG;0), HL7 MESSAGE (MSG;0)
+12 KILL ^HL(771,DA,"SEG"),^("MSG")
+13 QUIT
HLAPF2 ;HL7 application parameter #771 file post
+1 NEW DA,DIK,XPDI,X,Y
+2 SET DA=0
SET DIK="^HL(771,"
+3 FOR
SET DA=$ORDER(^TMP($JOB,"XPD",DA))
if 'DA
QUIT
Begin DoDot:1
+4 ;repoint HL7 SEGMENT (SEG;0)
+5 SET XPDI=0
+6 FOR
SET XPDI=$ORDER(^HL(771,DA,"SEG",XPDI))
if 'XPDI
QUIT
SET Y=$PIECE($GET(^(XPDI,0)),U)
Begin DoDot:2
+7 SET X=$$LK^XPDIA("^HL(771.3)",$PIECE(Y,U))
+8 IF X]""
SET $PIECE(^HL(771,DA,"SEG",XPDI,0),U)=X
QUIT
+9 KILL ^HL(771,DA,"SEG",XPDI)
End DoDot:2
+10 ;repoint HL7 MESSAGE (MSG;0)
+11 SET XPDI=0
+12 FOR
SET XPDI=$ORDER(^HL(771,DA,"MSG",XPDI))
if 'XPDI
QUIT
SET Y=$PIECE($GET(^(XPDI,0)),U)
Begin DoDot:2
+13 SET X=$$LK^XPDIA("^HL(771.3)",$PIECE(Y,U))
+14 IF X]""
SET $PIECE(^HL(771,DA,"MSG",XPDI,0),U)=X
QUIT
+15 KILL ^HL(771,DA,"MSG",XPDI)
End DoDot:2
+16 DO IX1^DIK
End DoDot:1
+17 KILL ^TMP($JOB,"XPD")
+18 QUIT
HLLLPE ;HL7 lower level protocol #869.2 entry pre
+1 NEW I,J,L,TMP,Y
+2 SET L=$PIECE(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,0),U)
SET I=0
+3 ;loop thru logical links and find those pointing to this llp
+4 FOR
SET I=$ORDER(^XTMP("XPDI",XPDA,"KRN",870,I))
if 'I
QUIT
SET J=$GET(^(I,0))
Begin DoDot:1
+5 if $PIECE(J,U,3)'=L
QUIT
+6 ;save llp into tmp, get the llp type field
+7 MERGE TMP=^XTMP("XPDI",XPDA,"KRN",869.2,OLDA)
SET Y=$PIECE(TMP(0),U,2)
+8 KILL TMP(-1),TMP(0)
+9 MERGE ^XTMP("XPDI",XPDA,"KRN",870,I)=TMP
SET $PIECE(^(I,0),U,3)=Y
End DoDot:1
+10 SET I=$PIECE(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,0),U,2)
+11 ;repoint LLP TYPE (0;2)
+12 if I]""
SET $PIECE(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,0),U,2)=$$LK^XPDIA("^HLCS(869.1)",I)
+13 SET I=$PIECE($GET(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,100)),U)
+14 ;repoint MAIL GROUP (100;1)
+15 if I]""
SET $PIECE(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,100),U)=$$LK^XPDIA("^XMB(3.8)",I)
+16 ;save HLLP DEVICE (200;1)
+17 SET I=$GET(^HLCS(869.2,DA,200))
+18 if I
SET $PIECE(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,200),U)=$PIECE(I,U)
+19 ;save X3.28 DEVICE (300;1)
+20 SET I=$GET(^HLCS(869.2,DA,300))
+21 if I
SET $PIECE(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,300),U)=$PIECE(I,U)
+22 ;save TCP/IP Start-up Node (400;6)
+23 SET I=$GET(^HLCS(869.2,DA,400))
+24 if I
SET $PIECE(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,400),U,6)=$PIECE(I,U,6)
+25 QUIT
HLLLE ;HL7 logical link #870 entry pre
+1 NEW I,J,K,L,Y
+2 SET I=^HLCS(870,DA,0)
SET J=^XTMP("XPDI",XPDA,"KRN",870,OLDA,0)
+3 ;repoint INSTITUTION (0;2)
+4 IF $PIECE(J,U,2)]""
SET Y=$$LK^XPDIA("^DIC(4)",$PIECE(J,U,2))
if Y=""
Begin DoDot:1
+5 DO BMES^XPDUTL(" Couldn't resolve Institution "_$PIECE(J,U,2)_" for Logical Link "_$PIECE(^HLCS(870,DA,0),U))
End DoDot:1
SET $PIECE(J,U,2)=Y
+6 ;repoint LLP TYPE (0;3)
+7 if $PIECE(J,U,3)]""
SET $PIECE(J,U,3)=$$LK^XPDIA("^HLCS(869.1)",$PIECE(J,U,3))
+8 ;repoint MAILMAN DOMAIN (0;7)
+9 IF $PIECE(J,U,7)]""
SET Y=$$LK^XPDIA("^DIC(4.2)",$PIECE(J,U,7))
if Y=""
Begin DoDot:1
+10 DO BMES^XPDUTL(" Couldn't resolve Domain "_$PIECE(J,U,7)_" for Logical Link "_$PIECE(^HLCS(870,DA,0),U))
End DoDot:1
SET $PIECE(J,U,7)=Y
+11 ;save node 0; pieces 4,5,6,7,9,10,11,12,16,19,21
+12 FOR L=4:1:7,9:1:12,16,19,21
if $PIECE(I,U,L)]""
SET $PIECE(J,U,L)=$PIECE(I,U,L)
+13 ;set SHUTDOWN LLP (0;15) no for multi-listener and yes for all else
+14 SET Y=$PIECE($GET(^HLCS(870,DA,400)),U,3)
if Y]""
SET $PIECE(J,U,15)=$SELECT(Y="M":0,1:1)
+15 SET ^XTMP("XPDI",XPDA,"KRN",870,OLDA,0)=J
+16 SET I=$PIECE($GET(^XTMP("XPDI",XPDA,"KRN",870,OLDA,100)),U)
+17 ;repoint MAIL GROUP (100;1)
+18 if I]""
SET $PIECE(^XTMP("XPDI",XPDA,"KRN",870,OLDA,100),U)=$$LK^XPDIA("^XMB(3.8)",I)
+19 ;save data from site on nodes 200,300,400,500
+20 FOR L=200,300,400,500
SET I=$GET(^HLCS(870,DA,L))
if I]""
Begin DoDot:1
+21 SET J=$GET(^XTMP("XPDI",XPDA,"KRN",870,OLDA,L))
if J=""
QUIT
+22 ;check local data (I) and if exist set incomming data (J)
+23 FOR K=1:1:10
SET Y=$PIECE(I,U,K)
if Y]""
SET $PIECE(J,U,K)=Y
+24 SET ^XTMP("XPDI",XPDA,"KRN",870,OLDA,L)=J
End DoDot:1
+25 ;remove following values when a Test site (not a Production site)
+26 if $PIECE($$PARAM^HLCS2,U,3)'="P"
Begin DoDot:1
+27 ;MAILMAN DOMAIN (0;7), DNS DOMAIN (0;8)
+28 SET $PIECE(^XTMP("XPDI",XPDA,"KRN",870,OLDA,0),U,7,8)="^"
+29 ;TCP/IP ADDRESS (400,1), IPV6 ADDRESS (500,1)
+30 SET J=$GET(^XTMP("XPDI",XPDA,"KRN",870,OLDA,400))
+31 if J]""
SET $PIECE(^XTMP("XPDI",XPDA,"KRN",870,OLDA,400),U)=""
+32 SET J=$GET(^XTMP("XPDI",XPDA,"KRN",870,OLDA,500))
+33 if J]""
SET $PIECE(^XTMP("XPDI",XPDA,"KRN",870,OLDA,500),U)=""
End DoDot:1
+34 QUIT
KEYF1 ;SECURITY KEY file pre
+1 KILL ^TMP($JOB,"XPD")
+2 QUIT
KEYE1 ;SECURITY KEY file entry pre
+1 SET ^TMP($JOB,"XPD",DA)=""
+2 QUIT
KEYF2 ;SECURITY KEY file post
+1 NEW DA,DIK,I,X,Y,Y0
+2 ;Repoint fields
+3 SET DA=0
SET DIK=DIC
+4 FOR
SET DA=$ORDER(^TMP($JOB,"XPD",DA))
if 'DA
QUIT
Begin DoDot:1
+5 ;Repoint SUBORDINATE (3)
+6 SET I=0
FOR
SET I=$ORDER(^DIC(19.1,DA,3,I))
if 'I
QUIT
SET Y0=$GET(^(I,0))
Begin DoDot:2
+7 SET Y=$$LK^XPDIA("^DIC(19.1)",$PIECE(Y0,U))
if Y
SET $PIECE(^DIC(19.1,DA,3,I,0),U)=Y
End DoDot:2
+8 ;MUTUALLY EXCLUSIVE KEYS (5)
+9 SET (I,X)=0
FOR
SET I=$ORDER(^DIC(19.1,DA,5,I))
if 'I
QUIT
SET Y0=$GET(^(I,0))
Begin DoDot:2
+10 SET Y=$$LK^XPDIA("^DIC(19.1)",$PIECE(Y0,U))
if Y
SET $PIECE(^DIC(19.1,DA,5,I,0),U)=Y
End DoDot:2
+11 DO IX1^DIK
End DoDot:1
+12 KILL ^TMP($JOB,"XPD")
+13 QUIT
KEYDEL ;del security keys
+1 NEW XPDI
SET XPDI=0
+2 FOR
SET XPDI=$ORDER(^TMP($JOB,"XPDEL",XPDI))
if 'XPDI
QUIT
DO DEL^XPDKEY(XPDI)
+3 QUIT
LME1 ;List Templates entry pre
+1 ;kill old entry before data merge
+2 KILL ^SD(409.61,DA)
+3 QUIT
LMDEL ;del list manager templates
+1 DO DELIEN^XPDUTL1(409.61,$NAME(^TMP($JOB,"XPDEL")))
+2 QUIT
RPCDEL ;del Kernel RPC, file 8994
+1 DO DELIEN^XPDUTL1(8994,$GET(%))
+2 QUIT
RPCE1 ;RPC pre entry, file 8994
+1 ;kill Input parameters multiple, field #2
+2 KILL ^XWB(8994,DA,2)
+3 ;kill Description field #1 ;p750
+4 KILL ^XWB(8994,DA,1)
+5 QUIT
CRC32PE ;pre entry for Kernel RPCs CRC32
+1 ;if there is a new Description, kill the old Description
+2 if $ORDER(^XTMP("XPDI",XPDA,"KRN",8994.2,OLDA,1,0))
KILL ^XWB(8994.2,DA,1)
+3 QUIT
CRC32DEL ;del Kernel RPCs CRC32
+1 DO DELIEN^XPDUTL1(8994.2,$GET(%))
+2 QUIT
HLAPDEL(RT) ;del HL7 application parameter #771
+1 DO DELIEN^XPDUTL1(771,RT)
+2 QUIT
HLLLDEL(RT) ;del HL7 logical link #870
+1 NEW DA,DIK,XPDI,XPDJ,Y
+2 SET XPDI=0
+3 ;loop thru protocols, #101, get LL field, 770.7 (700;7)
+4 FOR
SET XPDI=$ORDER(^ORD(101,XPDI))
if 'XPDI
QUIT
SET Y=$PIECE($GET(^(XPDI,700)),U,7)
if Y
Begin DoDot:1
+5 if '$DATA(^TMP($JOB,"XPDEL",Y))
QUIT
+6 KILL XPDJ
SET XPDJ(101,XPDI_",",770.7)="@"
+7 DO FILE^DIE("","XPDJ")
End DoDot:1
+8 ;subscription, #774
+9 FOR
SET XPDI=$ORDER(TMP($JOB,"XPDEL",XPDI))
if 'XPDI
QUIT
if $DATA(^HLS(774,"C",XPDI))
Begin DoDot:1
+10 SET XPDJ=0
FOR
SET XPDJ=$ORDER(^HLS(774,"C",XPDI,XPDJ))
End DoDot:1
+11 DO DELIEN^XPDUTL1(870,RT)
+12 QUIT
HLOE ;pre entry HLO application registry #779.2
+1 NEW I,J,K,L,Y
+2 SET I=^HLD(779.2,DA,0)
SET J=^XTMP("XPDI",XPDA,"KRN",779.2,OLDA,0)
+3 ;repoint APPLICATION SPECIFIC LISTENER (0;9)
+4 IF $PIECE(J,U,9)]""
SET Y=$$LK^XPDIA("^HLCS(870)",$PIECE(J,U,9))
if Y=""
Begin DoDot:1
+5 DO BMES^XPDUTL(" Couldn't resolve APPLICATION SPECIFIC LISTENER "_$PIECE(J,U,2)_" HLO APPLICATION "_$PIECE(I,U))
End DoDot:1
SET $PIECE(J,U,9)=Y
+6 SET ^XTMP("XPDI",XPDA,"KRN",779.2,OLDA,0)=J
+7 ;repoint Package File Link (2;1)
+8 SET J=$PIECE($GET(^XTMP("XPDI",XPDA,"KRN",779.2,OLDA,2)),U)
+9 if J]""
SET $PIECE(^XTMP("XPDI",XPDA,"KRN",779.2,OLDA,2),U)=$$LK^XPDIA("^DIC(9.4)",J)
+10 ;save data from site on nodes 200,300,400
+11 QUIT
HLODEL(RT) ;delete for HLO APPLICATION REGISTRY #779.2 ;p768
+1 DO DELIEN^XPDUTL1(779.2,RT)
+2 QUIT
