Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RGUTSTX0

RGUTSTX0.m

Go to the documentation of this file. 
  1. RGUTSTX0 ;CAIRO/DKM - Continuation of RGUTSTX;04-Sep-1998 11:26;DKM
  1.  ;;2.1;RUN TIME LIBRARY;;Mar 22, 1999
  1.  ;=================================================================
  1. CMD(RGLBL) ;
  1.  D:RGLBL'="" @RGLBL
  1.  Q
  1.  ; Postconditional
  1. PC D:$$NEXT(":") EXP()
  1.  Q:RGERR
  1.  I " "'[$E(RGM,RGPSN) S RGERR=2
  1.  E  S RGPSN=RGPSN+1
  1.  Q
  1.  ; No postconditional
  1. NPC I $$NEXT(":") S RGERR=5
  1.  E  I " "'[$E(RGM,RGPSN) S RGERR=2
  1.  E  S RGPSN=RGPSN+1
  1.  Q
  1.  ; Arguments optional
  1. OPT S:" "[$E(RGM,RGPSN) RGRN=0
  1.  Q
  1.  ; Multiple arguments
  1. ARGS(RGEX) ;
  1.  S RGEX=$G(RGEX)
  1.  F  D EXP(RGEX) Q:RGERR!'$$NEXT(",")
  1.  Q
  1.  ; Expression
  1. EXP(RGEX) ;
  1.  D EXP^RGUTSTX1(.RGEX)
  1.  Q
  1.  ; Label reference
  1. LBL(RGA) F  D LBL1(.RGA) Q:RGERR!'$$NEXT(",")
  1.  Q
  1. LBL1(RGA) ;
  1.  S RGA=+$G(RGA)
  1.  D LBL2
  1.  Q:RGERR
  1.  D:$$NEXT("+") EXP(")")
  1.  Q:RGERR
  1.  D:$$NEXT(U) LBL2
  1.  I 'RGERR,RGA=2 D PARAMS(".;0-999")
  1.  I 'RGERR,RGA D EXP(")"):$$NEXT(":")
  1.  Q
  1. LBL2 I $$NEXT("@") D
  1.  .D EXP("=")
  1.  E  S:$E(RGM,RGPSN)?.1AN.1"%" RGPSN=$$LABEL
  1.  Q
  1.  ; Write command
  1. WRITE F  D  Q:RGERR!'$$NEXT(",")
  1.  .I $$NEXT("!#") D  Q:'$$NEXT("?",0)
  1.  ..F  Q:'$$NEXT("!#")
  1.  .I $$NEXT("?*")
  1.  .D EXP()
  1.  Q
  1.  ; Read command
  1. READ N RGZ
  1.  F  D  Q:RGERR!'$$NEXT(",")
  1.  .I $$NEXT("!#") D  Q:'$$NEXT("?",0)
  1.  ..F  Q:'$$NEXT("!#")
  1.  .I $$NEXT("?") D EXP() Q
  1.  .I $$NEXT(RGQT) D QT2^RGUTSTX1 Q
  1.  .S RGZ=$$NEXT("*")
  1.  .D LVAL("LGS")
  1.  .I 'RGERR,'RGZ,$$NEXT("#") D EXP()
  1.  .I 'RGERR,$$NEXT(":") D EXP()
  1.  Q
  1.  ; Lock command
  1. LOCK D LIST("LG+:","LG")
  1.  Q
  1.  ; Set command
  1. SET D LIST("LGS=","LGS")
  1.  Q
  1.  ; New command
  1. NEW D LIST("N","")
  1.  Q
  1.  ; Kill command
  1. KILL D LIST("KGL","")
  1.  Q
  1.  ; Merge command
  1. MERGE D LIST("LG=")
  1.  Q
  1.  ; For command
  1. FOR D LVAL("LGS")
  1.  I '$$NEXT("=") S RGERR=2 Q
  1.  F  D  Q:" "[$E(RGM,RGPSN)  I '$$NEXT(",") S RGERR=2 Q
  1.  .D EXP(),EXP():$$NEXT(":"),EXP():$$NEXT(":")
  1.  Q
  1.  ; Evaluate L-value
  1.  ; RGL: Allowed types:
  1.  ;     L=Local array
  1.  ;     G=Global arrays
  1.  ;     S=Settable intrinsics/system variables
  1.  ;     N=Newable system variables
  1.  ;     K=Killable system variables
  1. LVAL(RGL) ;
  1.  I $$NEXT("@",0) D  Q
  1.  .S RGL="="
  1.  .D EXP(.RGL)
  1.  S RGL=$G(RGL)
  1.  I RGL["G",$$NEXT(U) D  Q
  1.  .N RGF
  1.  .D GLBL^RGUTSTX1
  1.  I $TR(RGL,"SNK")'=RGL,$$NEXT("$") D  Q
  1.  .N RGZ
  1.  .S RGZ=$$INT(.RGPSN,RGL)
  1.  .D:'RGERR PARAMS(RGZ)
  1.  S RGPSN=$$NAME(RGPSN,"%")
  1.  I 'RGERR,RGL["L" D PARAMS()
  1.  Q
  1.  ; Evaluate parameters/subscripts
  1. PARAMS(RGX) ;
  1.  D:$$NEXT("(") PLIST^RGUTSTX1(.RGX)
  1.  Q
  1.  ; New/Kill/Set/Lock argument list
  1. LIST(RGL1,RGL2) ;
  1.  N RGP,RGI
  1.  S RGP=0
  1.  F  D  Q:RGERR!'$$NEXT(",")
  1.  .I 'RGP,RGL1["+",$$NEXT("+-")
  1.  .I $D(RGL2),$$NEXT("(") D  Q:RGERR
  1.  ..I RGP S RGERR=2 Q
  1.  ..E  S RGP=1
  1.  .S RGI=$S(RGP:RGL2,1:RGL1)
  1.  .D LVAL(.RGI)
  1.  .Q:RGERR
  1.  .I $$NEXT(")") D  Q:RGERR
  1.  ..I RGP S RGP=0
  1.  ..E  S RGERR=2
  1.  .I 'RGP,RGL1[":",$$NEXT(":") D EXP()
  1.  .I 'RGP,RGL1["=" D
  1.  ..I '$$NEXT("=") S:RGI'["@" RGERR=2
  1.  ..E  D EXP():$D(RGL2),LVAL(RGL1):'$D(RGL2)
  1.  I 'RGERR,RGP S RGERR=3
  1.  Q
  1.  ; Check for validity of label name
  1. LABEL(RGP) ;
  1.  Q $$NAME(.RGP,"L%")
  1.  ; Check for validity of variable/label name
  1. NAME(RGP,RGF) ;
  1.  N RGP1
  1.  S (RGP,RGP1)=$G(RGP,RGPSN),RGF=$G(RGF)
  1.  I RGF["$",$E(RGM,RGP)="$" S RGP=RGP+1
  1.  I RGF["%",$E(RGM,RGP)="%" S RGP=RGP+1
  1.  F RGP=RGP:1 Q:$E(RGM,RGP)'?@$S(RGF["L":"1AN",RGP=RGP1:"1A",1:"1AN")
  1.  S:RGP=RGP1 RGERR=$S(RGF["L":11,1:1)
  1.  Q RGP
  1.  ; Instrinsic function/system variable
  1. INT(RGP,RGL) ;
  1.  N RGP2,RGINT,RGNM
  1.  S RGP=$G(RGP,RGPSN),RGP2=$$NAME(RGP),RGL=$G(RGL)
  1.  Q:RGERR ""
  1.  S RGNM=$E(RGM,RGP,RGP2-1)
  1.  I $E(RGM,RGP2)="(" S:$D(^TMP(RGPID,"FCN",RGNM)) RGINT=^(RGNM)
  1.  E  S:$D(^TMP(RGPID,"SYS",RGNM)) RGINT=^(RGNM)
  1.  I '$D(RGINT),RGO["Z" S RGINT=";0-999"
  1.  I '$D(RGINT) S RGERR=7
  1.  E  I RGL'="",$TR(RGL,$P(RGINT,";"))=RGL S RGERR=2,RGINT=""
  1.  E  S RGP=RGP2
  1.  Q $G(RGINT)
  1.  ; Check next character
  1. NEXT(RGC,RGI) ;
  1.  I RGPSN'>RGLEN,RGC[$E(RGM,RGPSN) S RGPSN=RGPSN+$G(RGI,1)
  1.  Q $T