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