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

XPDIA0.m

Go to the documentation of this file.
  1. XPDIA0 ;SFISC/RSD - Cont. of XPDIA ;03/09/2000 06:50
  1. ;;8.0;KERNEL;**131,144,672**;Jul 10, 1995;Build 28
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. Q
  1. PROE1 ;protocols entry pre
  1. N %,I
  1. S ^TMP($J,"XPD",DA)=XPDFL
  1. ;if Event Driver, subscriber multiple is on node 775
  1. I $P(^XTMP("XPDI",XPDA,"KRN",101,OLDA,0),U,4)="E" D
  1. . Q:$D(^XTMP("XPDI",XPDA,"KRN",101,OLDA,775))
  1. . ;pre patch HL*1.6*57, convert menu multiple to subscriber
  1. . M ^XTMP("XPDI",XPDA,"KRN",101,OLDA,775)=^XTMP("XPDI",XPDA,"KRN",101,OLDA,10)
  1. . K ^XTMP("XPDI",XPDA,"KRN",101,OLDA,10)
  1. ;if Menu linking or merge save menu and subscriber mult. and process in FPOS code
  1. I XPDFL>1 D
  1. . 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)
  1. . K ^XTMP("XPDI",XPDA,"KRN",101,OLDA,775),^(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",101,OLDA,0),U,3)]""
  1. .S $P(^XTMP("XPDI",XPDA,"KRN",101,OLDA,0),U,3)=$P(XPDSET,U,3)
  1. .D ADD^XQOO1($P(XPDSET,U,2),101,DA)
  1. S I=^XTMP("XPDI",XPDA,"KRN",101,OLDA,0),%=^ORD(101,DA,0)
  1. ;$P(%,U,3)=disable message,
  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. S ^XTMP("XPDI",XPDA,"KRN",101,OLDA,0)=I
  1. ;if there is a new Description, kill the old Description
  1. K:$O(^XTMP("XPDI",XPDA,"KRN",101,OLDA,1,0)) ^ORD(101,DA,1)
  1. ;kill old ACCESS multiple
  1. K ^ORD(101,DA,3) 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" and "AB" x-ref., it will be reset with new options
  1. F S I=$O(^ORD(101,DA,10,I)) Q:'I S %=+$G(^(I,0)) K:% ^ORD(101,"AD",%,DA,I)
  1. F S I=$O(^ORD(101,DA,775,I)) Q:'I S %=+$G(^(I,0)) K:% ^ORD(101,"AB",%,DA,I)
  1. K ^ORD(101,DA,10),^ORD(101,DA,775)
  1. Q
  1. ;
  1. ENTF1 ;ENTITY #1.5 file pre
  1. K ^TMP($J,"XPD")
  1. Q
  1. ;
  1. ENTE1 ;ENTITY #1.5 entry pre
  1. N %,%1,%2,%6
  1. S ^TMP($J,"XPD",DA)=XPDFL
  1. ;save ITEM multiple and process in file post ENTF2
  1. M ^TMP($J,"XPD",DA,1)=^XTMP("XPDI",XPDA,"KRN",1.5,OLDA,1) K ^XTMP("XPDI",XPDA,"KRN",1.5,OLDA,1)
  1. ;%1=DISPLAY NAME(#.1), %2=DEFAULT FILE NUMBER(#.02), %6=DATA MODEL(#.06)
  1. S %=$G(^DDE(DA,0)),%1=$G(^DDE(DA,.1)),%2=$P(%,U,2),%6=$P(%,U,6)
  1. ;kill the DEFAULT FILE NUMBER cross ref.
  1. I %2 K ^DDE("F",%2,DA)
  1. ;kill the DATA MODEL(%6) & DISPLAY NAME(%1) & DEFAULT FILE(%2) cross ref. ^DDE("FHIR" and ^DDE("SDA"
  1. I %6]"",%1]"",%2 D
  1. . I %6="F" K ^DDE("FHIR",$E(%1,1,30),%2,DA)
  1. . I %6="S" K ^DDE("SDA",$E(%1,1,30),%2,DA)
  1. ;just save the .01 field
  1. S ^DDE(DA,0)=$P(%,U),%1=0
  1. ;loop thru ITEM multiple #1, check ENTITY #.08
  1. F S %1=$O(^DDE(DA,1,%1)) Q:'%1 S %2=$G(^(%1,0)) D:$P(%2,U,8)]""
  1. . ;kill the file level cross ref. ^DDE("AD",entity,ien,multiple)
  1. . K ^DDE("AD",$P(%2,U,8),DA,%1)
  1. ; kill rest of file
  1. S %=0 F S %=$O(^DDE(DA,%)) Q:%="" K ^(%)
  1. Q
  1. ;
  1. ENTF2 ;ENTITY #1.5 file post
  1. ;Loop ^TMP($J,"XPD",DA) and save ITEM multiple
  1. N DA,DIK,%,%1,%8
  1. S DIK="^DDE(",DA=0
  1. F S DA=$O(^TMP($J,"XPD",DA)) Q:'DA S %1=0 D
  1. . F S %1=$O(^TMP($J,"XPD",DA,1,%1)) Q:'%1 S %8=$P($G(^(%1,0)),U,8) D:%8]""
  1. .. ;resolve ENTITY(#.08) and put ien back
  1. .. S %=$$LK^XPDIA("^DDE",%8) S:%]"" $P(^TMP($J,"XPD",DA,1,%1,0),U,8)=%
  1. . ;save ITEM multiple into DDE
  1. . M ^DDE(DA,1)=^TMP($J,"XPD",DA,1)
  1. .;re-index this record
  1. .D IX1^DIK
  1. K ^TMP($J,"XPD")
  1. Q
  1. ;
  1. ENTDEL(RT) ;ENTITY #1.5 delete
  1. D DELIEN^XPDUTL1(1.5,RT)
  1. Q
  1. ;
  1. POLF1 ;POLICY #1.6 file pre
  1. K ^TMP($J,"XPD")
  1. ;add TYPE during a new record, XPDDR is for identifiers
  1. S XPDDR(.02)="$P(OLDA(0),U,2)"
  1. Q
  1. ;
  1. POLE1 ;POLICY 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 Member linking or merge save Member mult. and process in FPOS code
  1. 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)
  1. ;if Menu link, XPDQUIT prevents data merge
  1. I XPDFL=2 S XPDQUIT=1 Q
  1. ;if this is new to the site quit
  1. I $G(XPDNEW) Q
  1. ;if there is a new Description, kill the old Description
  1. K:$O(^XTMP("XPDI",XPDA,"KRN",1.6,OLDA,1,0)) ^DIAC(1.6,DA,1)
  1. Q
  1. ;
  1. POLE2 ;POLICY #1.6 entry post
  1. N %,%1,%2
  1. ;repoint ATTRIBUTE FUNCTION (0;4) and RESULT FUNCTION (0;7)
  1. S %=^DIAC(1.6,DA,0) D S ^DIAC(1.6,DA,0)=%
  1. .F %1=4,7 S %2=$P(%,U,%1),$P(%,U,%1)=$$LK^XPDIA("^DIAC(1.62)",%2)
  1. .Q
  1. ;repoint DENY OBLIGATION (7) and PERMIT OBLIGATION (8)
  1. F %1=7,8 S %=$G(^DIAC(1.6,DA,%1)) D:$L(%)
  1. .S %2=$P(%,U),$P(%,U)=$$LK^XPDIA("^DIAC(1.62)",%2)
  1. .S ^DIAC(1.6,DA,%1)=%
  1. .Q
  1. ;loop thru CONDITIONS (3) and repoint FUNCTION (0;2)
  1. S %1=0 F S %1=$O(^DIAC(1.6,DA,3,%1)) Q:'%1 S %=$G(^(%1,0)) D
  1. .S %2=$P(%,U,2) Q:%2=""
  1. .S $P(%,U,2)=$$LK^XPDIA("^DIAC(1.62)",%2)
  1. .S ^DIAC(1.6,DA,3,%1,0)=%
  1. .Q
  1. Q
  1. ;
  1. POLF2 ;POLICY #1.6 file post
  1. N ACT,DA,DIK,I,X,Y,Y0
  1. ;loop thru all the new incomming policies
  1. S DA=0,DIK=DIC F S DA=$O(^TMP($J,"XPD",DA)) Q:'DA S ACT=^(DA) D
  1. .;need to loop through ^TMP($J,"XPD",DA,10,I) these are MEMBERS that need to be
  1. .;merged, they are also linked memeber, 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]"" MEM(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(^DIAC(1.6,DA,10,I)) Q:'I S Y0=$G(^(I,U)) D
  1. ..I $L(Y0) D Q:'Y
  1. ...S Y=$$LK^XPDIA("^DIAC(1.6)",Y0)
  1. ...K ^DIAC(1.6,DA,10,I,U)
  1. ...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
  1. ...S $P(^DIAC(1.6,DA,10,I,0),U)=Y
  1. ...Q
  1. ..S X=I_U_(X+1)
  1. ..Q
  1. .S:X $P(^DIAC(1.6,DA,10,0),U,3,4)=X
  1. .;re-index this option
  1. .D IX1^DIK
  1. .Q
  1. K ^TMP($J,"XPD")
  1. Q
  1. ;
  1. POLDEL(RT) ;POLICY delete
  1. D DELPTR^XPDUTL1(1.6,RT) ;Delete any pointer entries
  1. D DELIEN^XPDUTL1(1.6,RT) ;Delete the entries
  1. Q
  1. ;
  1. POLEE1 ;EVENT #1.61 entry pre
  1. N %
  1. S %=^XTMP("XPDI",XPDA,"KRN",1.61,OLDA,0)
  1. ;repoint POLICY (0;5)
  1. I $P(%,U,5)]"" S $P(%,U,5)=$$LK^XPDIA("^DIAC(1.6)",$P(%,U,5)),^XTMP("XPDI",XPDA,"KRN",1.61,OLDA,0)=%
  1. Q
  1. ;
  1. POLEDEL(RT) ;EVENT delete
  1. D DELIEN^XPDUTL1(1.61,RT)
  1. Q
  1. ;
  1. POLFE1 ;FUNCTION #1.62 entry pre
  1. ;if there is a new Description, kill the old Description
  1. K:$O(^XTMP("XPDI",XPDA,"KRN",1.62,OLDA,2,0)) ^DIAC(1.62,DA,2)
  1. Q
  1. ;
  1. POLFDEL(RT) ;FUNCTION delete
  1. D DELPTR^XPDUTL1(1.62,RT) ;Delete any pointer entries
  1. D DELIEN^XPDUTL1(1.62,RT) ;Delete the entries
  1. Q
  1. ;
  1. ;this is used to add member to a policy
  1. MEM(DA,X,X0) ;DA=ien of option/protocol, X=Member, X0=0 node of member
  1. N DIC,DLAYGO,DIK,D0,D1,I,Y,Y0
  1. S DIC="^DIAC(1.6,"_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")=".02///"_$P(X0,U,2)
  1. D ^DIC
  1. Q