XPDET ;SFISC/RSD - Input transforms & help for file 9.6 & 9.7 ;10/19/2002
;;8.0;KERNEL;**15,39,41,44,51,58,66,137,229,393,539,672,713**;Jul 10, 1995;Build 15
;Per VHA Directive 2004-038, this routine should not be modified.
Q
INPUTB(X) ;input transform for NAME in BUILD file
;X=user input
;name must be unique
I $L(X)>50!($L(X)<3)!$D(^XPD(9.6,"B",X)) K X Q
I X["*" K:$P(X,"*",2,3)'?1.2N1"."1.2N.1(1"V",1"T").2N1"*"1.6N.1"b" X Q ;p713
S %=$L(X," ") I %<2 K X Q
S %=$P(X," ",%) K:%'?1.2N1"."1.2N.1(1"V",1"T",1"B").2N.1"b" X ;p172 add "b"
Q
INPUTE(X) ;input transform for ENTRIES in KERNEL FILES multiple
;X=user input
N D,DD,DIC,DICR,DIX,DIY,DS,DO,XPDLK,Y
S XPDLK=$$GR(D1)
I XPDLK=""!X["*" K X Q
S DIC(0)="QEMZ",DIC=XPDLK
S:D1=9.8 DIC("S")="I $T(^@$P(^(0),U))]"""""
D ^DIC K:Y<0 X Q:'$D(X)
S X=Y(0,0)
;check that this doesn't exist already
I $D(^XPD(9.6,D0,"KRN",D1,"NM","B",X)) K X Q
;if fm file, change X to contain file # of template
I D1<.404 S X=$$TX(X,$P(Y(0),U,$S(D1=.403:8,1:4)))
;POLICY FUNCTION file #1.62, entries below 1000 belong to FileMan
I D1=1.62 K:Y<1000 X
Q
GLOBALE(X) ;input transform for GLOBAL multiple .01 field in file 9.6
I $L(X)>30!($L(X)<2) K X Q
I X["(",X'[")" K X Q
;change ' back to " for subscripts, they were changed in the Pre-Lookup node of the DD, 7.5. This was done to trick FM, which doesn't allow " in .01 fields
S X=$TR(X,"'","""")
I '$D(@("^"_X)) K X
Q
INPUTMB(X) ;input transform for field 10 and 11 in file 9.6
;X=user input
N D,DD,DIC,DICR,DIX,DIY,DS,DO,Y
;can't select a global or multi package or itself (D0)
S DIC(0)="QEMZ",DIC="^XPD(9.6,",DIC("S")="I '$P(^(0),U,3),Y'="_D0
D ^DIC K:Y<0 X Q:'$D(X)
S X=Y(0,0)
Q
LOOKE(X) ;special lookup for ENTRIES in KERNEL FILES multiple
Q:X'?1.E1"*"
N %,XPD,XPDI,XPDIC,XPDF,XPDLK,XPDX,Y
S XPDLK=$$GR(D1),XPDIC=DIC,XPDF=D1
I XPDLK="" K X Q
G:$E(X)="-" DEL
S XPDX=$P(X,"*"),XPDI("IEN")=0
D LIST^DIC(D1,"","@;.01","","*",.XPDI,XPDX,"","I $$SCR^XPDET(Y)")
I '$G(^TMP("DILIST",$J,0)) K X Q
K ^TMP("XPDX",$J)
;loop thru list from lister and file using UPDATE^DIE
F XPDI=1:1 S X=$G(^TMP("DILIST",$J,"ID",XPDI,.01)) Q:X="" D
.;FM template will have file # associated with the template name
.S:D1<.404 %=^TMP("DILIST",$J,2,XPDI)_",",X=$$TX(X,$$GET1^DIQ(D1,%,$$TF(D1),"I"))
.;Lock Template, #8993, need to remove leading "^" if there
.S:D1=8993&($E(X)="^") X=$P(X,"^",2)
.S Y="+"_XPDI_","_D1_","_D0_",",^TMP("XPDX",$J,9.68,Y,.01)=X,^(.03)=0
I $D(^TMP("XPDX",$J)) D UPDATE^DIE("","^TMP(""XPDX"",$J)","^TMP(""XPD"",$J)")
;if in Screenman then call MLOAD to update screen
I $D(DDS),$D(^TMP("XPD",$J)) D MLOAD^DDSUTL("^TMP(""XPD"",$J)")
S X=""
K ^TMP("XPDX",$J),^TMP("XPD",$J)
Q
DEL ;delete using wild card
I X'?1"-"1.E1"*" K X Q
S X=$E(X,2,$L(X)-1),XPDX=X S:$L(X) XPDI("IEN")=0
D LIST^DIC(9.68,","_D1_","_D0_",","","","*",.XPDI,XPDX)
I '$G(^TMP("DILIST",$J,0)) K X Q
N DIK,DA,D2
S DIK=XPDIC,DA(1)=D1,DA(2)=D0
F XPDI=1:1 S (DA,D2)=$G(^TMP("DILIST",$J,2,XPDI)) Q:'DA D
.D ^DIK
I $D(DDS) D MDEL^DDSUTL("^TMP(""DILIST"",$J,2)")
S X=""
K ^TMP("DILIST",$J)
Q
HELP ;executable help of ENTRIES in KERNEL FILE multiple
N D,DIC,DIE,DIX,DIY,DO,DZ,DS,X,Y
;file 9.8 is routine file, check that routine exists
S DIC=$$GR(D1),DIC(0)="M",X="??" Q:DIC="" S:D1=9.8 DIC("S")="I $T(^@$P(^(0),U))]"""""
D ^DIC Q
;
HELPO ;executable help of INSTALL ORDER in KERNEL FILES multiple
N Y
W !,"Numbers in use: ORDER FILE#" S Y=0
F S Y=$O(^XPD(9.6,D0,"KRN","AC",Y)) Q:'Y W !,?18,$J(Y,2),?28,$O(^(Y,0))
W ! Q
;
HELPMB ;executable help of fields 10 & 11 in file 9.6
N D,DIC,DIE,DIX,DIY,DO,DZ,DS,X,Y
S DIC="^XPD(9.6,",DIC(0)="M",X="??",DIC("S")="I '$P(^(0),U,3),Y'="_D0
D ^DIC Q
;
SCRA(Y) ;screen of ACTION field in ENTRIES multiple in KERNEL FILES multiple, Y=action
;Y=0 - send, 1 - delete, 2 - link, 3 - merge, 4 - attach, 5 - disable
;all entries can send to site
;D0=Build ien, D1=File #, D2=record #
Q:'Y 1
;.5=function file, can't delete, all others can
I Y=1 Q (D1'=.5)
;then rest of code check if it is a Option, Protocal, and Policy and can have MENU ITEMS
Q:D1'=19&(D1'=101)&(D1'=1.6) 0
;only Options and Protocol can disable, Policy can't
I Y=5 Q (D1'=1.6)
N FGR,X,XPDF,XPDT,XPDY,XPDZ
;get X=name, FGR=global reference, XPDF=file #
S XPDY=Y,XPDF=D1,X=$P(^XPD(9.6,D0,"KRN",D1,"NM",D2,0),U),FGR=$$FILE^XPDV(D1)
Q:X="" 0
;X=ien of protocol, option, or policy
S X=+$O(@FGR@("B",X,0)) Q:'X 0
;get type
S XPDT=$S(XPDF=1.6:$P($G(@FGR@(X,0)),U,2),1:$P($G(@FGR@(X,0)),U,4))
;Policy; Type=Rule only send & delete
I XPDF=1.6,XPDT="R" Q (XPDY<2)
;Policy; Type=Set or Policy, if Members then okay, else allow only send & delete
I XPDF=1.6,XPDT'="R" Q:$O(@FGR@(X,10,0)) 1 Q (XPDY<2)
;all Options and Protocols, except Event Drivers, can be attached
I XPDY=4 Q '(XPDF=101&(XPDT="E"))
;Protocol and Type is Subscriber can't do anything else
I XPDF=101,XPDT="S" Q 0
;if it has SUBSCRIBERS, node 775 then ok
I $O(@FGR@(X,775,0)) Q 1
;if type is menu,potocol,protocol menu,limited,extended,window suite
I "MOQLXZ"[XPDT Q 1
;if it has ITEMs, node 10 then ok
I $O(@FGR@(X,10,0)) Q 1
Q 0
;
;only Fileman templates need to know what file they are associated with.
;this value is also triggered to field .02 in the DD.
TX(X,Y) ;X=template name, Y=file #
Q X_" FILE #"_Y
;
TF(F) ;F=file, return field of file# for templates
Q $S(F>.403:"",F<.403:4,1:7)
;
GR(X) Q $G(^DIC(X,0,"GL"))
;
;screens checks that X is not already in the ENTRIES multiple
SCR(Y) ;screen logic for ENTRIES multiple in file 9.6
N %,X,Z
S Z=^(0),X=$P(Z,U)
;FM files are less than .44
I XPDF<.44 D Q:X="" 0
.S %=$S(XPDF=.403:$P(Z,U,8),1:$P(Z,U,4)),X=X_" FILE #"_%
.S:XPDF'=.403&($P(Z,U,8)>2) %=0 S:'% X=""
;routine must exist and must be type 'R'
I XPDF=9.8 Q:$T(^@X)=""!($P(Z,U,2)'="R") 0
Q '$D(@(XPDIC_"""B"",X)"))
;
;screen checks that X is not in the exclude list, XPDN(0)
SCR1(Y) ;screen logic for exclude list
N %,X
;if name X is in the exclude list, XPDN(0,X), then fail
S Y(0)=^(0),X=$P(Y(0),U) Q:$D(XPDN(0,X)) 0
;check if X is refered in the namespace by check the subscript
;before X, if sub exist and $P(X,sub)="" then it is part of the
;namespace, fail and return 0
S %=$O(XPDN(0,X),-1) I $L(%) Q:$P(X,%)="" 0
Q $$SCR(.Y)
;
;screen on PACKAGE LINK field in file 9.6,
PCK(Y) ;check Package File name, Y=ien in package file
N %,Y,Z
S Z=^(0)
;DA is undef when you are adding a new Build without a version number
Q:'$D(^XPD(9.6,+$G(DA),0)) 1
S Y=$L($P(Z,U)),%=$P(^XPD(9.6,DA,0),U),%=$$PKG^XPDUTL(%)
Q $P(Z,U)=$E(%,1,Y)!($P(Z,U,2)=%)
VOLE(X) ;input transform for VOLUME SET multiple in INSTALL file
;X=user input
N D,DD,DIC,DICR,DIX,DIY,DO,DS,XPD,Y,%
;(0;11)=SIGNON/PRODUCTION
S DIC(0)="QEMZ",DIC="^%ZIS(14.5,",DIC("S")="I $P(^(0),U,11)"
D ^DIC K:Y<0 X Q:'$D(X)
S X=Y(0,0)
Q
VOLH ;executable help for VOLUME SET multiple in INSTALL file
N D,DD,DIC,DIE,DIX,DIY,DO,DS,DZ,X,Y,%
S X="??",DIC(0)="QEMZ",DIC="^%ZIS(14.5,",DIC("S")="I $P(^(0),U,11)"
D ^DIC
Q
ID97 ;identifier for Install file
N XPDET,XPD,XPD0,XPD1,XPD2,XPD9
S XPD0=$G(^(0)),XPD1=$G(^(1)),XPD2=$G(^(2)),XPD9=$P(XPD0,U,9),XPD="" Q:XPD9=""
D
.;Loaded, get DATE LOADED
.I 'XPD9 S XPD=$$FMTE^XLFDT($P(XPD0,U,3),2) Q
.Q:XPD9>4
.;Started, get INSTALL START TIME
.I XPD9=2 S XPD=$$FMTE^XLFDT($P(XPD1,U),2) Q
.;Completed or De-Installed, get INSTALL COMPLETE TIME
.I XPD9>2 S XPD=$$FMTE^XLFDT($P(XPD1,U,3),2) Q
.;Queued, get QUEUED TASK NUMBER
.I XPD9=1 S XPD="#"_$P(XPD0,U,6) Q
;S XPDET(1)=" "_$$EXTERNAL^DILFD(9.7,.02,"",XPD9)_" "_XPD,XPDET(1,"F")="?0"
S XPDET(1)=" "_XPD,XPDET(1,"F")="?0"
S:XPD2]"" XPDET(2)="=> "_$E(XPD2,1,70),XPDET(2,"F")="!?5"
D EN^DDIOL(.XPDET)
Q
;not being used right now,
DEL97(Y) ;delete access to file 9.7, 0-can't delete, 1-can
N %
S %=$P(^XPD(9.7,Y,0),U,9)
Q $S(%=3:1,%=2:0,$D(^XPD(9.7,"ASP",Y,1,Y)):1,1:0)
;
PAR964 ;Clear other fields if file is partial. Called from within form
D PUT^DDSVAL(DIE,.DA,222.7,"n","","I") ;Send data NO
D PUT^DDSVAL(DIE,.DA,222.5,"","","I") ;Resolve pointer
D PUT^DDSVAL(DIE,.DA,222.8,"","","I") ;Sites Data
D PUT^DDSVAL(DIE,.DA,222.9,"n","","I") ;User Override
D PUT^DDSVAL(DIE,.DA,224,"","","I") ;Data Screen
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXPDET 8462 printed Dec 13, 2024@02:03:26 Page 2
XPDET ;SFISC/RSD - Input transforms & help for file 9.6 & 9.7 ;10/19/2002
+1 ;;8.0;KERNEL;**15,39,41,44,51,58,66,137,229,393,539,672,713**;Jul 10, 1995;Build 15
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
INPUTB(X) ;input transform for NAME in BUILD file
+1 ;X=user input
+2 ;name must be unique
+3 IF $LENGTH(X)>50!($LENGTH(X)<3)!$DATA(^XPD(9.6,"B",X))
KILL X
QUIT
+4 ;p713
IF X["*"
if $PIECE(X,"*",2,3)'?1.2N1"."1.2N.1(1"V",1"T").2N1"*"1.6N.1"b"
KILL X
QUIT
+5 SET %=$LENGTH(X," ")
IF %<2
KILL X
QUIT
+6 ;p172 add "b"
SET %=$PIECE(X," ",%)
if %'?1.2N1"."1.2N.1(1"V",1"T",1"B").2N.1"b"
KILL X
+7 QUIT
INPUTE(X) ;input transform for ENTRIES in KERNEL FILES multiple
+1 ;X=user input
+2 NEW D,DD,DIC,DICR,DIX,DIY,DS,DO,XPDLK,Y
+3 SET XPDLK=$$GR(D1)
+4 IF XPDLK=""!X["*"
KILL X
QUIT
+5 SET DIC(0)="QEMZ"
SET DIC=XPDLK
+6 if D1=9.8
SET DIC("S")="I $T(^@$P(^(0),U))]"""""
+7 DO ^DIC
if Y<0
KILL X
if '$DATA(X)
QUIT
+8 SET X=Y(0,0)
+9 ;check that this doesn't exist already
+10 IF $DATA(^XPD(9.6,D0,"KRN",D1,"NM","B",X))
KILL X
QUIT
+11 ;if fm file, change X to contain file # of template
+12 IF D1<.404
SET X=$$TX(X,$PIECE(Y(0),U,$SELECT(D1=.403:8,1:4)))
+13 ;POLICY FUNCTION file #1.62, entries below 1000 belong to FileMan
+14 IF D1=1.62
if Y<1000
KILL X
+15 QUIT
GLOBALE(X) ;input transform for GLOBAL multiple .01 field in file 9.6
+1 IF $LENGTH(X)>30!($LENGTH(X)<2)
KILL X
QUIT
+2 IF X["("
IF X'[")"
KILL X
QUIT
+3 ;change ' back to " for subscripts, they were changed in the Pre-Lookup node of the DD, 7.5. This was done to trick FM, which doesn't allow " in .01 fields
+4 SET X=$TRANSLATE(X,"'","""")
+5 IF '$DATA(@("^"_X))
KILL X
+6 QUIT
INPUTMB(X) ;input transform for field 10 and 11 in file 9.6
+1 ;X=user input
+2 NEW D,DD,DIC,DICR,DIX,DIY,DS,DO,Y
+3 ;can't select a global or multi package or itself (D0)
+4 SET DIC(0)="QEMZ"
SET DIC="^XPD(9.6,"
SET DIC("S")="I '$P(^(0),U,3),Y'="_D0
+5 DO ^DIC
if Y<0
KILL X
if '$DATA(X)
QUIT
+6 SET X=Y(0,0)
+7 QUIT
LOOKE(X) ;special lookup for ENTRIES in KERNEL FILES multiple
+1 if X'?1.E1"*"
QUIT
+2 NEW %,XPD,XPDI,XPDIC,XPDF,XPDLK,XPDX,Y
+3 SET XPDLK=$$GR(D1)
SET XPDIC=DIC
SET XPDF=D1
+4 IF XPDLK=""
KILL X
QUIT
+5 if $EXTRACT(X)="-"
GOTO DEL
+6 SET XPDX=$PIECE(X,"*")
SET XPDI("IEN")=0
+7 DO LIST^DIC(D1,"","@;.01","","*",.XPDI,XPDX,"","I $$SCR^XPDET(Y)")
+8 IF '$GET(^TMP("DILIST",$JOB,0))
KILL X
QUIT
+9 KILL ^TMP("XPDX",$JOB)
+10 ;loop thru list from lister and file using UPDATE^DIE
+11 FOR XPDI=1:1
SET X=$GET(^TMP("DILIST",$JOB,"ID",XPDI,.01))
if X=""
QUIT
Begin DoDot:1
+12 ;FM template will have file # associated with the template name
+13 if D1<.404
SET %=^TMP("DILIST",$JOB,2,XPDI)_","
SET X=$$TX(X,$$GET1^DIQ(D1,%,$$TF(D1),"I"))
+14 ;Lock Template, #8993, need to remove leading "^" if there
+15 if D1=8993&($EXTRACT(X)="^")
SET X=$PIECE(X,"^",2)
+16 SET Y="+"_XPDI_","_D1_","_D0_","
SET ^TMP("XPDX",$JOB,9.68,Y,.01)=X
SET ^(.03)=0
End DoDot:1
+17 IF $DATA(^TMP("XPDX",$JOB))
DO UPDATE^DIE("","^TMP(""XPDX"",$J)","^TMP(""XPD"",$J)")
+18 ;if in Screenman then call MLOAD to update screen
+19 IF $DATA(DDS)
IF $DATA(^TMP("XPD",$JOB))
DO MLOAD^DDSUTL("^TMP(""XPD"",$J)")
+20 SET X=""
+21 KILL ^TMP("XPDX",$JOB),^TMP("XPD",$JOB)
+22 QUIT
DEL ;delete using wild card
+1 IF X'?1"-"1.E1"*"
KILL X
QUIT
+2 SET X=$EXTRACT(X,2,$LENGTH(X)-1)
SET XPDX=X
if $LENGTH(X)
SET XPDI("IEN")=0
+3 DO LIST^DIC(9.68,","_D1_","_D0_",","","","*",.XPDI,XPDX)
+4 IF '$GET(^TMP("DILIST",$JOB,0))
KILL X
QUIT
+5 NEW DIK,DA,D2
+6 SET DIK=XPDIC
SET DA(1)=D1
SET DA(2)=D0
+7 FOR XPDI=1:1
SET (DA,D2)=$GET(^TMP("DILIST",$JOB,2,XPDI))
if 'DA
QUIT
Begin DoDot:1
+8 DO ^DIK
End DoDot:1
+9 IF $DATA(DDS)
DO MDEL^DDSUTL("^TMP(""DILIST"",$J,2)")
+10 SET X=""
+11 KILL ^TMP("DILIST",$JOB)
+12 QUIT
HELP ;executable help of ENTRIES in KERNEL FILE multiple
+1 NEW D,DIC,DIE,DIX,DIY,DO,DZ,DS,X,Y
+2 ;file 9.8 is routine file, check that routine exists
+3 SET DIC=$$GR(D1)
SET DIC(0)="M"
SET X="??"
if DIC=""
QUIT
if D1=9.8
SET DIC("S")="I $T(^@$P(^(0),U))]"""""
+4 DO ^DIC
QUIT
+5 ;
HELPO ;executable help of INSTALL ORDER in KERNEL FILES multiple
+1 NEW Y
+2 WRITE !,"Numbers in use: ORDER FILE#"
SET Y=0
+3 FOR
SET Y=$ORDER(^XPD(9.6,D0,"KRN","AC",Y))
if 'Y
QUIT
WRITE !,?18,$JUSTIFY(Y,2),?28,$ORDER(^(Y,0))
+4 WRITE !
QUIT
+5 ;
HELPMB ;executable help of fields 10 & 11 in file 9.6
+1 NEW D,DIC,DIE,DIX,DIY,DO,DZ,DS,X,Y
+2 SET DIC="^XPD(9.6,"
SET DIC(0)="M"
SET X="??"
SET DIC("S")="I '$P(^(0),U,3),Y'="_D0
+3 DO ^DIC
QUIT
+4 ;
SCRA(Y) ;screen of ACTION field in ENTRIES multiple in KERNEL FILES multiple, Y=action
+1 ;Y=0 - send, 1 - delete, 2 - link, 3 - merge, 4 - attach, 5 - disable
+2 ;all entries can send to site
+3 ;D0=Build ien, D1=File #, D2=record #
+4 if 'Y
QUIT 1
+5 ;.5=function file, can't delete, all others can
+6 IF Y=1
QUIT (D1'=.5)
+7 ;then rest of code check if it is a Option, Protocal, and Policy and can have MENU ITEMS
+8 if D1'=19&(D1'=101)&(D1'=1.6)
QUIT 0
+9 ;only Options and Protocol can disable, Policy can't
+10 IF Y=5
QUIT (D1'=1.6)
+11 NEW FGR,X,XPDF,XPDT,XPDY,XPDZ
+12 ;get X=name, FGR=global reference, XPDF=file #
+13 SET XPDY=Y
SET XPDF=D1
SET X=$PIECE(^XPD(9.6,D0,"KRN",D1,"NM",D2,0),U)
SET FGR=$$FILE^XPDV(D1)
+14 if X=""
QUIT 0
+15 ;X=ien of protocol, option, or policy
+16 SET X=+$ORDER(@FGR@("B",X,0))
if 'X
QUIT 0
+17 ;get type
+18 SET XPDT=$SELECT(XPDF=1.6:$PIECE($GET(@FGR@(X,0)),U,2),1:$PIECE($GET(@FGR@(X,0)),U,4))
+19 ;Policy; Type=Rule only send & delete
+20 IF XPDF=1.6
IF XPDT="R"
QUIT (XPDY<2)
+21 ;Policy; Type=Set or Policy, if Members then okay, else allow only send & delete
+22 IF XPDF=1.6
IF XPDT'="R"
if $ORDER(@FGR@(X,10,0))
QUIT 1
QUIT (XPDY<2)
+23 ;all Options and Protocols, except Event Drivers, can be attached
+24 IF XPDY=4
QUIT '(XPDF=101&(XPDT="E"))
+25 ;Protocol and Type is Subscriber can't do anything else
+26 IF XPDF=101
IF XPDT="S"
QUIT 0
+27 ;if it has SUBSCRIBERS, node 775 then ok
+28 IF $ORDER(@FGR@(X,775,0))
QUIT 1
+29 ;if type is menu,potocol,protocol menu,limited,extended,window suite
+30 IF "MOQLXZ"[XPDT
QUIT 1
+31 ;if it has ITEMs, node 10 then ok
+32 IF $ORDER(@FGR@(X,10,0))
QUIT 1
+33 QUIT 0
+34 ;
+35 ;only Fileman templates need to know what file they are associated with.
+36 ;this value is also triggered to field .02 in the DD.
TX(X,Y) ;X=template name, Y=file #
+1 QUIT X_" FILE #"_Y
+2 ;
TF(F) ;F=file, return field of file# for templates
+1 QUIT $SELECT(F>.403:"",F<.403:4,1:7)
+2 ;
GR(X) QUIT $GET(^DIC(X,0,"GL"))
+1 ;
+2 ;screens checks that X is not already in the ENTRIES multiple
SCR(Y) ;screen logic for ENTRIES multiple in file 9.6
+1 NEW %,X,Z
+2 SET Z=^(0)
SET X=$PIECE(Z,U)
+3 ;FM files are less than .44
+4 IF XPDF<.44
Begin DoDot:1
+5 SET %=$SELECT(XPDF=.403:$PIECE(Z,U,8),1:$PIECE(Z,U,4))
SET X=X_" FILE #"_%
+6 if XPDF'=.403&($PIECE(Z,U,8)>2)
SET %=0
if '%
SET X=""
End DoDot:1
if X=""
QUIT 0
+7 ;routine must exist and must be type 'R'
+8 IF XPDF=9.8
if $TEXT(^@X)=""!($PIECE(Z,U,2)'="R")
QUIT 0
+9 QUIT '$DATA(@(XPDIC_"""B"",X)"))
+10 ;
+11 ;screen checks that X is not in the exclude list, XPDN(0)
SCR1(Y) ;screen logic for exclude list
+1 NEW %,X
+2 ;if name X is in the exclude list, XPDN(0,X), then fail
+3 SET Y(0)=^(0)
SET X=$PIECE(Y(0),U)
if $DATA(XPDN(0,X))
QUIT 0
+4 ;check if X is refered in the namespace by check the subscript
+5 ;before X, if sub exist and $P(X,sub)="" then it is part of the
+6 ;namespace, fail and return 0
+7 SET %=$ORDER(XPDN(0,X),-1)
IF $LENGTH(%)
if $PIECE(X,%)=""
QUIT 0
+8 QUIT $$SCR(.Y)
+9 ;
+10 ;screen on PACKAGE LINK field in file 9.6,
PCK(Y) ;check Package File name, Y=ien in package file
+1 NEW %,Y,Z
+2 SET Z=^(0)
+3 ;DA is undef when you are adding a new Build without a version number
+4 if '$DATA(^XPD(9.6,+$GET(DA),0))
QUIT 1
+5 SET Y=$LENGTH($PIECE(Z,U))
SET %=$PIECE(^XPD(9.6,DA,0),U)
SET %=$$PKG^XPDUTL(%)
+6 QUIT $PIECE(Z,U)=$EXTRACT(%,1,Y)!($PIECE(Z,U,2)=%)
VOLE(X) ;input transform for VOLUME SET multiple in INSTALL file
+1 ;X=user input
+2 NEW D,DD,DIC,DICR,DIX,DIY,DO,DS,XPD,Y,%
+3 ;(0;11)=SIGNON/PRODUCTION
+4 SET DIC(0)="QEMZ"
SET DIC="^%ZIS(14.5,"
SET DIC("S")="I $P(^(0),U,11)"
+5 DO ^DIC
if Y<0
KILL X
if '$DATA(X)
QUIT
+6 SET X=Y(0,0)
+7 QUIT
VOLH ;executable help for VOLUME SET multiple in INSTALL file
+1 NEW D,DD,DIC,DIE,DIX,DIY,DO,DS,DZ,X,Y,%
+2 SET X="??"
SET DIC(0)="QEMZ"
SET DIC="^%ZIS(14.5,"
SET DIC("S")="I $P(^(0),U,11)"
+3 DO ^DIC
+4 QUIT
ID97 ;identifier for Install file
+1 NEW XPDET,XPD,XPD0,XPD1,XPD2,XPD9
+2 SET XPD0=$GET(^(0))
SET XPD1=$GET(^(1))
SET XPD2=$GET(^(2))
SET XPD9=$PIECE(XPD0,U,9)
SET XPD=""
if XPD9=""
QUIT
+3 Begin DoDot:1
+4 ;Loaded, get DATE LOADED
+5 IF 'XPD9
SET XPD=$$FMTE^XLFDT($PIECE(XPD0,U,3),2)
QUIT
+6 if XPD9>4
QUIT
+7 ;Started, get INSTALL START TIME
+8 IF XPD9=2
SET XPD=$$FMTE^XLFDT($PIECE(XPD1,U),2)
QUIT
+9 ;Completed or De-Installed, get INSTALL COMPLETE TIME
+10 IF XPD9>2
SET XPD=$$FMTE^XLFDT($PIECE(XPD1,U,3),2)
QUIT
+11 ;Queued, get QUEUED TASK NUMBER
+12 IF XPD9=1
SET XPD="#"_$PIECE(XPD0,U,6)
QUIT
End DoDot:1
+13 ;S XPDET(1)=" "_$$EXTERNAL^DILFD(9.7,.02,"",XPD9)_" "_XPD,XPDET(1,"F")="?0"
+14 SET XPDET(1)=" "_XPD
SET XPDET(1,"F")="?0"
+15 if XPD2]""
SET XPDET(2)="=> "_$EXTRACT(XPD2,1,70)
SET XPDET(2,"F")="!?5"
+16 DO EN^DDIOL(.XPDET)
+17 QUIT
+18 ;not being used right now,
DEL97(Y) ;delete access to file 9.7, 0-can't delete, 1-can
+1 NEW %
+2 SET %=$PIECE(^XPD(9.7,Y,0),U,9)
+3 QUIT $SELECT(%=3:1,%=2:0,$DATA(^XPD(9.7,"ASP",Y,1,Y)):1,1:0)
+4 ;
PAR964 ;Clear other fields if file is partial. Called from within form
+1 ;Send data NO
DO PUT^DDSVAL(DIE,.DA,222.7,"n","","I")
+2 ;Resolve pointer
DO PUT^DDSVAL(DIE,.DA,222.5,"","","I")
+3 ;Sites Data
DO PUT^DDSVAL(DIE,.DA,222.8,"","","I")
+4 ;User Override
DO PUT^DDSVAL(DIE,.DA,222.9,"n","","I")
+5 ;Data Screen
DO PUT^DDSVAL(DIE,.DA,224,"","","I")
+6 QUIT
+7 ;
