| [641] | 1 | XBINTEG ; ROUTINE INTEGRITY CHECK
|
|---|
| 2 | ;;4.0;XB;;Jul 20, 2009;Build 2
|
|---|
| 3 | ;
|
|---|
| 4 | ; This routine calls ^%RSEL to select a set of routines and generates
|
|---|
| 5 | ; an integrity checking routine for the selected routines. The user
|
|---|
| 6 | ; is asked to enter the name of the generated routine.
|
|---|
| 7 | ;
|
|---|
| 8 | START ;
|
|---|
| 9 | NEW BYTE,COUNT,QUIT,RTDATE,RTN,RTNAME,VERSION
|
|---|
| 10 | K ^UTILITY($J),^UTILITY("XBINTEG",$J)
|
|---|
| 11 | D ^XBKVAR
|
|---|
| 12 | ;D ^%RSEL K QUIT
|
|---|
| 13 | X ^%ZOSF("RSEL")
|
|---|
| 14 | I $O(^UTILITY($J,""))="" D EOJ Q
|
|---|
| 15 | S DIR(0)="F^5:8^K:X'?1U.U X",DIR("A")="Enter name of routine to be generated: ",DIR("?")="Example: APCDINTG" D ^DIR K DIR
|
|---|
| 16 | I $D(DIRUT) D EOJ Q
|
|---|
| 17 | S RTNAME=Y
|
|---|
| 18 | D CHECKRTN
|
|---|
| 19 | I 'Y D EOJ Q
|
|---|
| 20 | S DIR(0)="F^1:5^K:'(X?1.2N!(X?1.2N1"".""1.2N)) X",DIR("A")="Enter version number",DIR("?")="Must be n or n.n where the length of n is 1-2" D ^DIR K DIR
|
|---|
| 21 | I $D(DIRUT) D EOJ Q
|
|---|
| 22 | S VERSION=" ;;"_X
|
|---|
| 23 | S DIR(0)="FO^2:30",DIR("A")="Enter package name" D ^DIR K DIR
|
|---|
| 24 | I $D(DTOUT)!($D(DUOUT)) D EOJ Q
|
|---|
| 25 | S VERSION=VERSION_";"_X
|
|---|
| 26 | S DIR(0)="D",DIR("A")="Enter date",DIR("B")="TODAY" D ^DIR K DIR
|
|---|
| 27 | I $D(DIRUT) D EOJ Q
|
|---|
| 28 | D DD^%DT
|
|---|
| 29 | S RTDATE=Y
|
|---|
| 30 | S VERSION=VERSION_";;"_Y
|
|---|
| 31 | F %=1:1:11 S X=$P($T(@("LINE"_%)),";;",2,99),@("XBINTEG("_%_")=X")
|
|---|
| 32 | F %=1:1:3 S X=$P($T(@("CODE"_%)),";;",2,99),@("XBINTEG(""CODE"_%_""")=X")
|
|---|
| 33 | K %,X,Y
|
|---|
| 34 | X XBINTEG(1)
|
|---|
| 35 | Q
|
|---|
| 36 | ;
|
|---|
| 37 | CHECKRTN ;
|
|---|
| 38 | S Y=1
|
|---|
| 39 | Q:'$D(^DD("OS"))#2
|
|---|
| 40 | Q:'$D(^DD("OS",^DD("OS"),18))#2
|
|---|
| 41 | S X=RTNAME X ^(18)
|
|---|
| 42 | E Q
|
|---|
| 43 | S DIR(0)="YO",DIR("A")="Routine already exists. Want to recreate it",DIR("B")="NO" D ^DIR K DIR
|
|---|
| 44 | I $D(DIRUT) S Y=0 Q
|
|---|
| 45 | Q
|
|---|
| 46 | ;
|
|---|
| 47 | EOJ ;
|
|---|
| 48 | K %,X,Y,XBINTEG,^UTILITY($J)
|
|---|
| 49 | K DTOUT,DUOUT,DIRUT,DIROUT
|
|---|
| 50 | Q
|
|---|
| 51 | ;
|
|---|
| 52 | ; The only good thing I can say about the following is that it works.
|
|---|
| 53 | LINE1 ;;X XBINTEG(2),XBINTEG(6),XBINTEG(11)
|
|---|
| 54 | LINE2 ;;S RTN="" F S RTN=$O(^UTILITY($J,RTN)) Q:RTN="" W !,RTN ZL @RTN S (BYTE,COUNT)=0 S X=$T(+1),X=$P(X," [ ",1) X XBINTEG(4),XBINTEG(3),XBINTEG(5)
|
|---|
| 55 | LINE3 ;;F I=2:1 S X=$T(+I) Q:X="" X XBINTEG(4)
|
|---|
| 56 | LINE4 ;;F J=1:1 S Y=$E(X,J) Q:Y="" S BYTE=BYTE+1,COUNT=COUNT+$A(Y)
|
|---|
| 57 | LINE5 ;;S ^UTILITY("XBINTEG",$J,RTN)=BYTE_"^"_COUNT
|
|---|
| 58 | LINE6 ;;ZR S X=RTNAME_" ;INTEGRITY CHECKER;"_RTDATE ZI X ZI VERSION ZI " ;" ZI "START ;" ZI " NEW BYTE,COUNT,RTN" ZI " K ^UTILITY($J)" X XBINTEG(7),XBINTEG(8),XBINTEG(9),XBINTEG(10) ZS @RTNAME
|
|---|
| 59 | LINE7 ;;F I=1:1:3 S V="CODE"_I S Z=XBINTEG(V) Q:Z="" ZI Z
|
|---|
| 60 | LINE8 ;;ZI " Q" ZI " ;" ZI "LINE1 ;;X XBINTEG(2),XBINTEG(6)" F I=2:1:4 S Z="LINE"_I_" ;;"_XBINTEG(I) ZI Z
|
|---|
| 61 | LINE9 ;;ZI "LINE5 ;;S B=$P(^(RTN),""^"",1),C=$P(^(RTN),""^"",2) I B'=BYTE!(C'=COUNT) W "" has been modified""" ZI "LINE6 ;;K XBINTEG,B,C,I,J,R,X,Y" ZI " ;" ZI "LIST ;"
|
|---|
| 62 | LINE10 ;;S RTN="" F S RTN=$O(^UTILITY("XBINTEG",$J,RTN)) Q:RTN="" S Z=^(RTN),Z=" ;;"_RTN_"^"_Z ZI Z
|
|---|
| 63 | LINE11 ;;K %,XBINTEG,DTOUT,DUOUT,DIRUT,DIROUT,I,J,V,X,Y,Z,^UTILITY($J),^UTILITY("XBINTEG",$J)
|
|---|
| 64 | CODE1 ;; F I=1:1 S X=$T(LIST+I) Q:X="" S X=$P(X,";;",2),R=$P(X,"^",1),B=$P(X,"^",2),C=$P(X,"^",3),^UTILITY($J,R)=B_"^"_C
|
|---|
| 65 | CODE2 ;; F I=1:1:6 S X=$P($T(@("LINE"_I)),";;",2,99),@("XBINTEG("_I_")=X")
|
|---|
| 66 | CODE3 ;; X XBINTEG(1)
|
|---|
