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