XTRUTL.m

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 ---XTRUTL   5172     printed  Mar 13, 2025@21:46:48                                                                                                                                                                                                      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       ;