KMPDUT4A ;OAK/RAK; Multi-Lookup Global/Array Check ;2/17/04 10:47
;;3.0;KMPD;;Jan 22, 2009;Build 42
;
CHECK() ;extrinsic function
;--------------------------------------------------------------------
; return: 0 - if successful
; 1 - if error found
;
; check variable 'ARRAY' for correct global or local array format
;--------------------------------------------------------------------
I '$D(ARRAY) D Q 1
.W !?7,"...variable 'ARRAY' is undefined..."
I $G(DIC)']"" D Q 1
.W !?7,"...variable 'DIC' is undefined..."
.D FTR^KMPDUTL4("Press <RET> to continue")
I $E(ARRAY)="^",(ARRAY'["(")!(ARRAY["()")!($E(ARRAY,$F(ARRAY,"("))']"")!($E(ARRAY,$F(ARRAY,"("))=",") D Q 1
.W !?7,"...global must have a subscript (ex: '^TMP($J' )..."
;
;global array must be either ^TMP or ^UTILITY - just to be safe
I $E(ARRAY)="^" I $E(ARRAY,2,($F(ARRAY,"(")-2))'="TMP",($E(ARRAY,2,($F(ARRAY,"(")-2))'="UTILITY") D Q 1
.W !!?7,"...global names must be either '^TMP' or '^UTILITY'..."
;
;if local array
I $E(ARRAY)'="^" D
.;remove '()' from local array if no subscript
.I $E(ARRAY,$F(ARRAY,"("))=")"!($E(ARRAY,$F(ARRAY,"("))']"") D
..S ARRAY=$TR(ARRAY,"(",""),ARRAY=$TR(ARRAY,")","")
;
;if subcript array add closing parenthesis and remove trailing comma
I ARRAY["("!($E(ARRAY)="^") D
.I $E(ARRAY,$L(ARRAY))'=")" S ARRAY=ARRAY_")"
.I $E(ARRAY,($L(ARRAY)-1))="," S ARRAY=$E(ARRAY,1,($L(ARRAY)-2))_")"
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HKMPDUT4A 1465 printed Apr 09, 2024@20:45:53 Page 2
KMPDUT4A ;OAK/RAK; Multi-Lookup Global/Array Check ;2/17/04 10:47
+1 ;;3.0;KMPD;;Jan 22, 2009;Build 42
+2 ;
CHECK() ;extrinsic function
+1 ;--------------------------------------------------------------------
+2 ; return: 0 - if successful
+3 ; 1 - if error found
+4 ;
+5 ; check variable 'ARRAY' for correct global or local array format
+6 ;--------------------------------------------------------------------
+7 IF '$DATA(ARRAY)
Begin DoDot:1
+8 WRITE !?7,"...variable 'ARRAY' is undefined..."
End DoDot:1
QUIT 1
+9 IF $GET(DIC)']""
Begin DoDot:1
+10 WRITE !?7,"...variable 'DIC' is undefined..."
+11 DO FTR^KMPDUTL4("Press <RET> to continue")
End DoDot:1
QUIT 1
+12 IF $EXTRACT(ARRAY)="^"
IF (ARRAY'["(")!(ARRAY["()")!($EXTRACT(ARRAY,$FIND(ARRAY,"("))']"")!($EXTRACT(ARRAY,$FIND(ARRAY,"("))=",")
Begin DoDot:1
+13 WRITE !?7,"...global must have a subscript (ex: '^TMP($J' )..."
End DoDot:1
QUIT 1
+14 ;
+15 ;global array must be either ^TMP or ^UTILITY - just to be safe
+16 IF $EXTRACT(ARRAY)="^"
IF $EXTRACT(ARRAY,2,($FIND(ARRAY,"(")-2))'="TMP"
IF ($EXTRACT(ARRAY,2,($FIND(ARRAY,"(")-2))'="UTILITY")
Begin DoDot:1
+17 WRITE !!?7,"...global names must be either '^TMP' or '^UTILITY'..."
End DoDot:1
QUIT 1
+18 ;
+19 ;if local array
+20 IF $EXTRACT(ARRAY)'="^"
Begin DoDot:1
+21 ;remove '()' from local array if no subscript
+22 IF $EXTRACT(ARRAY,$FIND(ARRAY,"("))=")"!($EXTRACT(ARRAY,$FIND(ARRAY,"("))']"")
Begin DoDot:2
+23 SET ARRAY=$TRANSLATE(ARRAY,"(","")
SET ARRAY=$TRANSLATE(ARRAY,")","")
End DoDot:2
End DoDot:1
+24 ;
+25 ;if subcript array add closing parenthesis and remove trailing comma
+26 IF ARRAY["("!($EXTRACT(ARRAY)="^")
Begin DoDot:1
+27 IF $EXTRACT(ARRAY,$LENGTH(ARRAY))'=")"
SET ARRAY=ARRAY_")"
+28 IF $EXTRACT(ARRAY,($LENGTH(ARRAY)-1))=","
SET ARRAY=$EXTRACT(ARRAY,1,($LENGTH(ARRAY)-2))_")"
End DoDot:1
+29 QUIT 0
