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

XPDIA.m

Go to the documentation of this file.
  1. XPDIA ;SFISC/RSD - Install Pre/Post Actions for Kernel Files ;09/13/2012
  1. ;;8.0;KERNEL;**10,15,21,28,44,58,68,131,145,672**;Jul 10, 1995;Build 28
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. Q
  1. OPTF1 ;options file pre
  1. K ^TMP($J,"XPD")
  1. ;add Menu Text during a new record
  1. S XPDDR(1)="$P(OLDA(0),U,2)"
  1. Q
  1. ;
  1. OPTE1 ;options entry pre
  1. N %,I
  1. ;XPDFL= 0-send,1-delete,2-link,3-merge,4-attach,5-disable
  1. ;attach & disable never get here
  1. S ^TMP($J,"XPD",DA)=XPDFL
  1. ;if Menu linking or merge save menu mult. and process in FPOS code
  1. I XPDFL>1 M ^TMP($J,"XPD",DA,10)=^XTMP("XPDI",XPDA,"KRN",19,OLDA,10) K ^XTMP("XPDI",XPDA,"KRN",19,OLDA,10)
  1. ;if Menu link, XPDQUIT prevents data merge
  1. I XPDFL=2 S XPDQUIT=1 Q
  1. ;if this is new to the site then disable and quit
  1. I $G(XPDNEW) D:XPDSET Q
  1. .;quit if option already has out of order msg.
  1. .Q:$P(^XTMP("XPDI",XPDA,"KRN",19,OLDA,0),U,3)]""
  1. .S $P(^XTMP("XPDI",XPDA,"KRN",19,OLDA,0),U,3)=$P(XPDSET,U,3)
  1. .D ADD^XQOO1($P(XPDSET,U,2),19,DA)
  1. S I=^XTMP("XPDI",XPDA,"KRN",19,OLDA,0),%=^DIC(19,DA,0)
  1. ;$P(%,U,3)=out of order message, keep sending ooo msg
  1. S:$P(I,U,3)="" $P(I,U,3)=$P(%,U,3)
  1. ;if there is no new Security Key, save the old Key
  1. S:$P(I,U,6)="" $P(I,U,6)=$P(%,U,6)
  1. ;if there is no reverse key, save the old key and flag
  1. I $P($G(^XTMP("XPDI",XPDA,"KRN",19,OLDA,3)),U)="",$L($P($G(^DIC(19,DA,3)),U)) S $P(I,U,16)=$P(%,U,16),$P(^XTMP("XPDI",XPDA,"KRN",19,OLDA,3),U)=$P(^(3),U)
  1. S ^XTMP("XPDI",XPDA,"KRN",19,OLDA,0)=I
  1. ;if there is a new Description, kill the old Description
  1. K:$O(^XTMP("XPDI",XPDA,"KRN",19,OLDA,1,0)) ^DIC(19,DA,1)
  1. ;kill old RCPs (RPC)
  1. K ^DIC(19,DA,"RPC")
  1. ;kill old DIC variables: fields 30 thru 36 ;p672
  1. F I=30:1:36 K ^DIC(19,DA,I)
  1. ;if Menu Text, (U;1) is different, kill C x-ref
  1. S I=$G(^DIC(19,DA,"U")) I I]"",I'=$G(^XTMP("XPDI",XPDA,"KRN",19,OLDA,"U")) K ^DIC(19,"C",I)
  1. S I=0
  1. ;XPDFL=3-merge menu items, Quit
  1. ;the new menu items have already been saved into ^TMP, will restore in
  1. ;the file post action as a relink
  1. Q:XPDFL=3
  1. ;we are replacing menu items, kill the old.
  1. ;loop thru and kill "AD" x-ref., it will be reset with new options
  1. F S I=$O(^DIC(19,DA,10,I)) Q:'I S %=+$G(^(I,0)) K:% ^DIC(19,"AD",%,DA,I)
  1. ;kill Menus (10)
  1. K ^DIC(19,DA,10)
  1. Q
  1. ;
  1. OPTF2 ;options file post
  1. N ACT,DA,DIK,I,X,Y,Y0
  1. ;loop thru all the new incomming options
  1. S DA=0,DIK=DIC F S DA=$O(^TMP($J,"XPD",DA)) Q:'DA S ACT=^(DA) D
  1. .;if use as link then goto OPTFL, just update menus
  1. .G:ACT=2 OPTFL
  1. .;repoint Bulletin (220;1) and Mail Group (220;3)
  1. .S Y0=$G(^DIC(19,DA,220)) I Y0]"" S $P(Y0,U)=$$LK("^XMB(3.6)",$P(Y0,U)),$P(Y0,U,3)=$$LK("^XMB(3.8)",$P(Y0,U,3)),^DIC(19,DA,220)=Y0
  1. .;repoint RPC (RPC;1)
  1. .S (I,X)=0 F S I=$O(^DIC(19,DA,"RPC",I)) Q:'I S Y0=$P($G(^(I,0)),U) D
  1. ..S Y=$$LK("^XWB(8994)",Y0)
  1. ..I 'Y K ^DIC(19,DA,"RPC",I) D BMES^XPDUTL(" RPC "_Y0_" in Option "_$P(^DIC(19,DA,0),U)_" **NOT FOUND**") Q
  1. ..S $P(^DIC(19,DA,"RPC",I,0),U)=Y,X=I_U_(X+1)
  1. .S:X $P(^DIC(19,DA,"RPC",0),U,3,4)=X
  1. .;repoint Package (0;12) and Help Frame (0;7)
  1. .S Y0=^DIC(19,DA,0),$P(Y0,U,12)=$$LK("^DIC(9.4)",$P(Y0,U,12)),$P(Y0,U,7)=$$LK("^DIC(9.2)",$P(Y0,U,7)),^DIC(19,DA,0)=Y0
  1. OPTFL .;need to loop through ^TMP($J,"XPD",DA,10,I) these are menus that need to be
  1. .;merged, they could also be linked menu, but treat like merge
  1. .S I=0 F S I=$O(^TMP($J,"XPD",DA,10,I)) Q:'I S Y0=$G(^(I,0)),X=$G(^(U)) D:X]"" MENU(DA,X,Y0)
  1. .;loop thru Menu and repoint Option (0;1), text is on ^(U) node
  1. .;also need to recount all menus and reset zeroth node, use X
  1. .S (I,X)=0 F S I=$O(^DIC(19,DA,10,I)) Q:'I S Y0=$G(^(I,U)) D
  1. ..I $L(Y0) D Q:'Y
  1. ...S Y=$$LK("^DIC(19)",Y0)
  1. ...K ^DIC(19,DA,10,I,U)
  1. ...I 'Y K ^DIC(19,DA,10,I) D BMES^XPDUTL(" Option "_Y0_" in Menu "_$P(^DIC(19,DA,0),U)_" **NOT FOUND**") Q
  1. ...S $P(^DIC(19,DA,10,I,0),U)=Y
  1. ..S X=I_U_(X+1)
  1. .S:X $P(^DIC(19,DA,10,0),U,3,4)=X
  1. .;re-index this option
  1. .D IX1^DIK
  1. K ^TMP($J,"XPD")
  1. Q
  1. ;
  1. OPTDEL ;option delete
  1. D DEL("^DIC(19,",DUZ)
  1. D OPT^XPDIA2
  1. Q
  1. ;
  1. PROF1 ;protocols file pre
  1. K ^TMP($J,"XPD")
  1. Q
  1. ;
  1. PROE1 ;protocols entry pre
  1. G PROE1^XPDIA0
  1. ;
  1. PROF2 ;protocols file post
  1. N ACT,DA,DIK,I,X,Y,Y0
  1. ;loop thru all the new incomming protocols
  1. S DA=0,DIK=DIC F S DA=$O(^TMP($J,"XPD",DA)) Q:'DA S ACT=^(DA) D
  1. .;if use as link then goto PROFL, just update menus
  1. .G:ACT=2 PROFL
  1. .;repoint Package (0;12)
  1. .S Y0=^ORD(101,DA,0) S:$L($P(Y0,U,12)) $P(Y0,U,12)=$$LK("^DIC(9.4)",$P(Y0,U,12)),^ORD(101,DA,0)=Y0
  1. .;repoint File Link (5;1), its a variable pointer
  1. .S Y0=$P($G(^ORD(101,DA,5)),U),Y=$P(Y0,";",2),Y0=$P(Y0,";")
  1. .I Y0,$L(Y) S Y0=$O(@("^"_Y_"""B"","""_Y0_""",0)")),$P(^ORD(101,DA,5),U)=$S(Y0:Y0_";"_Y,1:"")
  1. .;repoint HL7 fields, node 770
  1. .S Y0=$G(^ORD(101,DA,770)) I $L(Y0) D S ^ORD(101,DA,770)=Y0
  1. ..S $P(Y0,U)=$$LK("^HL(771)",$P(Y0,U)),$P(Y0,U,2)=$$LK("^HL(771)",$P(Y0,U,2))
  1. ..S $P(Y0,U,3)=$$LK("^HL(771.2)",$P(Y0,U,3)),$P(Y0,U,11)=$$LK("^HL(771.2)",$P(Y0,U,11))
  1. ..S $P(Y0,U,4)=$$LK("^HL(779.001)",$P(Y0,U,4)),$P(Y0,U,7)=$$LK("^HLCS(870)",$P(Y0,U,7))
  1. ..S $P(Y0,U,8)=$$LK("^HL(779.003)",$P(Y0,U,8)),$P(Y0,U,9)=$$LK("^HL(779.003)",$P(Y0,U,9))
  1. ..S $P(Y0,U,10)=$$LK("^HL(771.5)",$P(Y0,U,10))
  1. .;loop thru Access and resolve (3;1), kill if it doesn't resolve
  1. .S (I,X)=0 F S I=$O(^ORD(101,DA,3,I)) Q:'I S Y0=$P($G(^(I,0)),U) D
  1. ..;Y0=.01 of Access(Security Key)
  1. ..S Y=$$LK("^DIC(19.1)",Y0)
  1. ..I 'Y K ^ORD(101,DA,3,I) D BMES^XPDUTL(" Key "_Y0_" in Protocol "_$P(^ORD(101,DA,0),U)_" **NOT FOUND**") Q
  1. ..S $P(^ORD(101,DA,3,I,0),U)=Y,X=I_U_(X+1)
  1. .S:X $P(^ORD(101,DA,3,0),U,3,4)=X
  1. PROFL .;need to loop through ^TMP($J,"XPD",DA,10,I) these are menus that need to be
  1. .;merged, they are also linked menu, but treat like merge
  1. .S I=0 F S I=$O(^TMP($J,"XPD",DA,10,I)) Q:'I S Y0=$G(^(I,0)),X=$G(^(U)) D:X]"" MENU(DA,X,Y0)
  1. .;loop thru Menu and repoint Option (0;1), text is on ^(U) node
  1. .;also need to recount all menus and reset zeroth node, use X
  1. .S (I,X)=0 F S I=$O(^ORD(101,DA,10,I)) Q:'I S Y0=$G(^(I,U)) D
  1. ..I $L(Y0) D Q:'Y
  1. ...S Y=$$LK("^ORD(101)",Y0)
  1. ...K ^ORD(101,DA,10,I,U)
  1. ...I 'Y K ^ORD(101,DA,10,I) D BMES^XPDUTL(" Protocol "_Y0_" in Protocol Menu "_$P(^ORD(101,DA,0),U)_" **NOT FOUND**") Q
  1. ...S $P(^ORD(101,DA,10,I,0),U)=Y
  1. ..S X=I_U_(X+1)
  1. .S:X $P(^ORD(101,DA,10,0),U,3,4)=X
  1. .;need to loop through ^TMP($J,"XPD",DA,775,I) these are subscribers that need to be
  1. .;merged, they are also linked subscriber, but treat like merge
  1. .S I=0 F S I=$O(^TMP($J,"XPD",DA,775,I)) Q:'I S Y0=$G(^(I,0)),X=$G(^(U)) D:X]"" SUBS(DA,X)
  1. .;loop thru subscriber and repoint Option (0;1), text is on ^(U) node
  1. .;also need to recount all menus and reset zeroth node, use X
  1. .S (I,X)=0 F S I=$O(^ORD(101,DA,775,I)) Q:'I S Y0=$G(^(I,U)) D
  1. ..I $L(Y0) D Q:'Y
  1. ...S Y=$$LK("^ORD(101)",Y0)
  1. ...K ^ORD(101,DA,775,I,U)
  1. ...I 'Y K ^ORD(101,DA,775,I) D BMES^XPDUTL(" Protocol "_Y0_" in Protocol Subscriber "_$P(^ORD(101,DA,0),U)_" **NOT FOUND**") Q
  1. ...S $P(^ORD(101,DA,775,I,0),U)=Y
  1. ..S X=I_U_(X+1)
  1. .S:X $P(^ORD(101,DA,775,0),U,3,4)=X
  1. .;re-index this option
  1. .D IX1^DIK
  1. K ^TMP($J,"XPD")
  1. Q
  1. ;
  1. PRODEL ;option delete
  1. D DEL("^ORD(101,",DUZ)
  1. D PRO^XPDIA2
  1. Q
  1. ;
  1. LK(GR,X) ;lookup, GR=global root, X=lookup value
  1. Q:$G(X)="" ""
  1. N I S I=$O(@GR@("B",X,0))
  1. I I,$D(@GR@(I,0))#2 Q I
  1. Q ""
  1. ;
  1. ADD(XPDSDD,XPDSDA,X) ;add to multiple, XPDSDD=sub DD#, XPDSDA=DA, X=value
  1. Q:$G(X)=""
  1. N XPD
  1. S XPD(XPDSDD,"?+1,"_XPDSDA_",",.01)=X
  1. D UPDATE^DIE("E","XPD")
  1. Q
  1. ;this is used to add menu items to an option or protocol
  1. N DIC,DLAYGO,DIK,D0,D1,I,Y,Y0
  1. S DIC=$S(XPDFIL=19:"^DIC(19,",1:"^ORD(101,")_DA_",10,",DIC(0)="L",DLAYGO=XPDFIL,(D0,DA(1))=DA
  1. S:'$D(@(DIC_"0)")) @(DIC_"0)")=U_$P(^DD(XPDFIL,10,0),U,2)
  1. S:$L($G(X0)) DIC("DR")="2///"_$P(X0,U,2)_";3///"_$P(X0,U,3)_$S($L($P(X0,U,4)):";4///"_$P(X0,U,4)_";5///"_$P(X0,U,5)_";6///"_$P(X0,U,6),1:"")
  1. D ^DIC
  1. Q
  1. ;this is used to add subscriber items to a protocol
  1. SUBS(DA,X) ;DA=ien of protocol, X=subscriber
  1. N DIC,DLAYGO,DIK,D0,D1,I,Y,Y0
  1. S DIC="^ORD(101,"_DA_",775,",DIC(0)="L",DLAYGO=XPDFIL,(D0,DA(1))=DA
  1. S:'$D(@(DIC_"0)")) @(DIC_"0)")=U_$P(^DD(XPDFIL,775,0),U,2)
  1. D ^DIC
  1. Q
  1. ;
  1. DEL(DIK,DUZ) ;delete
  1. N DA,XPDI,XPDF
  1. S XPDI=0,DUZ(0)="@",XPDF=+$P(DIK,"(",2)
  1. F S XPDI=$O(^TMP($J,"XPDEL",XPDI)) Q:'XPDI D
  1. .K ^TMP("DIFIXPT",$J) S DA=XPDI
  1. .D ^DIK ;FIXPT^DIA3("D",XPDF,XPDI)
  1. .I $D(^TMP("DIFIXPT",$J)) D WP^XPDUTL("^TMP(""DIFIXPT"",$J)")
  1. Q