XPDIA0 ;SFISC/RSD - Cont. of XPDIA ;03/09/2000 06:50
;;8.0;KERNEL;**131,144,672**;Jul 10, 1995;Build 28
;Per VHA Directive 2004-038, this routine should not be modified.
Q
PROE1 ;protocols entry pre
N %,I
S ^TMP($J,"XPD",DA)=XPDFL
;if Event Driver, subscriber multiple is on node 775
I $P(^XTMP("XPDI",XPDA,"KRN",101,OLDA,0),U,4)="E" D
. Q:$D(^XTMP("XPDI",XPDA,"KRN",101,OLDA,775))
. ;pre patch HL*1.6*57, convert menu multiple to subscriber
. M ^XTMP("XPDI",XPDA,"KRN",101,OLDA,775)=^XTMP("XPDI",XPDA,"KRN",101,OLDA,10)
. K ^XTMP("XPDI",XPDA,"KRN",101,OLDA,10)
;if Menu linking or merge save menu and subscriber mult. and process in FPOS code
I XPDFL>1 D
. M ^TMP($J,"XPD",DA,775)=^XTMP("XPDI",XPDA,"KRN",101,OLDA,775),^TMP($J,"XPD",DA,10)=^XTMP("XPDI",XPDA,"KRN",101,OLDA,10)
. K ^XTMP("XPDI",XPDA,"KRN",101,OLDA,775),^(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",101,OLDA,0),U,3)]""
.S $P(^XTMP("XPDI",XPDA,"KRN",101,OLDA,0),U,3)=$P(XPDSET,U,3)
.D ADD^XQOO1($P(XPDSET,U,2),101,DA)
S I=^XTMP("XPDI",XPDA,"KRN",101,OLDA,0),%=^ORD(101,DA,0)
;$P(%,U,3)=disable message,
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)
S ^XTMP("XPDI",XPDA,"KRN",101,OLDA,0)=I
;if there is a new Description, kill the old Description
K:$O(^XTMP("XPDI",XPDA,"KRN",101,OLDA,1,0)) ^ORD(101,DA,1)
;kill old ACCESS multiple
K ^ORD(101,DA,3) 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" and "AB" x-ref., it will be reset with new options
F S I=$O(^ORD(101,DA,10,I)) Q:'I S %=+$G(^(I,0)) K:% ^ORD(101,"AD",%,DA,I)
F S I=$O(^ORD(101,DA,775,I)) Q:'I S %=+$G(^(I,0)) K:% ^ORD(101,"AB",%,DA,I)
K ^ORD(101,DA,10),^ORD(101,DA,775)
Q
;
ENTF1 ;ENTITY #1.5 file pre
K ^TMP($J,"XPD")
Q
;
ENTE1 ;ENTITY #1.5 entry pre
N %,%1,%2,%6
S ^TMP($J,"XPD",DA)=XPDFL
;save ITEM multiple and process in file post ENTF2
M ^TMP($J,"XPD",DA,1)=^XTMP("XPDI",XPDA,"KRN",1.5,OLDA,1) K ^XTMP("XPDI",XPDA,"KRN",1.5,OLDA,1)
;%1=DISPLAY NAME(#.1), %2=DEFAULT FILE NUMBER(#.02), %6=DATA MODEL(#.06)
S %=$G(^DDE(DA,0)),%1=$G(^DDE(DA,.1)),%2=$P(%,U,2),%6=$P(%,U,6)
;kill the DEFAULT FILE NUMBER cross ref.
I %2 K ^DDE("F",%2,DA)
;kill the DATA MODEL(%6) & DISPLAY NAME(%1) & DEFAULT FILE(%2) cross ref. ^DDE("FHIR" and ^DDE("SDA"
I %6]"",%1]"",%2 D
. I %6="F" K ^DDE("FHIR",$E(%1,1,30),%2,DA)
. I %6="S" K ^DDE("SDA",$E(%1,1,30),%2,DA)
;just save the .01 field
S ^DDE(DA,0)=$P(%,U),%1=0
;loop thru ITEM multiple #1, check ENTITY #.08
F S %1=$O(^DDE(DA,1,%1)) Q:'%1 S %2=$G(^(%1,0)) D:$P(%2,U,8)]""
. ;kill the file level cross ref. ^DDE("AD",entity,ien,multiple)
. K ^DDE("AD",$P(%2,U,8),DA,%1)
; kill rest of file
S %=0 F S %=$O(^DDE(DA,%)) Q:%="" K ^(%)
Q
;
ENTF2 ;ENTITY #1.5 file post
;Loop ^TMP($J,"XPD",DA) and save ITEM multiple
N DA,DIK,%,%1,%8
S DIK="^DDE(",DA=0
F S DA=$O(^TMP($J,"XPD",DA)) Q:'DA S %1=0 D
. F S %1=$O(^TMP($J,"XPD",DA,1,%1)) Q:'%1 S %8=$P($G(^(%1,0)),U,8) D:%8]""
.. ;resolve ENTITY(#.08) and put ien back
.. S %=$$LK^XPDIA("^DDE",%8) S:%]"" $P(^TMP($J,"XPD",DA,1,%1,0),U,8)=%
. ;save ITEM multiple into DDE
. M ^DDE(DA,1)=^TMP($J,"XPD",DA,1)
.;re-index this record
.D IX1^DIK
K ^TMP($J,"XPD")
Q
;
ENTDEL(RT) ;ENTITY #1.5 delete
D DELIEN^XPDUTL1(1.5,RT)
Q
;
POLF1 ;POLICY #1.6 file pre
K ^TMP($J,"XPD")
;add TYPE during a new record, XPDDR is for identifiers
S XPDDR(.02)="$P(OLDA(0),U,2)"
Q
;
POLE1 ;POLICY 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 Member linking or merge save Member mult. and process in FPOS code
I XPDFL>1 M ^TMP($J,"XPD",DA,10)=^XTMP("XPDI",XPDA,"KRN",1.6,OLDA,10) K ^XTMP("XPDI",XPDA,"KRN",1.6,OLDA,10)
;if Menu link, XPDQUIT prevents data merge
I XPDFL=2 S XPDQUIT=1 Q
;if this is new to the site quit
I $G(XPDNEW) Q
;if there is a new Description, kill the old Description
K:$O(^XTMP("XPDI",XPDA,"KRN",1.6,OLDA,1,0)) ^DIAC(1.6,DA,1)
Q
;
POLE2 ;POLICY #1.6 entry post
N %,%1,%2
;repoint ATTRIBUTE FUNCTION (0;4) and RESULT FUNCTION (0;7)
S %=^DIAC(1.6,DA,0) D S ^DIAC(1.6,DA,0)=%
.F %1=4,7 S %2=$P(%,U,%1),$P(%,U,%1)=$$LK^XPDIA("^DIAC(1.62)",%2)
.Q
;repoint DENY OBLIGATION (7) and PERMIT OBLIGATION (8)
F %1=7,8 S %=$G(^DIAC(1.6,DA,%1)) D:$L(%)
.S %2=$P(%,U),$P(%,U)=$$LK^XPDIA("^DIAC(1.62)",%2)
.S ^DIAC(1.6,DA,%1)=%
.Q
;loop thru CONDITIONS (3) and repoint FUNCTION (0;2)
S %1=0 F S %1=$O(^DIAC(1.6,DA,3,%1)) Q:'%1 S %=$G(^(%1,0)) D
.S %2=$P(%,U,2) Q:%2=""
.S $P(%,U,2)=$$LK^XPDIA("^DIAC(1.62)",%2)
.S ^DIAC(1.6,DA,3,%1,0)=%
.Q
Q
;
POLF2 ;POLICY #1.6 file post
N ACT,DA,DIK,I,X,Y,Y0
;loop thru all the new incomming policies
S DA=0,DIK=DIC F S DA=$O(^TMP($J,"XPD",DA)) Q:'DA S ACT=^(DA) D
.;need to loop through ^TMP($J,"XPD",DA,10,I) these are MEMBERS that need to be
.;merged, they are also linked memeber, 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]"" MEM(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(^DIAC(1.6,DA,10,I)) Q:'I S Y0=$G(^(I,U)) D
..I $L(Y0) D Q:'Y
...S Y=$$LK^XPDIA("^DIAC(1.6)",Y0)
...K ^DIAC(1.6,DA,10,I,U)
...I 'Y K ^DIAC(1.6,DA,10,I) D BMES^XPDUTL(" Policy "_Y0_" in Policy Members "_$P(^DIAC(1.6,DA,0),U)_" **NOT FOUND**") Q
...S $P(^DIAC(1.6,DA,10,I,0),U)=Y
...Q
..S X=I_U_(X+1)
..Q
.S:X $P(^DIAC(1.6,DA,10,0),U,3,4)=X
.;re-index this option
.D IX1^DIK
.Q
K ^TMP($J,"XPD")
Q
;
POLDEL(RT) ;POLICY delete
D DELPTR^XPDUTL1(1.6,RT) ;Delete any pointer entries
D DELIEN^XPDUTL1(1.6,RT) ;Delete the entries
Q
;
POLEE1 ;EVENT #1.61 entry pre
N %
S %=^XTMP("XPDI",XPDA,"KRN",1.61,OLDA,0)
;repoint POLICY (0;5)
I $P(%,U,5)]"" S $P(%,U,5)=$$LK^XPDIA("^DIAC(1.6)",$P(%,U,5)),^XTMP("XPDI",XPDA,"KRN",1.61,OLDA,0)=%
Q
;
POLEDEL(RT) ;EVENT delete
D DELIEN^XPDUTL1(1.61,RT)
Q
;
POLFE1 ;FUNCTION #1.62 entry pre
;if there is a new Description, kill the old Description
K:$O(^XTMP("XPDI",XPDA,"KRN",1.62,OLDA,2,0)) ^DIAC(1.62,DA,2)
Q
;
POLFDEL(RT) ;FUNCTION delete
D DELPTR^XPDUTL1(1.62,RT) ;Delete any pointer entries
D DELIEN^XPDUTL1(1.62,RT) ;Delete the entries
Q
;
;this is used to add member to a policy
MEM(DA,X,X0) ;DA=ien of option/protocol, X=Member, X0=0 node of member
N DIC,DLAYGO,DIK,D0,D1,I,Y,Y0
S DIC="^DIAC(1.6,"_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")=".02///"_$P(X0,U,2)
D ^DIC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXPDIA0 7164 printed Apr 09, 2024@21:17:53 Page 2
XPDIA0 ;SFISC/RSD - Cont. of XPDIA ;03/09/2000 06:50
+1 ;;8.0;KERNEL;**131,144,672**;Jul 10, 1995;Build 28
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
PROE1 ;protocols entry pre
+1 NEW %,I
+2 SET ^TMP($JOB,"XPD",DA)=XPDFL
+3 ;if Event Driver, subscriber multiple is on node 775
+4 IF $PIECE(^XTMP("XPDI",XPDA,"KRN",101,OLDA,0),U,4)="E"
Begin DoDot:1
+5 if $DATA(^XTMP("XPDI",XPDA,"KRN",101,OLDA,775))
QUIT
+6 ;pre patch HL*1.6*57, convert menu multiple to subscriber
+7 MERGE ^XTMP("XPDI",XPDA,"KRN",101,OLDA,775)=^XTMP("XPDI",XPDA,"KRN",101,OLDA,10)
+8 KILL ^XTMP("XPDI",XPDA,"KRN",101,OLDA,10)
End DoDot:1
+9 ;if Menu linking or merge save menu and subscriber mult. and process in FPOS code
+10 IF XPDFL>1
Begin DoDot:1
+11 MERGE ^TMP($JOB,"XPD",DA,775)=^XTMP("XPDI",XPDA,"KRN",101,OLDA,775),^TMP($JOB,"XPD",DA,10)=^XTMP("XPDI",XPDA,"KRN",101,OLDA,10)
+12 KILL ^XTMP("XPDI",XPDA,"KRN",101,OLDA,775),^(10)
End DoDot:1
+13 ;if Menu link, XPDQUIT prevents data merge
+14 IF XPDFL=2
SET XPDQUIT=1
QUIT
+15 ;if this is new to the site then disable and quit
+16 IF $GET(XPDNEW)
if XPDSET
Begin DoDot:1
+17 ;quit if option already has out of order msg.
+18 if $PIECE(^XTMP("XPDI",XPDA,"KRN",101,OLDA,0),U,3)]""
QUIT
+19 SET $PIECE(^XTMP("XPDI",XPDA,"KRN",101,OLDA,0),U,3)=$PIECE(XPDSET,U,3)
+20 DO ADD^XQOO1($PIECE(XPDSET,U,2),101,DA)
End DoDot:1
QUIT
+21 SET I=^XTMP("XPDI",XPDA,"KRN",101,OLDA,0)
SET %=^ORD(101,DA,0)
+22 ;$P(%,U,3)=disable message,
+23 if $PIECE(I,U,3)]""
SET $PIECE(I,U,3)=$PIECE(%,U,3)
+24 ;if there is no new Security Key, save the old Key
+25 if $PIECE(I,U,6)=""
SET $PIECE(I,U,6)=$PIECE(%,U,6)
+26 SET ^XTMP("XPDI",XPDA,"KRN",101,OLDA,0)=I
+27 ;if there is a new Description, kill the old Description
+28 if $ORDER(^XTMP("XPDI",XPDA,"KRN",101,OLDA,1,0))
KILL ^ORD(101,DA,1)
+29 ;kill old ACCESS multiple
+30 KILL ^ORD(101,DA,3)
SET I=0
+31 ;XPDFL=3-merge menu items, Quit
+32 ;the new menu items have already been saved into ^TMP, will restore in
+33 ;the file post action as a relink
+34 if XPDFL=3
QUIT
+35 ;we are replacing menu items, kill the old.
+36 ;loop thru and kill "AD" and "AB" x-ref., it will be reset with new options
+37 FOR
SET I=$ORDER(^ORD(101,DA,10,I))
if 'I
QUIT
SET %=+$GET(^(I,0))
if %
KILL ^ORD(101,"AD",%,DA,I)
+38 FOR
SET I=$ORDER(^ORD(101,DA,775,I))
if 'I
QUIT
SET %=+$GET(^(I,0))
if %
KILL ^ORD(101,"AB",%,DA,I)
+39 KILL ^ORD(101,DA,10),^ORD(101,DA,775)
+40 QUIT
+41 ;
ENTF1 ;ENTITY #1.5 file pre
+1 KILL ^TMP($JOB,"XPD")
+2 QUIT
+3 ;
ENTE1 ;ENTITY #1.5 entry pre
+1 NEW %,%1,%2,%6
+2 SET ^TMP($JOB,"XPD",DA)=XPDFL
+3 ;save ITEM multiple and process in file post ENTF2
+4 MERGE ^TMP($JOB,"XPD",DA,1)=^XTMP("XPDI",XPDA,"KRN",1.5,OLDA,1)
KILL ^XTMP("XPDI",XPDA,"KRN",1.5,OLDA,1)
+5 ;%1=DISPLAY NAME(#.1), %2=DEFAULT FILE NUMBER(#.02), %6=DATA MODEL(#.06)
+6 SET %=$GET(^DDE(DA,0))
SET %1=$GET(^DDE(DA,.1))
SET %2=$PIECE(%,U,2)
SET %6=$PIECE(%,U,6)
+7 ;kill the DEFAULT FILE NUMBER cross ref.
+8 IF %2
KILL ^DDE("F",%2,DA)
+9 ;kill the DATA MODEL(%6) & DISPLAY NAME(%1) & DEFAULT FILE(%2) cross ref. ^DDE("FHIR" and ^DDE("SDA"
+10 IF %6]""
IF %1]""
IF %2
Begin DoDot:1
+11 IF %6="F"
KILL ^DDE("FHIR",$EXTRACT(%1,1,30),%2,DA)
+12 IF %6="S"
KILL ^DDE("SDA",$EXTRACT(%1,1,30),%2,DA)
End DoDot:1
+13 ;just save the .01 field
+14 SET ^DDE(DA,0)=$PIECE(%,U)
SET %1=0
+15 ;loop thru ITEM multiple #1, check ENTITY #.08
+16 FOR
SET %1=$ORDER(^DDE(DA,1,%1))
if '%1
QUIT
SET %2=$GET(^(%1,0))
if $PIECE(%2,U,8)]""
Begin DoDot:1
+17 ;kill the file level cross ref. ^DDE("AD",entity,ien,multiple)
+18 KILL ^DDE("AD",$PIECE(%2,U,8),DA,%1)
End DoDot:1
+19 ; kill rest of file
+20 SET %=0
FOR
SET %=$ORDER(^DDE(DA,%))
if %=""
QUIT
KILL ^(%)
+21 QUIT
+22 ;
ENTF2 ;ENTITY #1.5 file post
+1 ;Loop ^TMP($J,"XPD",DA) and save ITEM multiple
+2 NEW DA,DIK,%,%1,%8
+3 SET DIK="^DDE("
SET DA=0
+4 FOR
SET DA=$ORDER(^TMP($JOB,"XPD",DA))
if 'DA
QUIT
SET %1=0
Begin DoDot:1
+5 FOR
SET %1=$ORDER(^TMP($JOB,"XPD",DA,1,%1))
if '%1
QUIT
SET %8=$PIECE($GET(^(%1,0)),U,8)
if %8]""
Begin DoDot:2
+6 ;resolve ENTITY(#.08) and put ien back
+7 SET %=$$LK^XPDIA("^DDE",%8)
if %]""
SET $PIECE(^TMP($JOB,"XPD",DA,1,%1,0),U,8)=%
End DoDot:2
+8 ;save ITEM multiple into DDE
+9 MERGE ^DDE(DA,1)=^TMP($JOB,"XPD",DA,1)
+10 ;re-index this record
+11 DO IX1^DIK
End DoDot:1
+12 KILL ^TMP($JOB,"XPD")
+13 QUIT
+14 ;
ENTDEL(RT) ;ENTITY #1.5 delete
+1 DO DELIEN^XPDUTL1(1.5,RT)
+2 QUIT
+3 ;
POLF1 ;POLICY #1.6 file pre
+1 KILL ^TMP($JOB,"XPD")
+2 ;add TYPE during a new record, XPDDR is for identifiers
+3 SET XPDDR(.02)="$P(OLDA(0),U,2)"
+4 QUIT
+5 ;
POLE1 ;POLICY 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 Member linking or merge save Member mult. and process in FPOS code
+6 IF XPDFL>1
MERGE ^TMP($JOB,"XPD",DA,10)=^XTMP("XPDI",XPDA,"KRN",1.6,OLDA,10)
KILL ^XTMP("XPDI",XPDA,"KRN",1.6,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 quit
+10 IF $GET(XPDNEW)
QUIT
+11 ;if there is a new Description, kill the old Description
+12 if $ORDER(^XTMP("XPDI",XPDA,"KRN",1.6,OLDA,1,0))
KILL ^DIAC(1.6,DA,1)
+13 QUIT
+14 ;
POLE2 ;POLICY #1.6 entry post
+1 NEW %,%1,%2
+2 ;repoint ATTRIBUTE FUNCTION (0;4) and RESULT FUNCTION (0;7)
+3 SET %=^DIAC(1.6,DA,0)
Begin DoDot:1
+4 FOR %1=4,7
SET %2=$PIECE(%,U,%1)
SET $PIECE(%,U,%1)=$$LK^XPDIA("^DIAC(1.62)",%2)
+5 QUIT
End DoDot:1
SET ^DIAC(1.6,DA,0)=%
+6 ;repoint DENY OBLIGATION (7) and PERMIT OBLIGATION (8)
+7 FOR %1=7,8
SET %=$GET(^DIAC(1.6,DA,%1))
if $LENGTH(%)
Begin DoDot:1
+8 SET %2=$PIECE(%,U)
SET $PIECE(%,U)=$$LK^XPDIA("^DIAC(1.62)",%2)
+9 SET ^DIAC(1.6,DA,%1)=%
+10 QUIT
End DoDot:1
+11 ;loop thru CONDITIONS (3) and repoint FUNCTION (0;2)
+12 SET %1=0
FOR
SET %1=$ORDER(^DIAC(1.6,DA,3,%1))
if '%1
QUIT
SET %=$GET(^(%1,0))
Begin DoDot:1
+13 SET %2=$PIECE(%,U,2)
if %2=""
QUIT
+14 SET $PIECE(%,U,2)=$$LK^XPDIA("^DIAC(1.62)",%2)
+15 SET ^DIAC(1.6,DA,3,%1,0)=%
+16 QUIT
End DoDot:1
+17 QUIT
+18 ;
POLF2 ;POLICY #1.6 file post
+1 NEW ACT,DA,DIK,I,X,Y,Y0
+2 ;loop thru all the new incomming policies
+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 ;need to loop through ^TMP($J,"XPD",DA,10,I) these are MEMBERS that need to be
+5 ;merged, they are also linked memeber, but treat like merge
+6 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 MEM(DA,X,Y0)
+7 ;loop thru Menu and repoint Option (0;1), text is on ^(U) node
+8 ;also need to recount all menus and reset zeroth node, use X
+9 SET (I,X)=0
FOR
SET I=$ORDER(^DIAC(1.6,DA,10,I))
if 'I
QUIT
SET Y0=$GET(^(I,U))
Begin DoDot:2
+10 IF $LENGTH(Y0)
Begin DoDot:3
+11 SET Y=$$LK^XPDIA("^DIAC(1.6)",Y0)
+12 KILL ^DIAC(1.6,DA,10,I,U)
+13 IF 'Y
KILL ^DIAC(1.6,DA,10,I)
DO BMES^XPDUTL(" Policy "_Y0_" in Policy Members "_$PIECE(^DIAC(1.6,DA,0),U)_" **NOT FOUND**")
QUIT
+14 SET $PIECE(^DIAC(1.6,DA,10,I,0),U)=Y
+15 QUIT
End DoDot:3
if 'Y
QUIT
+16 SET X=I_U_(X+1)
+17 QUIT
End DoDot:2
+18 if X
SET $PIECE(^DIAC(1.6,DA,10,0),U,3,4)=X
+19 ;re-index this option
+20 DO IX1^DIK
+21 QUIT
End DoDot:1
+22 KILL ^TMP($JOB,"XPD")
+23 QUIT
+24 ;
POLDEL(RT) ;POLICY delete
+1 ;Delete any pointer entries
DO DELPTR^XPDUTL1(1.6,RT)
+2 ;Delete the entries
DO DELIEN^XPDUTL1(1.6,RT)
+3 QUIT
+4 ;
POLEE1 ;EVENT #1.61 entry pre
+1 NEW %
+2 SET %=^XTMP("XPDI",XPDA,"KRN",1.61,OLDA,0)
+3 ;repoint POLICY (0;5)
+4 IF $PIECE(%,U,5)]""
SET $PIECE(%,U,5)=$$LK^XPDIA("^DIAC(1.6)",$PIECE(%,U,5))
SET ^XTMP("XPDI",XPDA,"KRN",1.61,OLDA,0)=%
+5 QUIT
+6 ;
POLEDEL(RT) ;EVENT delete
+1 DO DELIEN^XPDUTL1(1.61,RT)
+2 QUIT
+3 ;
POLFE1 ;FUNCTION #1.62 entry pre
+1 ;if there is a new Description, kill the old Description
+2 if $ORDER(^XTMP("XPDI",XPDA,"KRN",1.62,OLDA,2,0))
KILL ^DIAC(1.62,DA,2)
+3 QUIT
+4 ;
POLFDEL(RT) ;FUNCTION delete
+1 ;Delete any pointer entries
DO DELPTR^XPDUTL1(1.62,RT)
+2 ;Delete the entries
DO DELIEN^XPDUTL1(1.62,RT)
+3 QUIT
+4 ;
+5 ;this is used to add member to a policy
MEM(DA,X,X0) ;DA=ien of option/protocol, X=Member, X0=0 node of member
+1 NEW DIC,DLAYGO,DIK,D0,D1,I,Y,Y0
+2 SET DIC="^DIAC(1.6,"_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")=".02///"_$PIECE(X0,U,2)
+5 DO ^DIC
+6 QUIT
