Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XPDIA1

XPDIA1.m

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