DGINTEG.m

DGINTEG ; IHS/ADC/PDW/ENM - MAS INTEGRITY CHECKER DEC 12, 1987 ;  [ 03/25/1999  11:48 AM ]

 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;**1015**;MAR 25, 1999;Build 21

 ;;MAS VERSION 5.0

 ; IHS/HQW/KML 2/12/97 replace $N with $O w/o changing functionality

 G EN

CHK S X=$E(DGR_" "_DGDOT,1,12) W !,X S DGT=0 X "ZL @DGR X:DGRU DGIN F DGY=3:1 S (DGA,DGD)="""",DGL=$T(+DGY) Q:DGL']""""  S DGLN=$L(DGL) X DGCC" I '$D(DGU) X DGWR ; W " ASCII Value of Routine ===> ",$J(DGT,15)

 Q

CC S DGCC="F DGC=1:1:DGLN S DGA=$A(DGL,DGC) S DGD=DGA_""^""_$P(DGD,""^"",1,2) S DGT=(DGA*DGC)+DGT I $S(DGLN>2:$P(DGD,""^"",2,3),1:$P(DGD,""^"",1,2))=""59^32"",DGA'=59!(DGLN=2) X DGSB Q"

 S DGSB="S DGT=DGT-($P(DGD,""^"",1)*DGC)-($P(DGD,""^"",2)*(DGC-1)) I DGC>2 S DGT=DGT-($P(DGD,""^"",3)*(DGC-2)) I DGC>3,$A(DGL,DGC-3)=32 S DGT=DGT-(32*(DGC-3))"

 S DGWR="W "" ASCII Value ===> "",$J(DGT,11),""-Now"" S Y=$O(^DG(43,1,""ROU"",""B"",DGR,0)) I Y>0,$D(^DG(43,1,""ROU"",Y,0)) S X=$P(^(0),""^"",2) I X W $J(X,11),""-Orig."" X DGWR1"

 S DGWR1="S Y=$S(DGT=X:""No Change"",DGT<X:""-""_(X-DGT),1:""+""_(DGT-X)),Y=""(""_Y_"")"" W ""  "",$J(Y,12)" Q

EN D Q F I=1:1 S J=$P($T(T+I),";;",2) Q:J="QUIT"  W !,J

EN1 K ^UTILITY($J) X ^%ZOSF("RSEL") I $O(^UTILITY($J,0))']"" W !!,"NO ROUTINES SELECTED!",*7 G Q

 S DGR=0,(DGDOT,DGRU)="",$P(DGDOT,".",30)="" F DGR1=0:0 S DGR=$O(^UTILITY($J,DGR)) Q:DGR=""  D CC,CHK

 ;

Q K %,%DT,DGA,DGC,DGCC,DGCOM,DGCT,DGD,DGDT,DGE,DGI,DGIN,DGL,DGLB,DGLN,DGM,DGMOD,DGNODE,DGR,DGRU,DGSB,DGT,DGU,DGV,DGVER,DGY,DIC,I,J,X,Y Q

T ;

 ;;This routine is used to determine the existing ASCII value of a selected routine

 ;;versus the value which was transported at the time of release.  The ASCII value

 ;;of the routine is determined as follows:

 ;;

 ;;1.  The first line of the routine is presumed to contain the routine name and a

 ;;    brief description and is excluded from the count.

 ;;

 ;;2.  All lines which start with a singular semi-colon are presumed to be comment

 ;;    lines and are excluded from the count.

 ;;

 ;;3.  All other lines, including those starting with two semi-colons are included

 ;;    in the count.

 ;;

 ;;4.  Any line which contains a space followed by a singular semi-colon are pre-

 ;;    sumed to be followed by comments and this portion of the line will be ex-

 ;;    cluded from the count.  Likewise for lines which contain a QUIT followed by

 ;;    two spaces and a singular semi-colon.

 ;;

 ;;5.  The total ASCII value of the routine is determined by taking, excluding the

 ;;    exceptions, as noted above, and multiplying the ASCII value of each

 ;;    character by its position on the line being checked.

 ;;

 ;;QUIT

DGINTEG   ; IHS/ADC/PDW/ENM - MAS INTEGRITY CHECKER DEC 12, 1987 ;  [ 03/25/1999  11:48 AM ]

 +1       ;;5.0;ADMISSION/DISCHARGE/TRANSFER;**1015**;MAR 25, 1999;Build 21

 +2       ;;MAS VERSION 5.0

 +3       ; IHS/HQW/KML 2/12/97 replace $N with $O w/o changing functionality

 +4        GOTO EN

