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