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

XPDV.m

Go to the documentation of this file.
  1. XPDV ;SFISC/RSD - Verify Build ;10/15/2008
  1. ;;8.0;KERNEL;**30,44,58,108,511,525,539,547,755**;Jul 10, 1995;Build 6
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;checks that everything is ready to do a build
  1. ;XPDA=build ien, loop thru all nodes in ^XPD(9.6,XPDA and verify data
  1. EN ;check a build
  1. N DA,ERR,FGR,TYPE,XPDFILE,XPDOLDA,Y0,Y2 K ^TMP($J)
  1. S Y0=$G(^XPD(9.6,XPDA,0)),TYPE=$P(Y0,U,3)
  1. I $P(Y0,U,2)="" W !,"No Package File Link"
  1. I '$P(Y0,U,2) W !,$P(Y0,U,2)," in Package File Link field is free text, not a pointer"
  1. I $P(Y0,U,2),'$D(^DIC(9.4,$P(Y0,U,2),0)) W !,$P(Y0,U,2)," in PACKAGE File ** NOT FOUND **",*7
  1. ;type is global package goto CONT
  1. G CONT:TYPE=2
  1. I TYPE=1 S Y0=$$MULT(XPDA) G DONE
  1. S XPDFILE=0
  1. ;check DD being sent
  1. F S XPDFILE=$O(^XPD(9.6,XPDA,4,XPDFILE)) Q:'XPDFILE D
  1. .Q:$$FILE(XPDFILE)=""
  1. .S Y0=0,Y2=$G(^XPD(9.6,XPDA,4,XPDFILE,222))
  1. .Q:'$$DATA(XPDFILE,Y2)
  1. .F S Y0=$O(^XPD(9.6,XPDA,4,XPDFILE,2,Y0)) Q:'Y0 D
  1. ..I '$D(^DD(Y0)) W !," SubDD #",Y0," in File #",XPDFILE," ** NOT FOUND **" Q
  1. ..S XPDOLDA=0
  1. ..;check fields being sent for partial DD
  1. ..F S XPDOLDA=$O(^XPD(9.6,XPDA,4,XPDFILE,2,Y0,1,XPDOLDA)) Q:'XPDOLDA D
  1. ...I '$D(^DD(Y0,XPDOLDA)) W !,"Field #",XPDOLDA," in SubDD #",Y0," in File #",XPDFILE," ** NOT FOUND **" Q
  1. ;
  1. ;build components files
  1. S XPDFILE=0
  1. F S XPDFILE=$O(^XPD(9.6,XPDA,"KRN",XPDFILE)) Q:'XPDFILE D
  1. .;if file doesn't exist, save in ^TMP and deleted at end
  1. .S FGR=$$FILE(XPDFILE),XPDOLDA=0 I FGR="" S ^TMP($J,XPDFILE)="" Q
  1. .F S XPDOLDA=$O(^XPD(9.6,XPDA,"KRN",XPDFILE,"NM",XPDOLDA)) Q:'XPDOLDA S Y0=$G(^(XPDOLDA,0)) D
  1. ..;check action, quit if deleting at site
  1. ..Q:$P(Y0,U,3)=1
  1. ..;check that entry exist
  1. ..S:$P(Y0,U,2) $P(Y0,U)=$P(Y0," FILE #") S DA=$$ENTRY(Y0)
  1. ..Q:'$P(Y0,U,3)!($P(Y0,U,3)#2)
  1. ..;if attach check that parent is sent, if link check that child is sent
  1. ..Q:'$$MENU(XPDFILE,DA,$P(Y0,U,3))
  1. ;check Install Questions
  1. S XPDOLDA=0
  1. F S XPDOLDA=$O(^XPD(9.6,XPDA,"QUES",XPDOLDA)) Q:'XPDOLDA S Y0=$G(^(XPDOLDA,0)),Y2=$G(^(1)) D
  1. .I $P(Y0,U)="" W !,"Zero node doesn't exist for INSTALL QUESTION #",XPDOLDA Q
  1. .I Y2="" W !,"DIR(0) field is not defined for INSTALL QUESTION ",$P(Y0,U)
  1. I $O(^XPD(9.6,XPDA,"GLO",0)) W !,"Package cannot contain Globals, Files, & Components."
  1. ;check for PRE & POST routines
  1. F DA="INI","INIT" S Y0=$G(^XPD(9.6,XPDA,DA)),ERR="" I Y0]"",'$$RTN(Y0,.ERR) W !,"Routine ",Y0,ERR
  1. CONT ;
  1. ;check Environment Check routine
  1. S Y0=$G(^XPD(9.6,XPDA,"PRE")),ERR="" I Y0]"",'$$RTN(Y0,.ERR) W !,"Routine ",Y0,ERR
  1. I TYPE=2 S Y0=$$GLOPKG(XPDA)
  1. DONE I $O(^TMP($J,0)) D
  1. .N DA,DIK,DIR,DIRUT,Y
  1. .S DIR(0)="Y",DIR("A")="Do you want to remove the missing Files",DIR("B")="NO"
  1. .S DIR("?")="Yes means that the missing Files will be removed and you can transport this Build"
  1. .D ^DIR Q:'Y!$D(DIRUT)
  1. .S DIK="^XPD(9.6,"_XPDA_",""KRN"",",DA(1)=XPDA,DA=0 F S DA=$O(^TMP($J,DA)) Q:'DA D ^DIK
  1. W !!," ** DONE **"
  1. Q
  1. GLOPKG(X) ;GLOBAL PACKAGE
  1. ;returns 1 if ok, 0 if failed
  1. N I,J,Y,Z S Z=1
  1. I $O(^XPD(9.6,X,4,0)) W !,"GLOBAL PACKAGE cannot contain Files" S Z=0
  1. S I=0 F S I=$O(^XPD(9.6,X,"KRN",I)) Q:'I D:$O(^(I,"NM",0))
  1. .W !,"GLOBAL PACKAGE cannot contain ",$P(^DIC(I,0),U) S Z=0
  1. I $O(^XPD(9.6,X,"QUES",0)) W !,"GLOBAL PACKAGE cannot contain Install Questions" S Z=0
  1. I $G(^XPD(9.6,X,"INI"))]"" W !,"GLOBAL PACKAGE cannot have a Pre-Install Routine" S Z=0
  1. ;I $G(^XPD(9.6,X,"INIT"))]"" W !,"GLOBAL PACKAGE cannot have a Post-Install Routine" S Z=0
  1. S I=0 F J=0:1 S I=$O(^XPD(9.6,X,"GLO",I)) Q:'I S Y=$G(^(I,0)) D
  1. .I $P(Y,U)]"",'$D(@("^"_$P(Y,U))) W !,"Global ",Y," doesn't exist." S Z=0
  1. I 'J W !,"No Globals to transport" S Z=0
  1. Q Z
  1. ;
  1. QUES(X) ;X=.01 of INSTALL QUESTION multiple
  1. ;returns ien or 0 if failed
  1. N Y
  1. S Y=+$O(^XPD(9.6,XPDA,"QUES","B",X,0))
  1. I '$D(^XPD(9.6,XPDA,"QUES",Y,0)) W !,"Zero node doesn't exist for INSTALL QUESTION ",X Q 0
  1. I '$D(^XPD(9.6,XPDA,"QUES",Y,1)) W !,"DIR(0) field is not defined for INSTALL QUESTION ",X Q 0
  1. Q Y
  1. ;
  1. FILE(X) ;check file # X
  1. ;returns global ref or "" if failed
  1. N %,Y
  1. S Y=$G(^DIC(X,0,"GL"))
  1. I Y="" W !," File #",X," ** NOT FOUND **" Q ""
  1. S %=$E(Y,$L(Y)),X=$E(Y,1,$L(Y)-1)_$S(%="(":"",1:")")
  1. Q X
  1. ;
  1. ;Z only contains the file # for Fileman templates and forms
  1. ;XPDFILE=file #,FGR=file global ref
  1. ENTRY(Z) ;check entry, Z=name^file
  1. ;returns ien or 0 if failed
  1. N F,X,Y
  1. ;check for X, name, in "B" x-ref of file.
  1. S X=$P(Z,U),Y=0 F S Y=$O(@FGR@("B",X,Y)) D Q:X=""
  1. .I 'Y W:'$G(XPDIB) !?3,X," in ",$P(^DIC(XPDFILE,0),U)," File ** NOT FOUND **",*7 S X="" Q ;p755 XPDIB=don't write if doing Backup
  1. .;if Y is in x-ref but node doesn't exist, quit and try another
  1. .;if this is a fileman template, the file associated with it is piece 2 of Z
  1. .;if Form file check piece 8 else 4
  1. .Q:'$D(@FGR@(Y,0)) I $P(Z,U,2) S F=^(0) S:$P(Z,U,2)=$P(F,U,(4+(4*(FGR["DIST")))) X="" Q
  1. .;if it is routine file,9.8, check that routine exist
  1. .I XPDFILE=9.8 S F="" D I F]"" S X="",Y=0 Q
  1. .. I $G(XPDIB) S:$T(^@X)="" F=" DOESN'T EXIST!!" Q ;p755 XPDIB=Backup, just check routine exists
  1. .. I '$$RTN(X,.F) W !,"Routine ",X,F Q
  1. .. Q
  1. .;if this is not a fileman template or routine we found Y
  1. .S X="" Q
  1. Q +Y
  1. ;
  1. DATA(F,Y) ;
  1. ;return 1 if ok or 0 if failed
  1. I $P(Y,U,3)="p",$P(Y,U,7)="y" W !,"You can only send Data with a Full Data Dictionary,",!,"** File #",F," cannot be Sent **" Q 0
  1. Q 1
  1. ;
  1. RTN(X,MSG) ;verify tag^routine
  1. ;INPUT: X=[tag^]routine, MSG(passed by reference)
  1. ;OUTPUT: returns 1=exists, 0=doesn't; MSG=error message
  1. N L,S,T,R
  1. S MSG=""
  1. I X["(" S X=$P(X,"(") ;Handle tag^rtn(param) rwf
  1. I X["^" S T=$P(X,"^"),R=$P(X,"^",2)
  1. E S T="",R=X
  1. I (R'?1A.E) S MSG=" Name violates the SAC!!" Q 0
  1. I $T(^@R)="" S MSG=" DOESN'T EXIST!!" Q 0
  1. ;2nd line must begin with "[label] ;;n[n.nn];A[APN];"
  1. S S=$T(+2^@R) D I MSG]"" Q 0
  1. .I $L($P(S," ")) S L=$P(S," "),S=$P(S,L,2,99) I L'?1U.7UN S MSG=" 2nd line violates the SAC!!" Q
  1. .I S'?.1" ;;"1.2N.1".".2N1";"1.APN1";".E S MSG=" 2nd line violates the SAC!!"
  1. ;if no tag or tag^routine exists, then return 1
  1. Q:T="" 1 Q:$T(@T^@R)]"" 1
  1. S MSG=" Tag DOESN'T EXIST!!" Q 0
  1. ;
  1. MULT(DA) ;multi-package
  1. ;returns 1 if ok or 0 if failed
  1. N I,J,X,Y,Z
  1. S I=0,Z=1
  1. F J=0:1 S I=$O(^XPD(9.6,DA,10,I)) Q:'I S X=$P($G(^(I,0)),U),Y=0 D
  1. .S:X]"" Y=$O(^XPD(9.6,"B",X,0))
  1. .I Y,$D(^XPD(9.6,Y,0)) Q
  1. .W !,"Package ",X," doesn't exist." S Z=0
  1. I 'J W !,"No Packages to transport" S Z=0
  1. Q Z
  1. ;Y=action (2=link or 4=attach)
  1. ;returns 1 if ok or 0 if failed
  1. Q:'X 0
  1. N I,J,GR,Z
  1. S GR=$S(F=19:"^DIC(19)",1:"^ORD(101)"),(I,Z)=0
  1. ;link, check that at least 1 menu item or subscribers was sent
  1. I Y=2 D
  1. . F S I=$O(@GR@(X,10,"B",I)) Q:'I S J=$P($G(@GR@(I,0)),U) I J]"",$D(^XPD(9.6,XPDA,"KRN",F,"NM","B",J)) S Z=1 Q
  1. . ;if it didn't find menu item and this is a protocol, check the subscribers, 775
  1. . I 'Z,F=101 F S I=$O(@GR@(X,775,"B",I)) Q:'I S J=$P($G(@GR@(I,0)),U) I J]"",$D(^XPD(9.6,XPDA,"KRN",F,"NM","B",J)) S Z=1 Q
  1. ;attach, check that the parent was sent
  1. I Y=4 F S I=$O(@GR@("AD",X,I)) Q:'I S J=$P($G(@GR@(I,0)),U) I J]"",$D(^XPD(9.6,XPDA,"KRN",F,"NM","B",J)) S Z=1 Q
  1. D:'Z
  1. .W !,$S(F=19:"Option ",1:"Protocol "),$P($G(@GR@(X,0)),U)," has an Action of "
  1. .W:Y=2 "'USE AS LINK FOR MENU ITEMS' and no 'Menu Items' were sent."
  1. .W:Y=4 "'ATTACH TO MENU' and a 'Parent Menu' wasn't sent."
  1. Q Z