XPDDCS ;SFISC/RSD - Display Checksum for a package ;05/05/2008
;;8.0;KERNEL;**2,44,108,202,393,511,547,738**;Jul 10, 1995;Build 5
;Per VHA Directive 2004-038, this routine should not be modified.
Q
EN1 ;Verify checksums in Transport Global
N D0,DIC,X,XPD,XPDS,XPDSHW,XPDST,XPDT,Y,Z
;S DIC="^XPD(9.7,",DIC(0)="AEQMZ",DIC("S")="I $D(^XTMP(""XPDI"",Y))"
;D ^DIC Q:Y<0
S XPDS="I $D(^XTMP(""XPDI"",Y))"
S XPDST=$$LOOK^XPDI1(XPDS) Q:XPDST'>0
S XPDSHW=$$ASK Q:$D(DIRUT)
S XPD("XPDT(")="",XPD("XPDST")="",XPD("XPDSHW")="",X="XUTMDEVQ"
;during Virgin install, XUTMDEVQ might not exists
X ^%ZOSF("TEST") E D Q
.S IOSL=99999,IOM=80,IOF="#",IOST="",$Y=0 D LST1(9.7)
S Y="LST1^XPDDCS(9.7)",Z="Checksum Print"
;p345-rename AND* to XPD* - Patch was Cancelled keep code for future.
I '$G(XPDAUTO) D EN^XUTMDEVQ(Y,Z,.XPD)
I $G(XPDAUTO) S IO=XPDDEV U XPDDEV D LST1^XPDDCS(9.7)
Q
;
ASK() ;Ask if want each routine listed
N DIR
I $D(XPDAUTO) Q 1
S DIR(0)="YAO",DIR("A")="Want each Routine Listed with Checksums: ",DIR("A",1)="",DIR("B")="Yes"
D ^DIR
Q Y
;
EN2 ;print from build (system)
N D0,DIC,XPD,XPDT,XPDST,Y,Z
;S DIC="^XPD(9.6,",DIC(0)="AEQMZ"
;D ^DIC Q:Y<0
S XPDST=$$LOOK^XPDB1() Q:XPDST'>0
S XPDSHW=$$ASK Q:$D(DIRUT)
S XPD("XPDT(")="",XPD("XPDSHW")="",Y="LST1^XPDDCS(9.6)",Z="Checksum Print"
;p345-rename AND* to XPD*- Patch was Cancelled keep code for future.
I '$G(XPDAUTO) D EN^XUTMDEVQ(Y,Z,.XPD)
I $G(XPDAUTO) S:'$D(XPDDEV) XPDDEV=0 U XPDDEV D LST1^XPDDCS(9.6)
Q
;
LST1(FILE) ;Print group
N XPDI S XPDI=0
F S XPDI=$O(XPDT(XPDI)) Q:XPDI'>0 S D0=+XPDT(XPDI) D PNT(FILE)
Q
;
PNT(XPDFIL) ;print
N XPD0,XPDC,XPDDT,XPDE,XPDI,XPDJ,XPDPG,XPDQ,XPDUL,XPDBCS,X
Q:'$D(^XPD(XPDFIL,D0,0)) S XPD0=^(0),XPDPG=1,$P(XPDUL,"-",IOM)="",XPDDT=$$HTE^XLFDT($H,"1PM")
W:$E(IOST,1,2)="C-" @IOF D HDR
W !
S XPDI="",(XPDQ,XPDE)=0
;XPDFIL=9.7 use transport global exists
I XPDFIL=9.7 D
.I '$D(^XTMP("XPDI",D0)) W !!," ** Transport Global doesn't exist **" S XPDQ=1 Q
.;check for missing nodes in transport global
.I '$D(^XTMP("XPDI",D0,"BLD"))="" W !!," **Transport Global corrupted, please reload **" S XPDQ=1 Q
.F XPDC=0:1 S XPDI=$O(^XTMP("XPDI",D0,"RTN",XPDI)) Q:XPDI="" S XPDJ=$G(^(XPDI)) D Q:XPDQ
..I XPDJ="" W !," **Transport Global corrupted, please reload **" S XPDQ=1 Q
..;if deleting at site, there is no checksum
..I +XPDJ=1 S XPDC=XPDC-1 Q
..;if no before checksum, get from FORUM, XPDBCS(routine)=checksum, doesn't work no web service on Forum
..;I $P(XPDJ,U,4)="" D:'$D(XPDBCS) CHKS^XPDIST($P(XPD0,U),.XPDBCS) S $P(XPDJ,U,4)=$G(XPDBCS(XPDI))
..D SUM(XPDI,$NA(^XTMP("XPDI",D0,"RTN",XPDI)),$P(XPDJ,U,3),$P(XPDJ,U,4))
..S XPDQ=$$CHK(4)
;check build file
E D
.F XPDC=0:1 S XPDI=$O(^XPD(9.6,D0,"KRN",9.8,"NM","B",XPDI)) Q:XPDI="" S XPDJ=$O(^(XPDI,0)) D Q:XPDQ
..Q:'$D(^XPD(9.6,D0,"KRN",9.8,"NM",+XPDJ,0)) S XPDJ=$P(^(0),U,4)
..;quit if no checksum, routine wasn't loaded
..I XPDJ="" S XPDC=XPDC-1 Q
..N DIF,XCNP,%N
..S X=XPDI,DIF="^TMP($J,""RTN"",XPDI,",XCNP=0
..X ^%ZOSF("TEST") E W !,XPDI,?10,"Doesn't Exist" Q
..X ^%ZOSF("LOAD")
..D SUM(XPDI,$NA(^TMP($J,"RTN",XPDI)),XPDJ,"")
..S XPDQ=$$CHK(4)
Q:XPDQ
W !!?3,XPDC," Routine"_$S(XPDC>1:"s",1:"")_" checked, ",XPDE," failed.",!
;p345-rename AND* to XPD*-Patch was Cancelled keep code for future.
I $G(XPDAUTO) S XPDCHKSM=XPDE
Q
;
;XPDR=routine name, Z=global root, XPD=check sum, XPDBS=before Checksum from FORUM
SUM(XPDR,Z,XPD,XPDBS) ;check checksum
N Y
;See if we have a before checksum and compare.
I $L(XPDBS) D BEFORE(XPDR,XPDBS)
;first char. is the sum tag used in XPDRSUM
I XPD'?1U1.N W !,XPDR,?10,"ERROR in Checksum" S XPDE=XPDE+1 Q
S @("Y=$$SUM"_$E(XPD)_"^XPDRSUM(Z)"),XPD=$E(XPD,2,255)
I Y=XPD,XPDSHW W !,XPDR,?18,"Calculated "_$J(XPD,10) ;p738 change 10 to 18
I Y'=XPD W !,XPDR,?18,"Calculated "_$C(7)_$J(Y,10)_", expected value "_XPD S XPDE=XPDE+1
Q
;
BEFORE(RN,SUM) ;Check a before Checksum
N DIF,XCNP,%N,X
I SUM'?1U1.N Q
K ^TMP($J,"XPDDCS",RN) ;patch 511
S X=RN,DIF="^TMP($J,""XPDDCS"",RN,",XCNP=0
X ^%ZOSF("TEST") E W !,RN,?10,"Not on current system." Q
X ^%ZOSF("LOAD")
S DIF=$NA(^TMP($J,"XPDDCS",RN))
S @("Y=$$SUM"_$E(SUM)_"^XPDRSUM(DIF)"),SUM=$E(SUM,2,255)
I Y'=SUM W !,RN,?18,"Before Checksum Calculated "_Y_" expected value "_SUM ;p738
Q
;
CHK(Y) ;Y=excess lines, return 1 to exit
Q:$Y<(IOSL-Y) 0
I $E(IOST,1,2)="C-" D Q:'Y 1
.N DIR,I,J,K,X
.S DIR(0)="E" D ^DIR
S XPDPG=XPDPG+1
W @IOF D HDR
Q 0
;
HDR W !,"PACKAGE: ",$P(XPD0,U)," ",XPDDT,?70,"PAGE ",XPDPG,!,XPDUL,!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXPDDCS 4656 printed Nov 22, 2024@17:13:28 Page 2
XPDDCS ;SFISC/RSD - Display Checksum for a package ;05/05/2008
+1 ;;8.0;KERNEL;**2,44,108,202,393,511,547,738**;Jul 10, 1995;Build 5
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
EN1 ;Verify checksums in Transport Global
+1 NEW D0,DIC,X,XPD,XPDS,XPDSHW,XPDST,XPDT,Y,Z
+2 ;S DIC="^XPD(9.7,",DIC(0)="AEQMZ",DIC("S")="I $D(^XTMP(""XPDI"",Y))"
+3 ;D ^DIC Q:Y<0
+4 SET XPDS="I $D(^XTMP(""XPDI"",Y))"
+5 SET XPDST=$$LOOK^XPDI1(XPDS)
if XPDST'>0
QUIT
+6 SET XPDSHW=$$ASK
if $DATA(DIRUT)
QUIT
+7 SET XPD("XPDT(")=""
SET XPD("XPDST")=""
SET XPD("XPDSHW")=""
SET X="XUTMDEVQ"
+8 ;during Virgin install, XUTMDEVQ might not exists
+9 XECUTE ^%ZOSF("TEST")
IF '$TEST
Begin DoDot:1
+10 SET IOSL=99999
SET IOM=80
SET IOF="#"
SET IOST=""
SET $Y=0
DO LST1(9.7)
End DoDot:1
QUIT
+11 SET Y="LST1^XPDDCS(9.7)"
SET Z="Checksum Print"
+12 ;p345-rename AND* to XPD* - Patch was Cancelled keep code for future.
+13 IF '$GET(XPDAUTO)
DO EN^XUTMDEVQ(Y,Z,.XPD)
+14 IF $GET(XPDAUTO)
SET IO=XPDDEV
USE XPDDEV
DO LST1^XPDDCS(9.7)
+15 QUIT
+16 ;
ASK() ;Ask if want each routine listed
+1 NEW DIR
+2 IF $DATA(XPDAUTO)
QUIT 1
+3 SET DIR(0)="YAO"
SET DIR("A")="Want each Routine Listed with Checksums: "
SET DIR("A",1)=""
SET DIR("B")="Yes"
+4 DO ^DIR
+5 QUIT Y
+6 ;
EN2 ;print from build (system)
+1 NEW D0,DIC,XPD,XPDT,XPDST,Y,Z
+2 ;S DIC="^XPD(9.6,",DIC(0)="AEQMZ"
+3 ;D ^DIC Q:Y<0
+4 SET XPDST=$$LOOK^XPDB1()
if XPDST'>0
QUIT
+5 SET XPDSHW=$$ASK
if $DATA(DIRUT)
QUIT
+6 SET XPD("XPDT(")=""
SET XPD("XPDSHW")=""
SET Y="LST1^XPDDCS(9.6)"
SET Z="Checksum Print"
+7 ;p345-rename AND* to XPD*- Patch was Cancelled keep code for future.
+8 IF '$GET(XPDAUTO)
DO EN^XUTMDEVQ(Y,Z,.XPD)
+9 IF $GET(XPDAUTO)
if '$DATA(XPDDEV)
SET XPDDEV=0
USE XPDDEV
DO LST1^XPDDCS(9.6)
+10 QUIT
+11 ;
LST1(FILE) ;Print group
+1 NEW XPDI
SET XPDI=0
+2 FOR
SET XPDI=$ORDER(XPDT(XPDI))
if XPDI'>0
QUIT
SET D0=+XPDT(XPDI)
DO PNT(FILE)
+3 QUIT
+4 ;
PNT(XPDFIL) ;print
+1 NEW XPD0,XPDC,XPDDT,XPDE,XPDI,XPDJ,XPDPG,XPDQ,XPDUL,XPDBCS,X
+2 if '$DATA(^XPD(XPDFIL,D0,0))
QUIT
SET XPD0=^(0)
SET XPDPG=1
SET $PIECE(XPDUL,"-",IOM)=""
SET XPDDT=$$HTE^XLFDT($HOROLOG,"1PM")
+3 if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
DO HDR
+4 WRITE !
+5 SET XPDI=""
SET (XPDQ,XPDE)=0
+6 ;XPDFIL=9.7 use transport global exists
+7 IF XPDFIL=9.7
Begin DoDot:1
+8 IF '$DATA(^XTMP("XPDI",D0))
WRITE !!," ** Transport Global doesn't exist **"
SET XPDQ=1
QUIT
+9 ;check for missing nodes in transport global
+10 IF '$DATA(^XTMP("XPDI",D0,"BLD"))=""
WRITE !!," **Transport Global corrupted, please reload **"
SET XPDQ=1
QUIT
+11 FOR XPDC=0:1
SET XPDI=$ORDER(^XTMP("XPDI",D0,"RTN",XPDI))
if XPDI=""
QUIT
SET XPDJ=$GET(^(XPDI))
Begin DoDot:2
+12 IF XPDJ=""
WRITE !," **Transport Global corrupted, please reload **"
SET XPDQ=1
QUIT
+13 ;if deleting at site, there is no checksum
+14 IF +XPDJ=1
SET XPDC=XPDC-1
QUIT
+15 ;if no before checksum, get from FORUM, XPDBCS(routine)=checksum, doesn't work no web service on Forum
+16 ;I $P(XPDJ,U,4)="" D:'$D(XPDBCS) CHKS^XPDIST($P(XPD0,U),.XPDBCS) S $P(XPDJ,U,4)=$G(XPDBCS(XPDI))
+17 DO SUM(XPDI,$NAME(^XTMP("XPDI",D0,"RTN",XPDI)),$PIECE(XPDJ,U,3),$PIECE(XPDJ,U,4))
+18 SET XPDQ=$$CHK(4)
End DoDot:2
if XPDQ
QUIT
End DoDot:1
+19 ;check build file
+20 IF '$TEST
Begin DoDot:1
+21 FOR XPDC=0:1
SET XPDI=$ORDER(^XPD(9.6,D0,"KRN",9.8,"NM","B",XPDI))
if XPDI=""
QUIT
SET XPDJ=$ORDER(^(XPDI,0))
Begin DoDot:2
+22 if '$DATA(^XPD(9.6,D0,"KRN",9.8,"NM",+XPDJ,0))
QUIT
SET XPDJ=$PIECE(^(0),U,4)
+23 ;quit if no checksum, routine wasn't loaded
+24 IF XPDJ=""
SET XPDC=XPDC-1
QUIT
+25 NEW DIF,XCNP,%N
+26 SET X=XPDI
SET DIF="^TMP($J,""RTN"",XPDI,"
SET XCNP=0
+27 XECUTE ^%ZOSF("TEST")
IF '$TEST
WRITE !,XPDI,?10,"Doesn't Exist"
QUIT
+28 XECUTE ^%ZOSF("LOAD")
+29 DO SUM(XPDI,$NAME(^TMP($JOB,"RTN",XPDI)),XPDJ,"")
+30 SET XPDQ=$$CHK(4)
End DoDot:2
if XPDQ
QUIT
End DoDot:1
+31 if XPDQ
QUIT
+32 WRITE !!?3,XPDC," Routine"_$SELECT(XPDC>1:"s",1:"")_" checked, ",XPDE," failed.",!
+33 ;p345-rename AND* to XPD*-Patch was Cancelled keep code for future.
+34 IF $GET(XPDAUTO)
SET XPDCHKSM=XPDE
+35 QUIT
+36 ;
+37 ;XPDR=routine name, Z=global root, XPD=check sum, XPDBS=before Checksum from FORUM
SUM(XPDR,Z,XPD,XPDBS) ;check checksum
+1 NEW Y
+2 ;See if we have a before checksum and compare.
+3 IF $LENGTH(XPDBS)
DO BEFORE(XPDR,XPDBS)
+4 ;first char. is the sum tag used in XPDRSUM
+5 IF XPD'?1U1.N
WRITE !,XPDR,?10,"ERROR in Checksum"
SET XPDE=XPDE+1
QUIT
+6 SET @("Y=$$SUM"_$EXTRACT(XPD)_"^XPDRSUM(Z)")
SET XPD=$EXTRACT(XPD,2,255)
+7 ;p738 change 10 to 18
IF Y=XPD
IF XPDSHW
WRITE !,XPDR,?18,"Calculated "_$JUSTIFY(XPD,10)
+8 IF Y'=XPD
WRITE !,XPDR,?18,"Calculated "_$CHAR(7)_$JUSTIFY(Y,10)_", expected value "_XPD
SET XPDE=XPDE+1
+9 QUIT
+10 ;
BEFORE(RN,SUM) ;Check a before Checksum
+1 NEW DIF,XCNP,%N,X
+2 IF SUM'?1U1.N
QUIT
+3 ;patch 511
KILL ^TMP($JOB,"XPDDCS",RN)
+4 SET X=RN
SET DIF="^TMP($J,""XPDDCS"",RN,"
SET XCNP=0
+5 XECUTE ^%ZOSF("TEST")
IF '$TEST
WRITE !,RN,?10,"Not on current system."
QUIT
+6 XECUTE ^%ZOSF("LOAD")
+7 SET DIF=$NAME(^TMP($JOB,"XPDDCS",RN))
+8 SET @("Y=$$SUM"_$EXTRACT(SUM)_"^XPDRSUM(DIF)")
SET SUM=$EXTRACT(SUM,2,255)
+9 ;p738
IF Y'=SUM
WRITE !,RN,?18,"Before Checksum Calculated "_Y_" expected value "_SUM
+10 QUIT
+11 ;
CHK(Y) ;Y=excess lines, return 1 to exit
+1 if $Y<(IOSL-Y)
QUIT 0
+2 IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:1
+3 NEW DIR,I,J,K,X
+4 SET DIR(0)="E"
DO ^DIR
End DoDot:1
if 'Y
QUIT 1
+5 SET XPDPG=XPDPG+1
+6 WRITE @IOF
DO HDR
+7 QUIT 0
+8 ;
HDR WRITE !,"PACKAGE: ",$PIECE(XPD0,U)," ",XPDDT,?70,"PAGE ",XPDPG,!,XPDUL,!
+1 QUIT
