- 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 Jan 18, 2025@03:04:42 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