XPDIK ;SFISC/RSD - Install Kernel Files & FM Files ;04/26/2004 11:20
;;8.0;KERNEL;**15,58,108,124,146,346,672**;Jul 10, 1995;Build 28
;Per VHA Directive 2004-038, this routine should not be modified.
Q
KRN ;
;XPDA=package ien in INSTALL FILE, XPDNM=package name, XPDCP= check points
N DA,DIC,DIOVRD,EPOS,EPRE,FDEL,FPOS,FPRE,OLDA,ORD,X,XGCEDITR,XPDDR,XPDFIL,XPDFILNM,XPDFL,XPDNEW,XREF,Y,Z,%
;DIOVRD is used to override write protection on a file
;XGCEDITR is check in file 8995, at 'SCR' node of DD
S ORD=0,XPDCP="KRN",(DIOVRD,XGCEDITR)=1
F S ORD=$O(^XTMP("XPDI",XPDA,"ORD",ORD)) Q:'ORD S XPDFIL=+$O(^(ORD,0)),XREF=$G(^(XPDFIL)),XPDFILNM=$G(^(XPDFIL,0)) D:XPDFIL
.;sets up EPOS,EPRE,FDEL,FPOS,FPRE variables
.F DA=1:1:5 S @$P("FPRE^EPRE^FPOS^EPOS^FDEL",U,DA)=$P(XREF,";",DA+5)
.K DIC,^TMP($J,"XPDEL"),XPDDR
.S DIC=$G(^DIC(XPDFIL,0,"GL")),XREF=+$P(XREF,";",3)
.;check if file, XPDFIL, exist at this site
.I $P($G(^DIC(XPDFIL,0)),U)'=XPDFILNM D BMES^XPDUTL(" File "_XPDFIL_" is not "_XPDFILNM_", nothing installed.") Q
.;check if XPDFIL has already been installed
.I $P(^XPD(9.7,XPDA,"KRN",XPDFIL,0),U,2) D BMES^XPDUTL(" "_XPDFILNM_" already installed.") Q
.D BMES^XPDUTL(" Installing "_XPDFILNM),SETTOT^XPDID(XPDFIL)
.;do File Pre-install action, continue if ok
.;XPDFL= 0-send,1-delete,2-link,3-merge,4-attach,5-disable
.;loops thru the entries for this file
.I '$$ACT(FPRE) S OLDA=0 F S OLDA=$O(^XTMP("XPDI",XPDA,"KRN",XPDFIL,OLDA)) Q:'OLDA S XPDFL=+$G(^(OLDA,-1)),OLDA(0)=^(0) D
..;if we are doing VT graphic display, set counter
..I $D(XPDIDVT) S XPDIDCNT=XPDIDCNT+1 D:'(XPDIDCNT#XPDIDMOD) UPDATE^XPDID(XPDIDCNT)
..;quit if disable or attach (4 or 5). Attach will be processed under the parent menu.
..Q:XPDFL>3
..;if FM file, need to set screening logic
..I XPDFIL<.44 S %=$S(XPDFIL'=.403:4,1:8),DIC("S")="I $P(^(0),U,"_%_")="_$P(OLDA(0),U,%)
..;if deleting at site and a template, reset the lookup value and DIC("S")
..I XPDFL=1,XPDFIL<.44 S %=$P(OLDA(0),U),$P(OLDA(0),U)=$P(%," FILE #"),DIC("S")="I $P(^(0),U,"_$S(XPDFIL'=.403:4,1:8)_")="_+$P(%," FILE #",2)
..;XPDNEW=1 if entry is new, laygo
..S X=$P(OLDA(0),U),Y=$$DIC(XPDFIL,X,$G(DIC("S")),XPDFL,.XPDDR) Q:'Y S DA=+Y,XPDNEW=$P(Y,U,3)
..;if deleting then save and process after FPOS
..I XPDFL=1 S ^TMP($J,"XPDEL",DA)="" Q
..;do Entries Pre-install action
..Q:$$ACT(EPRE)
..;merges the data, if you want the data deleted before the merge, you must
..;do it in the Entry Pre-install node, EPRE.
..M @(DIC_DA_")")=^XTMP("XPDI",XPDA,"KRN",XPDFIL,OLDA)
..;kill the flag node from the live data node
..K @(DIC_DA_",-1)") Q:$$ACT(EPOS)
..;XREF is flag to x-ref file after each entry, it is set in file 9.6
..I XREF N DIK S DIK=DIC D IX1^DIK
.;do File Post Install Action
.S %=$$ACT(FPOS)
.;process the deleting of entries, FDEL should allow the passing of all entries
.;to delete in array ^TMP($J,"XPDEL",DA)=""
.I $L(FDEL),$D(^TMP($J,"XPDEL")) S %="^TMP($J,""XPDEL"")" D @FDEL
.;complete check point
.S %=$$XPCOM(XPDFIL)
.K ^TMP($J,"XPDEL")
.I $D(XPDIDVT) D UPDATE^XPDID(XPDIDCNT)
Q
FIA ;
;XPFIL2=file is new^DD screen failed^data already exists^change file name^don't add data; 1=yes, 0=no
N XPGR,XPFIL,XPFILO,XPFIL2,Z
S XPFIL=0,XPGR=$NA(^XTMP("XPDI",XPDA))
F S XPFIL=$O(^XTMP("XPDI",XPDA,"FIA",XPFIL)) Q:'XPFIL S XPFILO=^(XPFIL,0,1),XPFIL2=^(2) D
.;if we are doing VT graphic display, set counter
.I $D(XPDIDVT) S XPDIDCNT=XPDIDCNT+1 D:'(XPDIDCNT#XPDIDMOD) UPDATE^XPDID(XPDIDCNT)
.;file is new, alway install DD
.S:XPFIL2 $P(XPFILO,U)="y",$P(^XTMP("XPDI",XPDA,"FIA",XPFIL,0,1),U)="y"
.;DD failed screen
.I $P(XPFIL2,U,2) D Q
..N XPD
..S XPD(1)=" ",XPD(2)="Data Dictionary for File #"_XPFIL_" not installed, failed DD screen."
..D MES^XPDUTL(.XPD) S %=$$XPCOM(XPFIL)
.;if udate DD question = no & file is not new update checkpoint
.I $P(XPFILO,U)'="y"&'XPFIL2 S %=$$XPCOM(XPFIL)
.;check if XPFIL has already been installed
.Q:$P(^XPD(9.7,XPDA,4,XPFIL,0),U,2)
.;update file name
.I $P(XPFIL2,U,4) D
..N DIE,DR,DA
..S DR=".01////"_^XTMP("XPDI",XPDA,"FIA",XPFIL),DA=XPFIL,DIE=1
..D ^DIE
.;move DD and check for errors
.D DDIN^DIFROMS(XPFIL,"","",XPGR),DIERR("** ERROR IN DATA DICTIONARY FOR FILE # "_XPFIL_" **"):$D(DIERR)
.S %=$$XPCOM(XPFIL)
I $D(XPDIDVT) D UPDATE^XPDID(XPDIDTOT)
Q
DAT ;
N XPGR,XPFIL,XPFILO,XPFIL2,Z
S XPFIL=0,XPGR=$NA(^XTMP("XPDI",XPDA))
;DO if they are sending data
F S XPFIL=$O(^XTMP("XPDI",XPDA,"FIA",XPFIL)) Q:'XPFIL S XPFILO=^(XPFIL,0,1),XPFIL2=^(2) D:$P(XPFILO,U,7)="y"
.;DD failed screen or answer no to adding data or 'Add if new' & data already exists or file doesn't exist
.I $P(XPFIL2,U,2)!$P(XPFIL2,U,5)!($P(XPFILO,U,8)="a"&$P(XPFIL2,U,3))!'$D(^DIC(XPFIL,0)) S %=$$XPCOM(XPFIL,1) Q
.;check if XPFIL has already been installed or no data to input
.Q:$P(^XPD(9.7,XPDA,4,XPFIL,0),U,3)!('$D(^XTMP("XPDI",XPDA,"DATA",XPFIL)))
.;bring in Data and check for error
.D DATAIN^DIFROMS(XPFIL,"","",XPGR),DIERR("** ERROR IN DATA FOR FILE # "_XPFIL_" **"):$D(DIERR)
.S %=$$XPCOM(XPFIL,1)
D RP^DIFROMSR("","",XPGR),DIERR("** ERROR IN POINTER RESOLUTION OF DATA **"):$D(DIERR)
Q
;record error
DIERR(XPDI) N XPD
D MSG^DIALOG("AE",.XPD) Q:'$D(XPD)
D BMES^XPDUTL(XPDI),MES^XPDUTL(.XPD)
Q
;
;XPDF=file #,XPDX=input X,XPDS=screen logic, XPDACT=action, XPDDR(field)=indirect string; add required identifiers
DIC(XPDF,XPDX,XPDS,XPDACT,XPDDR) ;
N DIC,DIERR,XPD,XPDN
S DIC=$G(^DIC(XPDF,0,"GL"))
D FIND^DIC(XPDF,"","","XQf",XPDX,5,"",$G(XPDS),"","XPD")
;one or more matches, just return first one
I $G(XPD(0)) D:XPD(0)>1 Q XPD(1)
.S %(1)=$P($G(^DIC(XPDF,0)),U)_" "_XPDX_" is Duplicated,",%(2)=" only ien #"_XPD(1)_" was updated."
.D MES^XPDUTL(.%)
;no match and action=(delete,link, or attach), don't write message if deleting
I $G(XPDACT),XPDACT'=3 D:XPDACT'=1 BMES^XPDUTL(" "_$P($G(^DIC(XPDF,0)),U)_" "_XPDX_" Lookup failed, NO Action Taken.") Q 0
;add a new entry
N DLAYGO,X,Y,Z
;S X=XPDX,DIC(0)="LX",DLAYGO=XPDF,DIC("S")=$G(XPDS)
;D ^DIC
;I Y<0 D BMES^XPDUTL(" "_$P($G(^DIC(XPDF,0)),U)_" "_XPDX_" **Couldn't Add to file**") Q 0
;Q Y
;code can't be used until UPDATE^DIE allows the creation of a record
;without required identifiers
K XPD,DIERR
S XPD(XPDF,"+1,",.01)=XPDX,XPDDR=0
;XPDDR is an array that contains field # and indirection code to add an identifier field during a new record
;XPDDR(1)="$P(OLDA(0),U,2)" for file 19, add Menu Text #1
F S XPDDR=$O(XPDDR(XPDDR)) Q:'XPDDR S Z="XPD(XPDF,""+1,"",XPDDR)="_XPDDR(XPDDR),@Z
D UPDATE^DIE("E","XPD","XPDN") ;p672
;couldn't add as new
I $D(DIERR) D DIERR(" "_$P($G(^DIC(XPDF,0)),U)_" "_XPDX_" **Couldn't Add to file**") Q 0
I '$G(XPDN(1)) D BMES^XPDUTL(" "_$P($G(^DIC(XPDF,0)),U)_" "_XPDX_" **Couldn't Add to file**") Q 0
;"^^1" indicates new entry, same as Y in DIC call p672
Q XPDN(1)_"^^1"
;
ACT(%) ;execute action, returns 0 to continue, 1 to quit
;user can count on DIC,DA,XPDFIL,OLDA,XPDNM,XPDFL,X,Y being around
;XPDNEW is set only for Entry Pre-install action
Q:%="" 0
N %1,%2,%3,%4,%5
S %1=$G(DIC),%2=$G(DA),%3=$G(OLDA),%4=$P(%,U),%5=$P($P(%,U,2),"(")
N DA,DIC,DIOVRD,OLDA,EPOS,EPRE,FPOS,FPRE,ORD,XREF,XPDQUIT
S DIC=%1,DA=%2,OLDA=%3
;check that % is callable
D I %5="" Q 0
. S:%5="" %5=$P(%4,"("),%4="",%="^"_% ; no tag
. I %4]"" S:$T(@%4^@%5)="" %5="" Q ;tag^routine don't exists
. S:$T(^@%5)="" %5="" ;routine don't exists
. Q
;XPDQUIT=quit this level of processing
D @% Q $D(XPDQUIT)
Q
;
XPCOM(XPDF,XPDJ) ;complete checkpoint for file XPDF
;XPDJ=1 only for data of fm files, it set the field to edit = 2
N XPD,%,Z
S %=$$NOW^XLFDT,Z=$S(XPDCP="KRN":9.715,1:9.714),XPD(Z,XPDF_","_XPDA_",",$G(XPDJ)+1)=%
;if Build Components, save the ORDer number
S:Z=9.715 XPD(Z,XPDF_","_XPDA_",",2)=ORD
D FILE^DIE("","XPD")
Q 1
;
XPCK(XPDI) ;setup check points for file type XPDI
;XPDI="KRN"-components, ="FIA"-files
N %,XPD,XPDF,XPDJ,XPDK
;XPDK=sub DD
S XPDK=$S(XPDI="KRN":9.715,1:9.714),XPDF=0
F %=1:1 S XPDF=$O(^XTMP("XPDI",XPDA,XPDI,XPDF)) Q:'XPDF S (XPDJ(%),XPD(XPDK,"+"_%_","_XPDA_",",.01))=XPDF
D:$D(XPD)>9 UPDATE^DIE("","XPD","XPDJ")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXPDIK 8307 printed Dec 13, 2024@02:03:40 Page 2
XPDIK ;SFISC/RSD - Install Kernel Files & FM Files ;04/26/2004 11:20
+1 ;;8.0;KERNEL;**15,58,108,124,146,346,672**;Jul 10, 1995;Build 28
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
KRN ;
+1 ;XPDA=package ien in INSTALL FILE, XPDNM=package name, XPDCP= check points
+2 NEW DA,DIC,DIOVRD,EPOS,EPRE,FDEL,FPOS,FPRE,OLDA,ORD,X,XGCEDITR,XPDDR,XPDFIL,XPDFILNM,XPDFL,XPDNEW,XREF,Y,Z,%
+3 ;DIOVRD is used to override write protection on a file
+4 ;XGCEDITR is check in file 8995, at 'SCR' node of DD
+5 SET ORD=0
SET XPDCP="KRN"
SET (DIOVRD,XGCEDITR)=1
+6 FOR
SET ORD=$ORDER(^XTMP("XPDI",XPDA,"ORD",ORD))
if 'ORD
QUIT
SET XPDFIL=+$ORDER(^(ORD,0))
SET XREF=$GET(^(XPDFIL))
SET XPDFILNM=$GET(^(XPDFIL,0))
if XPDFIL
Begin DoDot:1
+7 ;sets up EPOS,EPRE,FDEL,FPOS,FPRE variables
+8 FOR DA=1:1:5
SET @$PIECE("FPRE^EPRE^FPOS^EPOS^FDEL",U,DA)=$PIECE(XREF,";",DA+5)
+9 KILL DIC,^TMP($JOB,"XPDEL"),XPDDR
+10 SET DIC=$GET(^DIC(XPDFIL,0,"GL"))
SET XREF=+$PIECE(XREF,";",3)
+11 ;check if file, XPDFIL, exist at this site
+12 IF $PIECE($GET(^DIC(XPDFIL,0)),U)'=XPDFILNM
DO BMES^XPDUTL(" File "_XPDFIL_" is not "_XPDFILNM_", nothing installed.")
QUIT
+13 ;check if XPDFIL has already been installed
+14 IF $PIECE(^XPD(9.7,XPDA,"KRN",XPDFIL,0),U,2)
DO BMES^XPDUTL(" "_XPDFILNM_" already installed.")
QUIT
+15 DO BMES^XPDUTL(" Installing "_XPDFILNM)
DO SETTOT^XPDID(XPDFIL)
+16 ;do File Pre-install action, continue if ok
+17 ;XPDFL= 0-send,1-delete,2-link,3-merge,4-attach,5-disable
+18 ;loops thru the entries for this file
+19 IF '$$ACT(FPRE)
SET OLDA=0
FOR
SET OLDA=$ORDER(^XTMP("XPDI",XPDA,"KRN",XPDFIL,OLDA))
if 'OLDA
QUIT
SET XPDFL=+$GET(^(OLDA,-1))
SET OLDA(0)=^(0)
Begin DoDot:2
+20 ;if we are doing VT graphic display, set counter
+21 IF $DATA(XPDIDVT)
SET XPDIDCNT=XPDIDCNT+1
if '(XPDIDCNT#XPDIDMOD)
DO UPDATE^XPDID(XPDIDCNT)
+22 ;quit if disable or attach (4 or 5). Attach will be processed under the parent menu.
+23 if XPDFL>3
QUIT
+24 ;if FM file, need to set screening logic
+25 IF XPDFIL<.44
SET %=$SELECT(XPDFIL'=.403:4,1:8)
SET DIC("S")="I $P(^(0),U,"_%_")="_$PIECE(OLDA(0),U,%)
+26 ;if deleting at site and a template, reset the lookup value and DIC("S")
+27 IF XPDFL=1
IF XPDFIL<.44
SET %=$PIECE(OLDA(0),U)
SET $PIECE(OLDA(0),U)=$PIECE(%," FILE #")
SET DIC("S")="I $P(^(0),U,"_$SELECT(XPDFIL'=.403:4,1:8)_")="_+$PIECE(%," FILE #",2)
+28 ;XPDNEW=1 if entry is new, laygo
+29 SET X=$PIECE(OLDA(0),U)
SET Y=$$DIC(XPDFIL,X,$GET(DIC("S")),XPDFL,.XPDDR)
if 'Y
QUIT
SET DA=+Y
SET XPDNEW=$PIECE(Y,U,3)
+30 ;if deleting then save and process after FPOS
+31 IF XPDFL=1
SET ^TMP($JOB,"XPDEL",DA)=""
QUIT
+32 ;do Entries Pre-install action
+33 if $$ACT(EPRE)
QUIT
+34 ;merges the data, if you want the data deleted before the merge, you must
+35 ;do it in the Entry Pre-install node, EPRE.
+36 MERGE @(DIC_DA_")")=^XTMP("XPDI",XPDA,"KRN",XPDFIL,OLDA)
+37 ;kill the flag node from the live data node
+38 KILL @(DIC_DA_",-1)")
if $$ACT(EPOS)
QUIT
+39 ;XREF is flag to x-ref file after each entry, it is set in file 9.6
+40 IF XREF
NEW DIK
SET DIK=DIC
DO IX1^DIK
End DoDot:2
+41 ;do File Post Install Action
+42 SET %=$$ACT(FPOS)
+43 ;process the deleting of entries, FDEL should allow the passing of all entries
+44 ;to delete in array ^TMP($J,"XPDEL",DA)=""
+45 IF $LENGTH(FDEL)
IF $DATA(^TMP($JOB,"XPDEL"))
SET %="^TMP($J,""XPDEL"")"
DO @FDEL
+46 ;complete check point
+47 SET %=$$XPCOM(XPDFIL)
+48 KILL ^TMP($JOB,"XPDEL")
+49 IF $DATA(XPDIDVT)
DO UPDATE^XPDID(XPDIDCNT)
End DoDot:1
+50 QUIT
FIA ;
+1 ;XPFIL2=file is new^DD screen failed^data already exists^change file name^don't add data; 1=yes, 0=no
+2 NEW XPGR,XPFIL,XPFILO,XPFIL2,Z
+3 SET XPFIL=0
SET XPGR=$NAME(^XTMP("XPDI",XPDA))
+4 FOR
SET XPFIL=$ORDER(^XTMP("XPDI",XPDA,"FIA",XPFIL))
if 'XPFIL
QUIT
SET XPFILO=^(XPFIL,0,1)
SET XPFIL2=^(2)
Begin DoDot:1
+5 ;if we are doing VT graphic display, set counter
+6 IF $DATA(XPDIDVT)
SET XPDIDCNT=XPDIDCNT+1
if '(XPDIDCNT#XPDIDMOD)
DO UPDATE^XPDID(XPDIDCNT)
+7 ;file is new, alway install DD
+8 if XPFIL2
SET $PIECE(XPFILO,U)="y"
SET $PIECE(^XTMP("XPDI",XPDA,"FIA",XPFIL,0,1),U)="y"
+9 ;DD failed screen
+10 IF $PIECE(XPFIL2,U,2)
Begin DoDot:2
+11 NEW XPD
+12 SET XPD(1)=" "
SET XPD(2)="Data Dictionary for File #"_XPFIL_" not installed, failed DD screen."
+13 DO MES^XPDUTL(.XPD)
SET %=$$XPCOM(XPFIL)
End DoDot:2
QUIT
+14 ;if udate DD question = no & file is not new update checkpoint
+15 IF $PIECE(XPFILO,U)'="y"&'XPFIL2
SET %=$$XPCOM(XPFIL)
+16 ;check if XPFIL has already been installed
+17 if $PIECE(^XPD(9.7,XPDA,4,XPFIL,0),U,2)
QUIT
+18 ;update file name
+19 IF $PIECE(XPFIL2,U,4)
Begin DoDot:2
+20 NEW DIE,DR,DA
+21 SET DR=".01////"_^XTMP("XPDI",XPDA,"FIA",XPFIL)
SET DA=XPFIL
SET DIE=1
+22 DO ^DIE
End DoDot:2
+23 ;move DD and check for errors
+24 DO DDIN^DIFROMS(XPFIL,"","",XPGR)
if $DATA(DIERR)
DO DIERR("** ERROR IN DATA DICTIONARY FOR FILE # "_XPFIL_" **")
+25 SET %=$$XPCOM(XPFIL)
End DoDot:1
+26 IF $DATA(XPDIDVT)
DO UPDATE^XPDID(XPDIDTOT)
+27 QUIT
DAT ;
+1 NEW XPGR,XPFIL,XPFILO,XPFIL2,Z
+2 SET XPFIL=0
SET XPGR=$NAME(^XTMP("XPDI",XPDA))
+3 ;DO if they are sending data
+4 FOR
SET XPFIL=$ORDER(^XTMP("XPDI",XPDA,"FIA",XPFIL))
if 'XPFIL
QUIT
SET XPFILO=^(XPFIL,0,1)
SET XPFIL2=^(2)
if $PIECE(XPFILO,U,7)="y"
Begin DoDot:1
+5 ;DD failed screen or answer no to adding data or 'Add if new' & data already exists or file doesn't exist
+6 IF $PIECE(XPFIL2,U,2)!$PIECE(XPFIL2,U,5)!($PIECE(XPFILO,U,8)="a"&$PIECE(XPFIL2,U,3))!'$DATA(^DIC(XPFIL,0))
SET %=$$XPCOM(XPFIL,1)
QUIT
+7 ;check if XPFIL has already been installed or no data to input
+8 if $PIECE(^XPD(9.7,XPDA,4,XPFIL,0),U,3)!('$DATA(^XTMP("XPDI",XPDA,"DATA",XPFIL)))
QUIT
+9 ;bring in Data and check for error
+10 DO DATAIN^DIFROMS(XPFIL,"","",XPGR)
if $DATA(DIERR)
DO DIERR("** ERROR IN DATA FOR FILE # "_XPFIL_" **")
+11 SET %=$$XPCOM(XPFIL,1)
End DoDot:1
+12 DO RP^DIFROMSR("","",XPGR)
if $DATA(DIERR)
DO DIERR("** ERROR IN POINTER RESOLUTION OF DATA **")
+13 QUIT
+14 ;record error
DIERR(XPDI) NEW XPD
+1 DO MSG^DIALOG("AE",.XPD)
if '$DATA(XPD)
QUIT
+2 DO BMES^XPDUTL(XPDI)
DO MES^XPDUTL(.XPD)
+3 QUIT
+4 ;
+5 ;XPDF=file #,XPDX=input X,XPDS=screen logic, XPDACT=action, XPDDR(field)=indirect string; add required identifiers
DIC(XPDF,XPDX,XPDS,XPDACT,XPDDR) ;
+1 NEW DIC,DIERR,XPD,XPDN
+2 SET DIC=$GET(^DIC(XPDF,0,"GL"))
+3 DO FIND^DIC(XPDF,"","","XQf",XPDX,5,"",$GET(XPDS),"","XPD")
+4 ;one or more matches, just return first one
+5 IF $GET(XPD(0))
if XPD(0)>1
Begin DoDot:1
+6 SET %(1)=$PIECE($GET(^DIC(XPDF,0)),U)_" "_XPDX_" is Duplicated,"
SET %(2)=" only ien #"_XPD(1)_" was updated."
+7 DO MES^XPDUTL(.%)
End DoDot:1
QUIT XPD(1)
+8 ;no match and action=(delete,link, or attach), don't write message if deleting
+9 IF $GET(XPDACT)
IF XPDACT'=3
if XPDACT'=1
DO BMES^XPDUTL(" "_$PIECE($GET(^DIC(XPDF,0)),U)_" "_XPDX_" Lookup failed, NO Action Taken.")
QUIT 0
+10 ;add a new entry
+11 NEW DLAYGO,X,Y,Z
+12 ;S X=XPDX,DIC(0)="LX",DLAYGO=XPDF,DIC("S")=$G(XPDS)
+13 ;D ^DIC
+14 ;I Y<0 D BMES^XPDUTL(" "_$P($G(^DIC(XPDF,0)),U)_" "_XPDX_" **Couldn't Add to file**") Q 0
+15 ;Q Y
+16 ;code can't be used until UPDATE^DIE allows the creation of a record
+17 ;without required identifiers
+18 KILL XPD,DIERR
+19 SET XPD(XPDF,"+1,",.01)=XPDX
SET XPDDR=0
+20 ;XPDDR is an array that contains field # and indirection code to add an identifier field during a new record
+21 ;XPDDR(1)="$P(OLDA(0),U,2)" for file 19, add Menu Text #1
+22 FOR
SET XPDDR=$ORDER(XPDDR(XPDDR))
if 'XPDDR
QUIT
SET Z="XPD(XPDF,""+1,"",XPDDR)="_XPDDR(XPDDR)
SET @Z
+23 ;p672
DO UPDATE^DIE("E","XPD","XPDN")
+24 ;couldn't add as new
+25 IF $DATA(DIERR)
DO DIERR(" "_$PIECE($GET(^DIC(XPDF,0)),U)_" "_XPDX_" **Couldn't Add to file**")
QUIT 0
+26 IF '$GET(XPDN(1))
DO BMES^XPDUTL(" "_$PIECE($GET(^DIC(XPDF,0)),U)_" "_XPDX_" **Couldn't Add to file**")
QUIT 0
+27 ;"^^1" indicates new entry, same as Y in DIC call p672
+28 QUIT XPDN(1)_"^^1"
+29 ;
ACT(%) ;execute action, returns 0 to continue, 1 to quit
+1 ;user can count on DIC,DA,XPDFIL,OLDA,XPDNM,XPDFL,X,Y being around
+2 ;XPDNEW is set only for Entry Pre-install action
+3 if %=""
QUIT 0
+4 NEW %1,%2,%3,%4,%5
+5 SET %1=$GET(DIC)
SET %2=$GET(DA)
SET %3=$GET(OLDA)
SET %4=$PIECE(%,U)
SET %5=$PIECE($PIECE(%,U,2),"(")
+6 NEW DA,DIC,DIOVRD,OLDA,EPOS,EPRE,FPOS,FPRE,ORD,XREF,XPDQUIT
+7 SET DIC=%1
SET DA=%2
SET OLDA=%3
+8 ;check that % is callable
+9 Begin DoDot:1
+10 ; no tag
if %5=""
SET %5=$PIECE(%4,"(")
SET %4=""
SET %="^"_%
+11 ;tag^routine don't exists
IF %4]""
if $TEXT(@%4^@%5)=""
SET %5=""
QUIT
+12 ;routine don't exists
if $TEXT(^@%5)=""
SET %5=""
+13 QUIT
End DoDot:1
IF %5=""
QUIT 0
+14 ;XPDQUIT=quit this level of processing
+15 DO @%
QUIT $DATA(XPDQUIT)
+16 QUIT
+17 ;
XPCOM(XPDF,XPDJ) ;complete checkpoint for file XPDF
+1 ;XPDJ=1 only for data of fm files, it set the field to edit = 2
+2 NEW XPD,%,Z
+3 SET %=$$NOW^XLFDT
SET Z=$SELECT(XPDCP="KRN":9.715,1:9.714)
SET XPD(Z,XPDF_","_XPDA_",",$GET(XPDJ)+1)=%
+4 ;if Build Components, save the ORDer number
+5 if Z=9.715
SET XPD(Z,XPDF_","_XPDA_",",2)=ORD
+6 DO FILE^DIE("","XPD")
+7 QUIT 1
+8 ;
XPCK(XPDI) ;setup check points for file type XPDI
+1 ;XPDI="KRN"-components, ="FIA"-files
+2 NEW %,XPD,XPDF,XPDJ,XPDK
+3 ;XPDK=sub DD
+4 SET XPDK=$SELECT(XPDI="KRN":9.715,1:9.714)
SET XPDF=0
+5 FOR %=1:1
SET XPDF=$ORDER(^XTMP("XPDI",XPDA,XPDI,XPDF))
if 'XPDF
QUIT
SET (XPDJ(%),XPD(XPDK,"+"_%_","_XPDA_",",.01))=XPDF
+6 if $DATA(XPD)>9
DO UPDATE^DIE("","XPD","XPDJ")
+7 QUIT
