KMPDU2 ;OAK/RAK - CM Tools Routine Utilities ;08/31/11 09:21
;;3.0;KMPD;;Jan 22, 2009;Build 42
;
IRSRC(KMPDDA) ;-- extrinsic function - check for local mods in INSTALL file
;-----------------------------------------------------------------------
; KMPDDA... DA as defined in fileman programmers manual.
;
; Return: "NO" - no local mods.
; "YES" - local mods.
;
; This extrinsic function is called from computed field #573099 (LOCAL
; MODIFICATIONS) in file #9.7 (INSTALL).
;-----------------------------------------------------------------------
;
Q:'$G(KMPDDA) "NO"
;
N I,RTN,RETURN
S I=0,RETURN="NO"
F S I=$O(^XPD(9.7,KMPDDA,"RTN",I)) Q:'I D Q:RETURN="YES"
.Q:'$D(^XPD(9.7,KMPDDA,"RTN",I,0)) S RTN=$P(^(0),U)
.S:$$ROUSRC1(RTN,"LOCAL MOD/") RETURN="YES"
.;S:$$ROUSRC1(RTN,"/LOCAL MOD/") RETURN="YES"
;
Q RETURN
;
ROUFIND(KMPDY,KMPDRNM,KMPDGBL) ;-- find routines.
;-----------------------------------------------------------------------
; KMPDRNM.. Routine name to search for.
; KMPDGBL... Global to store data. Stored in format:
; RoutineName^RoutineSize^Checksum
;-----------------------------------------------------------------------
;
K KMPDY
;
S KMPDRNM=$G(KMPDRNM),KMPDGBL=$G(KMPDGBL)
;
I KMPDRNM="" S KMPDY="[Routine not defined]" Q
I KMPDGBL="" S KMPDY="[Global for storage is not defined]" Q
;
N DATA,LN,ROU,RTN,X,Y
;
; kill global with check for ^tmp or ^utility.
D KILL^KMPDU(.DATA,KMPDGBL)
; if error.
I $E(DATA)="[" S KMPDY=DATA Q
;
S KMPDY=$NA(@KMPDGBL)
;
; remove all spaces
S KMPDRNM=$TR(KMPDRNM," ","")
; if just one routine
I $E(KMPDRNM,$L(KMPDRNM))'["*" D Q
.; if invalid routine name
.I '$$ROUNAME(KMPDRNM) S @KMPDGBL@(0)="<"_KMPDRNM_" contains invalid characters or is greater than 8 characters length>" Q
.; if routine not defined.
.I '$D(^$ROUTINE(KMPDRNM)) S @KMPDGBL@(0)="<Routine "_KMPDRNM_" not defined>" Q
.I $G(^%ZOSF("OS"))["OpenM",'$D(^ROUTINE(KMPDRNM)) S @KMPDGBL@(0)="<Routine "_KMPDRNM_" missing source code>" Q
.; if defined.
.S $P(@KMPDGBL@(0),U)=KMPDRNM
.; checksum
.S X=KMPDRNM X ^%ZOSF("RSUM1") S $P(@KMPDGBL@(0),U,2)=Y
;
; remove "*" if any.
S:$E(KMPDRNM,$L(KMPDRNM))="*" KMPDRNM=$E(KMPDRNM,1,$L(KMPDRNM)-1)
I '$$ROUNAME(KMPDRNM) S @KMPDGBL@(0)="<"_KMPDRNM_" contains invalid characters or is greater than 8 characters in length>" Q
S ROU=$$ENDCHAR(KMPDRNM),RTN=KMPDRNM,LN=0
F S ROU=$O(^$ROUTINE(ROU)) Q:ROU=""!($E(ROU,1,$L(RTN))'=RTN)!(LN>1000) D
.I $G(^%ZOSF("OS"))["OpenM",'$D(^ROUTINE(ROU)) S @KMPDGBL@(LN)=ROU_"^no source",LN=LN+1 Q
.S $P(@KMPDGBL@(LN),U)=ROU
.; checksum
.S X=ROU X ^%ZOSF("RSUM1") S $P(@KMPDGBL@(LN),U,2)=Y
.S LN=LN+1
;
S:'$D(@KMPDGBL) KMPDY(0)="<No Data To Report>"
;
Q
;
ROUINQ(KMPDY,KMPDROU) ;-- routine inquiry.
;----------------------------------------------------------------------
; KMPDROU.. Routine(s) to search (this may be a partial name.
;----------------------------------------------------------------------
;
K KMPDY
;
S KMPDROU=$G(KMPDROU)
I KMPDROU="" S KMPDY(0)="[Routine name not defined]" Q
I '$$ROUNAME(KMPDROU) S @KMPDGBL@(0)="<"_KMPDROU_" contains invalid characters or is greater than 8 characters in length>" Q
I '$D(^$ROUTINE(KMPDROU)) S KMPDY(0)="[Routine '"_KMPDROU_"' not defined]" Q
;
N DIF,I,LN,ROU,X,XCNP
;
S DIF="ROU(",XCNP=0
S X=KMPDROU X ^%ZOSF("TEST")
I '$T S KMPDY(0)="[Routine '"_KMPDROU_"' not defined]" Q
I $G(^%ZOSF("OS"))["OpenM",'$D(^ROUTINE(KMPDROU)) S KMPDY(0)="[Unable to load routine - no source code]" Q
X ^%ZOSF("LOAD")
S (I,LN,LN(0))=0
F S I=$O(ROU(I)) Q:'I I $D(ROU(I,0)) D
.S X=$P(ROU(I,0)," ",1),ROU(I,0)=$P(ROU(I,0)," ",2,999)
.I $A($E(X))>32 S LN(0)=0
.I LN(0)>0,(LN(0)#10)=0 S X="[+"_LN(0)_"]"
.S KMPDY(LN)=$$LJ^XLFSTR(X,8," ")_ROU(I,0),LN=LN+1,LN(0)=LN(0)+1
;
S:'$D(KMPDY) KMPDY(0)="[Unable to load routine]"
;
Q
;
ROUSRC(KMPDY,KMPDROU,KMPDTXT) ;-- routine search
;----------------------------------------------------------------------
; KMPDROU.. Routine(s) to search (this may be a partial name.
; KMPDTXT.. Text to search for in routine.
;----------------------------------------------------------------------
;
K KMPDY
;
S KMPDROU=$G(KMPDROU),KMPDTXT=$$UP^XLFSTR($G(KMPDTXT))
;
I KMPDROU="" S KMPDY(0)="[Routine(s) not defined]" Q
I KMPDTXT="" S KMPDY(0)="[Search Text not defined]" Q
;
N LN,RN,RTN,STAR
;
S RTN=KMPDROU,STAR=$E(RTN,$L(RTN))
S:STAR="*" RTN=$E(RTN,1,$L(RTN)-1)
;
; if just one routine.
I STAR'="*" D Q
.I '$$ROUNAME(RTN) S @KMPDGBL@(0)="<"_RTN_" contains invalid characters or is greater than 8 characters in length>" Q
.; if match.
.I $$ROUSRC1(RTN,KMPDTXT) S KMPDY(0)=RTN Q
.; else no match.
.S KMPDY(0)="<No Matches Found>"
;
S RN=RTN,LN=0
F S RN=$O(^$ROUTINE(RN)) Q:RN=""!($E(RN,1,$L(RTN))'=RTN) D
.; if match.
.I $$ROUSRC1(RN,KMPDTXT) S KMPDY(LN)=RN,LN=LN+1 Q
;
S:'$D(KMPDY) KMPDY(0)="<No Matches Found>"
;
Q
;
ROUSRC1(KMPDROU,KMPDTXT) ;-- extrinsic function - check for text.
;----------------------------------------------------------------------
; KMPDROU.. Routine(s) to search (this may be a partial name.
; KMPDTXT.. Text to search for in routine.
;
; Return: 0 - no match.
; 1 - match.
;----------------------------------------------------------------------
;
S KMPDROU=$G(KMPDROU),KMPDTXT=$$UP^XLFSTR($G(KMPDTXT))
;
Q:KMPDROU="" 0
Q:KMPDTXT="" 0
;
N DIF,I,RETURN,ROU,X,XCNP
;
S DIF="ROU(",(I,RETURN,XCNP)=0,RETURN=0
S X=KMPDROU X ^%ZOSF("TEST")
Q:'$T 0
I $G(^%ZOSF("OS"))["OpenM",'$D(^ROUTINE(KMPDROU)) Q
X ^%ZOSF("LOAD")
F S I=$O(ROU(I)) Q:'I I $D(ROU(I,0)) D Q:RETURN
.I $$UP^XLFSTR(ROU(I,0))[KMPDTXT S RETURN=1
;
Q RETURN
;
ROUSRC2(KMPDY,KMPDTXT,KMPDGBL,KMPDROU) ;-- search for text in routine.
;----------------------------------------------------------------------
; KMPDTXT.. Text to search for in routine.
; KMPDGBL... Global to store data.
; KMPDROU.. array containing routine names to be searches.
;-----------------------------------------------------------------------
;
K KMPDY
;
S KMPDTXT=$G(KMPDTXT),KMPDGBL=$G(KMPDGBL)
;
I '$D(KMPDROU) S @KMPDGBL@(0)="[Routine(s) name not defined]" Q
I KMPDTXT="" S @KMPDGBL@(0)="[Search text not defined]" Q
I KMPDGBL="" S KMPDY="[Global for storage is not defined]" Q
;
N DATA,DIF,I,LABEL,LN,OFFSET,ROU,RTN,X,XCNP
;
; kill global with check for ^tmp or ^utility.
D KILL^KMPDU(.DATA,KMPDGBL)
; if error.
I $E(DATA)="[" S KMPDY=DATA Q
;
S KMPDY=$NA(@KMPDGBL)
;
S KMPDTXT=$$UP^XLFSTR(KMPDTXT)
;
S ROU="",LN=0
F S ROU=$O(KMPDROU(ROU)) Q:ROU="" D
.K ROUT
.S DIF="ROUT(",(I,OFFSET,XCNP)=0,LABEL=ROU
.S X=ROU X ^%ZOSF("TEST") Q:'$T
.I $G(^%ZOSF("OS"))["OpenM",'$D(^ROUTINE(ROU)) Q
.X ^%ZOSF("LOAD")
.F S I=$O(ROUT(I)) Q:'I I $D(ROUT(I,0)) D
..S OFFSET=OFFSET+1
..; if new label.
..I $E(ROUT(I,0))'=" " S LABEL=$$ROULABEL^KMPDU2(ROUT(I,0)),OFFSET=0
..; quit if no match.
..Q:$$UP^XLFSTR(ROUT(I,0))'[KMPDTXT
..S @KMPDGBL@(LN)=ROU_"^"_LABEL_$S(OFFSET:"+"_OFFSET,1:"")_" "_ROUT(I,0)
..S LN=LN+1
;
S:'$D(@KMPDGBL) @KMPDGBL@(0)="<No Match Found>"
;
Q
;
ROULABEL(TEXT) ;-- routine label.
Q:$G(TEXT)="" ""
N I,LABEL
S LABEL=""
F I=1:1 Q:$E(TEXT,I)=" "!($E(TEXT,I)="(") S LABEL=$E(TEXT,0,I)
Q LABEL
;
ROUNAME(KMPDRNM) ;-- extrinsic function - determine if routine name is valid
;--------------------------------------------------------------------
; KMPDRNM... free text - routine name
;--------------------------------------------------------------------
; routine name must begin with alpha and then be 1 to 7 additional
; alpha or numeric characters.
S KMPDRNM=$G(KMPDRNM)
Q KMPDRNM?1A!(KMPDRNM?1A1.7AN)!(KMPDRNM?1"%"1.7AN)
;
ENDCHAR(RTN) ;-- extrinsic function - determine last character for $ordering
;--------------------------------------------------------------------
; RTN - routine name
;--------------------------------------------------------------------
Q:$G(RTN)="" ""
; less than one
Q:($A($E(RTN,$L(RTN)))<49) $E(RTN,1,$L(RTN)-1)
; numbers
Q:($A($E(RTN,$L(RTN)))<58) $E(RTN,1,$L(RTN)-1)_$C(($A($E(RTN,$L(RTN)))-1))_"z"
; if RTN = 'A'
Q:RTN="A" "%z"
; if 'A' then use '%'
Q:($E(RTN,$L(RTN))="A") $E(RTN,1,$L(RTN)-1)_"9z"
; if 91 through 97
Q:($A($E(RTN,$L(RTN)))>90)&($A($E(RTN,$L(RTN)))<98) $E(RTN,1,$L(RTN)-1)_"Z"
; if lowercase
Q:($A($E(RTN,$L(RTN)))<123) $E(RTN,1,$L(RTN)-1)_$C(($A($E(RTN,$L(RTN)))-1))_"z"
; if greater than 122
Q:($A($E(RTN,$L(RTN)))>122) $E(RTN,1,$L(RTN)-1)_"y"
; default
Q RTN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HKMPDU2 8751 printed Jan 18, 2025@02:42:12 Page 2
KMPDU2 ;OAK/RAK - CM Tools Routine Utilities ;08/31/11 09:21
+1 ;;3.0;KMPD;;Jan 22, 2009;Build 42
+2 ;
IRSRC(KMPDDA) ;-- extrinsic function - check for local mods in INSTALL file
+1 ;-----------------------------------------------------------------------
+2 ; KMPDDA... DA as defined in fileman programmers manual.
+3 ;
+4 ; Return: "NO" - no local mods.
+5 ; "YES" - local mods.
+6 ;
+7 ; This extrinsic function is called from computed field #573099 (LOCAL
+8 ; MODIFICATIONS) in file #9.7 (INSTALL).
+9 ;-----------------------------------------------------------------------
+10 ;
+11 if '$GET(KMPDDA)
QUIT "NO"
+12 ;
+13 NEW I,RTN,RETURN
+14 SET I=0
SET RETURN="NO"
+15 FOR
SET I=$ORDER(^XPD(9.7,KMPDDA,"RTN",I))
if 'I
QUIT
Begin DoDot:1
+16 if '$DATA(^XPD(9.7,KMPDDA,"RTN",I,0))
QUIT
SET RTN=$PIECE(^(0),U)
+17 if $$ROUSRC1(RTN,"LOCAL MOD/")
SET RETURN="YES"
+18 ;S:$$ROUSRC1(RTN,"/LOCAL MOD/") RETURN="YES"
End DoDot:1
if RETURN="YES"
QUIT
+19 ;
+20 QUIT RETURN
+21 ;
ROUFIND(KMPDY,KMPDRNM,KMPDGBL) ;-- find routines.
+1 ;-----------------------------------------------------------------------
+2 ; KMPDRNM.. Routine name to search for.
+3 ; KMPDGBL... Global to store data. Stored in format:
+4 ; RoutineName^RoutineSize^Checksum
+5 ;-----------------------------------------------------------------------
+6 ;
+7 KILL KMPDY
+8 ;
+9 SET KMPDRNM=$GET(KMPDRNM)
SET KMPDGBL=$GET(KMPDGBL)
+10 ;
+11 IF KMPDRNM=""
SET KMPDY="[Routine not defined]"
QUIT
+12 IF KMPDGBL=""
SET KMPDY="[Global for storage is not defined]"
QUIT
+13 ;
+14 NEW DATA,LN,ROU,RTN,X,Y
+15 ;
+16 ; kill global with check for ^tmp or ^utility.
+17 DO KILL^KMPDU(.DATA,KMPDGBL)
+18 ; if error.
+19 IF $EXTRACT(DATA)="["
SET KMPDY=DATA
QUIT
+20 ;
+21 SET KMPDY=$NAME(@KMPDGBL)
+22 ;
+23 ; remove all spaces
+24 SET KMPDRNM=$TRANSLATE(KMPDRNM," ","")
+25 ; if just one routine
+26 IF $EXTRACT(KMPDRNM,$LENGTH(KMPDRNM))'["*"
Begin DoDot:1
+27 ; if invalid routine name
+28 IF '$$ROUNAME(KMPDRNM)
SET @KMPDGBL@(0)="<"_KMPDRNM_" contains invalid characters or is greater than 8 characters length>"
QUIT
+29 ; if routine not defined.
+30
*** ERROR ***
IF '$DATA(^$ROUTINE(KMPDRNM))
SET @KMPDGBL@(0)="<Routine "_KMPDRNM_" not defined>"
QUIT
+31 IF $GET(^%ZOSF("OS"))["OpenM"
IF '$DATA(^ROUTINE(KMPDRNM))
SET @KMPDGBL@(0)="<Routine "_KMPDRNM_" missing source code>"
QUIT
+32 ; if defined.
+33 SET $PIECE(@KMPDGBL@(0),U)=KMPDRNM
+34 ; checksum
+35 SET X=KMPDRNM
XECUTE ^%ZOSF("RSUM1")
SET $PIECE(@KMPDGBL@(0),U,2)=Y
End DoDot:1
QUIT
+36 ;
+37 ; remove "*" if any.
+38 if $EXTRACT(KMPDRNM,$LENGTH(KMPDRNM))="*"
SET KMPDRNM=$EXTRACT(KMPDRNM,1,$LENGTH(KMPDRNM)-1)
+39 IF '$$ROUNAME(KMPDRNM)
SET @KMPDGBL@(0)="<"_KMPDRNM_" contains invalid characters or is greater than 8 characters in length>"
QUIT
+40 SET ROU=$$ENDCHAR(KMPDRNM)
SET RTN=KMPDRNM
SET LN=0
+41 FOR
