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

CIAUSTX0.m

Go to the documentation of this file. 
  1. CIAUSTX0 ;MSC/IND/DKM - Continuation of CIAUSTX;04-May-2006 08:19;DKM
  1.  ;;1.2;CIA UTILITIES;;Mar 20, 2007
  1.  ;;Copyright 2000-2006, Medsphere Systems Corporation
  1.  ;=================================================================
  1. CMD(CIALBL) ;
  1.  D:CIALBL'="" @CIALBL
  1.  Q
  1.  ; Postconditional
  1. PC D:$$NEXT(":") EXP()
  1.  Q:CIAERR
  1.  I " "'[$E(CIAM,CIAPSN) S CIAERR=2
  1.  E  S CIAPSN=CIAPSN+1
  1.  Q
  1.  ; No postconditional
  1. NPC I $$NEXT(":") S CIAERR=5
  1.  E  I " "'[$E(CIAM,CIAPSN) S CIAERR=2
  1.  E  S CIAPSN=CIAPSN+1
  1.  Q
  1.  ; Arguments optional
  1. OPT S:" "[$E(CIAM,CIAPSN) CIARN=0
  1.  Q
  1.  ; Multiple arguments
  1. ARGS(CIAEX) ;
  1.  S CIAEX=$G(CIAEX)
  1.  F  D EXP(CIAEX) Q:CIAERR!'$$NEXT(",")
  1.  Q
  1.  ; Expression
  1. EXP(CIAEX) ;
  1.  D EXP^CIAUSTX1(.CIAEX)
  1.  Q
  1.  ; Label reference
  1. LBL(CIAA) F  D LBL1(.CIAA) Q:CIAERR!'$$NEXT(",")
  1.  Q
  1. LBL1(CIAA) ;
  1.  S CIAA=+$G(CIAA)
  1.  D LBL2
  1.  Q:CIAERR
  1.  D:$$NEXT("+") EXP(")")
  1.  Q:CIAERR
  1.  D:$$NEXT(U) LBL2
  1.  I 'CIAERR,CIAA=2 D PARAMS(".;0-999")
  1.  I 'CIAERR,CIAA D EXP(")"):$$NEXT(":")
  1.  Q
  1. LBL2 I $$NEXT("@") D
  1.  .D EXP("=")
  1.  E  S:$E(CIAM,CIAPSN)?.1AN.1"%" CIAPSN=$$LABEL
  1.  Q
  1.  ; Write command
  1. WRITE F  D  Q:CIAERR!'$$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 CIAZ
  1.  F  D  Q:CIAERR!'$$NEXT(",")
  1.  .I $$NEXT("!#") D  Q:'$$NEXT("?",0)
  1.  ..F  Q:'$$NEXT("!#")
  1.  .I $$NEXT("?") D EXP() Q
  1.  .I $$NEXT(CIAQT) D QT2^CIAUSTX1 Q
  1.  .S CIAZ=$$NEXT("*")
  1.  .D LVAL("LGS")
  1.  .I 'CIAERR,'CIAZ,$$NEXT("#") D EXP()
  1.  .I 'CIAERR,$$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 CIAERR=2 Q
  1.  F  D  Q:" "[$E(CIAM,CIAPSN)  I '$$NEXT(",") S CIAERR=2 Q
  1.  .D EXP(),EXP():$$NEXT(":"),EXP():$$NEXT(":")
  1.  Q
  1.  ; Evaluate L-value
  1.  ; CIAL: 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(CIAL) ;
  1.  I $$NEXT("@",0) D  Q
  1.  .S CIAL="="
  1.  .D EXP(.CIAL)
  1.  S CIAL=$G(CIAL)
  1.  I CIAL["G",$$NEXT(U) D  Q
  1.  .N CIAF
  1.  .D GLBL^CIAUSTX1
  1.  I $TR(CIAL,"SNK")'=CIAL,$$NEXT("$") D  Q
  1.  .N CIAZ
  1.  .S CIAZ=$$INT(.CIAPSN,CIAL)
  1.  .D:'CIAERR PARAMS(CIAZ)
  1.  S CIAPSN=$$NAME(CIAPSN,"%")
  1.  I 'CIAERR,CIAL["L" D PARAMS()
  1.  Q
  1.  ; Evaluate parameters/subscripts
  1. PARAMS(CIAX) ;
  1.  D:$$NEXT("(") PLIST^CIAUSTX1(.CIAX)
  1.  Q
  1.  ; New/Kill/Set/Lock argument list
  1. LIST(CIAL1,CIAL2) ;
  1.  N CIAP,CIAI
  1.  S CIAP=0
  1.  F  D  Q:CIAERR!'$$NEXT(",")
  1.  .I 'CIAP,CIAL1["+",$$NEXT("+-")
  1.  .I $D(CIAL2),$$NEXT("(") D  Q:CIAERR
  1.  ..I CIAP S CIAERR=2 Q
  1.  ..E  S CIAP=1
  1.  .S CIAI=$S(CIAP:CIAL2,1:CIAL1)
  1.  .D LVAL(.CIAI)
  1.  .Q:CIAERR
  1.  .I $$NEXT(")") D  Q:CIAERR
  1.  ..I CIAP S CIAP=0
  1.  ..E  S CIAERR=2
  1.  .I 'CIAP,CIAL1[":",$$NEXT(":") D EXP()
  1.  .I 'CIAP,CIAL1["=" D
  1.  ..I '$$NEXT("=") S:CIAI'["@" CIAERR=2
  1.  ..E  D EXP():$D(CIAL2),LVAL(CIAL1):'$D(CIAL2)
  1.  I 'CIAERR,CIAP S CIAERR=3
  1.  Q
  1.  ; Check for validity of label name
  1. LABEL(CIAP) ;
  1.  Q $$NAME(.CIAP,"L%")
  1.  ; Check for validity of variable/label name
  1. NAME(CIAP,CIAF) ;
  1.  N CIAP1
  1.  S (CIAP,CIAP1)=$G(CIAP,CIAPSN),CIAF=$G(CIAF)
  1.  I CIAF["$",$E(CIAM,CIAP)="$" S CIAP=CIAP+1,CIAP1=CIAP
  1.  I CIAF["%",$E(CIAM,CIAP)="%" S CIAP=CIAP+1
  1.  F CIAP=CIAP:1 Q:$E(CIAM,CIAP)'?@$S(CIAF["L":"1AN",CIAP=CIAP1:"1A",1:"1AN")
  1.  I CIAP=CIAP1 S CIAERR=$S(CIAF["L":11,1:1)
  1.  E  S:CIAP-CIAP1>8 CIAERR=12
  1.  Q CIAP
  1.  ; Instrinsic function/system variable
  1. INT(CIAP,CIAL) ;
  1.  N CIAP2,CIAINT,CIANM
  1.  S CIAP=$G(CIAP,CIAPSN),CIAP2=$$NAME(CIAP),CIAL=$G(CIAL)
  1.  Q:CIAERR ""
  1.  S CIANM=$E(CIAM,CIAP,CIAP2-1)
  1.  I $E(CIAM,CIAP2)="(" S:$D(^TMP(CIAPID,$J,"FCN",CIANM)) CIAINT=^(CIANM)
  1.  E  S:$D(^TMP(CIAPID,$J,"SYS",CIANM)) CIAINT=^(CIANM)
  1.  I '$D(CIAINT),CIAO["Z" S CIAINT=";0-999"
  1.  I '$D(CIAINT) S CIAERR=7
  1.  E  I CIAL'="",$TR(CIAL,$P(CIAINT,";"))=CIAL S CIAERR=2,CIAINT=""
  1.  E  S CIAP=CIAP2
  1.  Q $G(CIAINT)
  1.  ; Check next character
  1. NEXT(CIAC,CIAI) ;
  1.  I CIAPSN'>CIALEN,CIAC[$E(CIAM,CIAPSN) S CIAPSN=CIAPSN+$G(CIAI,1)
  1.  Q $T