KMPDU1 ;SF/RAK - CM Developer Tools Utilities ;2/17/04 09:49
;;3.0;KMPD;;Jan 22, 2009;Build 42
GBLCHK(KMPDY,KMPDGBL) ;-- check global name.
;----------------------------------------------------------------------
; KMPDGBL... Global name.
;
; Check to make sure global name is in format for subscript indirection.
;----------------------------------------------------------------------
;
K KMPDY
;
I $G(KMPDGBL)="" S KMPDY(0)="[Global name not defined]" Q
;
I $E(KMPDGBL)["?" D Q
.S KMPDY(0)="['"_KMPDGBL_" is an incorrect global name]"
;
I KMPDGBL["*" S KMPDY(0)="['"_KMPDGBL_" is an incorrect global name]" Q
;
N GLOBAL
;
S GLOBAL=KMPDGBL
; make sure begins with up-arrow (^).
I $E(GLOBAL)'="^" S GLOBAL="^"_GLOBAL
; make sure contains a '('.
I GLOBAL'["(" S GLOBAL=GLOBAL_"("
; if ends with comma (,) then remove comma.
I $E(GLOBAL,($L(GLOBAL)))="," S $E(GLOBAL,($L(GLOBAL)))=""
; make sure ends with a ')'.
I $E(GLOBAL,$L(GLOBAL))'=")" S GLOBAL=GLOBAL_")"
; if ends with comma (,) then remove comma.
I $E(GLOBAL,($L(GLOBAL)-1))="," S $E(GLOBAL,($L(GLOBAL)-1))=""
; if global contains () then change to ("").
I $E(GLOBAL,($L(GLOBAL)-1),$L(GLOBAL))="()" D
.S $E(GLOBAL,$L(GLOBAL))=""""")"
;
S KMPDY(0)=GLOBAL
;
Q
;
GBLLIST(KMPDY,KMPDGBL,KMPDST,KMPDLN,KMPDLEN) ;-- get global data
;----------------------------------------------------------------------
; KMPDGBL... Global name.
; KMPDST... Starting global node. If this is a continuation then use
; this entry as starting point. If original time through
; this should be set to null ("").
; KMPDLN... Number of lines to fill before quitting.
; KMPDLEN.. Length of line before continuing on next line
;----------------------------------------------------------------------
;
K KMPDY
;
S KMPDGBL=$G(KMPDGBL),KMPDST=$G(KMPDST),KMPDLN=+$G(KMPDLN),KMPDLEN=+$G(KMPDLEN)
S:'KMPDLEN KMPDLEN=80
;
I 'KMPDLN S KMPDY(0)="[Number of lines not defined]" Q
;
N GBL,GLOBAL,LAST,LEN,LN
;
D GBLCHK(.KMPDY,KMPDGBL)
; if error.
I $E($G(KMPDY(0)))="[" Q
;
S GLOBAL=$G(KMPDY(0))
I GLOBAL="" S KMPDY(0)="[Unable to process]" Q
I GLOBAL[",," S KMPDY(0)="[Cannot have a blank subscript]" Q
I $Q(@GLOBAL)="" S KMPDY(0)="<No Data to Report>" Q
;
S GBL=$E(GLOBAL,1,$L(GLOBAL)-1)
; if GLOBAL("") then just use GLOBAL.
S:$E(GBL,$L(GBL))="""" GBL=$P(GBL,"(")
S LEN=KMPDLEN,LN=1
;
; if data in GLOBAL.
I KMPDST=""&(GLOBAL'["("""")") I $D(@GLOBAL)#2 D
.S KMPDY(LN)=GLOBAL_" = "_@GLOBAL,LN=LN+1
;
S:KMPDST]"" GLOBAL=KMPDST
;
F S GLOBAL=$Q(@GLOBAL) Q:GLOBAL=""!($E(GLOBAL,1,$L(GBL))'=GBL) D Q:LN>KMPDLN
.S LAST=GLOBAL
.S KMPDY(LN)=GLOBAL_" = "
.; if fits within LEN.
.I $L(@GLOBAL)'>LEN S KMPDY(LN)=KMPDY(LN)_@GLOBAL,LN=LN+1 Q
.; parse data to fit on line.
.D PARSE(LEN)
;
S KMPDY(0)=GLOBAL
; if no more subscripts.
;($E(GLOBAL,1,$L(GBL))'=GBL)
I GLOBAL="" S KMPDY(0)="***end of list***"
E I $E($Q(@GLOBAL),1,$L(GBL))'=GBL S KMPDY(0)="***end of list***"
;
Q
;
PARSE(LEN) ;
; if length of data is greater than current position to the end
; of the screen the data must be broken down and printed on
; separate lines so that $Y will continue to be updated
;
S LEN=+$G(LEN) Q:'LEN N C
F C=0:1 Q:$E(@GLOBAL,(LEN*C),(LEN*(C+1)-1))']"" D
.S:$G(KMPDY(LN))="" KMPDY(LN)=" "
.S KMPDY(LN)=$G(KMPDY(LN))_$E(@GLOBAL,(LEN*C),(LEN*(C+1)-1))
.S LN=LN+1
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HKMPDU1 3516 printed Dec 13, 2024@01:40:57 Page 2
KMPDU1 ;SF/RAK - CM Developer Tools Utilities ;2/17/04 09:49
+1 ;;3.0;KMPD;;Jan 22, 2009;Build 42
GBLCHK(KMPDY,KMPDGBL) ;-- check global name.
+1 ;----------------------------------------------------------------------
+2 ; KMPDGBL... Global name.
+3 ;
+4 ; Check to make sure global name is in format for subscript indirection.
+5 ;----------------------------------------------------------------------
+6 ;
+7 KILL KMPDY
+8 ;
+9 IF $GET(KMPDGBL)=""
SET KMPDY(0)="[Global name not defined]"
QUIT
+10 ;
+11 IF $EXTRACT(KMPDGBL)["?"
Begin DoDot:1
+12 SET KMPDY(0)="['"_KMPDGBL_" is an incorrect global name]"
End DoDot:1
QUIT
+13 ;
+14 IF KMPDGBL["*"
SET KMPDY(0)="['"_KMPDGBL_" is an incorrect global name]"
QUIT
+15 ;
+16 NEW GLOBAL
+17 ;
+18 SET GLOBAL=KMPDGBL
+19 ; make sure begins with up-arrow (^).
+20 IF $EXTRACT(GLOBAL)'="^"
SET GLOBAL="^"_GLOBAL
+21 ; make sure contains a '('.
+22 IF GLOBAL'["("
SET GLOBAL=GLOBAL_"("
+23 ; if ends with comma (,) then remove comma.
+24 IF $EXTRACT(GLOBAL,($LENGTH(GLOBAL)))=","
SET $EXTRACT(GLOBAL,($LENGTH(GLOBAL)))=""
+25 ; make sure ends with a ')'.
+26 IF $EXTRACT(GLOBAL,$LENGTH(GLOBAL))'=")"
SET GLOBAL=GLOBAL_")"
+27 ; if ends with comma (,) then remove comma.
+28 IF $EXTRACT(GLOBAL,($LENGTH(GLOBAL)-1))=","
SET $EXTRACT(GLOBAL,($LENGTH(GLOBAL)-1))=""
+29 ; if global contains () then change to ("").
+30 IF $EXTRACT(GLOBAL,($LENGTH(GLOBAL)-1),$LENGTH(GLOBAL))="()"
Begin DoDot:1
+31 SET $EXTRACT(GLOBAL,$LENGTH(GLOBAL))=""""")"
End DoDot:1
+32 ;
+33 SET KMPDY(0)=GLOBAL
+34 ;
+35 QUIT
+36 ;
GBLLIST(KMPDY,KMPDGBL,KMPDST,KMPDLN,KMPDLEN) ;-- get global data
+1 ;----------------------------------------------------------------------
+2 ; KMPDGBL... Global name.
+3 ; KMPDST... Starting global node. If this is a continuation then use
+4 ; this entry as starting point. If original time through
+5 ; this should be set to null ("").
+6 ; KMPDLN... Number of lines to fill before quitting.
+7 ; KMPDLEN.. Length of line before continuing on next line
+8 ;----------------------------------------------------------------------
+9 ;
+10 KILL KMPDY
+11 ;
+12 SET KMPDGBL=$GET(KMPDGBL)
SET KMPDST=$GET(KMPDST)
SET KMPDLN=+$GET(KMPDLN)
SET KMPDLEN=+$GET(KMPDLEN)
+13 if 'KMPDLEN
SET KMPDLEN=80
+14 ;
+15 IF 'KMPDLN
SET KMPDY(0)="[Number of lines not defined]"
QUIT
+16 ;
+17 NEW GBL,GLOBAL,LAST,LEN,LN
+18 ;
+19 DO GBLCHK(.KMPDY,KMPDGBL)
+20 ; if error.
+21 IF $EXTRACT($GET(KMPDY(0)))="["
QUIT
+22 ;
+23 SET GLOBAL=$GET(KMPDY(0))
+24 IF GLOBAL=""
SET KMPDY(0)="[Unable to process]"
QUIT
+25 IF GLOBAL[",,"
SET KMPDY(0)="[Cannot have a blank subscript]"
QUIT
+26 IF $QUERY(@GLOBAL)=""
SET KMPDY(0)="<No Data to Report>"
QUIT
+27 ;
+28 SET GBL=$EXTRACT(GLOBAL,1,$LENGTH(GLOBAL)-1)
+29 ; if GLOBAL("") then just use GLOBAL.
+30 if $EXTRACT(GBL,$LENGTH(GBL))=""""
SET GBL=$PIECE(GBL,"(")
+31 SET LEN=KMPDLEN
SET LN=1
+32 ;
+33 ; if data in GLOBAL.
+34 IF KMPDST=""&(GLOBAL'["("""")")
IF $DATA(@GLOBAL)#2
Begin DoDot:1
+35 SET KMPDY(LN)=GLOBAL_" = "_@GLOBAL
SET LN=LN+1
End DoDot:1
+36 ;
+37 if KMPDST]""
SET GLOBAL=KMPDST
+38 ;
+39 FOR
SET GLOBAL=$QUERY(@GLOBAL)
if GLOBAL=""!($EXTRACT(GLOBAL,1,$LENGTH(GBL))'=GBL)
QUIT
Begin DoDot:1
+40 SET LAST=GLOBAL
+41 SET KMPDY(LN)=GLOBAL_" = "
+42 ; if fits within LEN.
+43 IF $LENGTH(@GLOBAL)'>LEN
SET KMPDY(LN)=KMPDY(LN)_@GLOBAL
SET LN=LN+1
QUIT
+44 ; parse data to fit on line.
+45 DO PARSE(LEN)
End DoDot:1
if LN>KMPDLN
QUIT
+46 ;
+47 SET KMPDY(0)=GLOBAL
+48 ; if no more subscripts.
+49 ;($E(GLOBAL,1,$L(GBL))'=GBL)
+50 IF GLOBAL=""
SET KMPDY(0)="***end of list***"
+51 IF '$TEST
IF $EXTRACT($QUERY(@GLOBAL),1,$LENGTH(GBL))'=GBL
SET KMPDY(0)="***end of list***"
+52 ;
+53 QUIT
+54 ;
PARSE(LEN) ;
+1 ; if length of data is greater than current position to the end
+2 ; of the screen the data must be broken down and printed on
+3 ; separate lines so that $Y will continue to be updated
+4 ;
+5 SET LEN=+$GET(LEN)
if 'LEN
QUIT
NEW C
+6 FOR C=0:1
if $EXTRACT(@GLOBAL,(LEN*C),(LEN*(C+1)-1))']""
QUIT
Begin DoDot:1
+7 if $GET(KMPDY(LN))=""
SET KMPDY(LN)=" "
+8 SET KMPDY(LN)=$GET(KMPDY(LN))_$EXTRACT(@GLOBAL,(LEN*C),(LEN*(C+1)-1))
+9 SET LN=LN+1
End DoDot:1
+10 ;
+11 QUIT
