Released XU*8*539 SEQ #439 Extracted from mail message **KIDS**:XU*8.0*539^ **INSTALL NAME** XU*8.0*539 "BLD",1284,0) XU*8.0*539^KERNEL^0^3100303^y "BLD",1284,1,0) ^^3^3^3100128^^ "BLD",1284,1,1,0) Please see the patch description on FORUM, in the National Patch Module. "BLD",1284,1,2,0) "BLD",1284,1,3,0) "BLD",1284,4,0) ^9.64PA^9.6^1 "BLD",1284,4,9.6,0) 9.6 "BLD",1284,4,9.6,2,0) ^9.641^9.68^1 "BLD",1284,4,9.6,2,9.68,0) ENTRIES (sub-file) "BLD",1284,4,9.6,2,9.68,1,0) ^9.6411^.03^1 "BLD",1284,4,9.6,2,9.68,1,.03,0) ACTION "BLD",1284,4,9.6,222) y^n^p^^^^n^^n "BLD",1284,4,9.6,224) "BLD",1284,4,"APDD",9.6,9.68) "BLD",1284,4,"APDD",9.6,9.68,.03) "BLD",1284,4,"B",9.6,9.6) "BLD",1284,6.3) 11 "BLD",1284,"ABPKG") n "BLD",1284,"KRN",0) ^9.67PA^9002226^21 "BLD",1284,"KRN",.4,0) .4 "BLD",1284,"KRN",.401,0) .401 "BLD",1284,"KRN",.402,0) .402 "BLD",1284,"KRN",.403,0) .403 "BLD",1284,"KRN",.5,0) .5 "BLD",1284,"KRN",.84,0) .84 "BLD",1284,"KRN",3.6,0) 3.6 "BLD",1284,"KRN",3.8,0) 3.8 "BLD",1284,"KRN",9.2,0) 9.2 "BLD",1284,"KRN",9.8,0) 9.8 "BLD",1284,"KRN",9.8,"NM",0) ^9.68A^10^10 "BLD",1284,"KRN",9.8,"NM",1,0) XPDET^^0^B32656156 "BLD",1284,"KRN",9.8,"NM",2,0) XPDT^^0^B81300874 "BLD",1284,"KRN",9.8,"NM",3,0) XPDCOM^^0^B18549454 "BLD",1284,"KRN",9.8,"NM",4,0) XPDCOMF^^0^B109672448 "BLD",1284,"KRN",9.8,"NM",5,0) XPDE^^0^B45567472 "BLD",1284,"KRN",9.8,"NM",6,0) XPDIA1^^0^B72722233 "BLD",1284,"KRN",9.8,"NM",7,0) XPDTA^^0^B30171675 "BLD",1284,"KRN",9.8,"NM",8,0) XPDV^^0^B41656792 "BLD",1284,"KRN",9.8,"NM",9,0) XPDIST^^0^B15156441 "BLD",1284,"KRN",9.8,"NM",10,0) XPDB1^^0^B1360586 "BLD",1284,"KRN",9.8,"NM","B","XPDB1",10) "BLD",1284,"KRN",9.8,"NM","B","XPDCOM",3) "BLD",1284,"KRN",9.8,"NM","B","XPDCOMF",4) "BLD",1284,"KRN",9.8,"NM","B","XPDE",5) "BLD",1284,"KRN",9.8,"NM","B","XPDET",1) "BLD",1284,"KRN",9.8,"NM","B","XPDIA1",6) "BLD",1284,"KRN",9.8,"NM","B","XPDIST",9) "BLD",1284,"KRN",9.8,"NM","B","XPDT",2) "BLD",1284,"KRN",9.8,"NM","B","XPDTA",7) "BLD",1284,"KRN",9.8,"NM","B","XPDV",8) "BLD",1284,"KRN",19,0) 19 "BLD",1284,"KRN",19,"NM",0) ^9.68A^2^2 "BLD",1284,"KRN",19,"NM",1,0) XPD EDIT INSTALL^^0 "BLD",1284,"KRN",19,"NM",2,0) XPD UTILITY^^2 "BLD",1284,"KRN",19,"NM","B","XPD EDIT INSTALL",1) "BLD",1284,"KRN",19,"NM","B","XPD UTILITY",2) "BLD",1284,"KRN",19.1,0) 19.1 "BLD",1284,"KRN",101,0) 101 "BLD",1284,"KRN",409.61,0) 409.61 "BLD",1284,"KRN",771,0) 771 "BLD",1284,"KRN",779.2,0) 779.2 "BLD",1284,"KRN",870,0) 870 "BLD",1284,"KRN",8989.51,0) 8989.51 "BLD",1284,"KRN",8989.52,0) 8989.52 "BLD",1284,"KRN",8994,0) 8994 "BLD",1284,"KRN",9002226,0) 9002226 "BLD",1284,"KRN","B",.4,.4) "BLD",1284,"KRN","B",.401,.401) "BLD",1284,"KRN","B",.402,.402) "BLD",1284,"KRN","B",.403,.403) "BLD",1284,"KRN","B",.5,.5) "BLD",1284,"KRN","B",.84,.84) "BLD",1284,"KRN","B",3.6,3.6) "BLD",1284,"KRN","B",3.8,3.8) "BLD",1284,"KRN","B",9.2,9.2) "BLD",1284,"KRN","B",9.8,9.8) "BLD",1284,"KRN","B",19,19) "BLD",1284,"KRN","B",19.1,19.1) "BLD",1284,"KRN","B",101,101) "BLD",1284,"KRN","B",409.61,409.61) "BLD",1284,"KRN","B",771,771) "BLD",1284,"KRN","B",779.2,779.2) "BLD",1284,"KRN","B",870,870) "BLD",1284,"KRN","B",8989.51,8989.51) "BLD",1284,"KRN","B",8989.52,8989.52) "BLD",1284,"KRN","B",8994,8994) "BLD",1284,"KRN","B",9002226,9002226) "BLD",1284,"QDEF") ^^^^NO^^^^YES^^NO "BLD",1284,"QUES",0) ^9.62^^ "BLD",1284,"REQB",0) ^9.611^8^6 "BLD",1284,"REQB",3,0) DI*22.0*160^2 "BLD",1284,"REQB",4,0) XU*8.0*525^2 "BLD",1284,"REQB",5,0) XU*8.0*507^2 "BLD",1284,"REQB",6,0) XU*8.0*506^2 "BLD",1284,"REQB",7,0) XU*8.0*498^2 "BLD",1284,"REQB",8,0) XU*8.0*486^2 "BLD",1284,"REQB","B","DI*22.0*160",3) "BLD",1284,"REQB","B","XU*8.0*486",8) "BLD",1284,"REQB","B","XU*8.0*498",7) "BLD",1284,"REQB","B","XU*8.0*506",6) "BLD",1284,"REQB","B","XU*8.0*507",5) "BLD",1284,"REQB","B","XU*8.0*525",4) "FIA",9.6) BUILD "FIA",9.6,0) ^XPD(9.6, "FIA",9.6,0,0) 9.6I "FIA",9.6,0,1) y^n^p^^^^n^^n "FIA",9.6,0,10) "FIA",9.6,0,11) "FIA",9.6,0,"RLRO") "FIA",9.6,0,"VR") 8.0^XU "FIA",9.6,9.6) 1 "FIA",9.6,9.68) 1 "FIA",9.6,9.68,.03) "KRN",19,243,-1) 2^2 "KRN",19,243,0) XPD UTILITY^Utilities^^M^.5^^^^^^^2 "KRN",19,243,10,0) ^19.01IP^10^10 "KRN",19,243,10,10,0) 1512^^12 "KRN",19,243,10,10,"^") XPD EDIT INSTALL "KRN",19,243,"U") UTILITIES "KRN",19,1512,-1) 0^1 "KRN",19,1512,0) XPD EDIT INSTALL^Edit Install Status^^E^^^^^^^^KIDS "KRN",19,1512,1,0) ^19.06^5^5^3100126^^^ "KRN",19,1512,1,1,0) This option lets you edit the STATUS and the INSTALL COMPLETE TIME "KRN",19,1512,1,2,0) fields in the INSTALL file. "KRN",19,1512,1,3,0) "KRN",19,1512,1,4,0) "KRN",19,1512,1,5,0) "KRN",19,1512,30) XPD(9.7, "KRN",19,1512,31) AEMQ "KRN",19,1512,50) XPD(9.7, "KRN",19,1512,51) .02;17 "KRN",19,1512,"U") EDIT INSTALL STATUS "MBREQ") 0 "ORD",18,19) 19;18;;;OPT^XPDTA;OPTF1^XPDIA;OPTE1^XPDIA;OPTF2^XPDIA;;OPTDEL^XPDIA "ORD",18,19,0) OPTION "PKG",3,-1) 1^1 "PKG",3,0) KERNEL^XU^SIGN-ON, SECURITY, MENU DRIVER, DEVICES, TASKMAN^ "PKG",3,20,0) ^9.402P^^0 "PKG",3,22,0) ^9.49I^1^1 "PKG",3,22,1,0) 8.0^3090706^3090706^6 "PKG",3,22,1,"PAH",1,0) 539^3100303 "PKG",3,22,1,"PAH",1,1,0) ^^3^3^3100303 "PKG",3,22,1,"PAH",1,1,1,0) Please see the patch description on FORUM, in the National Patch Module. "PKG",3,22,1,"PAH",1,1,2,0) "PKG",3,22,1,"PAH",1,1,3,0) "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") NO "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") YES "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") NO "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 10 "RTN","XPDB1") 0^10^B1360586^B1328479 "RTN","XPDB1",1,0) XPDB1 ;SFISC/RSD - Build utilities ;10/15/2008 "RTN","XPDB1",2,0) ;;8.0;KERNEL;**108,539**;Jul 10, 1995;Build 11 "RTN","XPDB1",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","XPDB1",4,0) Q "RTN","XPDB1",5,0) LOOK() ;Lookup BUILD, build XPDT from build file "RTN","XPDB1",6,0) ;XPDT(seq #)=ien^name "RTN","XPDB1",7,0) ;XPDT("DA",ien)=seq # "RTN","XPDB1",8,0) N XPD,XPDA,XPDI,XPDNM,X,Y,Z K XPDT "RTN","XPDB1",9,0) S XPDT=0 "RTN","XPDB1",10,0) S XPDA=$$DIC^XPDE("AEMQZ",,1) Q:'XPDA 0 "RTN","XPDB1",11,0) S XPDI=$P(Y(0),U) "RTN","XPDB1",12,0) ;if type is Global Package, set DIRUT if there is other packages "RTN","XPDB1",13,0) I $P(Y(0),U,3)=2 W " GLOBAL PACKAGE" "RTN","XPDB1",14,0) D PCK(XPDA,XPDI) "RTN","XPDB1",15,0) G:$P(Y(0),U,3)'=1 LKX "RTN","XPDB1",16,0) ;multi-package "RTN","XPDB1",17,0) W " (Multi-Package)" S X=0 "RTN","XPDB1",18,0) F S X=$O(^XPD(9.6,XPDA,10,X)) Q:'X S Z=$P($G(^(X,0)),U) D:Z]"" "RTN","XPDB1",19,0) .N XPDA,X "RTN","XPDB1",20,0) .W !?3,Z S XPDA=$O(^XPD(9.6,"B",Z,0)) "RTN","XPDB1",21,0) .I 'XPDA W " **Can't find definition in Build file**" Q "RTN","XPDB1",22,0) .I $D(XPDT("DA",XPDA)) W " already listed" Q "RTN","XPDB1",23,0) .D PCK(XPDA,Z) "RTN","XPDB1",24,0) LKX Q XPDA "RTN","XPDB1",25,0) ; "RTN","XPDB1",26,0) PCK(XPDA,XPDNM) ;XPDA=Build ien, XPDNM=Build name "RTN","XPDB1",27,0) N Y "RTN","XPDB1",28,0) S XPDT=XPDT+1,XPDT(XPDT)=XPDA_U_XPDNM,XPDT("DA",XPDA)=XPDT "RTN","XPDB1",29,0) Q "RTN","XPDB1",30,0) ; "RTN","XPDCOM") 0^3^B18549454^B16563839 "RTN","XPDCOM",1,0) XPDCOM ;SFISC/RSD - Compare Transport Global ;08/14/2008 "RTN","XPDCOM",2,0) ;;8.0;KERNEL;**21,58,108,124,393,506,539**;Jul 10, 1995;Build 11 "RTN","XPDCOM",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","XPDCOM",4,0) EN1 ;compare to current system "RTN","XPDCOM",5,0) N DIC,DIR,DIRUT,DITCPT,DTOUT,DUOUT,POP,XPD,XPDA,XPDC,XPDNM,XPDT,XPDST,XPDUL,Y,Z,%ZIS "RTN","XPDCOM",6,0) S XPDST=$$LOOK^XPDI1("I '$P(^(0),U,9),$D(^XTMP(""XPDI"",Y))",1) Q:XPDST'>0 "RTN","XPDCOM",7,0) S DIR(0)="SO^1:Full Comparison;2:Second line of Routines only;3:Routines only;4:Old style Routine compare",DIR("A")="Type of Compare",DIR("?")="Enter the type of comparison." ;rwf "RTN","XPDCOM",8,0) D ^DIR Q:Y=""!$D(DTOUT)!$D(DUOUT) "RTN","XPDCOM",9,0) S XPDC=Y,Y="JOB^XPDCOM",Z="Transport Global Compare",XPD("XPDNM")="",XPD("XPDC")="",XPD("XPDT(")="" "RTN","XPDCOM",10,0) D EN^XUTMDEVQ(Y,Z,.XPD) "RTN","XPDCOM",11,0) Q "RTN","XPDCOM",12,0) ; "RTN","XPDCOM",13,0) JOB ;Loop thru XPDT "RTN","XPDCOM",14,0) N XPDIT "RTN","XPDCOM",15,0) F XPDIT=0:0 S XPDIT=$O(XPDT(XPDIT)) Q:XPDIT'>0 D COM(+XPDT(XPDIT)) "RTN","XPDCOM",16,0) Q "RTN","XPDCOM",17,0) ; "RTN","XPDCOM",18,0) COM(XPDA) ;XPDA=ien of package in ^XTMP("XPDI" "RTN","XPDCOM",19,0) Q:'$D(^XTMP("XPDI",$G(XPDA))) "RTN","XPDCOM",20,0) S:$D(XPDT("DA",XPDA)) XPDNM=$P(XPDT(+XPDT("DA",XPDA)),U,2) "RTN","XPDCOM",21,0) D HDR,COMR,EN^XPDCOMG:XPDC=1 "RTN","XPDCOM",22,0) W !! "RTN","XPDCOM",23,0) Q "RTN","XPDCOM",24,0) ; "RTN","XPDCOM",25,0) COMR ;compare routines "RTN","XPDCOM",26,0) N DL,NAME,RM,XL,XPDI,X,XL,Y,YL,XPDHEAD "RTN","XPDCOM",27,0) S (NAME,XPDI)="",RM=IOM/2-8 "RTN","XPDCOM",28,0) F S XPDI=$O(^XTMP("XPDI",XPDA,"RTN",XPDI)) Q:XPDI="" S X=+$G(^(XPDI)) D "RTN","XPDCOM",29,0) .S NAME=" Routine: "_XPDI,XPDHEAD=0 "RTN","XPDCOM",30,0) .I X W:X=1 !!,"*DELETE*",NAME,! Q "RTN","XPDCOM",31,0) .S X=XPDI X ^%ZOSF("TEST") E W !!,"*ADD*",NAME,! Q "RTN","XPDCOM",32,0) .;check 2nd line only "RTN","XPDCOM",33,0) .I XPDC=2 D Q "RTN","XPDCOM",34,0) ..S XL(2)=$G(^XTMP("XPDI",XPDA,"RTN",XPDI,2,0)),YL(2)=$T(+2^@XPDI) "RTN","XPDCOM",35,0) ..D EN^XPDCOML("XL","YL",NAME) "RTN","XPDCOM",36,0) ..W:'XPDHEAD !,?IOM-$L(NAME)\2,NAME "RTN","XPDCOM",37,0) ..W ! "RTN","XPDCOM",38,0) ..I XL(2)=YL(2)!(XL(2)'["**") Q "RTN","XPDCOM",39,0) ..;check patch string "RTN","XPDCOM",40,0) ..S X=$P(XL(2),"**",2),XL=$L(X,","),Y=$P(YL(2),"**",2),YL=$L(Y,",") "RTN","XPDCOM",41,0) ..Q:X=Y "RTN","XPDCOM",42,0) ..;incoming has more patches than system, remove last patch and check if the same "RTN","XPDCOM",43,0) ..I XL>YL W:$P(X,",",1,(XL-1))'=Y "*** WARNING, you are missing one or more Patches ***",! Q "RTN","XPDCOM",44,0) ..;incoming has less patches "RTN","XPDCOM",45,0) ..I YL>XL W "*** WARNING, your routine has more patches than the incoming routine ***",! Q "RTN","XPDCOM",46,0) ..;incoming has same number of patches, check if they are the same "RTN","XPDCOM",47,0) ..I XL=YL,X'=Y W "*** WARNING, your routine has different patches than the incoming routine ***",! Q "RTN","XPDCOM",48,0) ..Q "RTN","XPDCOM",49,0) .;get number of lines in rouitine, XL "RTN","XPDCOM",50,0) .F X=1:1 Q:'$D(^XTMP("XPDI",XPDA,"RTN",XPDI,X)) "RTN","XPDCOM",51,0) .S XL=X-1 "RTN","XPDCOM",52,0) .K ^TMP($J,XPDI) "RTN","XPDCOM",53,0) .F X=1:1 S Y=$T(+X^@XPDI) Q:Y="" S ^TMP($J,XPDI,X,0)=Y "RTN","XPDCOM",54,0) .S DL=X-1 ;number of line in routine on disk "RTN","XPDCOM",55,0) .D EN^XPDCOML($NA(^XTMP("XPDI",XPDA,"RTN",XPDI)),$NA(^TMP($J,XPDI)),NAME):XPDC<4,COMP:XPDC=4 "RTN","XPDCOM",56,0) .W:'XPDHEAD !,?IOM-$L(NAME)\2,NAME "RTN","XPDCOM",57,0) .W ! K ^TMP($J,XPDI) "RTN","XPDCOM",58,0) .Q "RTN","XPDCOM",59,0) I NAME="" W ?RM,"No Routines" "RTN","XPDCOM",60,0) Q "RTN","XPDCOM",61,0) ; "RTN","XPDCOM",62,0) COMP ;taken from XMPC routine "RTN","XPDCOM",63,0) N D1,DI,I,J,K,NL,X1,XI,Y1 "RTN","XPDCOM",64,0) S (XI,DI)=0,NL=5,XPDHEAD=1 "RTN","XPDCOM",65,0) W !,?IOM-$L(NAME)\2,NAME "RTN","XPDCOM",66,0) ;check each line in the incoming routine,X1, against the routine on disk,D1 "RTN","XPDCOM",67,0) F S XI=XI+1,DI=DI+1 Q:XI>XL!(DI>DL) D:^XTMP("XPDI",XPDA,"RTN",XPDI,XI,0)'=^TMP($J,XPDI,DI,0) "RTN","XPDCOM",68,0) .S X1=^XTMP("XPDI",XPDA,"RTN",XPDI,XI,0),Y1=0 "RTN","XPDCOM",69,0) .;if lines are not the same, look ahead five lines in D1 "RTN","XPDCOM",70,0) .F I=DI:1:$S(DI+NLXL&(DI<(DL+1)) F I=DI:1:DL D WP(^TMP($J,XPDI,I,0),2) "RTN","XPDCOM",81,0) I DI>DL&(XI<(XL+1)) F I=XI:1:XL D WP(^XTMP("XPDI",XPDA,"RTN",XPDI,I,0),1) "RTN","XPDCOM",82,0) Q "RTN","XPDCOM",83,0) WP(X,Y) ; "RTN","XPDCOM",84,0) W !,"* "_$P("ADD^DEL^OLD^NEW",U,Y)_" * ",X "RTN","XPDCOM",85,0) Q "RTN","XPDCOM",86,0) ; "RTN","XPDCOM",87,0) HDR ; "RTN","XPDCOM",88,0) S $P(XPDUL,"-",80)="" "RTN","XPDCOM",89,0) W @IOF,!,"Compare KIDS package ",XPDNM," to current site (Disk)" "RTN","XPDCOM",90,0) W !,"Site: ",$$KSP^XUPARAM("WHERE") "RTN","XPDCOM",91,0) D GETENV^%ZOSV W " UCI: ",$P(Y,U),",",$P(Y,U,2)," ",?IOM/2+2,$$FMTE^XLFDT($$NOW^XLFDT()),! "RTN","XPDCOM",92,0) I XPDC>1 W:XPDC=2 "2nd Line of " W "Routines Only",! "RTN","XPDCOM",93,0) W ?3,"KIDS",?IOM\2+3,"Disk",! "RTN","XPDCOM",94,0) W XPDUL,! "RTN","XPDCOM",95,0) Q "RTN","XPDCOMF") 0^4^B109672448^B79333923 "RTN","XPDCOMF",1,0) XPDCOMF ;SFISC/GFT/MSC - COMPARE FILES ;08/14/2008 "RTN","XPDCOMF",2,0) ;;8.0;KERNEL;**506,539**;Jul 10, 1995;Build 11 "RTN","XPDCOMF",3,0) ; Per VHA Directive 2004-038, this routine should not be modified. "RTN","XPDCOMF",4,0) ;DI1 & DI2 are left & right roots "RTN","XPDCOMF",5,0) ;DIFLAG[1 -->compare files [2-->compare entries ["L" --> IGNORE EXTRA ENTRIES ON RIGHT SIDE "RTN","XPDCOMF",6,0) ;DITCPT is array of TITLES, called by reference "RTN","XPDCOMF",7,0) EN(DI1,DI2,DIDD,DIFLAG,DITCPT) ; "RTN","XPDCOMF",8,0) N I '$D(@DI1),'$D(@DI2) Q "RTN","XPDCOMF",9,0) N I,DIR,DID,W,DIL,DIN1,DIN2,DIV1,DIV2,DIGL,DIDDN,DIO,DIV,DIT,DIOX,DITM,DIN,D1,D2 "RTN","XPDCOMF",10,0) K DIRUT "RTN","XPDCOMF",11,0) S DIL=+DIFLAG "RTN","XPDCOMF",12,0) I '$D(DITCPT(1)),$G(DITCPT)'>DIL D "RTN","XPDCOMF",13,0) .I DIDD S DITCPT(1)="ENTRIES IN FILE #"_DIDD_" ("_$P($G(^DIC(DIDD,0)),U)_")" "RTN","XPDCOMF",14,0) .E S X="" D S DITCPT(1)="DATA DICTIONARY #"_$QS(DI2,1)_" ("_X_")" "RTN","XPDCOMF",15,0) ..S I=$NA(@DI1,1) I '$D(@I@(0,"NM")) S I=$NA(@DI2,1) "RTN","XPDCOMF",16,0) ..F S X=X_$O(@I@(0,"NM",0)) Q:'$D(@I@(0,"UP")) S X=X_" SUBFIELD" Q "RTN","XPDCOMF",17,0) ; "RTN","XPDCOMF",18,0) KILL S DIV=$D(^DD(DIDD,.001)),(DIOX,U)="^",IOM=$G(IOM,80) F S X=$O(^UTILITY("DITCP",$J,DIL)) Q:$D(DIRUT)!'X K ^(X) "RTN","XPDCOMF",19,0) I '$D(@DI1) D Q "RTN","XPDCOMF",20,0) .S D1="{Missing}" I '$D(@DI2) S D2="{Also Missing}" D WB Q "RTN","XPDCOMF",21,0) .I DIL#2 S D2="" D WB Q "RTN","XPDCOMF",22,0) .S DIN2=$QS(DI2,$QL(DI2)),DIGL=0,DIN=1 D RIGHT(DI2) "RTN","XPDCOMF",23,0) I '$D(@DI2) D Q "RTN","XPDCOMF",24,0) .I DIL#2 S D1="",D2="{Missing}" D WB Q "RTN","XPDCOMF",25,0) .S DIGL=0,DIN=1,^UTILITY("DITCP",$J,"X1",DIDD,$QS(DI1,$QL(DI1)))=$P(@DI1@(0),U) G END "RTN","XPDCOMF",26,0) I 'DIDD,DIL=1 D "RTN","XPDCOMF",27,0) .N P,DITCPL F X=1,2 S Y=@("DI"_X),P=1,%="" D S P(X)=P-1 "RTN","XPDCOMF",28,0) ..F S %=$O(@Y@(0,"ID",%)) Q:%="" S A=$S(+%=%:%,1:+$P(%,"WDI",2)) S:$D(@Y@(A,0))=1 DITCPL(X,P)=$S(A:$P($G(@Y@(A,0)),U),1:%_" (Display only)"),P=P+1 "RTN","XPDCOMF",29,0) .I DIFLAG'["L"!$D(DITCPL(1)) D DITCPL("IDENTIFIERS") "RTN","XPDCOMF",30,0) .F P="DIC","ACT" K DITCPL M DITCPL(1,1)=@DI1@(0,P),DITCPL(2,1)=@DI2@(0,P) I DIFLAG'["L"!$D(DITCPL(1)) D DITCPL($S(P="DIC":"SPECIAL LOOKUP",1:"POST-SELECTION ACTION")) "RTN","XPDCOMF",31,0) S I DIL#2 S DIN1=$O(@DI1@(0)) K ^UTILITY("DITCP",$J,DIL) G ENTRY ;WE ARE AT ROOT OF A (SUB)-FILE FIND 1ST ENTRY ON LEFT SIDE "RTN","XPDCOMF",32,0) S (DIN1,DIN2)=-1 "RTN","XPDCOMF",33,0) I DIL'9 S DIV2=@DI2@(DIN2),DIV1=@DI1@(DIN1) G GET2D:DIV2=DIV1 S DIN="",DIGL=DIN1 D G GET2D "RTN","XPDCOMF",43,0) .F S DIN=$O(^DD(DIDD,"GL",DIGL,DIN)) Q:DIN=""!$D(DIRUT) D "RTN","XPDCOMF",44,0) ..I 'DIN S %X=+$E(DIN,2,9),%Y=$P(DIN,",",2),D2=$E(DIV2,%X,%Y),D1=$E(DIV1,%X,%Y) "RTN","XPDCOMF",45,0) ..E S D1=$P(DIV1,U,DIN),D2=$P(DIV2,U,DIN) I DIN=2 S:DIDD=0 D1=$TR(D1,"a"),D2=$TR(D2,"a") I DIDD=.4031 D BLOCK(D1) ;SPECIFIER OR HEADER BLOCK "RTN","XPDCOMF",46,0) ..I D1'=D2 D:D1]""!(DIFLAG'["L") DIO12($$TITLE) Q "RTN","XPDCOMF",47,0) .I DIGL=0,'DIDD,'$D(DIRUT) S D1=$P(DIV1,U,5,99),D2=$P(DIV2,U,5,99) Q:D1=D2 D DIO12($S($P(DIV1,U,2)["C":"COMPUTED EXPRESSION",1:"INPUT TRANSFORM")) Q "RTN","XPDCOMF",48,0) D X G END:$D(DIRUT),NEXTD "RTN","XPDCOMF",49,0) ; "RTN","XPDCOMF",50,0) D2 G ENTRY:DIL#2 S Y=$O(^DD(DIDD,"GL",DIN1,0,0)) ;DOWN TO A MULTIPLE FIELD "RTN","XPDCOMF",51,0) I Y,$D(^DD(DIDD,+Y,0)) S Y=$P(^(0),U,2) I Y]"",Y-.15,$D(^DD(+Y,.01,0)) G WP:$P(^(0),U,2)["W" D DN S DIDD=+Y G S "RTN","XPDCOMF",52,0) G GET2D "RTN","XPDCOMF",53,0) ; "RTN","XPDCOMF",54,0) WP S X=$P(^(0),U),%Y=0 "RTN","XPDCOMF",55,0) F %X=0:0 S %X=$O(@DI1@(DIN1,%X)) Q:$D(^(+%X,0))[0 S I=^(0),%Y=$O(@DI2@(DIN2,%Y)) G WPD:$G(^(+%Y,0))'=I ;IS EVERY LINE IDENTICAL? "RTN","XPDCOMF",56,0) G GET2D:'$O(@DI2@(DIN2,%Y)) "RTN","XPDCOMF",57,0) WPD D SUBHD W !?IOM-$L(X)\2,X,"..." "RTN","XPDCOMF",58,0) G GET2D "RTN","XPDCOMF",59,0) ; "RTN","XPDCOMF",60,0) ;^UTILITY("DITCP",$J,"X1",DIDD,DIN1) = new entry "RTN","XPDCOMF",61,0) ;^UTILITY("DITCP",$J,"X2",DIDD,DIN1) = KIDS will delete "RTN","XPDCOMF",62,0) ENTRY S DIGL=0,DIN=1 G NEXTENT:'$D(@DI1@(+DIN1,0)) S X=$P(^(0),U) "RTN","XPDCOMF",63,0) ;check if we are comparing to KIDS "RTN","XPDCOMF",64,0) I $E(DI1,1,12)="^XTMP(""XPDI""" D G NEXTENT:Y "RTN","XPDCOMF",65,0) .;check KIDS action,(0,3)=continue processing "RTN","XPDCOMF",66,0) .S Y=+$G(@DI1@(+DIN1,-1)) I Y=3!'Y S Y=0 Q "RTN","XPDCOMF",67,0) .;delete: save & goto next entry "RTN","XPDCOMF",68,0) .I Y=1 S ^UTILITY("DITCP",$J,"X2",DIDD,DIN1)=X "RTN","XPDCOMF",69,0) .Q "RTN","XPDCOMF",70,0) I DIDD=.11,$G(DITCPIF),DITCPIF-X G NEXTENT ;Skip INDEXes not for this DD "RTN","XPDCOMF",71,0) I DIDD=.4032 D D BLOCK(X) G NEXTENT "RTN","XPDCOMF",72,0) .N V S V=$$EXT(X,.01,1) I V]"" S V=$O(@($$NS(2)_"DIST(.404,""B"",V,0)")) I V S X=V "RTN","XPDCOMF",73,0) .S ^UTILITY("DITCP",$J,DIL,X)="" "RTN","XPDCOMF",74,0) S DIV=$D(^DD(DIDD,.001)) G UP:DIDD=.4032!(DIDD=19.01) ;for now, give up matching BLOCKS or MENUS "RTN","XPDCOMF",75,0) I DIDD=.1 S DIN2=+DIN1,X=@DI1@(DIN1,0) G NEW:'$D(@DI2@(DIN2,0)),NEW:^(0)'=X,OLD ;CROSS-REFERENCE matches on entire 0 node "RTN","XPDCOMF",76,0) BIX I $P($G(@DI2@(DIN1,0)),U)=X S DIN2=DIN1 G OLD:$$MATCH,NEW:DIV "RTN","XPDCOMF",77,0) I $P(^DD(DIDD,.01,0),U,2)["P" S MSCP=$$EXT(X,.01,1) F DIN2=0:0 S DIN2=$O(@DI2@(DIN2)) G NEW:DIN2'>0 I $$EXT($P($G(^(DIN2,0)),U),2)=MSCP G OLD:$$MATCH "RTN","XPDCOMF",78,0) S DIN2=0 I '$D(^DD(DIDD,0,"IX","B",DIDD,.01)) F S DIN2=$O(@DI2@(DIN2)) G NEW:DIN2'>0 I $P($G(^(DIN2,0)),U)=X G OLD:$$MATCH "RTN","XPDCOMF",79,0) BI S DIN2=$O(@DI2@("B",X,DIN2)) I 'DIN2 S:$L(X)>30 DIN2=$O(@DI2@("B",$E(X,1,30),DIN2)) G NEW:'DIN2 "RTN","XPDCOMF",80,0) I $D(@DI2@(DIN2,0)),$P(^(0),X)="" G OLD:$$MATCH ;COMPARE BY NAME "RTN","XPDCOMF",81,0) G BI "RTN","XPDCOMF",82,0) ; "RTN","XPDCOMF",83,0) NEW S ^UTILITY("DITCP",$J,"X1",DIDD,DIN1)=X ;WILL SHOW EXTRA ENTRY ON LEFT SIDE "RTN","XPDCOMF",84,0) NEXTENT S DIN1=$O(@DI1@(DIN1)) "RTN","XPDCOMF",85,0) N2 I DIN1 G ENTRY "RTN","XPDCOMF",86,0) I DIFLAG'["L" F DIN2=0:0 S DIN2=$O(@DI2@(DIN2)) Q:'DIN2 Q:+DIN2'=DIN2 D Q:$D(DIRUT) ;Print extras on right "RTN","XPDCOMF",87,0) .I '$D(^UTILITY("DITCP",$J,DIL,DIN2)) D RIGHT($NA(@DI2@(DIN2))) "RTN","XPDCOMF",88,0) G END:$D(DIRUT),UP "RTN","XPDCOMF",89,0) ; "RTN","XPDCOMF",90,0) RIGHT(X) Q:'$D(@X@(0))#2 I DIDD=.11,$G(DITCPIF),DITCPIF-^(0) Q "RTN","XPDCOMF",91,0) D XTRAM($P(^(0),U,1,$S(DIDD=.1:99,1:1)),2) Q ;If X-REF, compare entire node "RTN","XPDCOMF",92,0) ; "RTN","XPDCOMF",93,0) ;DID=title, X: 1=left,2=right, P=prefix to title "RTN","XPDCOMF",94,0) XTRAM(DID,X,P) Q:DIDD=.15 ;FORGET TRIGGERED-BY "RTN","XPDCOMF",95,0) F I=DIL+(DIL#2):1 K DITCPT(I) I $O(DITCPT(I))="" Q ;S:$G(DITCPT)>(I-1) DITCPT=I-1 B:DIDD=8994 Q "RTN","XPDCOMF",96,0) I DIDD=.11 S DID="@DI"_X_"@(DIN"_X_",0)",DID=$P(@DID,U,2,3) "RTN","XPDCOMF",97,0) S DIDDN=$S(DIDD:$O(^DD(DIDD,0,"NM","")),1:"FIELD")_$S(DIV:" #"_@("DIN"_X),$D(^DIC(DIDD)):"",1:" Multiple")_": ",Y=^DD(DIDD,.01,0) "RTN","XPDCOMF",98,0) S:$G(P)]"" DIDDN=P_DIDDN "RTN","XPDCOMF",99,0) D DIT,DIO "RTN","XPDCOMF",100,0) Q "RTN","XPDCOMF",101,0) ; "RTN","XPDCOMF",102,0) ; "RTN","XPDCOMF",103,0) ; "RTN","XPDCOMF",104,0) ; "RTN","XPDCOMF",105,0) MATCH() I DIV,DIN1'=DIN2 Q 0 ;DO ENTRIES MATCH? NOT IF NUMBERS DON'T AND IT'S NUMBER-MEANINGFUL "RTN","XPDCOMF",106,0) I $D(^UTILITY("DITCP",$J,DIL,DIN2)) Q 0 ;We already matched this one "RTN","XPDCOMF",107,0) I DIDD=.11 Q '$$MISMATCH(.02) ;INDEX must match on NAME "RTN","XPDCOMF",108,0) I DIDD=.403 Q '$$MISMATCH(7) ;FORM must match on PRIMARY FILE "RTN","XPDCOMF",109,0) I DIDD=.4!(DIDD=.401)!(DIDD=.402) Q '$$MISMATCH(4) ;TEMPLATES must match on FILE "RTN","XPDCOMF",110,0) I DIDD=19 Q 1 ;OPTION matches on NAME alone "RTN","XPDCOMF",111,0) S DITM=.01 "RTN","XPDCOMF",112,0) ID S DITM=$O(^DD(DIDD,0,"ID",DITM)) I DITM="" Q 1 "RTN","XPDCOMF",113,0) S I=DITM S:I?1"W"1.NP I=$E(I,2,99) I $$MISMATCH(I) Q 0 ;MATCH EACH NON-NULL IDENTIFIER "RTN","XPDCOMF",114,0) G ID "RTN","XPDCOMF",115,0) ; "RTN","XPDCOMF",116,0) MISMATCH(I) K B S A=$P($G(^DD(DIDD,I,0)),U,2) I A=""!(A["P")!(A["V") Q 0 ;DON'T TRY TO MATCH POINTERS "RTN","XPDCOMF",117,0) D Q:W="" 0 S B=W Q:'$D(^DD(DIDD,I,0)) 0 D Q:W="" 0 Q W'=B ;If two non-null values aren't equal it's a mismatch "RTN","XPDCOMF",118,0) .S A=$P(^(0),U,4),%=$P(A,";",2),W=$P(A,";"),A=$S($D(B):DI2,1:DI1) I W?." " S W="" Q "RTN","XPDCOMF",119,0) .I $D(@A@($S($D(B):DIN2,1:DIN1),W))[0 S W="" Q "RTN","XPDCOMF",120,0) .I % S W=$P(^(W),U,%) "RTN","XPDCOMF",121,0) .E S W=$E(^(W),+$E(%,2,9),$P(%,",",2)) "RTN","XPDCOMF",122,0) .S:W?.E1L.E W=$$UP^DILIBF(W) "RTN","XPDCOMF",123,0) ; "RTN","XPDCOMF",124,0) OLD S ^UTILITY("DITCP",$J,DIL,DIN2)="" ;Remember that we found DIN2 as a match "RTN","XPDCOMF",125,0) D DN G S "RTN","XPDCOMF",126,0) ; "RTN","XPDCOMF",127,0) ; "RTN","XPDCOMF",128,0) DN S DIDD(DIL)=DIDD "RTN","XPDCOMF",129,0) N X,%X F X=1,2 S %X=@("DIN"_X),(W,W(X,DIL))=@("DI"_X),W=$NA(@W@(%X)),@("DI"_X)=W ;ADD A SUBSCRIPT "RTN","XPDCOMF",130,0) S DIL=DIL+1 Q "RTN","XPDCOMF",131,0) ; "RTN","XPDCOMF",132,0) UP ; "RTN","XPDCOMF",133,0) G END:'$D(W(2,DIL-1)) "RTN","XPDCOMF",134,0) S DIN1=$O(@DI1) I DIL#2=0 S:$G(DITCPT)>DIL DITCPT=DIL D U G N2 "RTN","XPDCOMF",135,0) D LEFT Q:$D(DIRUT) S DIN2=$O(@DI2),DIDD=DIDD(DIL-1) "RTN","XPDCOMF",136,0) D U G NEXTD "RTN","XPDCOMF",137,0) U S (DIL,Y)=DIL-1,DI1=W(1,Y),DI2=W(2,Y) "RTN","XPDCOMF",138,0) Q "RTN","XPDCOMF",139,0) ; "RTN","XPDCOMF",140,0) ; "RTN","XPDCOMF",141,0) 2 ; "RTN","XPDCOMF",142,0) X G XTRA1:DIN2="",XTRA2:DIN1="" I +DIN1=DIN1 G XTRA1:+DIN2'=DIN2!(DIN2>DIN1),XTRA2 "RTN","XPDCOMF",143,0) G XTRA2:+DIN2=DIN2!(DIN1]DIN2) "RTN","XPDCOMF",144,0) XTRA1 S X=1,DIGL=DIN1 "RTN","XPDCOMF",145,0) D XTRA S DIN1=$O(@DI1@(DIN1)) Q "RTN","XPDCOMF",146,0) XTRA2 S X=2,DIGL=DIN2 D:DIFLAG'["L" XTRA S DIN2=$O(@DI2@(DIN2)) Q "RTN","XPDCOMF",147,0) ; "RTN","XPDCOMF",148,0) XTRA S DIR="@DI"_X_"@(DIGL)" I $D(@DIR)<9 S DIN="",DIV=@DIR G GL "RTN","XPDCOMF",149,0) S I=$O(^(DIGL,0)) Q:'I S I=$O(^(I)),DIN=$O(^DD(DIDD,"GL",DIGL,0,0)) Q:$D(^DD(DIDD,+DIN,0))[0 "RTN","XPDCOMF",150,0) S DIDDN=$P(^(0),U)_$S($P(^DD(+$P(^(0),U,2),.01,0),U,2)["W":"...",1:" Multiple"_$E("s",I>0)),(DID,DIT)="" D DIO S DIOX=0 Q "RTN","XPDCOMF",151,0) ; "RTN","XPDCOMF",152,0) GL S DIN=$O(^DD(DIDD,"GL",DIGL,DIN)) Q:DIN="" S Y=$O(^(DIN,0)) G GL:'$D(^DD(DIDD,+Y,0)) S DIO=$P(^(0),U)_": " "RTN","XPDCOMF",153,0) I DIN S DID=$P(DIV,U,DIN) G:DID="" GL:$P(DIV,U,DIN,999)]"",Q "RTN","XPDCOMF",154,0) E S DID=$E(DIV,+$E(DIN,2,9),$P(DIN,",",2)) Q:DID?." " "RTN","XPDCOMF",155,0) S DIDDN=$$TITLE G GL:DIDDN="" S DIDDN=DIDDN_": " "RTN","XPDCOMF",156,0) D DIO G GL:'$D(DIRUT) "RTN","XPDCOMF",157,0) END D LEFT Q:$D(DIRUT) "RTN","XPDCOMF",158,0) I 'DIDD,DIFLAG#2 N DITCPIF,DIDD D G ENTRY ;INDEXES for File #DITCPIF "RTN","XPDCOMF",159,0) .S DITCPIF=$QS(DI1,1),DIDD=.11,DI1=$NA(@DI1,0)_"(""IX"")",DI2=$NA(@DI2,0)_"(""IX"")",(DIN1,DIN2)=0 "RTN","XPDCOMF",160,0) Q Q "RTN","XPDCOMF",161,0) ; "RTN","XPDCOMF",162,0) ; "RTN","XPDCOMF",163,0) ; "RTN","XPDCOMF",164,0) LEFT ;display left side; "X1" subscript, these are new records "RTN","XPDCOMF",165,0) N DIN1 "RTN","XPDCOMF",166,0) F DIN1=0:0 S DIN1=$O(^UTILITY("DITCP",$J,"X1",DIDD,DIN1)) Q:'DIN1 D XTRAM(^(DIN1),1,"*ADD* ") K ^UTILITY("DITCP",$J,"X1",DIDD,DIN1) Q:$D(DIRUT) "RTN","XPDCOMF",167,0) ;"X2" subscript, these are KIDS delete records "RTN","XPDCOMF",168,0) Q:'$D(^UTILITY("DITCP",$J,"X2",DIDD)) "RTN","XPDCOMF",169,0) F DIN1=0:0 S DIN1=$O(^UTILITY("DITCP",$J,"X2",DIDD,DIN1)) Q:'DIN1 D XTRAM(^(DIN1),1,"*DELETE* ") K ^UTILITY("DITCP",$J,"X2",DIDD,DIN1) Q:$D(DIRUT) "RTN","XPDCOMF",170,0) Q "RTN","XPDCOMF",171,0) ; "RTN","XPDCOMF",172,0) ; "RTN","XPDCOMF",173,0) TITLE() S Y=$$FLDNUM I '$D(^DD(DIDD,+Y,0)) Q "" ;decide whether this FIELD is interesting "RTN","XPDCOMF",174,0) I $O(^(5,0)) Q "" ;Forget TRIGGERED FIELDS! (INTERESTING!) "RTN","XPDCOMF",175,0) I DIDD=.403,Y'>5 Q "" "RTN","XPDCOMF",176,0) I DIDD=19,DIGL\1=99!(Y=3.6) Q "" "RTN","XPDCOMF",177,0) I 'DIDD,Y=50!(DIGL="DT")!(DIGL=8)!(DIGL=8.5)!(DIGL=9)!(Y=1.1) Q "" "RTN","XPDCOMF",178,0) I 'DIDD,Y=.3,$G(DIV1)[":" Q "SET OF CODES" ;INSTEAD OF "POINTER" "RTN","XPDCOMF",179,0) S Y=^DD(DIDD,+Y,0) D DIT Q $P(Y,U) "RTN","XPDCOMF",180,0) ; "RTN","XPDCOMF",181,0) FLDNUM() I DIN]"" Q $O(^DD(DIDD,"GL",DIGL,DIN,0)) "RTN","XPDCOMF",182,0) Q .01 "RTN","XPDCOMF",183,0) ; "RTN","XPDCOMF",184,0) DIT ; "RTN","XPDCOMF",185,0) S DIT=$P(Y,U,2),I=$P(Y,U,3) Q "RTN","XPDCOMF",186,0) ; "RTN","XPDCOMF",187,0) EXT(X,C,MSCSIDE) I X]"" N Y I C S C=$P($G(^DD(DIDD,C,0)),U,2),Y=X D:$G(MSCSIDE) D S^DIQ I Y]"" Q Y ;101.41 BOMBED IN $$EXTERNAL^DIDU(DIDD,$$FLDNUM,,X) "RTN","XPDCOMF",188,0) .F Q:C'["P" Q:'$D(@($$NS(MSCSIDE)_$P(^(0),U,3)_"0)")) S C=$P(^(0),U,2) Q:'$D(^(+Y,0)) S Y=$P(^(0),U),C=$P($G(^DD(+C,.01,0)),U,2) "RTN","XPDCOMF",189,0) Q X "RTN","XPDCOMF",190,0) ; "RTN","XPDCOMF",191,0) NS(MSCSIDE) N N S N=@("DI"_MSCSIDE) I $E(N,2)="[" Q $E(N,1,$F(N,"]")-1) ;returns "^" OR "^[NS]" "RTN","XPDCOMF",192,0) Q U "RTN","XPDCOMF",193,0) ; "RTN","XPDCOMF",194,0) DIO ;X=1 MEANS LEFT SIDE, X=2 MEANS RIGHT SIDE "RTN","XPDCOMF",195,0) ;DID=WHAT WE HAVE TO PRINT "RTN","XPDCOMF",196,0) S DIOX=$Y D SUBHD Q:$D(DIRUT) S DIO=DIDDN_$$EXT(DID,$$FLDNUM,X) "RTN","XPDCOMF",197,0) DIO1 ;DIO IS OUTPUT "RTN","XPDCOMF",198,0) I X=1 S DIOX(1)=DIDDN D LF "RTN","XPDCOMF",199,0) Q:$D(DIRUT) "RTN","XPDCOMF",200,0) I X=2 D:$S(DIOX-1:1,'$D(DIOX(1)):1,1:$P(DIO,DIOX(1))]"") LF Q:$D(DIRUT) W ?IOM\2 K DIOX(1) "RTN","XPDCOMF",201,0) W !,$J("",DIL),$E(DIO,1,IOM\2-DIL-1) S DIO=$E(DIO,IOM\2-DIL,999) I $L(DIO)<$S(X=1:17,X=2:2) W DIO S DIOX=X Q ;WRITE A LITTLE MORE THAN HALF A LINE "RTN","XPDCOMF",202,0) S DIOX=0 G DIO1 "RTN","XPDCOMF",203,0) ; "RTN","XPDCOMF",204,0) ; "RTN","XPDCOMF",205,0) DIO12(T) ;WRITE D1 AND D2 SIDE BY SIDE "RTN","XPDCOMF",206,0) N D,V "RTN","XPDCOMF",207,0) Q:D1=D2!(T="") "RTN","XPDCOMF",208,0) F D=1,2 D "RTN","XPDCOMF",209,0) .S V="D"_D Q:@V="" "RTN","XPDCOMF",210,0) .S @V=T_": "_$$EXT(@V,$$FLDNUM,D) "RTN","XPDCOMF",211,0) Q:D1=D2 ;EXTERNAL VERSIONS MAY BE SAME "RTN","XPDCOMF",212,0) WB D SUBHD "RTN","XPDCOMF",213,0) F Q:D1=""&(D2="") D LF Q:$D(DIRUT) F D=1,2 S X="D"_D W:D=2 ?IOM\2 W $J("",DIL),$E(@X,1,IOM\2-DIL-1) S @X=$E(@X,IOM\2-DIL,999) "RTN","XPDCOMF",214,0) Q "RTN","XPDCOMF",215,0) ; "RTN","XPDCOMF",216,0) ; "RTN","XPDCOMF",217,0) SUBHD ; "RTN","XPDCOMF",218,0) N Y,L S Y=$O(DITCPT("")) Q:Y="" "RTN","XPDCOMF",219,0) I $G(DITCPT) S L=DITCPT "RTN","XPDCOMF",220,0) E S L=Y F Y=$G(DIL):-1:Y D LF G Q:$D(DIRUT) "RTN","XPDCOMF",221,0) F Q:L>$G(DIL)!$D(DIRUT) D LF Q:$D(DIRUT) W:$D(DITCPT(L)) ?IOM-$L(DITCPT(L))\2,DITCPT(L) S L=L+1 "RTN","XPDCOMF",222,0) K DITCPT S DITCPT=L-1 Q ;REMEMBER HOW DEEP WE WERE AT LAST OUTPUT "RTN","XPDCOMF",223,0) ; "RTN","XPDCOMF",224,0) ; "RTN","XPDCOMF",225,0) LF W ! Q:$Y+32 DITCPT=2 D E(.404,$P($G(^DIST(.404,+X,0)),U)) ;compare ScreenMan BLOCKs "RTN","XPDCOMF",253,0) Q "RTN","XPDCOMF",254,0) E(XPDI,NAME,DIFL) N X,N,MSC,S Q:NAME=""!'XPDI "RTN","XPDCOMF",255,0) S MSCF=$G(^DIC(XPDI,0,"GL")) Q:MSCF'?1"^".E S MSCF=$E($$CREF^DILF(MSCF),2,99) "RTN","XPDCOMF",256,0) F X=1,2 S N=$$NS(X)_MSCF D S:'S S=-999 S MSC(X)=$NA(@N@(S)) "RTN","XPDCOMF",257,0) .F S=0:0 S S=$O(@N@("B",NAME,S)) Q:'S Q:'$G(DIFL) Q:XPDI<.4!(XPDI>.402) Q:$P($G(@N@(S,0)),U,4)=DIFL ;TEMPLATE FILE# MUST MATCH "RTN","XPDCOMF",258,0) D EN(MSC(1),MSC(2),XPDI,$G(DIL,2),.DITCPT) "RTN","XPDCOMF",259,0) Q "RTN","XPDE") 0^5^B45567472^B45439335 "RTN","XPDE",1,0) XPDE ;SFISC/RSD - Package Edit ;06/24/2008 "RTN","XPDE",2,0) ;;8.0;KERNEL;**2,15,21,44,51,68,131,182,201,229,302,399,507,539**;Jul 10, 1995;Build 11 "RTN","XPDE",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","XPDE",4,0) Q "RTN","XPDE",5,0) ;these tags are called from options. "RTN","XPDE",6,0) EDIT ;edit Build file package "RTN","XPDE",7,0) N DA,DIR,DDSFILE,DR,Y,Z "RTN","XPDE",8,0) Q:'$$DIC("AEMQLZ","",1) S DA=+Y "RTN","XPDE",9,0) I $P(Y,U,3) D NEW(DA) "RTN","XPDE",10,0) S Z=$P(^XPD(9.6,DA,0),U,3)+1,DR="["_$P("XPD EDIT BUILD^XPD EDIT MP^XPD EDIT GP",U,Z)_"]",DDSFILE="^XPD(9.6," "RTN","XPDE",11,0) D ^DDS Q:'$G(DA) "RTN","XPDE",12,0) ;if full DD, kill multiple for partial DD "RTN","XPDE",13,0) S Y=0 F S Y=$O(^XPD(9.6,DA,4,Y)) Q:'Y S Z=$G(^(Y,222)) D "RTN","XPDE",14,0) .K:$P(Z,U,3)="f" ^XPD(9.6,DA,4,Y,2),^XPD(9.6,DA,4,"APDD",Y) "RTN","XPDE",15,0) D QUIT(DA) "RTN","XPDE",16,0) Q "RTN","XPDE",17,0) COPY ;copy a Build file package "RTN","XPDE",18,0) N DA,DIK,DIR,FR,FR0,TO,TO0,X,Y,Z W ! "RTN","XPDE",19,0) Q:'$$DIC("QEAMZ","Copy FROM what Package: ") "RTN","XPDE",20,0) S FR=+Y,FR0=Y(0),Z="QEAMZL",Z("S")="I Y'="_FR "RTN","XPDE",21,0) I '$$DIC(.Z,"Copy TO what Package: ") D QUIT(FR) Q "RTN","XPDE",22,0) S TO=Y,TO0=Y(0) "RTN","XPDE",23,0) ;if this is not new, then it will be purged before copy. "RTN","XPDE",24,0) I '$P(TO,U,3) W !,$P(TO0,U)," package will be PURGED before the copy." "RTN","XPDE",25,0) W ! S DIR(0)="Y",DIR("A")="OK to continue",DIR("B")="YES" D ^DIR "RTN","XPDE",26,0) S DIK="^XPD(9.6,",DA=+TO "RTN","XPDE",27,0) I 'Y!$D(DIRUT) D W ! Q "RTN","XPDE",28,0) .;they didn't want to continue, kill if it was a new package. "RTN","XPDE",29,0) .I $P(TO,U,3) D ^DIK W $P(TO0,U)," being deleted!" "RTN","XPDE",30,0) .;unlock both packages "RTN","XPDE",31,0) .D QUIT(FR),QUIT(TO) "RTN","XPDE",32,0) D WAIT^DICD "RTN","XPDE",33,0) ;if not new, kill old data "RTN","XPDE",34,0) K:'$P(TO,U,3) ^XPD(9.6,DA) "RTN","XPDE",35,0) M ^XPD(9.6,DA)=^XPD(9.6,FR) S $P(^(DA,0),U)=$P(TO0,U) "RTN","XPDE",36,0) D NEW(+TO) "RTN","XPDE",37,0) ;if new National Package name, then kill x-ref "RTN","XPDE",38,0) I $P(TO0,U,2)]"",$P(FR0,U,2)'=$P(TO0,U,2) K ^XPD(9.6,"C",$E($P(TO0,U,2),1,30),DA) S DIK(1)=1 D EN1^DIK "RTN","XPDE",39,0) D QUIT(FR),QUIT(TO) "RTN","XPDE",40,0) W "...Done.",! "RTN","XPDE",41,0) Q "RTN","XPDE",42,0) BUILD ;build package from a namespace "RTN","XPDE",43,0) N DIR,DIRUT,XPDA,XPDI,XPDF,XPDN,XPDX,XPDXL,X,X1,Y,Y1 W ! "RTN","XPDE",44,0) Q:'$$DIC("QEAML") "RTN","XPDE",45,0) S XPDA=+Y W ! "RTN","XPDE",46,0) I $P(^XPD(9.6,XPDA,0),U,3) W !,"The Build Type must be SINGLE PACKAGE!!",! Q "RTN","XPDE",47,0) ;if not a new package "RTN","XPDE",48,0) I '$P(Y,U,3) D I $D(DIRUT) D QUIT(XPDA) Q "RTN","XPDE",49,0) .S DIR(0)="Y",DIR("A")="Package already exists, Want to PURGE the existing data",DIR("B")="NO",DIR("?")="YES will delete all the KERNEL FILE information for this package in the BUILD file." "RTN","XPDE",50,0) .D ^DIR K DIR Q:'Y "RTN","XPDE",51,0) .S Y=0 F S Y=$O(^XPD(9.6,XPDA,"KRN",Y)) Q:'Y K ^(Y,"NM") "RTN","XPDE",52,0) E D NEW(XPDA) "RTN","XPDE",53,0) ;XPDN(0=excluded names or 1=include names, namespace)="" "RTN","XPDE",54,0) W ! S DIR(0)="FO^1:15^K:X'?.1""-""1U.15UNP X",DIR("A")="Namespace",DIR("?")="Enter 1 to 15 characters, preceed with ""-"" to exclude namespace" "RTN","XPDE",55,0) F D ^DIR Q:$D(DIRUT) S X=$E(Y,$L(Y))="*",%=$E(Y)="-",XPDN('%,$E(Y,%+1,$L(Y)-X))="" "RTN","XPDE",56,0) I '$D(XPDN)!$D(DTOUT)!$D(DUOUT) D QUIT(XPDA) Q "RTN","XPDE",57,0) W !!,"NAMESPACE INCLUDE",?35,"EXCLUDE",!,?11,"-------",?35,"-------" "RTN","XPDE",58,0) S (X,Y)="",(X1,Y1)=1 "RTN","XPDE",59,0) F D W !?11,X,?35,Y Q:'X1&'Y1 "RTN","XPDE",60,0) .S:X1 X=$O(XPDN(1,X)),X1=X]"" S:Y1 Y=$O(XPDN(0,Y)),Y1=Y]"" "RTN","XPDE",61,0) S DIR(0)="Y",DIR("A")="OK to continue",DIR("B")="YES" D ^DIR "RTN","XPDE",62,0) I 'Y!$D(DIRUT) D QUIT(XPDA) Q "RTN","XPDE",63,0) D WAIT^DICD S XPDX="",XPDI("IEN")=0 "RTN","XPDE",64,0) F S XPDX=$O(XPDN(1,XPDX)),XPDXL=$L(XPDX),XPDF=0 Q:XPDX="" D "RTN","XPDE",65,0) .F S XPDF=$O(^XPD(9.6,XPDA,"KRN",XPDF)) Q:'XPDF D "RTN","XPDE",66,0) ..N XPD,XPDIC,XPDJ,XPCNT W "." "RTN","XPDE",67,0) ..;XPDIC is used in $$SCR1^XPDET "RTN","XPDE",68,0) ..S XPDIC="^XPD(9.6,"_XPDA_",""KRN"","_XPDF_",""NM"",",XPCNT=0 "RTN","XPDE",69,0) ..D LIST^DIC(XPDF,"","","","*",.XPDI,XPDX,"","I $E(^(0),1,XPDXL)=XPDX,$$SCR1^XPDET(Y)") "RTN","XPDE",70,0) ..F XPDJ=1:1 S X=$G(^TMP("DILIST",$J,1,XPDJ)) Q:X="" D "RTN","XPDE",71,0) ...S:XPDF<.404 %=^TMP("DILIST",$J,2,XPDJ)_",",X=$$TX^XPDET(X,$$GET1^DIQ(XPDF,%,$$TF^XPDET(XPDF),"I")) "RTN","XPDE",72,0) ...S Y="+"_XPDJ_","_XPDF_","_XPDA_",",XPD(9.68,Y,.01)=X,XPD(9.68,Y,.03)=0 "RTN","XPDE",73,0) ...;Keep XPD from getting too big. "RTN","XPDE",74,0) ...S XPCNT=XPCNT+1 I XPCNT>100 D UPDATE^DIE("","XPD") S XPCNT=0 K XPD "RTN","XPDE",75,0) ..Q:'$D(XPD) D UPDATE^DIE("","XPD") "RTN","XPDE",76,0) D QUIT(XPDA) "RTN","XPDE",77,0) W "...Done.",! "RTN","XPDE",78,0) Q "RTN","XPDE",79,0) VER ;verify a Build file package "RTN","XPDE",80,0) N XPDA,Y "RTN","XPDE",81,0) Q:'$$DIC("AEMQZ") S XPDA=+Y "RTN","XPDE",82,0) D EN^XPDV "RTN","XPDE",83,0) Q "RTN","XPDE",84,0) DIC(DIC,A,XPDL) ;DIC lookup to Build file, 9.6 "RTN","XPDE",85,0) N DLAYGO "RTN","XPDE",86,0) S DIC(0)=$G(DIC),DIC="^XPD(9.6," S:$G(A)]"" DIC("A")=A "RTN","XPDE",87,0) S:DIC(0)["L" DLAYGO=9.6,DIC("DR")="1;2//SINGLE PACKAGE;5//YES" "RTN","XPDE",88,0) D ^DIC Q:Y<0 0 "RTN","XPDE",89,0) I '$G(XPDL) L +^XPD(9.6,+Y):0 E W !,"Being accessed by another user" Q 0 "RTN","XPDE",90,0) Q +Y "RTN","XPDE",91,0) ; "RTN","XPDE",92,0) NEW(DA) ;create Kernel Files multiple for package DA "RTN","XPDE",93,0) N I,J,X,XPDNEWF,XPD,XPDI "RTN","XPDE",94,0) S:'$D(^XPD(9.6,DA,"KRN",0)) ^XPD(9.6,DA,"KRN",0)=U_$P(^DD(9.6,7,0),U,2) "RTN","XPDE",95,0) S I=0 "RTN","XPDE",96,0) F J=1:1 S X=+$P($T(FILES+J),";;",2) Q:'X S:$D(^DD(X))&'$D(^XPD(9.6,DA,"KRN",X)) I=I+1,(XPDI(I),XPD(9.67,"+"_I_","_DA_",",.01))=X "RTN","XPDE",97,0) Q:'$D(XPD) "RTN","XPDE",98,0) ;XPDNEWF is a flag in INPUT transform of BUILD COMPONENT multiple "RTN","XPDE",99,0) S XPDNEWF=1 "RTN","XPDE",100,0) D UPDATE^DIE("","XPD","XPDI") "RTN","XPDE",101,0) Q "RTN","XPDE",102,0) QUIT(Y) ;unlock Y "RTN","XPDE",103,0) L -^XPD(9.6,Y) "RTN","XPDE",104,0) Q "RTN","XPDE",105,0) ; "RTN","XPDE",106,0) ;;file;install order;x-ref;file build;entry build;file pre;entry pre;file post;entry post;delete "RTN","XPDE",107,0) ;You must put in code to delete anything "RTN","XPDE",108,0) FILES ;kernel files for field 7 in file 9.6 "RTN","XPDE",109,0) ;;9.8;;1;RTNF^XPDTA;RTNE^XPDTA "RTN","XPDE",110,0) ;;9.2;1;;;HELP^XPDTA1;HLPF1^XPDIA1;HLPE1^XPDIA1;HLPF2^XPDIA1;;HLPDEL^XPDIA1 "RTN","XPDE",111,0) ;;3.6;2;1;;BUL^XPDTA1;;BULE1^XPDIA1;;;BULDEL^XPDIA1 "RTN","XPDE",112,0) ;;19.1;3;;;KEY^XPDTA1;KEYF1^XPDIA1;KEYE1^XPDIA1;KEYF2^XPDIA1;;KEYDEL^XPDIA1 "RTN","XPDE",113,0) ;;.5;4;;;EDEOUT^DIFROMSO(.5,DA,"",XPDA);FPRE^DIFROMSI(.5,"",XPDA);EPRE^DIFROMSI(.5,DA,"",XPDA,"",OLDA);;EPOST^DIFROMSI(.5,DA,"",XPDA) "RTN","XPDE",114,0) ;;.4;5;;;EDEOUT^DIFROMSO(.4,DA,"",XPDA);FPRE^DIFROMSI(.4,"",XPDA);EPRE^DIFROMSI(.4,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.4,DA,"",XPDA);DEL^DIFROMSK(.4,"",%) "RTN","XPDE",115,0) ;;.401;6;;;EDEOUT^DIFROMSO(.401,DA,"",XPDA);FPRE^DIFROMSI(.401,"",XPDA);EPRE^DIFROMSI(.401,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.401,DA,"",XPDA);DEL^DIFROMSK(.401,"",%) "RTN","XPDE",116,0) ;;.402;7;;;EDEOUT^DIFROMSO(.402,DA,"",XPDA);FPRE^DIFROMSI(.402,"",XPDA);EPRE^DIFROMSI(.402,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.402,DA,"",XPDA);DEL^DIFROMSK(.402,"",%) "RTN","XPDE",117,0) ;;.403;8;;;EDEOUT^DIFROMSO(.403,DA,"",XPDA);FPRE^DIFROMSI(.403,"",XPDA);EPRE^DIFROMSI(.403,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.403,DA,"",XPDA);DEL^DIFROMSK(.403,"",%) "RTN","XPDE",118,0) ;;.84;9;;;EDEOUT^DIFROMSO(.84,DA,"",XPDA);FPRE^DIFROMSI(.84,"",XPDA);EPRE^DIFROMSI(.84,DA,"",XPDA,"",OLDA);;EPOST^DIFROMSI(.84,DA,"",XPDA);DEL^DIFROMSK(.84,"",%) "RTN","XPDE",119,0) ;;3.8;11;;;MAILG^XPDTA1;MAILGF1^XPDIA1;MAILGE1^XPDIA1;MAILGF2^XPDIA1;;MAILGDEL^XPDIA1(%) "RTN","XPDE",120,0) ;;870;13;1;;HLLL^XPDTA1;;HLLLE^XPDIA1;;;HLLLDEL^XPDIA1(%) "RTN","XPDE",121,0) ;;771;14;;;HLAP^XPDTA1;HLAPF1^XPDIA1;HLAPE1^XPDIA1;HLAPF2^XPDIA1;;HLAPDEL^XPDIA1(%) "RTN","XPDE",122,0) ;;101;15;;;PRO^XPDTA;PROF1^XPDIA;PROE1^XPDIA;PROF2^XPDIA;;PRODEL^XPDIA "RTN","XPDE",123,0) ;;8994;16;1;;;;;;;RPCDEL^XPDIA1 "RTN","XPDE",124,0) ;;409.61;17;1;;;;LME1^XPDIA1;;;LMDEL^XPDIA1 "RTN","XPDE",125,0) ;;19;18;;;OPT^XPDTA;OPTF1^XPDIA;OPTE1^XPDIA;OPTF2^XPDIA;;OPTDEL^XPDIA "RTN","XPDE",126,0) ;;8994.2;19;1;;;;CRC32PE^XPDIA1;;;CRC32DEL^XPDIA1 "RTN","XPDE",127,0) ;;8989.51;20;;;PAR1E1^XPDTA2;PAR1F1^XPDIA3;PAR1E1^XPDIA3;PAR1F2^XPDIA3;;PAR1DEL^XPDIA3(%) "RTN","XPDE",128,0) ;;8989.52;21;1;;PAR2E1^XPDTA2;PAR2F1^XPDIA3;PAR2E1^XPDIA3;PAR2F2^XPDIA3;;PAR2DEL^XPDIA3(%) "RTN","XPDE",129,0) ;;779.2;22;1;;HLOAP^XPDTA1;;HLOE^XPDIA1;;; "RTN","XPDE",130,0) ;;9002226;23;1;;BLD^XPDIHS;BLD1^XPDIHS;BLD^XPDIHS;BLD1^XPDIHS;;BLD^XPDIHS "RTN","XPDET") 0^1^B32656156^B32583280 "RTN","XPDET",1,0) XPDET ;SFISC/RSD - Input tranforms & help for file 9.6 & 9.7 ;10/19/2002 "RTN","XPDET",2,0) ;;8.0;KERNEL;**15,39,41,44,51,58,66,137,229,393,539**;Jul 10, 1995;Build 11 "RTN","XPDET",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","XPDET",4,0) Q "RTN","XPDET",5,0) INPUTB(X) ;input tranfrom for NAME in BUILD file "RTN","XPDET",6,0) ;X=user input "RTN","XPDET",7,0) ;name must be unique "RTN","XPDET",8,0) I $L(X)>50!($L(X)<3)!$D(^XPD(9.6,"B",X)) K X Q "RTN","XPDET",9,0) I X["*" K:$P(X,"*",2,3)'?1.2N1"."1.2N.1(1"V",1"T").2N1"*"1.6N X Q "RTN","XPDET",10,0) S %=$L(X," ") I %<2 K X Q "RTN","XPDET",11,0) S %=$P(X," ",%) K:%'?1.2N1"."1.2N.1(1"V",1"T",1"B").2N X "RTN","XPDET",12,0) Q "RTN","XPDET",13,0) INPUTE(X) ;input transform for ENTRIES in KERNEL FILES multiple "RTN","XPDET",14,0) ;X=user input "RTN","XPDET",15,0) N D,DD,DIC,DICR,DIX,DIY,DS,DO,XPDLK,Y "RTN","XPDET",16,0) S XPDLK=$$GR(D1) "RTN","XPDET",17,0) I XPDLK=""!X["*" K X Q "RTN","XPDET",18,0) S DIC(0)="QEMZ",DIC=XPDLK "RTN","XPDET",19,0) S:D1=9.8 DIC("S")="I $T(^@$P(^(0),U))]""""" "RTN","XPDET",20,0) D ^DIC K:Y<0 X Q:'$D(X) "RTN","XPDET",21,0) S X=Y(0,0) "RTN","XPDET",22,0) ;check that this doesn't exist already "RTN","XPDET",23,0) I $D(^XPD(9.6,D0,"KRN",D1,"NM","B",X)) K X Q "RTN","XPDET",24,0) ;if fm file, change X to contain file # of template "RTN","XPDET",25,0) I D1<.404 S X=$$TX(X,$P(Y(0),U,$S(D1=.403:8,1:4))) "RTN","XPDET",26,0) Q "RTN","XPDET",27,0) GLOBALE(X) ;input transform for GLOBAL multiple .01 field in file 9.6 "RTN","XPDET",28,0) I $L(X)>30!($L(X)<2) K X Q "RTN","XPDET",29,0) I X["(",X'[")" K X Q "RTN","XPDET",30,0) ;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 "RTN","XPDET",31,0) S X=$TR(X,"'","""") "RTN","XPDET",32,0) I '$D(@("^"_X)) K X "RTN","XPDET",33,0) Q "RTN","XPDET",34,0) INPUTMB(X) ;input transform for field 10 and 11 in file 9.6 "RTN","XPDET",35,0) ;X=user input "RTN","XPDET",36,0) N D,DD,DIC,DICR,DIX,DIY,DS,DO,Y "RTN","XPDET",37,0) ;can't select a global or multi package or itself (D0) "RTN","XPDET",38,0) S DIC(0)="QEMZ",DIC="^XPD(9.6,",DIC("S")="I '$P(^(0),U,3),Y'="_D0 "RTN","XPDET",39,0) D ^DIC K:Y<0 X Q:'$D(X) "RTN","XPDET",40,0) S X=Y(0,0) "RTN","XPDET",41,0) Q "RTN","XPDET",42,0) LOOKE(X) ;special lookup for ENTRIES in KERNEL FILES multiple "RTN","XPDET",43,0) Q:X'?1.E1"*" "RTN","XPDET",44,0) N %,XPD,XPDI,XPDIC,XPDF,XPDLK,XPDX,Y "RTN","XPDET",45,0) S XPDLK=$$GR(D1),XPDIC=DIC,XPDF=D1 "RTN","XPDET",46,0) I XPDLK="" K X Q "RTN","XPDET",47,0) G:$E(X)="-" DEL "RTN","XPDET",48,0) S XPDX=$P(X,"*"),XPDI("IEN")=0 "RTN","XPDET",49,0) D LIST^DIC(D1,"","","","*",.XPDI,XPDX,"","I $$SCR^XPDET(Y)") "RTN","XPDET",50,0) I '$G(^TMP("DILIST",$J,0)) K X Q "RTN","XPDET",51,0) K ^TMP("XPDX",$J) "RTN","XPDET",52,0) ;loop thru list from lister and file using UPDATE^DIE "RTN","XPDET",53,0) F XPDI=1:1 S X=$G(^TMP("DILIST",$J,1,XPDI)) Q:X="" D "RTN","XPDET",54,0) .S:D1<.404 %=^TMP("DILIST",$J,2,XPDI)_",",X=$$TX(X,$$GET1^DIQ(D1,%,$$TF(D1),"I")) "RTN","XPDET",55,0) .S Y="+"_XPDI_","_D1_","_D0_",",^TMP("XPDX",$J,9.68,Y,.01)=X,^(.03)=0 "RTN","XPDET",56,0) I $D(^TMP("XPDX",$J)) D UPDATE^DIE("","^TMP(""XPDX"",$J)","^TMP(""XPD"",$J)") "RTN","XPDET",57,0) ;if in Screenman then call MLOAD to update screen "RTN","XPDET",58,0) I $D(DDS),$D(^TMP("XPD",$J)) D MLOAD^DDSUTL("^TMP(""XPD"",$J)") "RTN","XPDET",59,0) S X="" "RTN","XPDET",60,0) K ^TMP("XPDX",$J),^TMP("XPD",$J) "RTN","XPDET",61,0) Q "RTN","XPDET",62,0) DEL ;delete using wild card "RTN","XPDET",63,0) I X'?1"-"1.E1"*" K X Q "RTN","XPDET",64,0) S X=$E(X,2,$L(X)-1),XPDX=X S:$L(X) XPDI("IEN")=0 "RTN","XPDET",65,0) D LIST^DIC(9.68,","_D1_","_D0_",","","","*",.XPDI,XPDX) "RTN","XPDET",66,0) I '$G(^TMP("DILIST",$J,0)) K X Q "RTN","XPDET",67,0) N DIK,DA,D2 "RTN","XPDET",68,0) S DIK=XPDIC,DA(1)=D1,DA(2)=D0 "RTN","XPDET",69,0) F XPDI=1:1 S (DA,D2)=$G(^TMP("DILIST",$J,2,XPDI)) Q:'DA D "RTN","XPDET",70,0) .D ^DIK "RTN","XPDET",71,0) I $D(DDS) D MDEL^DDSUTL("^TMP(""DILIST"",$J,2)") "RTN","XPDET",72,0) S X="" "RTN","XPDET",73,0) K ^TMP("DILIST",$J) "RTN","XPDET",74,0) Q "RTN","XPDET",75,0) HELP ;executable help of ENTRIES in KERNEL FILE multiple "RTN","XPDET",76,0) N D,DIC,DIE,DIX,DIY,DO,DZ,DS,X,Y "RTN","XPDET",77,0) ;file 9.8 is routine file, check that routine exists "RTN","XPDET",78,0) S DIC=$$GR(D1),DIC(0)="M",X="??" Q:DIC="" S:D1=9.8 DIC("S")="I $T(^@$P(^(0),U))]""""" "RTN","XPDET",79,0) D ^DIC Q "RTN","XPDET",80,0) ; "RTN","XPDET",81,0) HELPO ;executable help of INSTALL ORDER in KERNEL FILES multiple "RTN","XPDET",82,0) N Y "RTN","XPDET",83,0) W !,"Numbers in use: ORDER FILE#" S Y=0 "RTN","XPDET",84,0) F S Y=$O(^XPD(9.6,D0,"KRN","AC",Y)) Q:'Y W !,?18,$J(Y,2),?28,$O(^(Y,0)) "RTN","XPDET",85,0) W ! Q "RTN","XPDET",86,0) ; "RTN","XPDET",87,0) HELPMB ;executable help of fields 10 & 11 in file 9.6 "RTN","XPDET",88,0) N D,DIC,DIE,DIX,DIY,DO,DZ,DS,X,Y "RTN","XPDET",89,0) S DIC="^XPD(9.6,",DIC(0)="M",X="??",DIC("S")="I '$P(^(0),U,3),Y'="_D0 "RTN","XPDET",90,0) D ^DIC Q "RTN","XPDET",91,0) ; "RTN","XPDET",92,0) SCRA(Y) ;screen of ACTION field in ENTRIES multiple in KERNEL FILES multiple, Y=action "RTN","XPDET",93,0) ;Y=0 - send, 1 - delete, 2 - link, 3 - merge, 4 - attach, 5 - disable "RTN","XPDET",94,0) ;all entries can send to site "RTN","XPDET",95,0) Q:'Y 1 "RTN","XPDET",96,0) ;.5=function file, can't delete, all others can "RTN","XPDET",97,0) I Y=1 Q (D1'=.5) "RTN","XPDET",98,0) ;then rest of code check if it is a Option or Protocal and can have MENU ITEMS "RTN","XPDET",99,0) Q:D1'=19&(D1'=101) 0 "RTN","XPDET",100,0) ;only Options and Protocol can disable "RTN","XPDET",101,0) Q:Y=5 1 "RTN","XPDET",102,0) N FGR,X,XPDF,XPDT,XPDY,XPDZ "RTN","XPDET",103,0) ;get X=name, FGR=global reference, XPDF=file # "RTN","XPDET",104,0) S XPDY=Y,XPDF=D1,X=$P(^XPD(9.6,D0,"KRN",D1,"NM",D2,0),U),FGR=$$FILE^XPDV(D1) "RTN","XPDET",105,0) Q:X="" 0 "RTN","XPDET",106,0) ;X=ien of protocol or option "RTN","XPDET",107,0) S X=+$O(@FGR@("B",X,0)) Q:'X 0 "RTN","XPDET",108,0) ;get type "RTN","XPDET",109,0) S XPDT=$P($G(@FGR@(X,0)),U,4) "RTN","XPDET",110,0) ;all Options and Protocols, except Event Drivers, can be attached "RTN","XPDET",111,0) I XPDY=4 Q '(XPDF=101&(XPDT="E")) "RTN","XPDET",112,0) ;Protocol and Type is Subscriber can't do anything else "RTN","XPDET",113,0) I XPDF=101,XPDT="S" Q 0 "RTN","XPDET",114,0) ;if it has SUBSCRIBERS, node 775 then ok "RTN","XPDET",115,0) I $O(@FGR@(X,775,0)) Q 1 "RTN","XPDET",116,0) ;if type is menu,potocol,protocol menu,limited,extended,window suite "RTN","XPDET",117,0) I "MOQLXZ"[$P($G(@FGR@(X,0)),U,4) Q 1 "RTN","XPDET",118,0) ;if it has ITEMs, node 10 then ok "RTN","XPDET",119,0) I $O(@FGR@(X,10,0)) Q 1 "RTN","XPDET",120,0) Q 0 "RTN","XPDET",121,0) ; "RTN","XPDET",122,0) ;only Fileman templates need to know what file they are associated with. "RTN","XPDET",123,0) ;this value is also triggered to field .02 in the DD. "RTN","XPDET",124,0) TX(X,Y) ;X=template name, Y=file # "RTN","XPDET",125,0) Q X_" FILE #"_Y "RTN","XPDET",126,0) ; "RTN","XPDET",127,0) TF(F) ;F=file, return field of file# for templates "RTN","XPDET",128,0) Q $S(F>.403:"",F<.403:4,1:7) "RTN","XPDET",129,0) ; "RTN","XPDET",130,0) GR(X) Q $G(^DIC(X,0,"GL")) "RTN","XPDET",131,0) ; "RTN","XPDET",132,0) ;screens checks that X is not already in the ENTRIES multiple "RTN","XPDET",133,0) SCR(Y) ;screen logic for ENTRIES multiple in file 9.6 "RTN","XPDET",134,0) N %,X,Z "RTN","XPDET",135,0) S Z=^(0),X=$P(Z,U) "RTN","XPDET",136,0) ;FM files are less than .44 "RTN","XPDET",137,0) I XPDF<.44 D Q:X="" 0 "RTN","XPDET",138,0) .S %=$S(XPDF=.403:$P(Z,U,8),1:$P(Z,U,4)),X=X_" FILE #"_% "RTN","XPDET",139,0) .S:XPDF'=.403&($P(Z,U,8)>2) %=0 S:'% X="" "RTN","XPDET",140,0) ;routine must exist and must be type 'R' "RTN","XPDET",141,0) I XPDF=9.8 Q:$T(^@X)=""!($P(Z,U,2)'="R") 0 "RTN","XPDET",142,0) Q '$D(@(XPDIC_"""B"",X)")) "RTN","XPDET",143,0) ; "RTN","XPDET",144,0) ;screen checks that X is not in the exclude list, XPDN(0) "RTN","XPDET",145,0) SCR1(Y) ;screen logic for exclude list "RTN","XPDET",146,0) N %,X "RTN","XPDET",147,0) ;if name X is in the exclude list, XPDN(0,X), then fail "RTN","XPDET",148,0) S Y(0)=^(0),X=$P(Y(0),U) Q:$D(XPDN(0,X)) 0 "RTN","XPDET",149,0) ;check if X is refered in the namespace by check the subscript "RTN","XPDET",150,0) ;before X, if sub exist and $P(X,sub)="" then it is part of the "RTN","XPDET",151,0) ;namespace, fail and return 0 "RTN","XPDET",152,0) S %=$O(XPDN(0,X),-1) I $L(%) Q:$P(X,%)="" 0 "RTN","XPDET",153,0) Q $$SCR(.Y) "RTN","XPDET",154,0) ; "RTN","XPDET",155,0) ;screen on PACKAGE LINK field in file 9.6, "RTN","XPDET",156,0) PCK(Y) ;check Package File name, Y=ien in package file "RTN","XPDET",157,0) N %,Y,Z "RTN","XPDET",158,0) S Z=^(0) "RTN","XPDET",159,0) ;DA is undef when you are adding a new Build without a version number "RTN","XPDET",160,0) Q:'$D(^XPD(9.6,+$G(DA),0)) 1 "RTN","XPDET",161,0) S Y=$L($P(Z,U)),%=$P(^XPD(9.6,DA,0),U),%=$$PKG^XPDUTL(%) "RTN","XPDET",162,0) Q $P(Z,U)=$E(%,1,Y)!($P(Z,U,2)=%) "RTN","XPDET",163,0) VOLE(X) ;input transform for VOLUME SET multiple in INSTALL file "RTN","XPDET",164,0) ;X=user input "RTN","XPDET",165,0) N D,DD,DIC,DICR,DIX,DIY,DO,DS,XPD,Y,% "RTN","XPDET",166,0) ;(0;11)=SIGNON/PRODUCTION "RTN","XPDET",167,0) S DIC(0)="QEMZ",DIC="^%ZIS(14.5,",DIC("S")="I $P(^(0),U,11)" "RTN","XPDET",168,0) D ^DIC K:Y<0 X Q:'$D(X) "RTN","XPDET",169,0) S X=Y(0,0) "RTN","XPDET",170,0) Q "RTN","XPDET",171,0) VOLH ;executable help for VOLUME SET multiple in INSTALL file "RTN","XPDET",172,0) N D,DD,DIC,DIE,DIX,DIY,DO,DS,DZ,X,Y,% "RTN","XPDET",173,0) S X="??",DIC(0)="QEMZ",DIC="^%ZIS(14.5,",DIC("S")="I $P(^(0),U,11)" "RTN","XPDET",174,0) D ^DIC "RTN","XPDET",175,0) Q "RTN","XPDET",176,0) ID97 ;identifier for Install file "RTN","XPDET",177,0) N XPDET,XPD,XPD0,XPD1,XPD2,XPD9 "RTN","XPDET",178,0) S XPD0=$G(^(0)),XPD1=$G(^(1)),XPD2=$G(^(2)),XPD9=$P(XPD0,U,9),XPD="" Q:XPD9="" "RTN","XPDET",179,0) D "RTN","XPDET",180,0) .;Loaded, get DATE LOADED "RTN","XPDET",181,0) .I 'XPD9 S XPD=$$FMTE^XLFDT($P(XPD0,U,3),2) Q "RTN","XPDET",182,0) .Q:XPD9>4 "RTN","XPDET",183,0) .;Started, get INSTALL START TIME "RTN","XPDET",184,0) .I XPD9=2 S XPD=$$FMTE^XLFDT($P(XPD1,U),2) Q "RTN","XPDET",185,0) .;Completed or De-Installed, get INSTALL COMPLETE TIME "RTN","XPDET",186,0) .I XPD9>2 S XPD=$$FMTE^XLFDT($P(XPD1,U,3),2) Q "RTN","XPDET",187,0) .;Queued, get QUEUED TASK NUMBER "RTN","XPDET",188,0) .I XPD9=1 S XPD="#"_$P(XPD0,U,6) Q "RTN","XPDET",189,0) ;S XPDET(1)=" "_$$EXTERNAL^DILFD(9.7,.02,"",XPD9)_" "_XPD,XPDET(1,"F")="?0" "RTN","XPDET",190,0) S XPDET(1)=" "_XPD,XPDET(1,"F")="?0" "RTN","XPDET",191,0) S:XPD2]"" XPDET(2)="=> "_$E(XPD2,1,70),XPDET(2,"F")="!?5" "RTN","XPDET",192,0) D EN^DDIOL(.XPDET) "RTN","XPDET",193,0) Q "RTN","XPDET",194,0) ;not being used right now, "RTN","XPDET",195,0) DEL97(Y) ;delete access to file 9.7, 0-can't delete, 1-can "RTN","XPDET",196,0) N % "RTN","XPDET",197,0) S %=$P(^XPD(9.7,Y,0),U,9) "RTN","XPDET",198,0) Q $S(%=3:1,%=2:0,$D(^XPD(9.7,"ASP",Y,1,Y)):1,1:0) "RTN","XPDET",199,0) ; "RTN","XPDET",200,0) PAR964 ;Clear other fields if file is partial. Called from within form "RTN","XPDET",201,0) D PUT^DDSVAL(DIE,.DA,222.7,"n","","I") ;Send data NO "RTN","XPDET",202,0) D PUT^DDSVAL(DIE,.DA,222.5,"","","I") ;Resolve pointer "RTN","XPDET",203,0) D PUT^DDSVAL(DIE,.DA,222.8,"","","I") ;Sites Data "RTN","XPDET",204,0) D PUT^DDSVAL(DIE,.DA,222.9,"n","","I") ;User Override "RTN","XPDET",205,0) D PUT^DDSVAL(DIE,.DA,224,"","","I") ;Data Screen "RTN","XPDET",206,0) Q "RTN","XPDET",207,0) ; "RTN","XPDIA1") 0^6^B72722233^B72175864 "RTN","XPDIA1",1,0) XPDIA1 ;SFISC/RSD - Install Pre/Post Actions for Kernel files cont. ;06/24/2008 "RTN","XPDIA1",2,0) ;;8.0;KERNEL;**2,44,51,58,68,85,131,146,182,229,302,399,507,539**;Jul 10, 1995;Build 11 "RTN","XPDIA1",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","XPDIA1",4,0) Q "RTN","XPDIA1",5,0) HLPF1 ;help frames file pre "RTN","XPDIA1",6,0) K ^TMP($J,"XPD") "RTN","XPDIA1",7,0) Q "RTN","XPDIA1",8,0) HLPE1 ;entry pre "RTN","XPDIA1",9,0) S ^TMP($J,"XPD",DA)="" K ^DIC(9.2,DA,1),^(2),^(3),^(10) "RTN","XPDIA1",10,0) Q "RTN","XPDIA1",11,0) HLPF2 ;file post "RTN","XPDIA1",12,0) N DA,DIK,I,X,Y,Y0 "RTN","XPDIA1",13,0) ;need to send error message, need to setup message "RTN","XPDIA1",14,0) S DA=0,DIK=DIC F S DA=$O(^TMP($J,"XPD",DA)) Q:'DA D "RTN","XPDIA1",15,0) .;repoint Related Frame (2;0) "RTN","XPDIA1",16,0) .S I=0 F S I=$O(^DIC(9.2,DA,2,I)) Q:'I S Y0=$G(^(I,0)),Y=$$LK^XPDIA("^DIC(9.2)",$P(Y0,U,2)),$P(^DIC(9.2,DA,2,I,0),U,2)=Y "RTN","XPDIA1",17,0) .;repoint OBJECT (10;0) "RTN","XPDIA1",18,0) .S (I,X)=0 F S I=$O(^DIC(9.2,DA,10,I)) Q:'I S Y0=$G(^(I,0)) D "RTN","XPDIA1",19,0) ..S Y=$$LK^XPDIA("^MAG",$P(Y0,U)) S:Y $P(^DIC(9.2,DA,10,I,0),U)=Y,X=X+1_U_I "RTN","XPDIA1",20,0) ..K:'Y ^DIC(9.2,DA,10,I) "RTN","XPDIA1",21,0) .I X S $P(^DIC(9.2,DA,10,0),U,3,4)=$P(X,U,2)_U_+X "RTN","XPDIA1",22,0) .D IX1^DIK "RTN","XPDIA1",23,0) K ^TMP($J,"XPD") "RTN","XPDIA1",24,0) Q "RTN","XPDIA1",25,0) HLPDEL ;help frame delete "RTN","XPDIA1",26,0) N DA,DIK,XPDI,XPDJ "RTN","XPDIA1",27,0) S XPDI=0 "RTN","XPDIA1",28,0) F S XPDI=$O(^TMP($J,"XPDEL",XPDI)),XPDJ=0 Q:'XPDI D "RTN","XPDIA1",29,0) .S DIK="^DIC(9.2,XPDJ,2," "RTN","XPDIA1",30,0) .;check other frames that point to this one "RTN","XPDIA1",31,0) .F S XPDJ=$O(^DIC(9.2,"AE",XPDI,XPDJ)) Q:'XPDJ S Z=$O(^(XPDJ,0)) D:Z "RTN","XPDIA1",32,0) ..K DA S DA=Z,DA(1)=XPDJ D ^DIK "RTN","XPDIA1",33,0) .;delete this frame "RTN","XPDIA1",34,0) .K DA S DA=XPDI,DIK="^DIC(9.2," D ^DIK "RTN","XPDIA1",35,0) Q "RTN","XPDIA1",36,0) BULE1 ;bulletin entry pre "RTN","XPDIA1",37,0) N X,I S I=0 "RTN","XPDIA1",38,0) ;save current Mail Groups (2) "RTN","XPDIA1",39,0) I $G(^XMB(3.6,DA,2,0))]"" S X(0)=^(0) F S I=$O(^XMB(3.6,DA,2,I)) Q:'I S X(I)=$G(^(I,0)) "RTN","XPDIA1",40,0) K ^XMB(3.6,DA) "RTN","XPDIA1",41,0) ;after killing data, put back Mail Groups before data merge "RTN","XPDIA1",42,0) I $D(X) S ^XMB(3.6,DA,2,0)=X(0),I=0 F S I=$O(X(I)) Q:'I S ^XMB(3.6,DA,2,I,0)=X(I) "RTN","XPDIA1",43,0) Q "RTN","XPDIA1",44,0) BULDEL ;del bulletins "RTN","XPDIA1",45,0) D DELIEN^XPDUTL1(3.6,$G(%)) "RTN","XPDIA1",46,0) Q "RTN","XPDIA1",47,0) MAILGF1 ;mail groups file pre "RTN","XPDIA1",48,0) K ^TMP($J,"XPD") "RTN","XPDIA1",49,0) Q "RTN","XPDIA1",50,0) MAILGE1 ;mail group entry pre "RTN","XPDIA1",51,0) N I,J "RTN","XPDIA1",52,0) S ^TMP($J,"XPD",DA)="" "RTN","XPDIA1",53,0) ;save MEMBER GROUPS (5;0) "RTN","XPDIA1",54,0) I $O(^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,5,0)) M ^TMP($J,"XPD",DA,5)=^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,5) K ^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,5) "RTN","XPDIA1",55,0) ;save MEMBER - REMOTE (6;0) "RTN","XPDIA1",56,0) I $O(^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,6,0)) M ^TMP($J,"XPD",DA,6)=^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,6) K ^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,6) "RTN","XPDIA1",57,0) ;if there is a new Description, kill the old Description "RTN","XPDIA1",58,0) K:$O(^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,2,0)) ^XMB(3.8,DA,2) "RTN","XPDIA1",59,0) ;I=current mail group, J=incoming mail group "RTN","XPDIA1",60,0) S I=^XMB(3.8,DA,0),J=^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,0) "RTN","XPDIA1",61,0) ;save REFERENCE COUNT (0;4) & LAST REFERENCED (0;5) "RTN","XPDIA1",62,0) S:$P(I,U,4) $P(J,U,4)=$P(I,U,4) S:$P(I,U,5) $P(J,U,5)=$P(I,U,5) "RTN","XPDIA1",63,0) ;check COORDINATOR (0;7), bring in one that was asked during install question "RTN","XPDIA1",64,0) D "RTN","XPDIA1",65,0) .;get the existing coordinator, and set it "RTN","XPDIA1",66,0) .I $P(I,U,7) S $P(J,U,7)=$P(I,U,7) "RTN","XPDIA1",67,0) .;check if there is a pre-question "RTN","XPDIA1",68,0) .S %=$O(^XPD(9.7,XPDA,"QUES","B","XPM"_OLDA_"#1",0)) Q:'% "RTN","XPDIA1",69,0) .;if they entered a coordinator, then set it "RTN","XPDIA1",70,0) .I $G(^XPD(9.7,XPDA,"QUES",%,1)) S $P(J,U,7)=^(1) "RTN","XPDIA1",71,0) S ^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,0)=J,I=$G(^XMB(3.8,DA,3)) "RTN","XPDIA1",72,0) ;save ORGANIZER (3;1) "RTN","XPDIA1",73,0) I $P(I,U) S $P(^XTMP("XPDI",XPDA,"KRN",3.8,OLDA,3),U)=$P(I,U) "RTN","XPDIA1",74,0) Q "RTN","XPDIA1",75,0) MAILGF2 ;mail group file post "RTN","XPDIA1",76,0) N DA,DIK,XPDMDA,XPDI,Y "RTN","XPDIA1",77,0) S XPDMDA=0,DIK="^XMB(3.8," "RTN","XPDIA1",78,0) F S XPDMDA=$O(^TMP($J,"XPD",XPDMDA)) Q:'XPDMDA D "RTN","XPDIA1",79,0) .;merge & repoint MEMBER GROUP (5;0) "RTN","XPDIA1",80,0) .S XPDI=0 "RTN","XPDIA1",81,0) .F S XPDI=$O(^TMP($J,"XPD",XPDMDA,5,XPDI)) Q:'XPDI S Y=$P($G(^(XPDI,0)),U) D:Y]"" ADD^XPDIA(3.811,XPDMDA,Y) "RTN","XPDIA1",82,0) .;merge & repoint MEMBER - REMOTE (6;0) "RTN","XPDIA1",83,0) .S XPDI=0 "RTN","XPDIA1",84,0) .F S XPDI=$O(^TMP($J,"XPD",XPDMDA,6,XPDI)) Q:'XPDI S Y=$P($G(^(XPDI,0)),U) D:Y]"" ADD^XPDIA(3.812,XPDMDA,Y) "RTN","XPDIA1",85,0) .S DA=XPDMDA D IX1^DIK "RTN","XPDIA1",86,0) K ^TMP($J,"XPD") "RTN","XPDIA1",87,0) Q "RTN","XPDIA1",88,0) MAILGDEL(RT) ;Mail Group delete "RTN","XPDIA1",89,0) D DELPTR^XPDUTL1(3.8,RT) ;Delete any pointer entries "RTN","XPDIA1",90,0) D DELIEN^XPDUTL1(3.8,RT) ;Delete the entries "RTN","XPDIA1",91,0) Q "RTN","XPDIA1",92,0) HLAPF1 ;HL7 application parameter #771 file pre "RTN","XPDIA1",93,0) K ^TMP($J,"XPD") "RTN","XPDIA1",94,0) Q "RTN","XPDIA1",95,0) HLAPE1 ;HL7 application parameter #771 entry pre "RTN","XPDIA1",96,0) N I,J "RTN","XPDIA1",97,0) S ^TMP($J,"XPD",DA)="" "RTN","XPDIA1",98,0) S I=^HL(771,DA,0),J=^XTMP("XPDI",XPDA,"KRN",771,OLDA,0) "RTN","XPDIA1",99,0) ;save FACILITY NAME (0;3) "RTN","XPDIA1",100,0) S:$P(I,U,3)]"" $P(J,U,3)=$P(I,U,3) "RTN","XPDIA1",101,0) ;repoint MAIL GROUP (0;4) "RTN","XPDIA1",102,0) S:$P(J,U,4)]"" $P(J,U,4)=$$LK^XPDIA("^XMB(3.8)",$P(J,U,4)) "RTN","XPDIA1",103,0) ;repoint COUNTRY CODE (0;7) "RTN","XPDIA1",104,0) S:$P(J,U,7)]"" $P(J,U,7)=$$LK^XPDIA("^HL(779.004)",$P(J,U,7)) "RTN","XPDIA1",105,0) S ^XTMP("XPDI",XPDA,"KRN",771,OLDA,0)=J "RTN","XPDIA1",106,0) ;remove HL7 SEGMENT (SEG;0), HL7 MESSAGE (MSG;0) "RTN","XPDIA1",107,0) K ^HL(771,DA,"SEG"),^("MSG") "RTN","XPDIA1",108,0) Q "RTN","XPDIA1",109,0) HLAPF2 ;HL7 application parameter #771 file post "RTN","XPDIA1",110,0) N DA,DIK,XPDI,X,Y "RTN","XPDIA1",111,0) S DA=0,DIK="^HL(771," "RTN","XPDIA1",112,0) F S DA=$O(^TMP($J,"XPD",DA)) Q:'DA D "RTN","XPDIA1",113,0) .;repoint HL7 SEGMENT (SEG;0) "RTN","XPDIA1",114,0) .S XPDI=0 "RTN","XPDIA1",115,0) .F S XPDI=$O(^HL(771,DA,"SEG",XPDI)) Q:'XPDI S Y=$P($G(^(XPDI,0)),U) D "RTN","XPDIA1",116,0) ..S X=$$LK^XPDIA("^HL(771.3)",$P(Y,U)) "RTN","XPDIA1",117,0) ..I X]"" S $P(^HL(771,DA,"SEG",XPDI,0),U)=X Q "RTN","XPDIA1",118,0) ..K ^HL(771,DA,"SEG",XPDI) "RTN","XPDIA1",119,0) .;repoint HL7 MESSAGE (MSG;0) "RTN","XPDIA1",120,0) .S XPDI=0 "RTN","XPDIA1",121,0) .F S XPDI=$O(^HL(771,DA,"MSG",XPDI)) Q:'XPDI S Y=$P($G(^(XPDI,0)),U) D "RTN","XPDIA1",122,0) ..S X=$$LK^XPDIA("^HL(771.3)",$P(Y,U)) "RTN","XPDIA1",123,0) ..I X]"" S $P(^HL(771,DA,"MSG",XPDI,0),U)=X Q "RTN","XPDIA1",124,0) ..K ^HL(771,DA,"MSG",XPDI) "RTN","XPDIA1",125,0) .D IX1^DIK "RTN","XPDIA1",126,0) K ^TMP($J,"XPD") "RTN","XPDIA1",127,0) Q "RTN","XPDIA1",128,0) HLLLPE ;HL7 lower level protocol #869.2 entry pre "RTN","XPDIA1",129,0) N I,J,L,TMP,Y "RTN","XPDIA1",130,0) S L=$P(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,0),U),I=0 "RTN","XPDIA1",131,0) ;loop thru logical links and find those pointing to this llp "RTN","XPDIA1",132,0) F S I=$O(^XTMP("XPDI",XPDA,"KRN",870,I)) Q:'I S J=$G(^(I,0)) D "RTN","XPDIA1",133,0) . Q:$P(J,U,3)'=L "RTN","XPDIA1",134,0) . ;save llp into tmp, get the llp type field "RTN","XPDIA1",135,0) . M TMP=^XTMP("XPDI",XPDA,"KRN",869.2,OLDA) S Y=$P(TMP(0),U,2) "RTN","XPDIA1",136,0) . K TMP(-1),TMP(0) "RTN","XPDIA1",137,0) . M ^XTMP("XPDI",XPDA,"KRN",870,I)=TMP S $P(^(I,0),U,3)=Y "RTN","XPDIA1",138,0) S I=$P(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,0),U,2) "RTN","XPDIA1",139,0) ;repoint LLP TYPE (0;2) "RTN","XPDIA1",140,0) S:I]"" $P(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,0),U,2)=$$LK^XPDIA("^HLCS(869.1)",I) "RTN","XPDIA1",141,0) S I=$P($G(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,100)),U) "RTN","XPDIA1",142,0) ;repoint MAIL GROUP (100;1) "RTN","XPDIA1",143,0) S:I]"" $P(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,100),U)=$$LK^XPDIA("^XMB(3.8)",I) "RTN","XPDIA1",144,0) ;save HLLP DEVICE (200;1) "RTN","XPDIA1",145,0) S I=$G(^HLCS(869.2,DA,200)) "RTN","XPDIA1",146,0) S:I $P(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,200),U)=$P(I,U) "RTN","XPDIA1",147,0) ;save X3.28 DEVICE (300;1) "RTN","XPDIA1",148,0) S I=$G(^HLCS(869.2,DA,300)) "RTN","XPDIA1",149,0) S:I $P(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,300),U)=$P(I,U) "RTN","XPDIA1",150,0) ;save TCP/IP Start-up Node (400;6) "RTN","XPDIA1",151,0) S I=$G(^HLCS(869.2,DA,400)) "RTN","XPDIA1",152,0) S:I $P(^XTMP("XPDI",XPDA,"KRN",869.2,OLDA,400),U,6)=$P(I,U,6) "RTN","XPDIA1",153,0) Q "RTN","XPDIA1",154,0) HLLLE ;HL7 logical link #870 entry pre "RTN","XPDIA1",155,0) N I,J,K,L,Y "RTN","XPDIA1",156,0) S I=^HLCS(870,DA,0),J=^XTMP("XPDI",XPDA,"KRN",870,OLDA,0) "RTN","XPDIA1",157,0) ;repoint INSTITUTION (0;2) "RTN","XPDIA1",158,0) I $P(J,U,2)]"" S Y=$$LK^XPDIA("^DIC(4)",$P(J,U,2)) D:Y="" S $P(J,U,2)=Y "RTN","XPDIA1",159,0) .D BMES^XPDUTL(" Couldn't resolve Institution "_$P(J,U,2)_" for Logical Link "_$P(^HLCS(870,DA,0),U)) "RTN","XPDIA1",160,0) ;repoint LLP TYPE (0;3) "RTN","XPDIA1",161,0) S:$P(J,U,3)]"" $P(J,U,3)=$$LK^XPDIA("^HLCS(869.1)",$P(J,U,3)) "RTN","XPDIA1",162,0) ;repoint MAILMAN DOMAIN (0;7) "RTN","XPDIA1",163,0) I $P(J,U,7)]"" S Y=$$LK^XPDIA("^DIC(4.2)",$P(J,U,7)) D:Y="" S $P(J,U,7)=Y "RTN","XPDIA1",164,0) .D BMES^XPDUTL(" Couldn't resolve Domain "_$P(J,U,7)_" for Logical Link "_$P(^HLCS(870,DA,0),U)) "RTN","XPDIA1",165,0) ;save node 0; pieces 4,5,6,7,9,10,11,12,16,19,21 "RTN","XPDIA1",166,0) F L=4:1:7,9:1:12,16,19,21 S:$P(I,U,L)]"" $P(J,U,L)=$P(I,U,L) "RTN","XPDIA1",167,0) ;set SHUTDOWN LLP (0;15) no for multi-listener and yes for all else "RTN","XPDIA1",168,0) S Y=$P($G(^HLCS(870,DA,400)),U,3) S:Y]"" $P(J,U,15)=$S(Y="M":0,1:1) "RTN","XPDIA1",169,0) S ^XTMP("XPDI",XPDA,"KRN",870,OLDA,0)=J "RTN","XPDIA1",170,0) S I=$P($G(^XTMP("XPDI",XPDA,"KRN",870,OLDA,100)),U) "RTN","XPDIA1",171,0) ;repoint MAIL GROUP (100;1) "RTN","XPDIA1",172,0) S:I]"" $P(^XTMP("XPDI",XPDA,"KRN",870,OLDA,100),U)=$$LK^XPDIA("^XMB(3.8)",I) "RTN","XPDIA1",173,0) ;save data from site on nodes 200,300,400,500 "RTN","XPDIA1",174,0) F L=200,300,400,500 S I=$G(^HLCS(870,DA,L)) D:I]"" "RTN","XPDIA1",175,0) . S J=$G(^XTMP("XPDI",XPDA,"KRN",870,OLDA,L)) Q:J="" "RTN","XPDIA1",176,0) . ;check local data (I) and if exist set incomming data (J) "RTN","XPDIA1",177,0) . F K=1:1:10 S Y=$P(I,U,K) S:Y]"" $P(J,U,K)=Y "RTN","XPDIA1",178,0) . S ^XTMP("XPDI",XPDA,"KRN",870,OLDA,L)=J "RTN","XPDIA1",179,0) ;remove following values when a Test site (not a Production site) "RTN","XPDIA1",180,0) D:$P($$PARAM^HLCS2,U,3)'="P" "RTN","XPDIA1",181,0) . ;MAILMAN DOMAIN (0;7), DNS DOMAIN (0;8) "RTN","XPDIA1",182,0) . S $P(^XTMP("XPDI",XPDA,"KRN",870,OLDA,0),U,7,8)="^" "RTN","XPDIA1",183,0) . ;TCP/IP ADDRESS (400,1), IPV6 ADDRESS (500,1) "RTN","XPDIA1",184,0) . S J=$G(^XTMP("XPDI",XPDA,"KRN",870,OLDA,400)) "RTN","XPDIA1",185,0) . S:J]"" $P(^XTMP("XPDI",XPDA,"KRN",870,OLDA,400),U)="" "RTN","XPDIA1",186,0) . S J=$G(^XTMP("XPDI",XPDA,"KRN",870,OLDA,500)) "RTN","XPDIA1",187,0) . S:J]"" $P(^XTMP("XPDI",XPDA,"KRN",870,OLDA,500),U)="" "RTN","XPDIA1",188,0) Q "RTN","XPDIA1",189,0) KEYF1 ;SECURITY KEY file pre "RTN","XPDIA1",190,0) K ^TMP($J,"XPD") "RTN","XPDIA1",191,0) Q "RTN","XPDIA1",192,0) KEYE1 ;SECURITY KEY file entry pre "RTN","XPDIA1",193,0) S ^TMP($J,"XPD",DA)="" "RTN","XPDIA1",194,0) Q "RTN","XPDIA1",195,0) KEYF2 ;SECURITY KEY file post "RTN","XPDIA1",196,0) N DA,DIK,I,X,Y,Y0 "RTN","XPDIA1",197,0) ;Repoint fields "RTN","XPDIA1",198,0) S DA=0,DIK=DIC "RTN","XPDIA1",199,0) F S DA=$O(^TMP($J,"XPD",DA)) Q:'DA D "RTN","XPDIA1",200,0) . ;Repoint SUBORDINATE (3) "RTN","XPDIA1",201,0) . S I=0 F S I=$O(^DIC(19.1,DA,3,I)) Q:'I S Y0=$G(^(I,0)) D "RTN","XPDIA1",202,0) . . S Y=$$LK^XPDIA("^DIC(19.1)",$P(Y0,U)) S:Y $P(^DIC(19.1,DA,3,I,0),U)=Y "RTN","XPDIA1",203,0) . ;MUTUALLY EXCLUSIVE KEYS (5) "RTN","XPDIA1",204,0) . S (I,X)=0 F S I=$O(^DIC(19.1,DA,5,I)) Q:'I S Y0=$G(^(I,0)) D "RTN","XPDIA1",205,0) . . S Y=$$LK^XPDIA("^DIC(19.1)",$P(Y0,U)) S:Y $P(^DIC(19.1,DA,5,I,0),U)=Y "RTN","XPDIA1",206,0) . D IX1^DIK "RTN","XPDIA1",207,0) K ^TMP($J,"XPD") "RTN","XPDIA1",208,0) Q "RTN","XPDIA1",209,0) KEYDEL ;del security keys "RTN","XPDIA1",210,0) N XPDI S XPDI=0 "RTN","XPDIA1",211,0) F S XPDI=$O(^TMP($J,"XPDEL",XPDI)) Q:'XPDI D DEL^XPDKEY(XPDI) "RTN","XPDIA1",212,0) Q "RTN","XPDIA1",213,0) LME1 ;List Templates entry pre "RTN","XPDIA1",214,0) ;kill old entry before data merge "RTN","XPDIA1",215,0) K ^SD(409.61,DA) "RTN","XPDIA1",216,0) Q "RTN","XPDIA1",217,0) LMDEL ;del list manager templates "RTN","XPDIA1",218,0) D DELIEN^XPDUTL1(409.61,$NA(^TMP($J,"XPDEL"))) "RTN","XPDIA1",219,0) Q "RTN","XPDIA1",220,0) RPCDEL ;del Kernel RPCs "RTN","XPDIA1",221,0) D DELIEN^XPDUTL1(8994,$G(%)) "RTN","XPDIA1",222,0) Q "RTN","XPDIA1",223,0) CRC32PE ;pre entry for Kernel RPCs CRC32 "RTN","XPDIA1",224,0) ;if there is a new Description, kill the old Description "RTN","XPDIA1",225,0) K:$O(^XTMP("XPDI",XPDA,"KRN",8994.2,OLDA,1,0)) ^XWB(8994.2,DA,1) "RTN","XPDIA1",226,0) Q "RTN","XPDIA1",227,0) CRC32DEL ;del Kernel RPCs CRC32 "RTN","XPDIA1",228,0) D DELIEN^XPDUTL1(8994.2,$G(%)) "RTN","XPDIA1",229,0) Q "RTN","XPDIA1",230,0) HLAPDEL(RT) ;del HL7 application parameter #771 "RTN","XPDIA1",231,0) D DELIEN^XPDUTL1(771,RT) "RTN","XPDIA1",232,0) Q "RTN","XPDIA1",233,0) HLLLDEL(RT) ;del HL7 logical link #870 "RTN","XPDIA1",234,0) N DA,DIK,XPDI,XPDJ,Y "RTN","XPDIA1",235,0) S XPDI=0 "RTN","XPDIA1",236,0) ;loop thru protocols, #101, get LL field, 770.7 (700;7) "RTN","XPDIA1",237,0) F S XPDI=$O(^ORD(101,XPDI)) Q:'XPDI S Y=$P($G(^(XPDI,700)),U,7) D:Y "RTN","XPDIA1",238,0) . Q:'$D(^TMP($J,"XPDEL",Y)) "RTN","XPDIA1",239,0) . K XPDJ S XPDJ(101,XPDI_",",770.7)="@" "RTN","XPDIA1",240,0) . D FILE^DIE("","XPDJ") "RTN","XPDIA1",241,0) ;subscription, #774 "RTN","XPDIA1",242,0) F S XPDI=$O(TMP($J,"XPDEL",XPDI)) Q:'XPDI D:$D(^HLS(774,"C",XPDI)) "RTN","XPDIA1",243,0) . S XPDJ=0 F S XPDJ=$O(^HLS(774,"C",XPDI,XPDJ)) "RTN","XPDIA1",244,0) D DELIEN^XPDUTL1(870,RT) "RTN","XPDIA1",245,0) Q "RTN","XPDIA1",246,0) HLOE ;HLO application registry #779.2 "RTN","XPDIA1",247,0) N I,J,K,L,Y "RTN","XPDIA1",248,0) S I=^HLD(779.2,DA,0),J=^XTMP("XPDI",XPDA,"KRN",779.2,OLDA,0) "RTN","XPDIA1",249,0) ;repoint APPLICATION SPECIFIC LISTENER (0;9) "RTN","XPDIA1",250,0) I $P(J,U,9)]"" S Y=$$LK^XPDIA("^HLCS(870)",$P(J,U,9)) D:Y="" S $P(J,U,9)=Y "RTN","XPDIA1",251,0) .D BMES^XPDUTL(" Couldn't resolve APPLICATION SPECIFIC LISTENER "_$P(J,U,2)_" HLO APPLICATION "_$P(I,U)) "RTN","XPDIA1",252,0) S ^XTMP("XPDI",XPDA,"KRN",779.2,OLDA,0)=J "RTN","XPDIA1",253,0) ;repoint Package File Link (2;1) "RTN","XPDIA1",254,0) S J=$P($G(^XTMP("XPDI",XPDA,"KRN",779.2,OLDA,2)),U) "RTN","XPDIA1",255,0) S:J]"" $P(^XTMP("XPDI",XPDA,"KRN",779.2,OLDA,2),U)=$$LK^XPDIA("^DIC(9.4)",J) "RTN","XPDIA1",256,0) ;save data from site on nodes 200,300,400 "RTN","XPDIA1",257,0) Q "RTN","XPDIST") 0^9^B15156441^B15011055 "RTN","XPDIST",1,0) XPDIST ;SFISC/RSD - site tracking; 06/01/2006 ;03/05/2008 "RTN","XPDIST",2,0) ;;8.0;KERNEL;**66,108,185,233,350,393,486,539**;Jul 10, 1995;Build 11 "RTN","XPDIST",3,0) ; Per VHA Directive 2004-038, this routine should not be modified. "RTN","XPDIST",4,0) ;Returns ""=failed, XMZ=sent "RTN","XPDIST",5,0) ;D0=ien in file 9.7, XPY=national site tracking^address(optional) "RTN","XPDIST",6,0) EN(D0,XPY) ;send message "RTN","XPDIST",7,0) N %,DIFROM,XPD,XPD0,XPD1,XPD2,XPDV,XPZ,X,X1,Z,Y,XPD6,XPDTRACK "RTN","XPDIST",8,0) ;Get data needed "RTN","XPDIST",9,0) I '$D(^XPD(9.7,$G(D0),0)) D BMES^XPDUTL(" INSTALL file entry missing") Q "" "RTN","XPDIST",10,0) ;p350 -add node 6 for the Test# and Seq#. -REM "RTN","XPDIST",11,0) S XPD0=^XPD(9.7,D0,0),XPD1=$G(^(1)),XPD2=$G(^(2)),XPD6=$G(^(6)) "RTN","XPDIST",12,0) I '$P(XPD0,U,2) D BMES^XPDUTL(" No link to PACKAGE file") Q "" "RTN","XPDIST",13,0) S XPD=$P($G(^DIC(9.4,+$P(XPD0,U,2),0)),U),XPDV=$$VER^XPDUTL($P(XPD0,U)) "RTN","XPDIST",14,0) I XPD="" D BMES^XPDUTL(" PACKAGE file entry missing") Q "" "RTN","XPDIST",15,0) ;XPZ(1)=start, XPZ(2)=completion date/time, XPZ(3)=run time "RTN","XPDIST",16,0) S XPZ(1)=$P(XPD1,U),XPZ(2)=$P(XPD1,U,3),XPZ(3)=$$FMDIFF^XLFDT(XPZ(2),XPZ(1),3),XPZ(1)=$$FMTE^XLFDT(XPZ(1)),XPZ(2)=$$FMTE^XLFDT(XPZ(2)) "RTN","XPDIST",17,0) D LOCAL "RTN","XPDIST",18,0) S XPDTRACK=$$TRACK "RTN","XPDIST",19,0) D REMEDY ;p350 -REM "RTN","XPDIST",20,0) Q $$FORUM() "RTN","XPDIST",21,0) LOCAL ;Send a message to local mail group "RTN","XPDIST",22,0) N XMY,XPDTEXT,XMTEXT,XMDUZ,XMSUB,XMZ "RTN","XPDIST",23,0) K ^TMP($J) "RTN","XPDIST",24,0) S X=$$MAILGRP^XPDUTL(XPD) Q:X="" "RTN","XPDIST",25,0) S XMY(X)="" D GETENV^%ZOSV "RTN","XPDIST",26,0) ;Message for users "RTN","XPDIST",27,0) S XPDTEXT(1,0)="PACKAGE INSTALL" "RTN","XPDIST",28,0) S XPDTEXT(2,0)="SITE: "_$G(^XMB("NETNAME")) "RTN","XPDIST",29,0) S XPDTEXT(3,0)="PACKAGE: "_XPD "RTN","XPDIST",30,0) S XPDTEXT(4,0)="VERSION: "_XPDV "RTN","XPDIST",31,0) S XPDTEXT(5,0)="Start time: "_XPZ(1) "RTN","XPDIST",32,0) S XPDTEXT(6,0)="Completion time: "_XPZ(2) "RTN","XPDIST",33,0) S XPDTEXT(7,0)="Environment: "_Y "RTN","XPDIST",34,0) S XPDTEXT(8,0)="Installed by: "_$P($G(^VA(200,+$P(XPD0,U,11),0)),U) "RTN","XPDIST",35,0) S XPDTEXT(9,0)="Install Name: "_$P(XPD0,U) "RTN","XPDIST",36,0) S XPDTEXT(10,0)="Distribution Date: "_$$FMTE^XLFDT($P(XPD1,U,4)) "RTN","XPDIST",37,0) S XMDUZ=$S($P(XPD0,U,11):+$P(XPD0,U,11),1:.5),XMTEXT="XPDTEXT(",XMSUB=$P(XPD0,U)_" INSTALLATION" "RTN","XPDIST",38,0) D ^XMD "RTN","XPDIST",39,0) Q "RTN","XPDIST",40,0) TRACK() ; Should VA track the installation of this patch at a national level? "RTN","XPDIST",41,0) Q:$G(XPY)="" 0 ; No - National site tracking was not requested "RTN","XPDIST",42,0) ;Quit if not VA production primary domain "RTN","XPDIST",43,0) I $G(^XMB("NETNAME"))'[".VA.GOV" D BMES^XPDUTL(" Not a VA primary domain") Q 0 "RTN","XPDIST",44,0) ;X ^%ZOSF("UCI") S %=^%ZOSF("PROD") "RTN","XPDIST",45,0) ;S:%'["," Y=$P(Y,",") "RTN","XPDIST",46,0) ;I Y'=% D BMES^XPDUTL(" Not a production UCI") Q "" "RTN","XPDIST",47,0) ; 486/GMB Replaced the above 3 lines with the following line: "RTN","XPDIST",48,0) I '$$PROD^XUPROD D BMES^XPDUTL(" Not a production UCI") Q 0 "RTN","XPDIST",49,0) Q 1 "RTN","XPDIST",50,0) REMEDY ;Send to Remedy Server - ESSRESOURCE@MED.VA.GOV *p350 -REM "RTN","XPDIST",51,0) Q:'XPDTRACK "RTN","XPDIST",52,0) N XMY,XPDTEXT,XMTEXT,XMDUZ,XMSUB,XMZ "RTN","XPDIST",53,0) K ^TMP($J) "RTN","XPDIST",54,0) S:XPY XMY("ESSRESOURCE@MED.VA.GOV")="" "RTN","XPDIST",55,0) S:$L($P(XPY,U,2)) XMY($P(XPY,U,2))="" "RTN","XPDIST",56,0) ;Message for server (all in one string) "RTN","XPDIST",57,0) ;XMTEXT=Type(1),Domain(2-65),Pkg(66-95),Version(96-125), "RTN","XPDIST",58,0) ; StartTime(126-147),CompleteTime(148-169),RunTime(170-177), "RTN","XPDIST",59,0) ; Date(178-199),InstalledBy(200-229),InstallName(230-259), "RTN","XPDIST",60,0) ; DistributionDate(260-281),Seq#(282-286), "RTN","XPDIST",61,0) ; PatchTestVersion(287-317) "RTN","XPDIST",62,0) ; "RTN","XPDIST",63,0) S X1=1_$G(^XMB("NETNAME")) ;Type is always "1"(1=patch,0=pkg). "RTN","XPDIST",64,0) S $E(X1,66,95)=XPD,$E(X1,96,125)=XPDV,$E(X1,126,147)=XPZ(1),$E(X1,148,169)=XPZ(2),$E(X1,170,177)=XPZ(3),$E(X1,178,199)=DT "RTN","XPDIST",65,0) S $E(X1,200,229)=$P($G(^VA(200,+$P(XPD0,U,11),0)),U),$E(X1,230,259)=$P(XPD0,U),$E(X1,260,281)=$P(XPD1,U,4),$E(X1,282,286)=$P(XPD6,U,2),$E(X1,287,317)=$P(XPD6,U) "RTN","XPDIST",66,0) S XPDTEXT(1,0)=X1 "RTN","XPDIST",67,0) S XMDUZ=$S($P(XPD0,U,11):+$P(XPD0,U,11),1:.5),XMTEXT="XPDTEXT(",XMSUB="KIDS-"_$P(XPD0,U)_" INSTALLATION" "RTN","XPDIST",68,0) D ^XMD "RTN","XPDIST",69,0) Q "RTN","XPDIST",70,0) FORUM() ;send to Server on FORUM "RTN","XPDIST",71,0) Q:'XPDTRACK "" "RTN","XPDIST",72,0) N XMY,XPDTEXT,XMTEXT,XMDUZ,XMSUB,XMZ "RTN","XPDIST",73,0) K ^TMP($J) "RTN","XPDIST",74,0) S:XPY XMY("S.A5CSTS@FORUM.VA.GOV")="" "RTN","XPDIST",75,0) S:$L($P(XPY,U,2)) XMY($P(XPY,U,2))="" "RTN","XPDIST",76,0) ;Message for server "RTN","XPDIST",77,0) S XPDTEXT(1,0)="PACKAGE INSTALL" "RTN","XPDIST",78,0) S XPDTEXT(2,0)="SITE: "_$G(^XMB("NETNAME")) "RTN","XPDIST",79,0) S XPDTEXT(3,0)="PACKAGE: "_XPD "RTN","XPDIST",80,0) S XPDTEXT(4,0)="VERSION: "_XPDV "RTN","XPDIST",81,0) S XPDTEXT(5,0)="Start time: "_XPZ(1) "RTN","XPDIST",82,0) S XPDTEXT(6,0)="Completion time: "_XPZ(2) "RTN","XPDIST",83,0) S XPDTEXT(7,0)="Run time: "_XPZ(3) "RTN","XPDIST",84,0) S XPDTEXT(8,0)="DATE: "_DT "RTN","XPDIST",85,0) S XPDTEXT(9,0)="Installed by: "_$P($G(^VA(200,+$P(XPD0,U,11),0)),U) "RTN","XPDIST",86,0) S XPDTEXT(10,0)="Install Name: "_$P(XPD0,U) "RTN","XPDIST",87,0) S XPDTEXT(11,0)="Distribution Date: "_$P(XPD1,U,4) "RTN","XPDIST",88,0) S XPDTEXT(12,0)=XPD2 "RTN","XPDIST",89,0) S XPDTEXT(13,0)=+XPD6 "RTN","XPDIST",90,0) S XMDUZ=$S($P(XPD0,U,11):+$P(XPD0,U,11),1:.5),XMTEXT="XPDTEXT(",XMSUB=$P(XPD0,U)_" INSTALLATION" "RTN","XPDIST",91,0) D ^XMD "RTN","XPDIST",92,0) Q "#"_$G(XMZ) "RTN","XPDT") 0^2^B81300874^B79741055 "RTN","XPDT",1,0) XPDT ;SFISC/RSD - Transport a package ;02/12/2009 "RTN","XPDT",2,0) ;;8.0;KERNEL;**2,10,28,41,44,51,58,66,68,85,100,108,393,511,539**;Jul 10, 1995;Build 11 "RTN","XPDT",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","XPDT",4,0) EN ;build XTMP("XPDT",ien, XPDA=ien,XPDNM=name "RTN","XPDT",5,0) ;XPDT(seq #)=ien^name^1=use current transport global on system "RTN","XPDT",6,0) ;XPDT("DA",ien)=seq # "RTN","XPDT",7,0) ;XPDVER=version number^package name "RTN","XPDT",8,0) ;XPDGP=flag;global^flag;global^... flag=1 replace global at site "RTN","XPDT",9,0) N DIR,DIRUT,I,POP,XPD,XPDA,XPDERR,XPDGP,XPDGREF,XPDH,XPDH1,XPDHD,XPDI,XPDNM,XPDSEQ,XPDSIZ,XPDSIZA,XPDT,XPDTP,XPDVER "RTN","XPDT",10,0) N DUOUT,DTOUT,XPDFMSG,X,Y,Z,Z1 "RTN","XPDT",11,0) K ^TMP($J,"XPD") "RTN","XPDT",12,0) S XPD="First Package Name: ",DIR(0)="Y",DIR("A")=" Use this Transport Global",DIR("?")="Yes, will use the current Transport Global on your system. No, will create a new one.",XPDT=0 "RTN","XPDT",13,0) W !!,"Enter the Package Names to be transported. The order in which",!,"they are entered will be the order in which they are installed.",!! "RTN","XPDT",14,0) F S XPDA=$$DIC^XPDE("AEMQZ",XPD) Q:'XPDA D Q:$D(DIRUT)!$D(XPDERR) "RTN","XPDT",15,0) .S:'XPDT XPD="Another Package Name: " "RTN","XPDT",16,0) .;XPDI=name^1=use current transport global "RTN","XPDT",17,0) .S XPDI=$P(Y(0),U)_"^" "RTN","XPDT",18,0) .I $D(XPDT("DA",XPDA)) W " ",$P(Y(0),U)," already listed",! Q "RTN","XPDT",19,0) .;if type is Global Package, set DIRUT if there is other packages "RTN","XPDT",20,0) .I $P(Y(0),U,3)=2 W " GLOBAL PACKAGE" D Q "RTN","XPDT",21,0) ..;if there is already a package in distribution, abort "RTN","XPDT",22,0) ..I XPDT S DIRUT=1 W !,"A GLOBAL PACKAGE cannot be sent with any other packages" Q "RTN","XPDT",23,0) ..I $D(^XTMP("XPDT",XPDA)) W " **Cannot have a pre-existing Transport Global**" S DIRUT=1 Q "RTN","XPDT",24,0) ..W !?10,"will transport the following globals:",! S X=0,XPDGP="" "RTN","XPDT",25,0) ..F S X=$O(^XPD(9.6,XPDA,"GLO",X)) Q:'X S Z=$G(^(X,0)) I $P(Z,U)]"" S XPDGP=XPDGP_($P(Z,U,2)="y")_";"_$P(Z,U)_"^" W ?12,$P(Z,U),! "RTN","XPDT",26,0) ..;XPDERR is set to quit loop, so no other packages can be added "RTN","XPDT",27,0) ..S XPDERR=1,XPDT=XPDT+1,XPDT(XPDT)=XPDA_U_XPDI,XPDT("DA",XPDA)=XPDT "RTN","XPDT",28,0) .Q:$D(XPDERR) "RTN","XPDT",29,0) .D PCK(XPDA,XPDI) "RTN","XPDT",30,0) .;multi-package "RTN","XPDT",31,0) .Q:$P(Y(0),U,3)'=1 "RTN","XPDT",32,0) .W " (Multi-Package)" S X=0 "RTN","XPDT",33,0) .I XPDT>1 S DIRUT=1 W !,"A Master Build must be the first/only package in a transport" Q "RTN","XPDT",34,0) .F S X=$O(^XPD(9.6,XPDA,10,X)) Q:'X S Z=$P($G(^(X,0)),U),Z1=$P($G(^(0)),U,2) D:Z]"" "RTN","XPDT",35,0) ..N XPDA,X "RTN","XPDT",36,0) ..W !?3,Z S XPDA=$O(^XPD(9.6,"B",Z,0)) "RTN","XPDT",37,0) ..I 'XPDA W " **Can't find definition in Build file**" Q "RTN","XPDT",38,0) ..I $D(XPDT("DA",XPDA)) W " already listed" Q "RTN","XPDT",39,0) ..D PCK(XPDA,Z,Z1) "RTN","XPDT",40,0) .S XPDERR=1 ;XPDERR is set to quit loop, so no other packages can be added "RTN","XPDT",41,0) .Q "RTN","XPDT",42,0) G:'XPDT!$D(DIRUT) QUIT K XPDERR "RTN","XPDT",43,0) W !!,"ORDER PACKAGE",! "RTN","XPDT",44,0) F XPDT=1:1:XPDT S Y=$P(XPDT(XPDT),U,2) W ?2,XPDT,?7,Y D W ! "RTN","XPDT",45,0) .W:$P(XPDT(XPDT),U,3) " **will use current Transport Global**" "RTN","XPDT",46,0) .;check if New Version and single package, has Package File Link, Package App. History "RTN","XPDT",47,0) .Q:Y["*"!'$$PAH(+XPDT(XPDT)) "RTN","XPDT",48,0) .S DIR(0)="Y",DIR("A")="Send the PATCH APPLICATION HISTORY from the PACKAGE file",DIR("B")="YES" "RTN","XPDT",49,0) .W !! D ^DIR I 'Y S $P(XPDT(XPDT),U,5)=1 "RTN","XPDT",50,0) S DIR(0)="Y",DIR("A")="OK to continue",DIR("B")="YES",XPDH="" "RTN","XPDT",51,0) W !! D ^DIR G:$D(DIRUT)!'Y QUIT K DIR "RTN","XPDT",52,0) I $G(XPDTP),XPDT>1 W !!,"You cannot send multiple Builds through PackMan." "RTN","XPDT",53,0) S DIR(0)="SAO^HF:Host File"_$S(XPDT=1:";PM:PackMan",1:"") "RTN","XPDT",54,0) S DIR("A")="Transport through (HF)Host File"_$S(XPDT=1:" or (PM)PackMan: ",1:": ") "RTN","XPDT",55,0) S DIR("?")="Enter the method of transport for the package(s)." "RTN","XPDT",56,0) D ^DIR G:$D(DTOUT)!$D(DUOUT) QUIT K DIR "RTN","XPDT",57,0) I Y="" W !,"No Transport Method selected, will only write Transport Global to ^XTMP." S XPDH="" "RTN","XPDT",58,0) ;XPDTP = transports using Packman "RTN","XPDT",59,0) S:Y="PM" XPDTP=1 "RTN","XPDT",60,0) I $D(XPDGP),Y'="HF" W !,"**Global Package can only be sent with a Host File, Transport ABORTED**" Q "RTN","XPDT",61,0) I Y="HF" D DEV G:POP QUIT "RTN","XPDT",62,0) W !! "RTN","XPDT",63,0) F XPDT=1:1:XPDT S XPDA=XPDT(XPDT),XPDNM=$P(XPDA,U,2) D G:$D(XPDERR) ABORT "RTN","XPDT",64,0) .W !?5,XPDNM,"..." S XPDGREF="^XTMP(""XPDT"","_+XPDA_",""TEMP"")" "RTN","XPDT",65,0) .;if using current transport global, run pre-transp routine and quit "RTN","XPDT",66,0) .I $P(XPDA,U,3) S XPDA=+XPDA D PRET Q "RTN","XPDT",67,0) .;if package file link then set XPDVER=version number^package name "RTN","XPDT",68,0) .S XPDA=+XPDA,XPDVER=$S($P(^XPD(9.6,XPDA,0),U,2):$$VER^XPDUTL(XPDNM)_U_$$PKG^XPDUTL(XPDNM),1:"") "RTN","XPDT",69,0) .;Inc the Build number "RTN","XPDT",70,0) .S $P(^XPD(9.6,XPDA,6.3),U)=$G(^XPD(9.6,XPDA,6.3))+1 "RTN","XPDT",71,0) .K ^XTMP("XPDT",XPDA) "RTN","XPDT",72,0) .;GLOBAL PACKAGE "RTN","XPDT",73,0) .I $D(XPDGP) D S XPDT=1 Q "RTN","XPDT",74,0) ..;can't send global package in packman message "RTN","XPDT",75,0) ..I $G(XPDTP) S XPDERR=1 Q "RTN","XPDT",76,0) ..;verify global package "RTN","XPDT",77,0) ..I '$$GLOPKG^XPDV(XPDA) S XPDERR=1 Q "RTN","XPDT",78,0) ..;get Environment check and Post Install routines "RTN","XPDT",79,0) ..F Y="PRE","INIT" I $G(^XPD(9.6,XPDA,Y))]"" S X=^(Y) D "RTN","XPDT",80,0) ...S ^XTMP("XPDT",XPDA,Y)=X,X=$P(X,U,$L(X,U)),%=$$LOAD^XPDTA(X,"0^") "RTN","XPDT",81,0) ..D BLD^XPDTC,PRET "RTN","XPDT",82,0) .F X="DD^XPDTC","KRN^XPDTC","QUES^XPDTC","INT^XPDTC","BLD^XPDTC" D @X Q:$D(XPDERR) "RTN","XPDT",83,0) .D:'$D(XPDERR) PRET "RTN","XPDT",84,0) ;XPDTP - call ^XPDTP to build Packman message "RTN","XPDT",85,0) I $G(XPDTP) S XPDA=+XPDT(XPDT) D ^XPDTP G QUIT "RTN","XPDT",86,0) I $L(XPDH) D GO G QUIT "RTN","XPDT",87,0) ;if no device then just create transport global "RTN","XPDT",88,0) W !! F XPDT=1:1:XPDT W "Transport Global ^XTMP(""XPDT"","_+XPDT(XPDT)_") created for ",$P(XPDT(XPDT),U,2),! "RTN","XPDT",89,0) Q "RTN","XPDT",90,0) DEV N FIL,DIR,IOP,X,Y,%ZIS W ! "RTN","XPDT",91,0) D HOME^%ZIS "RTN","XPDT",92,0) S DIR(0)="F^3:245",DIR("A")="Enter a Host File",DIR("?")="Enter a filename and/or path to output package(s).",POP=0 "RTN","XPDT",93,0) D ^DIR I $D(DTOUT)!$D(DUOUT) S POP=1 Q "RTN","XPDT",94,0) ;if no file, then quit "RTN","XPDT",95,0) Q:Y="" S FIL=Y "RTN","XPDT",96,0) S DIR(0)="F^3:80",DIR("A")="Header Comment",DIR("?")="Enter a comment between 3 and 80 characters." "RTN","XPDT",97,0) D ^DIR I $D(DIRUT) S POP=1 Q "RTN","XPDT",98,0) S XPDH=Y,%ZIS="",%ZIS("HFSNAME")=FIL,%ZIS("HFSMODE")="W",IOP="HFS",(XPDSIZ,XPDSIZA)=0,XPDSEQ=1 "RTN","XPDT",99,0) D ^%ZIS I POP W !!,"**Incorrect Host File name**",!,$C(7) Q "RTN","XPDT",100,0) ;write date and comment header "RTN","XPDT",101,0) S XPDHD="KIDS Distribution saved on "_$$HTE^XLFDT($H) "RTN","XPDT",102,0) U IO W $$SUM(XPDHD),!,$$SUM(XPDH),! "RTN","XPDT",103,0) S XPDFMSG=1 ;Send mail to forum of routines in HFS. "RTN","XPDT",104,0) ;U IO(0) is to insure I am writing to the terminal "RTN","XPDT",105,0) U IO(0) Q "RTN","XPDT",106,0) ; "RTN","XPDT",107,0) GO S I=1,Y="",XPDH1="**KIDS**:" U IO "RTN","XPDT",108,0) ;Global Package, header is different and there is only 1 package "RTN","XPDT",109,0) I $D(XPDGP) W $$SUM("**KIDS**GLOBALS:"_$P(XPDT(1),U,2)_U_XPDGP),! G GO1 "RTN","XPDT",110,0) ;write header that maintains package list, keep less than 255 char "RTN","XPDT",111,0) F D W $$SUM(XPDH1_Y),! Q:I=XPDT S Y="",I=I+1,XPDH1="**KIDS**" "RTN","XPDT",112,0) .F I=I:1 S Y=Y_$P(XPDT(I),U,2)_"^" Q:$L(Y)>200!(I=XPDT) "RTN","XPDT",113,0) ;after the package list write an extra line feed "RTN","XPDT",114,0) GO1 W ! S XPDSIZA=XPDSIZA+2 "RTN","XPDT",115,0) N XMSUB,XMY,XMTEXT "RTN","XPDT",116,0) ;loop thru & write global, don't kill if set to permanent, set in XPDIU "RTN","XPDT",117,0) F XPDT=1:1:XPDT S XPDA=+XPDT(XPDT),XPDNM=$P(XPDT(XPDT),U,2) D GW,XM K:'$G(^XTMP("XPDT",XPDA)) ^(XPDA) "RTN","XPDT",118,0) W "**END**",! "RTN","XPDT",119,0) ;GLOBAL PACKAGE there could only be one package, write globals "RTN","XPDT",120,0) I $D(XPDGP) D GPW W "**END**",! "RTN","XPDT",121,0) ;we're done with device, close it "RTN","XPDT",122,0) W "**END**",! D ^%ZISC "RTN","XPDT",123,0) W !!,"Package Transported Successfully",! "RTN","XPDT",124,0) Q "RTN","XPDT",125,0) GW ;global write "RTN","XPDT",126,0) N GR,GCK,GL "RTN","XPDT",127,0) S GCK="^XTMP(""XPDT"","_XPDA,GR=GCK_")",GCK=GCK_",",GL=$L(GCK) "RTN","XPDT",128,0) ;INSTALL NAME line will mark the beginning of global for all lines until "RTN","XPDT",129,0) ;the next INSTALL NAME "RTN","XPDT",130,0) W $$SUM("**INSTALL NAME**",1),!,$$SUM(XPDNM),! "RTN","XPDT",131,0) F Q:$D(DIRUT) S GR=$Q(@GR) Q:GR=""!($E(GR,1,GL)'=GCK) W $$SUM($P(GR,GCK,2),1),!,$$SUM(@GR),! "RTN","XPDT",132,0) Q "RTN","XPDT",133,0) XM ;Send HFS checksum message "RTN","XPDT",134,0) Q:'$G(XPDFMSG) "RTN","XPDT",135,0) N XMTEXT,C,RN,X,X2 "RTN","XPDT",136,0) K ^TMP($J) "RTN","XPDT",137,0) S XMSUB="**KIDS** Checksum for "_XPDNM,XMTEXT="^TMP($J)" "RTN","XPDT",138,0) I $G(^XMB("NETNAME"))["VA.GOV" S XMY("S.A1AE HFS CHKSUM SVR@FORUM.VA.GOV")="" "RTN","XPDT",139,0) E S X=$$GET^XPAR("PKG","XPD PATCH HFS SERVER",1,"Q") S:$L(X) XMY(X)="" "RTN","XPDT",140,0) I '$D(XMY) Q ;No one to send it to. "RTN","XPDT",141,0) S C=1,@XMTEXT@(1,0)="~~1:"_XPDNM "RTN","XPDT",142,0) I XPDT=1,$O(XPDT(1)) D "RTN","XPDT",143,0) . S RN=1 F S RN=$O(XPDT(RN)) Q:'RN S C=C+1,@XMTEXT@(C,0)="~~2:"_$P(XPDT(RN),"^",2) "RTN","XPDT",144,0) S RN="" ;Send full RTN node "RTN","XPDT",145,0) F S RN=$O(^XTMP("XPDT",XPDA,"RTN",RN)) Q:'$L(RN) S X=^(RN),X2=$G(^(RN,2,0)),C=C+1,@XMTEXT@(C,0)="~~3:"_RN_"^"_X_"^"_$P(X2,";",5) "RTN","XPDT",146,0) S C=C+1,@XMTEXT@(C,0)="~~8:"_$G(^XMB("NETNAME")) "RTN","XPDT",147,0) S C=C+1,@XMTEXT@(C,0)="~~9:Save" "RTN","XPDT",148,0) S XMTEXT="^TMP($J," "RTN","XPDT",149,0) D ^XMD "RTN","XPDT",150,0) Q "RTN","XPDT",151,0) GPW ;global package write "RTN","XPDT",152,0) N I,G,GR,GCK,GL "RTN","XPDT",153,0) W ! "RTN","XPDT",154,0) F I=1:1 S G=$P(XPDGP,U,I) Q:G="" D "RTN","XPDT",155,0) .S GR="^"_$P(G,";",2),GCK=$S(GR[")":$E(GR,1,$L(GR)-1)_",",1:GR_"("),GL=$L(GCK) "RTN","XPDT",156,0) .;GLOBAL line will mark the beginning of global for all lines until "RTN","XPDT",157,0) .;the next GLOBAL "RTN","XPDT",158,0) .W $$SUM("**GLOBAL**",1),!,$$SUM(GR),! "RTN","XPDT",159,0) .F Q:$D(DIRUT) S GR=$Q(@GR) Q:GR=""!($E(GR,1,GL)'=GCK) W $$SUM($P(GR,GCK,2),1),!,$$SUM(@GR),! "RTN","XPDT",160,0) Q "RTN","XPDT",161,0) QUIT F XPDT=1:1:XPDT L -^XPD(9.6,+XPDT(XPDT)) "RTN","XPDT",162,0) Q "RTN","XPDT",163,0) ABORT W !!,"**TRANSPORT ABORTED**",*7 "RTN","XPDT",164,0) D QUIT "RTN","XPDT",165,0) F XPDT=1:1:XPDT K ^XTMP("XPDT",+XPDT(XPDT)) "RTN","XPDT",166,0) ;if HF, save file name IO into XPDH "RTN","XPDT",167,0) S:$L(XPDH) XPDH=IO "RTN","XPDT",168,0) D ^%ZISC "RTN","XPDT",169,0) ;if HF, then delete file "RTN","XPDT",170,0) I $L(XPDH),$$DEL1^%ZISH(XPDH) W !,"File: ",XPDH," (Deleted)" "RTN","XPDT",171,0) Q "RTN","XPDT",172,0) ; "RTN","XPDT",173,0) PCK(XPDA,XPDNM,XPDREQ) ;XPDA=Build ien, XPDNM=Build name, XPDREQ=Required "RTN","XPDT",174,0) N Y "RTN","XPDT",175,0) S XPDT=XPDT+1,XPDT(XPDT)=XPDA_U_XPDNM,XPDT("DA",XPDA)=XPDT "RTN","XPDT",176,0) S:'$G(XPDREQ) XPDREQ=0 "RTN","XPDT",177,0) S $P(XPDT(XPDT),U,4)=XPDREQ "RTN","XPDT",178,0) Q:'$D(^XTMP("XPDT",XPDA)) S Y=$G(^(XPDA)) "RTN","XPDT",179,0) W " **Transport Global exists**" "RTN","XPDT",180,0) ;Y=1 if TG is permanent "RTN","XPDT",181,0) I Y S $P(XPDT(XPDT),U,3)=1 Q "RTN","XPDT",182,0) ;ask if they want to use TG "RTN","XPDT",183,0) D ^DIR S $P(XPDT(XPDT),U,3)=Y "RTN","XPDT",184,0) Q "RTN","XPDT",185,0) ; "RTN","XPDT",186,0) SUM(X,Z) ;X=string to write, Z 0=don't check size "RTN","XPDT",187,0) S XPDSIZA=XPDSIZA+$L(X)+2 "RTN","XPDT",188,0) Q X "RTN","XPDT",189,0) ; "RTN","XPDT",190,0) PAH(XPDA) ;check for PATCH APPLICATION HISTORY in Package file "RTN","XPDT",191,0) N Y,Z "RTN","XPDT",192,0) S Y=^XPD(9.6,XPDA,0),Z=$$VER^XPDUTL($P(Y,U)) "RTN","XPDT",193,0) ;Single Package, Version multiple, PAH multiple "RTN","XPDT",194,0) I $P(Y,U,3)=0,$D(^DIC(9.4,+$P(Y,U,2),22)),Z S Z=$O(^(22,"B",Z,0)) I Z,$O(^DIC(9.4,+$P(Y,U,2),22,Z,"PAH",0)) Q 1 "RTN","XPDT",195,0) Q 0 "RTN","XPDT",196,0) ; "RTN","XPDT",197,0) PRET ;Pre-Transport Routine "RTN","XPDT",198,0) N Y,Z "RTN","XPDT",199,0) S Y=$G(^XPD(9.6,XPDA,"PRET")) Q:Y="" "RTN","XPDT",200,0) I '$$RTN^XPDV(Y,.Z) W !!,"Pre-Transportation Routine ",Y,Z,*7 Q "RTN","XPDT",201,0) S Y=$S(Y["^":Y,1:"^"_Y) W !,"Running Pre-Transportation Routine ",Y "RTN","XPDT",202,0) D @Y Q "RTN","XPDT",203,0) ; "RTN","XPDT",204,0) ; "RTN","XPDT",205,0) ;FROM DEV "RTN","XPDT",206,0) ;if MSM and HFS file is on device A or B, then get size for floppy disk "RTN","XPDT",207,0) ;XPDSIZ=disk size, XPDSIZA=accummulated size,XPDSEQ=disk sequence number "RTN","XPDT",208,0) I ^%ZOSF("OS")["MSM",FIL?1(1"A",1"B")1":"1.E D Q:POP "RTN","XPDT",209,0) .S DIR(0)="N^0:5000",DIR("A")="Size of Diskette (1K blocks)",DIR("B")=1400,DIR("?")="Enter the number of 1K blocks which each diskette will hold, 0 means unlimited space" "RTN","XPDT",210,0) .D ^DIR I $D(DIRUT) S POP=1 Q "RTN","XPDT",211,0) .S XPDSIZ=$S(Y:Y*1024,1:0) "RTN","XPDT",212,0) ;FROM SUM "RTN","XPDT",213,0) ;ask for next disk "RTN","XPDT",214,0) ;this code is for MSM system only "RTN","XPDT",215,0) I $G(Z),XPDSIZ,XPDSIZ-XPDSIZA<1024 D "RTN","XPDT",216,0) .;write continue flag at end of this file "RTN","XPDT",217,0) .W "**CONTINUE**",!,"**END**",! "RTN","XPDT",218,0) .;should call %ZIS HFS utilities to close and open file "RTN","XPDT",219,0) .X "C IO" U IO(0) "RTN","XPDT",220,0) .N DIR,G,GR,GCK,GL,I,X,Y "RTN","XPDT",221,0) .W !!,"Diskette #",XPDSEQ," is full." "RTN","XPDT",222,0) .S DIR(0)="E",DIR("A")="Insert the next diskette and Press the return key",DIR("?")="The current diskette is full, insert a new diskette to continue." "RTN","XPDT",223,0) .;$D(DIRUT)=the user aborted the distribution "RTN","XPDT",224,0) .D ^DIR I $D(DIRUT) D ABORT Q "RTN","XPDT",225,0) .W ! S XPDSEQ=XPDSEQ+1,XPDSIZA=0 "RTN","XPDT",226,0) .;MSM specific code to open HFS "RTN","XPDT",227,0) .X "O IO:IOPAR" U IO "RTN","XPDT",228,0) .W $$SUM("Continuation #"_XPDSEQ_" of "_XPDHD),!,$$SUM(XPDH),!,$$SUM("**SEQ**:"_XPDSEQ),!! "RTN","XPDT",229,0) .S XPDSIZA=XPDSIZA+2 "RTN","XPDTA") 0^7^B30171675^B30119515 "RTN","XPDTA",1,0) XPDTA ;SFISC/RSD - Build Actions for Kernel Files ;02/14/2006 "RTN","XPDTA",2,0) ;;8.0;KERNEL;**15,44,58,131,229,393,498,539**;Jul 10, 1995;Build 11 "RTN","XPDTA",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","XPDTA",4,0) Q "RTN","XPDTA",5,0) ;^XTMP("XPDT",XPDA,"KRN",FILE,DA) is the global root "RTN","XPDTA",6,0) ;DA=ien in ^XTMP,XPDNM=package name, XPDA=package ien in ^XPD(9.6, "RTN","XPDTA",7,0) OPT ;options "RTN","XPDTA",8,0) N %,%1,%2 "RTN","XPDTA",9,0) ;if link, kill everything and just process the menu items "RTN","XPDTA",10,0) I XPDFL=2 D G OPTT "RTN","XPDTA",11,0) .S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",19,DA,%)) Q:'% K:%'=10 ^(%) "RTN","XPDTA",12,0) ;resolve Package (0;12), remove Creator (0;5) "RTN","XPDTA",13,0) S %=^XTMP("XPDT",XPDA,"KRN",19,DA,0),$P(%,U,12)=$$PT("^DIC(9.4)",$P(%,U,12)),$P(%,U,5)="" "RTN","XPDTA",14,0) ;resolve Help Frame (0;7), kill Permitted Devices (3.96;0) & queue node (200) "RTN","XPDTA",15,0) S $P(%,U,7)=$$PT("^DIC(9.2)",$P(%,U,7)),^XTMP("XPDT",XPDA,"KRN",19,DA,0)=% K ^(3.96),^(200) "RTN","XPDTA",16,0) ;resolve Server Bulletin (220;1), Server Mailgroup (220;3) "RTN","XPDTA",17,0) I $D(^XTMP("XPDT",XPDA,"KRN",19,DA,220)) S %=^(220),$P(%,U)=$$PT("^XMB(3.6)",+%),$P(%,U,3)=$$PT("^XMB(3.8)",$P(%,U,3)),^XTMP("XPDT",XPDA,"KRN",19,DA,220)=% "RTN","XPDTA",18,0) ;resolve RPC (RPC;0), must be type Broker "RTN","XPDTA",19,0) I $D(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC")) K:$P(^(0),U,4)'="B" ^("RPC") D "RTN","XPDTA",20,0) .;kill "B"=name x-ref, it will be re-indexed when installed "RTN","XPDTA",21,0) .K ^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC","B") "RTN","XPDTA",22,0) .;loop thru RPCs and resolve (RPC;1) "RTN","XPDTA",23,0) .S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%)) Q:'% S %1=$G(^(%,0)) D "RTN","XPDTA",24,0) ..S %2=$$PT("^XWB(8994)",+%1) "RTN","XPDTA",25,0) ..;if can't resolve then delete "RTN","XPDTA",26,0) ..I %2="" K ^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%,0) Q "RTN","XPDTA",27,0) ..;save the RPC name "RTN","XPDTA",28,0) ..S $P(^XTMP("XPDT",XPDA,"KRN",19,DA,"RPC",%,0),U)=%2 "RTN","XPDTA",29,0) .Q "RTN","XPDTA",30,0) OPTT ;Menus can only exist for options of type: menu,protocol,protocol menu, "RTN","XPDTA",31,0) ;extended action, limited, window suite "RTN","XPDTA",32,0) I "LMOQXZ"'[$P(^XTMP("XPDT",XPDA,"KRN",19,DA,0),U,4) K ^(10) Q "RTN","XPDTA",33,0) ;kill "B"=name, "C"=synonyms x-ref, it will be re-indexed when installed "RTN","XPDTA",34,0) K ^XTMP("XPDT",XPDA,"KRN",19,DA,10,"B"),^("C") "RTN","XPDTA",35,0) ;loop thru 10=Menus and resolve Menu (10;1), kill if it doesn't resolve "RTN","XPDTA",36,0) S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",19,DA,10,%)) Q:'% S %1=$G(^(%,0)) D "RTN","XPDTA",37,0) .S %2=$$PT("^DIC(19)",+%1) "RTN","XPDTA",38,0) .;items must be sent by themselves, check "B" x-ref "RTN","XPDTA",39,0) .I $L(%2),$D(^XPD(9.6,XPDA,"KRN",19,"NM","B",%2)) S ^XTMP("XPDT",XPDA,"KRN",19,DA,10,%,U)=%2 Q "RTN","XPDTA",40,0) .;if I couldn't resolve this option, then kill it "RTN","XPDTA",41,0) .K ^XTMP("XPDT",XPDA,"KRN",19,DA,10,%) "RTN","XPDTA",42,0) Q "RTN","XPDTA",43,0) ; "RTN","XPDTA",44,0) PRO ;protocols "RTN","XPDTA",45,0) N %,%1,%2 "RTN","XPDTA",46,0) ;if link, kill everything and just process the item(10) and subscribers (775) multiples "RTN","XPDTA",47,0) I XPDFL=2 D G PROT "RTN","XPDTA",48,0) .S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,%)) Q:'% K:%'=10&(%'=775) ^(%) "RTN","XPDTA",49,0) ;resolve Package (0;12), remove Creator (0;5) "RTN","XPDTA",50,0) S %=^XTMP("XPDT",XPDA,"KRN",101,DA,0),$P(%,U,12)=$$PT("^DIC(9.4)",$P(%,U,12)),$P(%,U,5)="" "RTN","XPDTA",51,0) ;kill under Menus (10), "B"=name, "C"=synonyms "RTN","XPDTA",52,0) S ^XTMP("XPDT",XPDA,"KRN",101,DA,0)=% "RTN","XPDTA",53,0) ;resolve File Link (5;1), its a variable pointer "RTN","XPDTA",54,0) S %=$P($G(^XTMP("XPDT",XPDA,"KRN",101,DA,5)),U),%1=$P(%,";",2) "RTN","XPDTA",55,0) I %,$D(@("^"_%1_+%_",0)")) S $P(^XTMP("XPDT",XPDA,"KRN",101,DA,5),U)=$P(^(0),U)_";"_%1 "RTN","XPDTA",56,0) ;resolve HL7 fields, node 770 "RTN","XPDTA",57,0) S %=$G(^XTMP("XPDT",XPDA,"KRN",101,DA,770)) I $L(%) D S ^XTMP("XPDT",XPDA,"KRN",101,DA,770)=% "RTN","XPDTA",58,0) .S $P(%,U)=$$PT("^HL(771)",$P(%,U)),$P(%,U,2)=$$PT("^HL(771)",$P(%,U,2)) "RTN","XPDTA",59,0) .S $P(%,U,3)=$$PT("^HL(771.2)",$P(%,U,3)),$P(%,U,11)=$$PT("^HL(771.2)",$P(%,U,11)) "RTN","XPDTA",60,0) .S $P(%,U,4)=$$PT("^HL(779.001)",$P(%,U,4)),$P(%,U,7)=$$PT("^HLCS(870)",$P(%,U,7)) "RTN","XPDTA",61,0) .S $P(%,U,8)=$$PT("^HL(779.003)",$P(%,U,8)),$P(%,U,9)=$$PT("^HL(779.003)",$P(%,U,9)) "RTN","XPDTA",62,0) .S $P(%,U,10)=$$PT("^HL(771.5)",$P(%,U,10)) "RTN","XPDTA",63,0) PROT ;loop thru 10=ITEM and 775=SUBSCRIBER and resolve Menu (10;1), kill if it doesn't resolve "RTN","XPDTA",64,0) ;kill under Menus (10), "B"=name, "C"=synonyms "RTN","XPDTA",65,0) I $D(^XTMP("XPDT",XPDA,"KRN",101,DA,10,0)) K ^("B"),^("C") "RTN","XPDTA",66,0) S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,10,%)) Q:'% S %1=$G(^(%,0)) D "RTN","XPDTA",67,0) .;%2=.01 of Menu(protocol) "RTN","XPDTA",68,0) .S %2=$$PT("^ORD(101)",+%1) "RTN","XPDTA",69,0) .;Menu must also be sent by itself, check "B" x-ref "RTN","XPDTA",70,0) .I $L(%2),$D(^XPD(9.6,XPDA,"KRN",101,"NM","B",%2)) S ^XTMP("XPDT",XPDA,"KRN",101,DA,10,%,U)=%2,$P(^XTMP("XPDT",XPDA,"KRN",101,DA,10,%,0),U,4)=$$PT("^ORD(101)",$P(%1,U,4)) Q "RTN","XPDTA",71,0) .K ^XTMP("XPDT",XPDA,"KRN",101,DA,10,%) "RTN","XPDTA",72,0) ;If type is Event Driver and sending Subscribers (775) "RTN","XPDTA",73,0) I $P(^XTMP("XPDT",XPDA,"KRN",101,DA,0),U,4)="E" D "RTN","XPDTA",74,0) . ;kill Menu multiple and Subscriber x-ref "B"=name "RTN","XPDTA",75,0) . K ^XTMP("XPDT",XPDA,"KRN",101,DA,10),^(775,"B") "RTN","XPDTA",76,0) . ;loop thru 775=Subscribers and resolve pointer (775;1) "RTN","XPDTA",77,0) . S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,775,%)) Q:'% S %1=$G(^(%,0)) D "RTN","XPDTA",78,0) .. ;%2=.01 of subscriber(protocol) "RTN","XPDTA",79,0) .. S %2=$$PT("^ORD(101)",+%1) "RTN","XPDTA",80,0) .. ;protocol must also be sent by itself, check "B" x-ref "RTN","XPDTA",81,0) .. I $L(%2),$D(^XPD(9.6,XPDA,"KRN",101,"NM","B",%2)) S ^XTMP("XPDT",XPDA,"KRN",101,DA,775,%,U)=%2 Q "RTN","XPDTA",82,0) .. K ^XTMP("XPDT",XPDA,"KRN",101,DA,775,%) "RTN","XPDTA",83,0) ;quit if no Access multiple "RTN","XPDTA",84,0) Q:'$D(^XTMP("XPDT",XPDA,"KRN",101,DA,3,0)) K ^("B") "RTN","XPDTA",85,0) ;loop thru Access and resolve (3;1), kill if it doesn't resolve "RTN","XPDTA",86,0) S %=0 F S %=$O(^XTMP("XPDT",XPDA,"KRN",101,DA,3,%)) Q:'% S %1=$G(^(%,0)) D "RTN","XPDTA",87,0) .;%2=.01 of Menu(protocol) "RTN","XPDTA",88,0) .S %2=$$PT("^DIC(19.1)",+%1) "RTN","XPDTA",89,0) .I $L(%2) S ^XTMP("XPDT",XPDA,"KRN",101,DA,3,%,0)=%2 Q "RTN","XPDTA",90,0) .K ^XTMP("XPDT",XPDA,"KRN",101,DA,3,%) "RTN","XPDTA",91,0) Q "RTN","XPDTA",92,0) ; "RTN","XPDTA",93,0) RTNE ;routine entry build action "RTN","XPDTA",94,0) N %,X,XPD "RTN","XPDTA",95,0) ;move routine to ^XTMP("XPDT",DPK1,"RTN",routine name "RTN","XPDTA",96,0) ;routines will have the checksum in XTMP("XPDT",XPDA,"RTN",X) & in "RTN","XPDTA",97,0) ;Build file "RTN","XPDTA",98,0) S X=$P(^XTMP("XPDT",XPDA,"KRN",9.8,DA,0),U),XPD=^(-1) "RTN","XPDTA",99,0) Q:X="" S %=$$LOAD(X,XPD),$P(^XPD(9.6,XPDA,"KRN",9.8,"NM",+$P(XPD,U,2),0),U,4)=% "RTN","XPDTA",100,0) K ^XTMP("XPDT",XPDA,"KRN",9.8,DA) "RTN","XPDTA",101,0) Q "RTN","XPDTA",102,0) ; "RTN","XPDTA",103,0) RTNF ;routine file build action "RTN","XPDTA",104,0) N X,Y,% S Y=0 "RTN","XPDTA",105,0) ;the routines that are left in XTMP("XPDT",XPDA,"KRN",9.8) are to be "RTN","XPDTA",106,0) ;deleted at site, move name field to RTN node "RTN","XPDTA",107,0) F S Y=$O(^XTMP("XPDT",XPDA,"KRN",9.8,Y)) Q:'Y S %=^(Y,-1),X=^(0) D "RTN","XPDTA",108,0) .I +%=1 S ^XTMP("XPDT",XPDA,"RTN",X)=%,^("RTN")=$G(^XTMP("XPDT",XPDA,"RTN"))+1 "RTN","XPDTA",109,0) ;kill everything "RTN","XPDTA",110,0) K ^XTMP("XPDT",XPDA,"KRN",9.8) "RTN","XPDTA",111,0) Q "RTN","XPDTA",112,0) ; "RTN","XPDTA",113,0) PT(GR,DA) ;GR=file global ref, DA=ien, return .01 value "RTN","XPDTA",114,0) Q:'DA "" "RTN","XPDTA",115,0) Q:GR="" "" "RTN","XPDTA",116,0) I $D(@GR@(+DA,0))#2 Q $P(^(0),U) "RTN","XPDTA",117,0) Q "" "RTN","XPDTA",118,0) ; "RTN","XPDTA",119,0) GR(FN) ;returns closed global root, FN=file number "RTN","XPDTA",120,0) N Y "RTN","XPDTA",121,0) Q:'$G(FN) "" "RTN","XPDTA",122,0) S Y=$G(^DIC(FN,0,"GL")) Q:Y="" "" "RTN","XPDTA",123,0) Q $E(Y,1,($L(Y)-1))_$S($L(Y,",")>1:")",1:"") "RTN","XPDTA",124,0) ; "RTN","XPDTA",125,0) LOAD(X,XPD) ;load routine X, XPD=action^ien in Build file "RTN","XPDTA",126,0) ;XPD = 0-load, 1-delete, 2-skip, returns checksum "RTN","XPDTA",127,0) ;quit if routine is already saved "RTN","XPDTA",128,0) Q:$D(^XTMP("XPDT",XPDA,"RTN",X)) $P(^(X),U,3) "RTN","XPDTA",129,0) N DIF,XCNP,%N,%A,FDA,IEN,LN2 "RTN","XPDTA",130,0) S DIF="^XTMP(""XPDT"",XPDA,""RTN"",X,",XCNP=0 "RTN","XPDTA",131,0) X ^%ZOSF("LOAD") "RTN","XPDTA",132,0) S $P(^XTMP("XPDT",XPDA,"RTN",X,2,0),";",7)="Build "_(+^XPD(9.6,XPDA,6.3)),LN2=^XTMP("XPDT",XPDA,"RTN",X,2,0) "RTN","XPDTA",133,0) S IEN=$$FIND1^DIC(9.8,"","X",X) "RTN","XPDTA",134,0) ;^XTMP("XPDT",XPDA,"RTN",X)=action^ien in Build^checksum "RTN","XPDTA",135,0) S %N="B"_$$SUMB^XPDRSUM($NA(^XTMP("XPDT",XPDA,"RTN",X))) "RTN","XPDTA",136,0) S $P(XPD,"^",3)=%N ;Make sure the Checksum is in the 3rd piece "RTN","XPDTA",137,0) S ^XTMP("XPDT",XPDA,"RTN",X)=XPD "RTN","XPDTA",138,0) ;update count node "RTN","XPDTA",139,0) S ^("RTN")=$G(^XTMP("XPDT",XPDA,"RTN"))+1 "RTN","XPDTA",140,0) N XUA,XUB S (XUA,XUB)="" "RTN","XPDTA",141,0) ;Update Dev Patch field in Routine file "RTN","XPDTA",142,0) I IEN D "RTN","XPDTA",143,0) . S XUB=$P(XPDT(XPDT),U,2) S:XUB["*" $P(XUB,"*",2)=+$P(XUB,"*",2) "RTN","XPDTA",144,0) . S IEN="?+2,"_IEN_",",FDA(9.819,IEN,.01)=XUB "RTN","XPDTA",145,0) . S FDA(9.819,IEN,2)=%N,FDA(9.819,IEN,3)=$P(LN2,";",5) "RTN","XPDTA",146,0) . D UPDATE^DIE("","FDA","IEN") "RTN","XPDTA",147,0) Q %N "RTN","XPDV") 0^8^B41656792^B38720817 "RTN","XPDV",1,0) XPDV ;SFISC/RSD - Verify Build ;10/15/2008 "RTN","XPDV",2,0) ;;8.0;KERNEL;**30,44,58,108,511,525,539**;Jul 10, 1995;Build 11 "RTN","XPDV",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","XPDV",4,0) ;checks that everything is ready to do a build "RTN","XPDV",5,0) ;XPDA=build ien, loop thru all nodes in ^XPD(9.6,XPDA and verify data "RTN","XPDV",6,0) EN ;check a build "RTN","XPDV",7,0) N DA,ERR,FGR,TYPE,XPDFILE,XPDOLDA,Y0,Y2 K ^TMP($J) "RTN","XPDV",8,0) S Y0=$G(^XPD(9.6,XPDA,0)),TYPE=$P(Y0,U,3) "RTN","XPDV",9,0) I $P(Y0,U,2)="" W !,"No Package File Link" "RTN","XPDV",10,0) I '$P(Y0,U,2) W !,$P(Y0,U,2)," in Package File Link field is free text, not a pointer" "RTN","XPDV",11,0) 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 "RTN","XPDV",12,0) ;type is global package goto CONT "RTN","XPDV",13,0) G CONT:TYPE=2 "RTN","XPDV",14,0) I TYPE=1 S Y0=$$MULT(XPDA) G DONE "RTN","XPDV",15,0) S XPDFILE=0 "RTN","XPDV",16,0) ;check DD being sent "RTN","XPDV",17,0) F S XPDFILE=$O(^XPD(9.6,XPDA,4,XPDFILE)) Q:'XPDFILE D "RTN","XPDV",18,0) .Q:$$FILE(XPDFILE)="" "RTN","XPDV",19,0) .S Y0=0,Y2=$G(^XPD(9.6,XPDA,4,XPDFILE,222)) "RTN","XPDV",20,0) .Q:'$$DATA(XPDFILE,Y2) "RTN","XPDV",21,0) .F S Y0=$O(^XPD(9.6,XPDA,4,XPDFILE,2,Y0)) Q:'Y0 D "RTN","XPDV",22,0) ..I '$D(^DD(Y0)) W !," SubDD #",Y0," in File #",XPDFILE," ** NOT FOUND **" Q "RTN","XPDV",23,0) ..S XPDOLDA=0 "RTN","XPDV",24,0) ..;check fields being sent for partial DD "RTN","XPDV",25,0) ..F S XPDOLDA=$O(^XPD(9.6,XPDA,4,XPDFILE,2,Y0,1,XPDOLDA)) Q:'XPDOLDA D "RTN","XPDV",26,0) ...I '$D(^DD(Y0,XPDOLDA)) W !,"Field #",XPDOLDA," in SubDD #",Y0," in File #",XPDFILE," ** NOT FOUND **" Q "RTN","XPDV",27,0) ; "RTN","XPDV",28,0) ;build components files "RTN","XPDV",29,0) S XPDFILE=0 "RTN","XPDV",30,0) F S XPDFILE=$O(^XPD(9.6,XPDA,"KRN",XPDFILE)) Q:'XPDFILE D "RTN","XPDV",31,0) .;if file doesn't exist, save in ^TMP and deleted at end "RTN","XPDV",32,0) .S FGR=$$FILE(XPDFILE),XPDOLDA=0 I FGR="" S ^TMP($J,XPDFILE)="" Q "RTN","XPDV",33,0) .F S XPDOLDA=$O(^XPD(9.6,XPDA,"KRN",XPDFILE,"NM",XPDOLDA)) Q:'XPDOLDA S Y0=$G(^(XPDOLDA,0)) D "RTN","XPDV",34,0) ..;check action, quit if deleting at site "RTN","XPDV",35,0) ..Q:$P(Y0,U,3)=1 "RTN","XPDV",36,0) ..;check that entry exist "RTN","XPDV",37,0) ..S:$P(Y0,U,2) $P(Y0,U)=$P(Y0," FILE #") S DA=$$ENTRY(Y0) "RTN","XPDV",38,0) ..Q:'$P(Y0,U,3)!($P(Y0,U,3)#2) "RTN","XPDV",39,0) ..;if attach check that parent is sent, if link check that child is sent "RTN","XPDV",40,0) ..Q:'$$MENU(XPDFILE,DA,$P(Y0,U,3)) "RTN","XPDV",41,0) ;check Install Questions "RTN","XPDV",42,0) S XPDOLDA=0 "RTN","XPDV",43,0) F S XPDOLDA=$O(^XPD(9.6,XPDA,"QUES",XPDOLDA)) Q:'XPDOLDA S Y0=$G(^(XPDOLDA,0)),Y2=$G(^(1)) D "RTN","XPDV",44,0) .I $P(Y0,U)="" W !,"Zero node doesn't exist for INSTALL QUESTION #",XPDOLDA Q "RTN","XPDV",45,0) .I Y2="" W !,"DIR(0) field is not defined for INSTALL QUESTION ",$P(Y0,U) "RTN","XPDV",46,0) I $O(^XPD(9.6,XPDA,"GLO",0)) W !,"Package cannot contain Globals, Files, & Components." "RTN","XPDV",47,0) ;check for PRE & POST routines "RTN","XPDV",48,0) F DA="INI","INIT" S Y0=$G(^XPD(9.6,XPDA,DA)),ERR="" I Y0]"",'$$RTN(Y0,.ERR) W !,"Routine ",Y0,ERR "RTN","XPDV",49,0) CONT ; "RTN","XPDV",50,0) ;check Environment Check routine "RTN","XPDV",51,0) S Y0=$G(^XPD(9.6,XPDA,"PRE")),ERR="" I Y0]"",'$$RTN(Y0,.ERR) W !,"Routine ",Y0,ERR "RTN","XPDV",52,0) I TYPE=2 S Y0=$$GLOPKG(XPDA) "RTN","XPDV",53,0) DONE I $O(^TMP($J,0)) D "RTN","XPDV",54,0) .N DA,DIK,DIR,DIRUT,Y "RTN","XPDV",55,0) .S DIR(0)="Y",DIR("A")="Do you want to remove the missing Files",DIR("B")="NO" "RTN","XPDV",56,0) .S DIR("?")="Yes means that the missing Files will be removed and you can transport this Build" "RTN","XPDV",57,0) .D ^DIR Q:'Y!$D(DIRUT) "RTN","XPDV",58,0) .S DIK="^XPD(9.6,"_XPDA_",""KRN"",",DA(1)=XPDA,DA=0 F S DA=$O(^TMP($J,DA)) Q:'DA D ^DIK "RTN","XPDV",59,0) W !!," ** DONE **" "RTN","XPDV",60,0) Q "RTN","XPDV",61,0) GLOPKG(X) ;GLOBAL PACKAGE "RTN","XPDV",62,0) ;returns 1 if ok, 0 if failed "RTN","XPDV",63,0) N I,J,Y,Z S Z=1 "RTN","XPDV",64,0) I $O(^XPD(9.6,X,4,0)) W !,"GLOBAL PACKAGE cannot contain Files" S Z=0 "RTN","XPDV",65,0) S I=0 F S I=$O(^XPD(9.6,X,"KRN",I)) Q:'I D:$O(^(I,"NM",0)) "RTN","XPDV",66,0) .W !,"GLOBAL PACKAGE cannot contain ",$P(^DIC(I,0),U) S Z=0 "RTN","XPDV",67,0) I $O(^XPD(9.6,X,"QUES",0)) W !,"GLOBAL PACKAGE cannot contain Install Questions" S Z=0 "RTN","XPDV",68,0) I $G(^XPD(9.6,X,"INI"))]"" W !,"GLOBAL PACKAGE cannot have a Pre-Install Routine" S Z=0 "RTN","XPDV",69,0) ;I $G(^XPD(9.6,X,"INIT"))]"" W !,"GLOBAL PACKAGE cannot have a Post-Install Routine" S Z=0 "RTN","XPDV",70,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 "RTN","XPDV",71,0) .I $P(Y,U)]"",'$D(@("^"_$P(Y,U))) W !,"Global ",Y," doesn't exist." S Z=0 "RTN","XPDV",72,0) I 'J W !,"No Globals to transport" S Z=0 "RTN","XPDV",73,0) Q Z "RTN","XPDV",74,0) ; "RTN","XPDV",75,0) QUES(X) ;X=.01 of INSTALL QUESTION multiple "RTN","XPDV",76,0) ;returns ien or 0 if failed "RTN","XPDV",77,0) N Y "RTN","XPDV",78,0) S Y=+$O(^XPD(9.6,XPDA,"QUES","B",X,0)) "RTN","XPDV",79,0) I '$D(^XPD(9.6,XPDA,"QUES",Y,0)) W !,"Zero node doesn't exist for INSTALL QUESTION ",X Q 0 "RTN","XPDV",80,0) I '$D(^XPD(9.6,XPDA,"QUES",Y,1)) W !,"DIR(0) field is not defined for INSTALL QUESTION ",X Q 0 "RTN","XPDV",81,0) Q Y "RTN","XPDV",82,0) ; "RTN","XPDV",83,0) FILE(X) ;check file # X "RTN","XPDV",84,0) ;returns global ref or "" if failed "RTN","XPDV",85,0) N %,Y "RTN","XPDV",86,0) S Y=$G(^DIC(X,0,"GL")) "RTN","XPDV",87,0) I Y="" W !," File #",X," ** NOT FOUND **" Q "" "RTN","XPDV",88,0) S %=$E(Y,$L(Y)),X=$E(Y,1,$L(Y)-1)_$S(%="(":"",1:")") "RTN","XPDV",89,0) Q X "RTN","XPDV",90,0) ; "RTN","XPDV",91,0) ;Z only contains the file # for Fileman templates and forms "RTN","XPDV",92,0) ;XPDFILE=file #,FGR=file global ref "RTN","XPDV",93,0) ENTRY(Z) ;check entry, Z=name^file "RTN","XPDV",94,0) ;returns ien or 0 if failed "RTN","XPDV",95,0) N F,X,Y "RTN","XPDV",96,0) ;check for X, name, in "B" x-ref of file. "RTN","XPDV",97,0) S X=$P(Z,U),Y=0 F S Y=$O(@FGR@("B",X,Y)) D Q:X="" "RTN","XPDV",98,0) .I 'Y W !?3,X," in ",$P(^DIC(XPDFILE,0),U)," File ** NOT FOUND **",*7 S X="" Q "RTN","XPDV",99,0) .;if Y is in x-ref but node doesn't exist, quit and try another "RTN","XPDV",100,0) .;if this is a fileman template, the file associated with it is piece 2 of Z "RTN","XPDV",101,0) .;if Form file check piece 8 else 4 "RTN","XPDV",102,0) .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 "RTN","XPDV",103,0) .;if it is routine file,9.8, check that routine exist "RTN","XPDV",104,0) .I XPDFILE=9.8 S F="" I '$$RTN(X,.F) W !,"Routine ",X,F S X="",Y=0 Q "RTN","XPDV",105,0) .;if this is not a fileman template or routine we found Y "RTN","XPDV",106,0) .S X="" Q "RTN","XPDV",107,0) Q +Y "RTN","XPDV",108,0) ; "RTN","XPDV",109,0) DATA(F,Y) ; "RTN","XPDV",110,0) ;return 1 if ok or 0 if failed "RTN","XPDV",111,0) 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 "RTN","XPDV",112,0) Q 1 "RTN","XPDV",113,0) ; "RTN","XPDV",114,0) RTN(X,MSG) ;verify tag^routine "RTN","XPDV",115,0) ;INPUT: X=[tag^]routine, MSG(passed by reference) "RTN","XPDV",116,0) ;OUTPUT: returns 1=exists, 0=doesn't; MSG=error message "RTN","XPDV",117,0) N L,S,T,R "RTN","XPDV",118,0) S MSG="" "RTN","XPDV",119,0) I X["(" S X=$P(X,"(") ;Handle tag^rtn(param) rwf "RTN","XPDV",120,0) I X["^" S T=$P(X,"^"),R=$P(X,"^",2) "RTN","XPDV",121,0) E S T="",R=X "RTN","XPDV",122,0) I (R'?1A.E) S MSG=" Name violates the SAC!!" Q 0 "RTN","XPDV",123,0) I $T(^@R)="" S MSG=" DOESN'T EXIST!!" Q 0 "RTN","XPDV",124,0) ;2nd line must begin with "[label] ;;n[n.nn];" "RTN","XPDV",125,0) S S=$T(+2^@R) D I MSG]"" Q 0 "RTN","XPDV",126,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 "RTN","XPDV",127,0) .I S'?.1" ;;"1.2N.1".".2N1";".E S MSG=" 2nd line violates the SAC!!" "RTN","XPDV",128,0) ;if no tag or tag^routine exists, then return 1 "RTN","XPDV",129,0) Q:T="" 1 Q:$T(@T^@R)]"" 1 "RTN","XPDV",130,0) S MSG=" Tag DOESN'T EXIST!!" Q 0 "RTN","XPDV",131,0) ; "RTN","XPDV",132,0) MULT(DA) ;multi-package "RTN","XPDV",133,0) ;returns 1 if ok or 0 if failed "RTN","XPDV",134,0) N I,J,X,Y,Z "RTN","XPDV",135,0) S I=0,Z=1 "RTN","XPDV",136,0) 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 "RTN","XPDV",137,0) .S:X]"" Y=$O(^XPD(9.6,"B",X,0)) "RTN","XPDV",138,0) .I Y,$D(^XPD(9.6,Y,0)) Q "RTN","XPDV",139,0) .W !,"Package ",X," doesn't exist." S Z=0 "RTN","XPDV",140,0) I 'J W !,"No Packages to transport" S Z=0 "RTN","XPDV",141,0) Q Z "RTN","XPDV",142,0) MENU(F,X,Y) ;check for Parent or Children, F=file (19 or 101), X=ien, "RTN","XPDV",143,0) ;Y=action (2=link or 4=attach) "RTN","XPDV",144,0) ;returns 1 if ok or 0 if failed "RTN","XPDV",145,0) Q:'X 0 "RTN","XPDV",146,0) N I,J,GR,Z "RTN","XPDV",147,0) S GR=$S(F=19:"^DIC(19)",1:"^ORD(101)"),(I,Z)=0 "RTN","XPDV",148,0) ;link, check that at least 1 menu item or subscribers was sent "RTN","XPDV",149,0) I Y=2 D "RTN","XPDV",150,0) . 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 "RTN","XPDV",151,0) . ;if it didn't find menu item and this is a protocol, check the subscribers, 775 "RTN","XPDV",152,0) . 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 "RTN","XPDV",153,0) ;attach, check that the parent was sent "RTN","XPDV",154,0) 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 "RTN","XPDV",155,0) D:'Z "RTN","XPDV",156,0) .W !,$S(F=19:"Option ",1:"Protocol "),$P($G(@GR@(X,0)),U)," has an Action of " "RTN","XPDV",157,0) .W:Y=2 "'USE AS LINK FOR MENU ITEMS' and no 'Menu Items' were sent." "RTN","XPDV",158,0) .W:Y=4 "'ATTACH TO MENU' and a 'Parent Menu' wasn't sent." "RTN","XPDV",159,0) Q Z "UP",9.6,9.68,-2) 9.6^KRN "UP",9.6,9.68,-1) 9.67^NM "UP",9.6,9.68,0) 9.68 "VER") 8.0^22.0 "^DD",9.6,9.68,.03,0) ACTION^R*S^0:SEND TO SITE;1:DELETE AT SITE;2:USE AS LINK FOR MENU/ITEM/SUBSCRIBERS;3:MERGE MENU ITEMS;4:ATTACH TO MENU;5:DISABLE DURING INSTALL;^0;3^Q "^DD",9.6,9.68,.03,12) Enter a number "^DD",9.6,9.68,.03,12.1) S DIC("S")="I $$SCRA^XPDET(Y)" "^DD",9.6,9.68,.03,21,0) ^^2^2^2970121^^^ "^DD",9.6,9.68,.03,21,1,0) This is the action you want performed at the installing site on "^DD",9.6,9.68,.03,21,2,0) the entry of the component you are sending for this package. "^DD",9.6,9.68,.03,"DT") 3090520 "BLD",1284,6) ^439 **END** **END**