CIAUSTX0 ;MSC/IND/DKM - Continuation of CIAUSTX;04-May-2006 08:19;DKM
;;1.2;CIA UTILITIES;;Mar 20, 2007
;;Copyright 2000-2006, Medsphere Systems Corporation
;=================================================================
CMD(CIALBL) ;
D:CIALBL'="" @CIALBL
Q
; Postconditional
PC D:$$NEXT(":") EXP()
Q:CIAERR
I " "'[$E(CIAM,CIAPSN) S CIAERR=2
E S CIAPSN=CIAPSN+1
Q
; No postconditional
NPC I $$NEXT(":") S CIAERR=5
E I " "'[$E(CIAM,CIAPSN) S CIAERR=2
E S CIAPSN=CIAPSN+1
Q
; Arguments optional
OPT S:" "[$E(CIAM,CIAPSN) CIARN=0
Q
; Multiple arguments
ARGS(CIAEX) ;
S CIAEX=$G(CIAEX)
F D EXP(CIAEX) Q:CIAERR!'$$NEXT(",")
Q
; Expression
EXP(CIAEX) ;
D EXP^CIAUSTX1(.CIAEX)
Q
; Label reference
LBL(CIAA) F D LBL1(.CIAA) Q:CIAERR!'$$NEXT(",")
Q
LBL1(CIAA) ;
S CIAA=+$G(CIAA)
D LBL2
Q:CIAERR
D:$$NEXT("+") EXP(")")
Q:CIAERR
D:$$NEXT(U) LBL2
I 'CIAERR,CIAA=2 D PARAMS(".;0-999")
I 'CIAERR,CIAA D EXP(")"):$$NEXT(":")
Q
LBL2 I $$NEXT("@") D
.D EXP("=")
E S:$E(CIAM,CIAPSN)?.1AN.1"%" CIAPSN=$$LABEL
Q
; Write command
WRITE F D Q:CIAERR!'$$NEXT(",")
.I $$NEXT("!#") D Q:'$$NEXT("?",0)
..F Q:'$$NEXT("!#")
.I $$NEXT("?*")
.D EXP()
Q
; Read command
READ N CIAZ
F D Q:CIAERR!'$$NEXT(",")
.I $$NEXT("!#") D Q:'$$NEXT("?",0)
..F Q:'$$NEXT("!#")
.I $$NEXT("?") D EXP() Q
.I $$NEXT(CIAQT) D QT2^CIAUSTX1 Q
.S CIAZ=$$NEXT("*")
.D LVAL("LGS")
.I 'CIAERR,'CIAZ,$$NEXT("#") D EXP()
.I 'CIAERR,$$NEXT(":") D EXP()
Q
; Lock command
LOCK D LIST("LG+:","LG")
Q
; Set command
SET D LIST("LGS=","LGS")
Q
; New command
NEW D LIST("N","")
Q
; Kill command
KILL D LIST("KGL","")
Q
; Merge command
MERGE D LIST("LG=")
Q
; For command
FOR D LVAL("LGS")
I '$$NEXT("=") S CIAERR=2 Q
F D Q:" "[$E(CIAM,CIAPSN) I '$$NEXT(",") S CIAERR=2 Q
.D EXP(),EXP():$$NEXT(":"),EXP():$$NEXT(":")
Q
; Evaluate L-value
; CIAL: Allowed types:
; L=Local array
; G=Global arrays
; S=Settable intrinsics/system variables
; N=Newable system variables
; K=Killable system variables
LVAL(CIAL) ;
I $$NEXT("@",0) D Q
.S CIAL="="
.D EXP(.CIAL)
S CIAL=$G(CIAL)
I CIAL["G",$$NEXT(U) D Q
.N CIAF
.D GLBL^CIAUSTX1
I $TR(CIAL,"SNK")'=CIAL,$$NEXT("$") D Q
.N CIAZ
.S CIAZ=$$INT(.CIAPSN,CIAL)
.D:'CIAERR PARAMS(CIAZ)
S CIAPSN=$$NAME(CIAPSN,"%")
I 'CIAERR,CIAL["L" D PARAMS()
Q
; Evaluate parameters/subscripts
PARAMS(CIAX) ;
D:$$NEXT("(") PLIST^CIAUSTX1(.CIAX)
Q
; New/Kill/Set/Lock argument list
LIST(CIAL1,CIAL2) ;
N CIAP,CIAI
S CIAP=0
F D Q:CIAERR!'$$NEXT(",")
.I 'CIAP,CIAL1["+",$$NEXT("+-")
.I $D(CIAL2),$$NEXT("(") D Q:CIAERR
..I CIAP S CIAERR=2 Q
..E S CIAP=1
.S CIAI=$S(CIAP:CIAL2,1:CIAL1)
.D LVAL(.CIAI)
.Q:CIAERR
.I $$NEXT(")") D Q:CIAERR
..I CIAP S CIAP=0
..E S CIAERR=2
.I 'CIAP,CIAL1[":",$$NEXT(":") D EXP()
.I 'CIAP,CIAL1["=" D
..I '$$NEXT("=") S:CIAI'["@" CIAERR=2
..E D EXP():$D(CIAL2),LVAL(CIAL1):'$D(CIAL2)
I 'CIAERR,CIAP S CIAERR=3
Q
; Check for validity of label name
LABEL(CIAP) ;
Q $$NAME(.CIAP,"L%")
; Check for validity of variable/label name
NAME(CIAP,CIAF) ;
N CIAP1
S (CIAP,CIAP1)=$G(CIAP,CIAPSN),CIAF=$G(CIAF)
I CIAF["$",$E(CIAM,CIAP)="$" S CIAP=CIAP+1,CIAP1=CIAP
I CIAF["%",$E(CIAM,CIAP)="%" S CIAP=CIAP+1
F CIAP=CIAP:1 Q:$E(CIAM,CIAP)'?@$S(CIAF["L":"1AN",CIAP=CIAP1:"1A",1:"1AN")
I CIAP=CIAP1 S CIAERR=$S(CIAF["L":11,1:1)
E S:CIAP-CIAP1>8 CIAERR=12
Q CIAP
; Instrinsic function/system variable
INT(CIAP,CIAL) ;
N CIAP2,CIAINT,CIANM
S CIAP=$G(CIAP,CIAPSN),CIAP2=$$NAME(CIAP),CIAL=$G(CIAL)
Q:CIAERR ""
S CIANM=$E(CIAM,CIAP,CIAP2-1)
I $E(CIAM,CIAP2)="(" S:$D(^TMP(CIAPID,$J,"FCN",CIANM)) CIAINT=^(CIANM)
E S:$D(^TMP(CIAPID,$J,"SYS",CIANM)) CIAINT=^(CIANM)
I '$D(CIAINT),CIAO["Z" S CIAINT=";0-999"
I '$D(CIAINT) S CIAERR=7
E I CIAL'="",$TR(CIAL,$P(CIAINT,";"))=CIAL S CIAERR=2,CIAINT=""
E S CIAP=CIAP2
Q $G(CIAINT)
; Check next character
NEXT(CIAC,CIAI) ;
I CIAPSN'>CIALEN,CIAC[$E(CIAM,CIAPSN) S CIAPSN=CIAPSN+$G(CIAI,1)
Q $T
CIAUSTX0 ;MSC/IND/DKM - Continuation of CIAUSTX;04-May-2006 08:19;DKM
+1 ;;1.2;CIA UTILITIES;;Mar 20, 2007
+2 ;;Copyright 2000-2006, Medsphere Systems Corporation
+3 ;=================================================================
CMD(CIALBL) ;
+1 IF CIALBL'=""
DO @CIALBL
+2 QUIT
+3 ; Postconditional
PC IF $$NEXT("
DO EXP()
+1 IF CIAERR
QUIT
+2 IF " "'[$EXTRACT(CIAM,CIAPSN)
SET CIAERR=2
+3 IF '$TEST
SET CIAPSN=CIAPSN+1
+4 QUIT
+5 ; No postconditional
NPC IF $$NEXT(":")
SET CIAERR=5
+1 IF '$TEST
IF " "'[$EXTRACT(CIAM,CIAPSN)
SET CIAERR=2
+2 IF '$TEST
SET CIAPSN=CIAPSN+1
+3 QUIT
+4 ; Arguments optional
OPT IF " "[$EXTRACT(CIAM,CIAPSN)
SET CIARN=0
+1 QUIT
+2 ; Multiple arguments
ARGS(CIAEX) ;
+1 SET CIAEX=$GET(CIAEX)
+2 FOR
DO EXP(CIAEX)
IF CIAERR!'$$NEXT(",")
QUIT
+3 QUIT
+4 ; Expression
EXP(CIAEX) ;
+1 DO EXP^CIAUSTX1(.CIAEX)
+2 QUIT
+3 ; Label reference
LBL(CIAA) FOR
DO LBL1(.CIAA)
IF CIAERR!'$$NEXT(",")
QUIT
+1 QUIT
LBL1(CIAA) ;
+1 SET CIAA=+$GET(CIAA)
+2 DO LBL2
+3 IF CIAERR
QUIT
+4 IF $$NEXT("+")
DO EXP(")")
+5 IF CIAERR
QUIT
+6 IF $$NEXT(U)
DO LBL2
+7 IF 'CIAERR
IF CIAA=2
DO PARAMS(".;0-999")
+8 IF 'CIAERR
IF CIAA
IF $$NEXT(":")
DO EXP(")")
+9 QUIT
LBL2 IF $$NEXT("@")
Begin DoDot:1
+1 DO EXP("=")
End DoDot:1
+2 IF '$TEST
IF $EXTRACT(CIAM,CIAPSN)?.1AN.1"%"
SET CIAPSN=$$LABEL
+3 QUIT
+4 ; Write command
WRITE FOR
Begin DoDot:1
+1 IF $$NEXT("!#")
Begin DoDot:2
+2 FOR
IF '$$NEXT("!#")
QUIT
End DoDot:2
IF '$$NEXT("?",0)
QUIT
+3 IF $$NEXT("?*")
+4 DO EXP()
End DoDot:1
IF CIAERR!'$$NEXT(",")
QUIT
+5 QUIT
+6 ; Read command
READ NEW CIAZ
+1 FOR
Begin DoDot:1
+2 IF $$NEXT("!#")
Begin DoDot:2
+3 FOR
IF '$$NEXT("!#")
QUIT
End DoDot:2
IF '$$NEXT("?",0)
QUIT
+4 IF $$NEXT("?")
DO EXP()
QUIT
+5 IF $$NEXT(CIAQT)
DO QT2^CIAUSTX1
QUIT
+6 SET CIAZ=$$NEXT("*")
+7 DO LVAL("LGS")
+8 IF 'CIAERR
IF 'CIAZ
IF $$NEXT("#")
DO EXP()
+9 IF 'CIAERR
IF $$NEXT(":")
DO EXP()
End DoDot:1
IF CIAERR!'$$NEXT(",")
QUIT
+10 QUIT
+11 ; Lock command
LOCK DO LIST("LG+:","LG")
+1 QUIT
+2 ; Set command
SET DO LIST("LGS=","LGS")
+1 QUIT
+2 ; New command
NEW DO LIST("N","")
+1 QUIT
+2 ; Kill command
KILL DO LIST("KGL","")
+1 QUIT
+2 ; Merge command
MERGE DO LIST("LG=")
+1 QUIT
+2 ; For command
FOR DO LVAL("LGS")
+1 IF '$$NEXT("=")
SET CIAERR=2
QUIT
+2 FOR
Begin DoDot:1
+3 DO EXP()
IF $$NEXT(":")
DO EXP()
IF $$NEXT(":")
DO EXP()
End DoDot:1
IF " "[$EXTRACT(CIAM,CIAPSN)
QUIT
IF '$$NEXT(",")
SET CIAERR=2
QUIT
+4 QUIT
+5 ; Evaluate L-value
+6 ; CIAL: Allowed types:
+7 ; L=Local array
+8 ; G=Global arrays
+9 ; S=Settable intrinsics/system variables
+10 ; N=Newable system variables
+11 ; K=Killable system variables
LVAL(CIAL) ;
+1 IF $$NEXT("@",0)
Begin DoDot:1
+2 SET CIAL="="
+3 DO EXP(.CIAL)
End DoDot:1
QUIT
+4 SET CIAL=$GET(CIAL)
+5 IF CIAL["G"
IF $$NEXT(U)
Begin DoDot:1
+6 NEW CIAF
+7 DO GLBL^CIAUSTX1
End DoDot:1
QUIT
+8 IF $TRANSLATE(CIAL,"SNK")'=CIAL
IF $$NEXT("$")
Begin DoDot:1
+9 NEW CIAZ
+10 SET CIAZ=$$INT(.CIAPSN,CIAL)
+11 IF 'CIAERR
DO PARAMS(CIAZ)
End DoDot:1
QUIT
+12 SET CIAPSN=$$NAME(CIAPSN,"%")
+13 IF 'CIAERR
IF CIAL["L"
DO PARAMS()
+14 QUIT
+15 ; Evaluate parameters/subscripts
PARAMS(CIAX) ;
+1 IF $$NEXT("(")
DO PLIST^CIAUSTX1(.CIAX)
+2 QUIT
+3 ; New/Kill/Set/Lock argument list
LIST(CIAL1,CIAL2) ;
+1 NEW CIAP,CIAI
+2 SET CIAP=0
+3 FOR
Begin DoDot:1
+4 IF 'CIAP
IF CIAL1["+"
IF $$NEXT("+-")
+5 IF $DATA(CIAL2)
IF $$NEXT("(")
Begin DoDot:2
+6 IF CIAP
SET CIAERR=2
QUIT
+7 IF '$TEST
SET CIAP=1
End DoDot:2
IF CIAERR
QUIT
+8 SET CIAI=$SELECT(CIAP:CIAL2,1:CIAL1)
+9 DO LVAL(.CIAI)
+10 IF CIAERR
QUIT
+11 IF $$NEXT(")")
Begin DoDot:2
+12 IF CIAP
SET CIAP=0
+13 IF '$TEST
SET CIAERR=2
End DoDot:2
IF CIAERR
QUIT
+14 IF 'CIAP
IF CIAL1[":"
IF $$NEXT(":")
DO EXP()
+15 IF 'CIAP
IF CIAL1["="
Begin DoDot:2
+16 IF '$$NEXT("=")
IF CIAI'["@"
SET CIAERR=2
+17 IF '$TEST
IF $DATA(CIAL2)
DO EXP()
IF '$DATA(CIAL2)
DO LVAL(CIAL1)
End DoDot:2
End DoDot:1
IF CIAERR!'$$NEXT(",")
QUIT
+18 IF 'CIAERR
IF CIAP
SET CIAERR=3
+19 QUIT
+20 ; Check for validity of label name
LABEL(CIAP) ;
+1 QUIT $$NAME(.CIAP,"L%")
+2 ; Check for validity of variable/label name
NAME(CIAP,CIAF) ;
+1 NEW CIAP1
+2 SET (CIAP,CIAP1)=$GET(CIAP,CIAPSN)
SET CIAF=$GET(CIAF)
+3 IF CIAF["$"
IF $EXTRACT(CIAM,CIAP)="$"
SET CIAP=CIAP+1
SET CIAP1=CIAP
+4 IF CIAF["%"
IF $EXTRACT(CIAM,CIAP)="%"
SET CIAP=CIAP+1
+5 FOR CIAP=CIAP:1
IF $EXTRACT(CIAM,CIAP)'?@$SELECT(CIAF["L"
QUIT
+6 IF CIAP=CIAP1
SET CIAERR=$SELECT(CIAF["L":11,1:1)
+7 IF '$TEST
IF CIAP-CIAP1>8
SET CIAERR=12
+8 QUIT CIAP
+9 ; Instrinsic function/system variable
INT(CIAP,CIAL) ;
+1 NEW CIAP2,CIAINT,CIANM
+2 SET CIAP=$GET(CIAP,CIAPSN)
SET CIAP2=$$NAME(CIAP)
SET CIAL=$GET(CIAL)
+3 IF CIAERR
QUIT ""
+4 SET CIANM=$EXTRACT(CIAM,CIAP,CIAP2-1)
+5 IF $EXTRACT(CIAM,CIAP2)="("
IF $DATA(^TMP(CIAPID,$JOB,"FCN",CIANM))
SET CIAINT=^(CIANM)
+6 IF '$TEST
IF $DATA(^TMP(CIAPID,$JOB,"SYS",CIANM))
SET CIAINT=^(CIANM)
+7 IF '$DATA(CIAINT)
IF CIAO["Z"
SET CIAINT=";0-999"
+8 IF '$DATA(CIAINT)
SET CIAERR=7
+9 IF '$TEST
IF CIAL'=""
IF $TRANSLATE(CIAL,$PIECE(CIAINT,";"))=CIAL
SET CIAERR=2
SET CIAINT=""
+10 IF '$TEST
SET CIAP=CIAP2
+11 QUIT $GET(CIAINT)
+12 ; Check next character
NEXT(CIAC,CIAI) ;
+1 IF CIAPSN'>CIALEN
IF CIAC[$EXTRACT(CIAM,CIAPSN)
SET CIAPSN=CIAPSN+$GET(CIAI,1)
+2 QUIT $TEST
