- 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 Jan 18, 2025@03:05:48 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