XTRUTL ;ISCSF/RWF - Developer Routine Utilities ;3/21/2006 2:50PM
;;7.3;TOOLKIT;**20,39,59,66,76,100**;Apr 25, 1995;Build 4
;
Q ;No entry from the top.
BUILD ;
K ^UTILITY($J),^TMP($J) D HOME^%ZIS
N BLDA,DIC,IX,X,PATCH,RTN,RN,L2,OLDSUM,OON
W !!,"This generates the Checksum/2nd line list for the routines from a BUILD file."
I '$D(^XPD(9.6,0)) W !,"No BUILD file to work from." Q
S Y=$$BUILD^XTRUTL1 G EXIT:Y'>0 S BLDA=+Y,PATCH=+$P(Y,"*",3)
D RTN^XTRUTL1(BLDA)
I '$D(^UTILITY($J)) W !,"No routines in this build." G EXIT
;Ask about old/new checksums
S OON=$$ASKOON Q:OON<1 ;Return 1 or 2
;S X=$P(^DIC(9.4,+$P(Y(0),U,2),0),U,2)
S RN="" F S RN=$O(^UTILITY($J,RN)) Q:RN="" D Q:$D(L2)
. S X=RN X ^%ZOSF("TEST") I '$T D Q
. . W !,RN,?13,"Routine not in this UCI."
. . K ^UTILITY($J,RN)
. S L2=$T(+2^@RN)
I '$D(L2) W !,"No other routines in this build." G EXIT
S L2=$P(L2,";",1,4)_";**[Patch List]**;"_$P(L2,";",6,99)
W !!,"Routine Summary"
W !,"Checksums shown are "_$S(OON=1:"OLD",1:"NEW")_" Checksums"
W !,"The following routines are included in this patch. The second line of each",!,"of these routines now looks like:"
W !,L2
W !!,?17,"Checksums",!,"Routine",?16,"Old",?28,"New",?39,"Patch List"
S RN=""
F S RN=$O(^UTILITY($J,RN)) Q:RN="" D
. S RSUM=$P($$NEWSUM(RN),"/",OON) ;rwf
. S OLDSUM=$$OLDSUM(RN),OLDSUM=$P(OLDSUM,"/",OON) ;rwf
. S X=$G(RTN(2,0)) ;X has second line of routine
. S:(+OLDSUM=0) OLDSUM="n/a " S:(+RSUM=0) RSUM="n/a "
. W !,RN,?13,$J(OLDSUM,8),?25,$J(RSUM,8) D WRAP(37,$P(X,";",5))
. D PTLBLD($P(X,";",5))
. S Y=$P(X,"**",2),Z=$P(Y,",",$L(Y,","))
. I PATCH,Z'=PATCH W " <<<No "_PATCH
. Q
W ! D PTLDSP
W !,"Sites should use CHECK"_$S(OON=2:"1",1:"")_"^XTSUMBLD to verify checksums.",!
EXIT K %
Q
;
ASKOON() ;Ask if user wants old/new checksum
;Return 1 or 2.
N DIR,DIOUT
S DIR(0)="S^1:Old;2:New",DIR("A")="New or Old Checksums",DIR("B")="New"
D ^DIR
I $D(DIRUT) S Y=-1
Q Y
;
WRAP(C,S) ;Wrap S starting at col C.
I $L(S)+C<80 W ?C,S Q
N I,T
S I=$F(S,",",70-C) W ?C,$E(S,1,I-1) S S=$E(S,I,999)
F S I=$F(S,",",70-C),I=$S(I>0:I,1:$L(S)+2) W !,?C+2,$E(S,1,I-1) S S=$E(S,I,999) Q:'$L(S)
Q
;
RSUM() N Y,Y2,%,%1,%2,%3 S (Y,Y2)=0
F %=1,3:1:LC S %1=RTN(%,0),%3=$F(%1," "),%3=$S($E(%1,%3)'=";":$L(%1),$E(%1,%3+1)=";":$L(%1),1:%3-2) F %2=1:1:%3 S Y=$A(%1,%2)*%2+Y,Y2=$A(%1,%2)*(%2+%)+Y2
;S RSUM=Y,RSUM2=Y2
Q Y_"/"_Y2
;
NEWSUM(X) ;Get the NEW Checksum
N XCNP,DIF K RTN I '$L($T(^@X)) Q 0
S XCNP=0,DIF="RTN(" K RTN X ^%ZOSF("LOAD") S LC=XCNP-1
Q $$RSUM
;
OLDSUM(X) ;Get the OLD Checksum
N Y S Y=$O(^DIC(9.8,"B",X,0)) Q:Y'>0 ""
S X=$G(^DIC(9.8,Y,4))
Q $P(X,"^",2)
;
PTLBLD(Z) ;Build in ^TMP the patches used
N I,J,K,P S Z=$P(Z,"**",2),K=""
F I=1:1 S J=$P(Z,",",I) Q:(J="") I (J'=PATCH) S P=$G(^TMP($J,J)),^TMP($J,J)=P_K S K=K_J_","
Q
PTLSRT ;Sort the list
N I,J,K,L S I=0
F I=0:0 S I=$O(^TMP($J,I)) Q:I'>0 S K=^(I) D
. F J=1:1 S L=$P(K,",",J) Q:L="" K ^TMP($J,L)
. Q
Q
;
PTLDSP ;Display list of patches.
D PTLSRT
N I,J K ^TMP($J,PATCH)
Q:$O(^TMP($J,0))=""
W !,"List of preceding patches: "
S (I,J)="" F S I=$O(^TMP($J,I)) Q:I="" D
. I $X>70 W ! S J=""
. W J,I S J=", "
S:$L(J)>2 J=$E(J,1,$L(J)-2)
Q
;
UPDATE ;Update the ROUTINE file with current checksums
K ^UTILITY($J)
N BLDA,DIC,IX,X,NOW,DIR
W !!,"This will update the ROUTINE file for the routines from a BUILD file."
I '$D(^XPD(9.6,0)) W !,"No BUILD file to work from." Q
S Y=$$BUILD^XTRUTL1 G EXIT:Y'>0 S BLDA=+Y
S DIR(0)="Y",DIR("A")="Is "_$P(Y,U,2)_" the one you want" D ^DIR
I $D(DIRUT)!(Y'=1) Q
D RTN^XTRUTL1(BLDA)
S NOW=$$NOW^XLFDT()
G EXIT:$O(^UTILITY($J,""))=""
S RN=""
F S RN=$O(^UTILITY($J,RN)) Q:RN="" D UD1(RN)
W !,"Done"
Q
;
UD1(RN) ;
N X,XCNP,DIF,LC,RSUM,Y S:'$D(NOW) NOW=$$NOW^XLFDT
S U="^",RSUM=$$NEWSUM(RN) Q:RSUM=0
S X=RTN(2,0)
S Y=$$GETDA(RN) I Y'>0 W !," Routine ",RN," not found in the database." Q
I '$$LOCAL(Y) W !,"This is a national routine and will not be updated" Q
S ^DIC(9.8,+Y,4)=NOW_U_RSUM_U_$P(X,";",5)
Q
;
SHOW(RN) ;Show current data
N Y,%0,%4,RTN,RSUM S %4="^n/a^n/a",U="^"
S Y=$$GETDA(RN) I Y>0 S %0=^DIC(9.8,Y,0),%4=$G(^(4))
S RSUM=$$NEWSUM(RN)
W !,"RTN",?10,"New ChkSum",?28,"Old ChkSum",?46,"Old Date"
W !,RN,?10,RSUM,?28,$P(%4,U,2),?46,$P(%4,U)
W !,$S($$LOCAL(Y):"Local",1:"National")_" Routine"
Q
;
GETDA(X) ;Find a DA in file
Q $O(^DIC(9.8,"B",X,0))
;
M ;Manual Update of the Routine file
N DIC,DIE,DA,DR
S DIC="^DIC(9.8,",DIC(0)="AEMQ" D ^DIC Q:Y'>0
I '$$LOCAL(+Y) W !,"This routine Checksum only updated from FORUM." Q
S DA=+Y,DIE=DIC,DR=7.2 D ^DIE
Q
;
LIST ;List all routines that don't match the old checksum
N Y,X,RN,RSUM,DA
S RN="",U="^"
F S RN=$O(^DIC(9.8,"B",RN)) Q:RN="" D
. S DA=$O(^DIC(9.8,"B",RN,0)) Q:DA'>0
. S %4=$G(^DIC(9.8,DA,4)) Q:$P(%4,U,2)="" S RSUM=$$NEWSUM(RN)
. I RSUM'=$P(%4,U,2) W !,RN,?10,"Checksum mismatch ",$P($T(+2^@RN),";",5)
. Q
Q
;
LOCAL(DA) ;Return if this is a local routine in the ROUTINE file.
Q $P($G(^DIC(9.8,DA,6)),"^")<2
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXTRUTL 5172 printed Dec 13, 2024@02:41:45 Page 2
XTRUTL ;ISCSF/RWF - Developer Routine Utilities ;3/21/2006 2:50PM
+1 ;;7.3;TOOLKIT;**20,39,59,66,76,100**;Apr 25, 1995;Build 4
+2 ;
+3 ;No entry from the top.
QUIT
BUILD ;
+1 KILL ^UTILITY($JOB),^TMP($JOB)
DO HOME^%ZIS
+2 NEW BLDA,DIC,IX,X,PATCH,RTN,RN,L2,OLDSUM,OON
+3 WRITE !!,"This generates the Checksum/2nd line list for the routines from a BUILD file."
+4 IF '$DATA(^XPD(9.6,0))
WRITE !,"No BUILD file to work from."
QUIT
+5 SET Y=$$BUILD^XTRUTL1
if Y'>0
GOTO EXIT
SET BLDA=+Y
SET PATCH=+$PIECE(Y,"*",3)
+6 DO RTN^XTRUTL1(BLDA)
+7 IF '$DATA(^UTILITY($JOB))
WRITE !,"No routines in this build."
GOTO EXIT
+8 ;Ask about old/new checksums
+9 ;Return 1 or 2
SET OON=$$ASKOON
if OON<1
QUIT
+10 ;S X=$P(^DIC(9.4,+$P(Y(0),U,2),0),U,2)
+11 SET RN=""
FOR
SET RN=$ORDER(^UTILITY($JOB,RN))
if RN=""
QUIT
Begin DoDot:1
+12 SET X=RN
XECUTE ^%ZOSF("TEST")
IF '$TEST
Begin DoDot:2
+13 WRITE !,RN,?13,"Routine not in this UCI."
+14 KILL ^UTILITY($JOB,RN)
End DoDot:2
QUIT
+15 SET L2=$TEXT(+2^@RN)
End DoDot:1
if $DATA(L2)
QUIT
+16 IF '$DATA(L2)
WRITE !,"No other routines in this build."
GOTO EXIT
+17 SET L2=$PIECE(L2,";",1,4)_";**[Patch List]**;"_$PIECE(L2,";",6,99)
+18 WRITE !!,"Routine Summary"
+19 WRITE !,"Checksums shown are "_$SELECT(OON=1:"OLD",1:"NEW")_" Checksums"
+20 WRITE !,"The following routines are included in this patch. The second line of each",!,"of these routines now looks like:"
+21 WRITE !,L2
+22 WRITE !!,?17,"Checksums",!,"Routine",?16,"Old",?28,"New",?39,"Patch List"
+23 SET RN=""
+24 FOR
SET RN=$ORDER(^UTILITY($JOB,RN))
if RN=""
QUIT
Begin DoDot:1
+25 ;rwf
SET RSUM=$PIECE($$NEWSUM(RN),"/",OON)
+26 ;rwf
SET OLDSUM=$$OLDSUM(RN)
SET OLDSUM=$PIECE(OLDSUM,"/",OON)
+27 ;X has second line of routine
SET X=$GET(RTN(2,0))
+28 if (+OLDSUM=0)
SET OLDSUM="n/a "
if (+RSUM=0)
SET RSUM="n/a "
+29 WRITE !,RN,?13,$JUSTIFY(OLDSUM,8),?25,$JUSTIFY(RSUM,8)
DO WRAP(37,$PIECE(X,";",5))
+30 DO PTLBLD($PIECE(X,";",5))
+31 SET Y=$PIECE(X,"**",2)
SET Z=$PIECE(Y,",",$LENGTH(Y,","))
+32 IF PATCH
IF Z'=PATCH
WRITE " <<<No "_PATCH
+33 QUIT
End DoDot:1
+34 WRITE !
DO PTLDSP
+35 WRITE !,"Sites should use CHECK"_$SELECT(OON=2:"1",1:"")_"^XTSUMBLD to verify checksums.",!
EXIT KILL %
+1 QUIT
+2 ;
ASKOON() ;Ask if user wants old/new checksum
+1 ;Return 1 or 2.
+2 NEW DIR,DIOUT
+3 SET DIR(0)="S^1:Old;2:New"
SET DIR("A")="New or Old Checksums"
SET DIR("B")="New"
+4 DO ^DIR
+5 IF $DATA(DIRUT)
SET Y=-1
+6 QUIT Y
+7 ;
WRAP(C,S) ;Wrap S starting at col C.
+1 IF $LENGTH(S)+C<80
WRITE ?C,S
QUIT
+2 NEW I,T
+3 SET I=$FIND(S,",",70-C)
WRITE ?C,$EXTRACT(S,1,I-1)
SET S=$EXTRACT(S,I,999)
+4 FOR
SET I=$FIND(S,",",70-C)
SET I=$SELECT(I>0:I,1:$LENGTH(S)+2)
WRITE !,?C+2,$EXTRACT(S,1,I-1)
SET S=$EXTRACT(S,I,999)
if '$LENGTH(S)
QUIT
+5 QUIT
+6 ;
RSUM() NEW Y,Y2,%,%1,%2,%3
SET (Y,Y2)=0
+1 FOR %=1,3:1:LC
SET %1=RTN(%,0)
SET %3=$FIND(%1," ")
SET %3=$SELECT($EXTRACT(%1,%3)'=";":$LENGTH(%1),$EXTRACT(%1,%3+1)=";":$LENGTH(%1),1:%3-2)
FOR %2=1:1:%3
SET Y=$ASCII(%1,%2)*%2+Y
SET Y2=$ASCII(%1,%2)*(%2+%)+Y2
+2 ;S RSUM=Y,RSUM2=Y2
+3 QUIT Y_"/"_Y2
+4 ;
NEWSUM(X) ;Get the NEW Checksum
+1 NEW XCNP,DIF
KILL RTN
IF '$LENGTH($TEXT(^@X))
QUIT 0
+2 SET XCNP=0
SET DIF="RTN("
KILL RTN
XECUTE ^%ZOSF("LOAD")
SET LC=XCNP-1
+3 QUIT $$RSUM
+4 ;
OLDSUM(X) ;Get the OLD Checksum
+1 NEW Y
SET Y=$ORDER(^DIC(9.8,"B",X,0))
if Y'>0
QUIT ""
+2 SET X=$GET(^DIC(9.8,Y,4))
+3 QUIT $PIECE(X,"^",2)
+4 ;
PTLBLD(Z) ;Build in ^TMP the patches used
+1 NEW I,J,K,P
SET Z=$PIECE(Z,"**",2)
SET K=""
+2 FOR I=1:1
SET J=$PIECE(Z,",",I)
if (J="")
QUIT
IF (J'=PATCH)
SET P=$GET(^TMP($JOB,J))
SET ^TMP($JOB,J)=P_K
SET K=K_J_","
+3 QUIT
PTLSRT ;Sort the list
+1 NEW I,J,K,L
SET I=0
+2 FOR I=0:0
SET I=$ORDER(^TMP($JOB,I))
if I'>0
QUIT
SET K=^(I)
Begin DoDot:1
+3 FOR J=1:1
SET L=$PIECE(K,",",J)
if L=""
QUIT
KILL ^TMP($JOB,L)
+4 QUIT
End DoDot:1
+5 QUIT
+6 ;
PTLDSP ;Display list of patches.
+1 DO PTLSRT
+2 NEW I,J
KILL ^TMP($JOB,PATCH)
+3 if $ORDER(^TMP($JOB,0))=""
QUIT
+4 WRITE !,"List of preceding patches: "
+5 SET (I,J)=""
FOR
SET I=$ORDER(^TMP($JOB,I))
if I=""
QUIT
Begin DoDot:1
+6 IF $X>70
WRITE !
SET J=""
+7 WRITE J,I
SET J=", "
End DoDot:1
+8 if $LENGTH(J)>2
SET J=$EXTRACT(J,1,$LENGTH(J)-2)
+9 QUIT
+10 ;
UPDATE ;Update the ROUTINE file with current checksums
+1 KILL ^UTILITY($JOB)
+2 NEW BLDA,DIC,IX,X,NOW,DIR
+3 WRITE !!,"This will update the ROUTINE file for the routines from a BUILD file."
+4 IF '$DATA(^XPD(9.6,0))
WRITE !,"No BUILD file to work from."
QUIT
+5 SET Y=$$BUILD^XTRUTL1
if Y'>0
GOTO EXIT
SET BLDA=+Y
+6 SET DIR(0)="Y"
SET DIR("A")="Is "_$PIECE(Y,U,2)_" the one you want"
DO ^DIR
+7 IF $DATA(DIRUT)!(Y'=1)
QUIT
+8 DO RTN^XTRUTL1(BLDA)
+9 SET NOW=$$NOW^XLFDT()
+10 if $ORDER(^UTILITY($JOB,""))=""
GOTO EXIT
+11 SET RN=""
+12 FOR
SET RN=$ORDER(^UTILITY($JOB,RN))
if RN=""
QUIT
DO UD1(RN)
+13 WRITE !,"Done"
+14 QUIT
+15 ;
UD1(RN) ;
+1 NEW X,XCNP,DIF,LC,RSUM,Y
if '$DATA(NOW)
SET NOW=$$NOW^XLFDT
+2 SET U="^"
SET RSUM=$$NEWSUM(RN)
if RSUM=0
QUIT
+3 SET X=RTN(2,0)
+4 SET Y=$$GETDA(RN)
IF Y'>0
WRITE !," Routine ",RN," not found in the database."
QUIT
+5 IF '$$LOCAL(Y)
WRITE !,"This is a national routine and will not be updated"
QUIT
+6 SET ^DIC(9.8,+Y,4)=NOW_U_RSUM_U_$PIECE(X,";",5)
+7 QUIT
+8 ;
SHOW(RN) ;Show current data
+1 NEW Y,%0,%4,RTN,RSUM
SET %4="^n/a^n/a"
SET U="^"
+2 SET Y=$$GETDA(RN)
IF Y>0
SET %0=^DIC(9.8,Y,0)
SET %4=$GET(^(4))
+3 SET RSUM=$$NEWSUM(RN)
+4 WRITE !,"RTN",?10,"New ChkSum",?28,"Old ChkSum",?46,"Old Date"
+5 WRITE !,RN,?10,RSUM,?28,$PIECE(%4,U,2),?46,$PIECE(%4,U)
+6 WRITE !,$SELECT($$LOCAL(Y):"Local",1:"National")_" Routine"
+7 QUIT
+8 ;
GETDA(X) ;Find a DA in file
+1 QUIT $ORDER(^DIC(9.8,"B",X,0))
+2 ;
M ;Manual Update of the Routine file
+1 NEW DIC,DIE,DA,DR
+2 SET DIC="^DIC(9.8,"
SET DIC(0)="AEMQ"
DO ^DIC
if Y'>0
QUIT
+3 IF '$$LOCAL(+Y)
WRITE !,"This routine Checksum only updated from FORUM."
QUIT
+4 SET DA=+Y
SET DIE=DIC
SET DR=7.2
DO ^DIE
+5 QUIT
+6 ;
LIST ;List all routines that don't match the old checksum
+1 NEW Y,X,RN,RSUM,DA
+2 SET RN=""
SET U="^"
+3 FOR
SET RN=$ORDER(^DIC(9.8,"B",RN))
if RN=""
QUIT
Begin DoDot:1
+4 SET DA=$ORDER(^DIC(9.8,"B",RN,0))
if DA'>0
QUIT
+5 SET %4=$GET(^DIC(9.8,DA,4))
if $PIECE(%4,U,2)=""
QUIT
SET RSUM=$$NEWSUM(RN)
+6 IF RSUM'=$PIECE(%4,U,2)
WRITE !,RN,?10,"Checksum mismatch ",$PIECE($TEXT(+2^@RN),";",5)
+7 QUIT
End DoDot:1
+8 QUIT
+9 ;
LOCAL(DA) ;Return if this is a local routine in the ROUTINE file.
+1 QUIT $PIECE($GET(^DIC(9.8,DA,6)),"^")<2
+2 ;