CHK       ; W " ASCII Value of Routine ===> ",$J(DGT,15)

           SET X=$EXTRACT(DGR_" "_DGDOT,1,12)

           WRITE !,X

           SET DGT=0

           XECUTE "ZL @DGR X:DGRU DGIN F DGY=3:1 S (DGA,DGD)="""",DGL=$T(+DGY) Q:DGL']""""  S DGLN=$L(DGL) X DGCC"

           IF '$DATA(DGU)

               XECUTE DGWR

 +1        QUIT 

CC         SET DGCC="F DGC=1:1:DGLN S DGA=$A(DGL,DGC) S DGD=DGA_""^""_$P(DGD,""^"",1,2) S DGT=(DGA*DGC)+DGT I $S(DGLN>2:$P(DGD,""^"",2,3),1:$P(DGD,""^"",1,2))=""59^32"",DGA'=59!(DGLN=2) X DGSB Q"

 +1        SET DGSB="S DGT=DGT-($P(DGD,""^"",1)*DGC)-($P(DGD,""^"",2)*(DGC-1)) I DGC>2 S DGT=DGT-($P(DGD,""^"",3)*(DGC-2)) I DGC>3,$A(DGL,DGC-3)=32 S DGT=DGT-(32*(DGC-3))"

 +2        SET DGWR="W "" ASCII Value ===> "",$J(DGT,11),""-Now"" S Y=$O(^DG(43,1,""ROU"",""B"",DGR,0)) I Y>0,$D(^DG(43,1,""ROU"",Y,0)) S X=$P(^(0),""^"",2) I X W $J(X,11),""-Orig."" X DGWR1"

 +3        SET DGWR1="S Y=$S(DGT=X:""No Change"",DGT<X:""-""_(X-DGT),1:""+""_(DGT-X)),Y=""(""_Y_"")"" W ""  "",$J(Y,12)"

           QUIT 

EN         DO Q

           FOR I=1:1

               SET J=$PIECE($TEXT(T+I),";;",2)

               IF J="QUIT"

                   QUIT 

               WRITE !,J

EN1        KILL ^UTILITY($JOB)

           XECUTE ^%ZOSF("RSEL")

           IF $ORDER(^UTILITY($JOB,0))']""

               WRITE !!,"NO ROUTINES SELECTED!",*7

               GOTO Q

 +1        SET DGR=0

           SET (DGDOT,DGRU)=""

           SET $PIECE(DGDOT,".",30)=""

           FOR DGR1=0:0

               SET DGR=$ORDER(^UTILITY($JOB,DGR))

               IF DGR=""

                   QUIT 

               DO CC

               DO CHK

 +2       ;

Q          KILL %,%DT,DGA,DGC,DGCC,DGCOM,DGCT,DGD,DGDT,DGE,DGI,DGIN,DGL,DGLB,DGLN,DGM,DGMOD,DGNODE,DGR,DGRU,DGSB,DGT,DGU,DGV,DGVER,DGY,DIC,I,J,X,Y

           QUIT 

T         ;

 +1       ;;This routine is used to determine the existing ASCII value of a selected routine

 +2       ;;versus the value which was transported at the time of release.  The ASCII value

 +3       ;;of the routine is determined as follows:

 +4       ;;

 +5       ;;1.  The first line of the routine is presumed to contain the routine name and a

 +6       ;;    brief description and is excluded from the count.

 +7       ;;

 +8       ;;2.  All lines which start with a singular semi-colon are presumed to be comment

 +9       ;;    lines and are excluded from the count.

 +10      ;;

 +11      ;;3.  All other lines, including those starting with two semi-colons are included

 +12      ;;    in the count.

 +13      ;;

 +14      ;;4.  Any line which contains a space followed by a singular semi-colon are pre-

 +15      ;;    sumed to be followed by comments and this portion of the line will be ex-

 +16      ;;    cluded from the count.  Likewise for lines which contain a QUIT followed by

 +17      ;;    two spaces and a singular semi-colon.

 +18      ;;

 +19      ;;5.  The total ASCII value of the routine is determined by taking, excluding the

 +20      ;;    exceptions, as noted above, and multiplying the ASCII value of each

 +21      ;;    character by its position on the line being checked.

 +22      ;;

 +23      ;;QUIT