FSCLDU ;SLC/STAFF-NOIS List Definition Utility ;1/3/97 16:57
;;1.1;NOIS;;Sep 06, 1998
;
BUILD(LISTNUM,OK) ; from FSCLDS, FSCLMPMS, FSCLMPS, FSCLP
; lock and unlock ^XTMP("FSC LIST DEF",LISTNUM) before and after this call
S OK=1
I '$D(^FSC("LIST",LISTNUM)) S OK=0 Q
N COND,CONDVAL,DEF,DEFCNT,EXE,EXT,FCOND,FIELD,FIELDAB,LEVEL,NUM,OP,OPER,PAREN,TYPE,VALUE,XOP,ZERO K DEF
S (EXE,OP)="",(DEFCNT,LEVEL)=0,PAREN="closed"
K ^XTMP("FSC LIST DEF",LISTNUM)
S NUM=0 F S NUM=$O(^FSC("LIST",LISTNUM,1,NUM)) Q:NUM<1 S ZERO=^(NUM,0) D Q:'OK
.I $L($P(ZERO,U,2)) D STORE
.S DEFCNT=DEFCNT+1,DEF(DEFCNT)=ZERO
.S OP=$P(ZERO,U,2),EXT=$P(ZERO,U,3),FIELD=$P(ZERO,U,4),COND=$P(ZERO,U,5),VALUE=$P(ZERO,U,6)
.I $L(OP) S EXE=OP_U,OPER=OP
.I $L(EXE)>245 S OK=0,$P(EXE,U,2)=0 Q
.S EXE=EXE_$S(EXT="A":"&",EXT="O":"!",1:"")
.I EXT="O",$L($G(^FSC("LIST",LISTNUM,1,NUM+1,0))),$P(^(0),U,2)="",$P(^(0),U,3)="A" S EXE=EXE_"(",PAREN="open"
.S EXE=EXE_"Q("_NUM_")"
.I EXT="A",PAREN="open",$L($G(^FSC("LIST",LISTNUM,1,NUM+1,0))),$P(^(0),U,2)="",$P(^(0),U,3)="O" S EXE=EXE_")",PAREN="closed"
.S FIELDAB=$P(^FSC("FLD",+FIELD,0),U,7),TYPE=$P(^(0),U,3),CONDVAL=$P(^FSC("COND",+COND,0),U,2) S:VALUE'=+VALUE VALUE=""""_VALUE_""""
.D
..I CONDVAL["exist" D Q
...I CONDVAL["not" S FCOND="'$L(VALUE("""_FIELDAB_"""))" Q
...S FCOND="$L(VALUE("""_FIELDAB_"""))"
..I CONDVAL["range" D Q
...I CONDVAL["not" S FCOND="VALUE("""_FIELDAB_""")<"_+VALUE_"!(VALUE("""_FIELDAB_""")>"_+$P(VALUE,"-",2)_")"
...S FCOND="VALUE("""_FIELDAB_""")'<"_+VALUE_",VALUE("""_FIELDAB_""")'>"_+$P(VALUE,"-",2)
..I TYPE="W",CONDVAL["[" D Q
...I CONDVAL="'[" S FCOND="$$WPNC^FSCLDU("""_$S(FIELDAB="DESC":30,FIELDAB="SUM":80,FIELDAB="STATHIST":110,1:50)_""",CALLNUM,"_VALUE_")" Q
...S FCOND="$$WPC^FSCLDU("""_$S(FIELDAB="DESC":30,FIELDAB="SUM":80,FIELDAB="STATHIST":110,1:50)_""",CALLNUM,"_VALUE_")" Q
..S FCOND="$P(VALUE("""_FIELDAB_"""),U)"_CONDVAL_VALUE
.S ^XTMP("FSC LIST DEF",LISTNUM,"VAR",FIELD)=FIELDAB
.S ^XTMP("FSC LIST DEF",LISTNUM,"Q",NUM)=FCOND
D STORE
S XOP="0" I OK S LEVEL=0 F S LEVEL=$O(^XTMP("FSC LIST DEF",LISTNUM,"X",LEVEL)) Q:LEVEL<1 S OP=$P(^(LEVEL),U) D I $L(XOP)>245 S OK=0,XOP="0" Q
.S XOP=XOP_$S(OP="A":"!",OP="S":"&",1:"&'")_"X("_LEVEL_")"
S ^XTMP("FSC LIST DEF",LISTNUM,"XOP")=XOP
I OK D CHECK(LISTNUM,.OK)
Q
;
CHECK(LISTNUM,OK) ;
N LEVEL,X S OK=1
S X="I "_^XTMP("FSC LIST DEF",LISTNUM,"XOP") D ^DIM I '$D(X) S OK=0
S LEVEL=0 F S LEVEL=$O(^XTMP("FSC LIST DEF",LISTNUM,"X",LEVEL)) Q:LEVEL<1 S X="I "_$P(^(LEVEL),U,2) D ^DIM I '$D(X) S OK=0,$P(^XTMP("FSC LIST DEF",LISTNUM,"X",LEVEL),U,2)=0
I 'OK S ^XTMP("FSC LIST DEF",LISTNUM,"XOP")=0
Q
;
STORE ;
Q:'$L(EXE)
I PAREN="open" S EXE=EXE_")",PAREN="closed"
S LEVEL=LEVEL+1
S ^XTMP("FSC LIST DEF",LISTNUM,"X",LEVEL)=EXE
N CRITERIA K CRITERIA S FSCLNAME=$P(^FSC("LIST",LISTNUM,0),U) D QDESC^FSCLMPMQ(.DEF,,.CRITERIA)
M ^XTMP("FSC LIST DEF",LISTNUM,"CRITERIA",LEVEL)=CRITERIA
K DEF S DEFCNT=0
Q
;
WPC(SUB,CALLNUM,VALUE) ; $$(wp subscript,call,value) -> 1 if wp entry contains value, else 0
N CHECK,LINE S CHECK=0
S LINE=0 F S LINE=$O(^FSCD("CALL",CALLNUM,SUB,LINE)) Q:LINE<1 I ^(LINE,0)[VALUE S CHECK=1 Q
Q CHECK
;
WPNC(SUB,CALLNUM,VALUE) ; $$(wp subscript,call,value) -> 1 if wp entry exists but does not contain value, else 0
I '$O(^FSCD("CALL",CALLNUM,SUB,0)) Q 0
N CHECK,LINE S CHECK=1
S LINE=0 F S LINE=$O(^FSCD("CALL",CALLNUM,SUB,LINE)) Q:LINE<1 I ^(LINE,0)[VALUE S CHECK=0 Q
Q CHECK
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFSCLDU 3526 printed Sep 23, 2025@19:54:19 Page 2
FSCLDU ;SLC/STAFF-NOIS List Definition Utility ;1/3/97 16:57
+1 ;;1.1;NOIS;;Sep 06, 1998
+2 ;
BUILD(LISTNUM,OK) ; from FSCLDS, FSCLMPMS, FSCLMPS, FSCLP
+1 ; lock and unlock ^XTMP("FSC LIST DEF",LISTNUM) before and after this call
+2 SET OK=1
+3 IF '$DATA(^FSC("LIST",LISTNUM))
SET OK=0
QUIT
+4 NEW COND,CONDVAL,DEF,DEFCNT,EXE,EXT,FCOND,FIELD,FIELDAB,LEVEL,NUM,OP,OPER,PAREN,TYPE,VALUE,XOP,ZERO
KILL DEF
+5 SET (EXE,OP)=""
SET (DEFCNT,LEVEL)=0
SET PAREN="closed"
+6 KILL ^XTMP("FSC LIST DEF",LISTNUM)
+7 SET NUM=0
FOR
SET NUM=$ORDER(^FSC("LIST",LISTNUM,1,NUM))
if NUM<1
QUIT
SET ZERO=^(NUM,0)
Begin DoDot:1
+8 IF $LENGTH($PIECE(ZERO,U,2))
DO STORE
+9 SET DEFCNT=DEFCNT+1
SET DEF(DEFCNT)=ZERO
+10 SET OP=$PIECE(ZERO,U,2)
SET EXT=$PIECE(ZERO,U,3)
SET FIELD=$PIECE(ZERO,U,4)
SET COND=$PIECE(ZERO,U,5)
SET VALUE=$PIECE(ZERO,U,6)
+11 IF $LENGTH(OP)
SET EXE=OP_U
SET OPER=OP
+12 IF $LENGTH(EXE)>245
SET OK=0
SET $PIECE(EXE,U,2)=0
QUIT
+13 SET EXE=EXE_$SELECT(EXT="A":"&",EXT="O":"!",1:"")
+14 IF EXT="O"
IF $LENGTH($GET(^FSC("LIST",LISTNUM,1,NUM+1,0)))
IF $PIECE(^(0),U,2)=""
IF $PIECE(^(0),U,3)="A"
SET EXE=EXE_"("
SET PAREN="open"
+15 SET EXE=EXE_"Q("_NUM_")"
+16 IF EXT="A"
IF PAREN="open"
IF $LENGTH($GET(^FSC("LIST",LISTNUM,1,NUM+1,0)))
IF $PIECE(^(0),U,2)=""
IF $PIECE(^(0),U,3)="O"
SET EXE=EXE_")"
SET PAREN="closed"
+17 SET FIELDAB=$PIECE(^FSC("FLD",+FIELD,0),U,7)
SET TYPE=$PIECE(^(0),U,3)
SET CONDVAL=$PIECE(^FSC("COND",+COND,0),U,2)
if VALUE'=+VALUE
SET VALUE=""""_VALUE_""""
+18 Begin DoDot:2
+19 IF CONDVAL["exist"
Begin DoDot:3
+20 IF CONDVAL["not"
SET FCOND="'$L(VALUE("""_FIELDAB_"""))"
QUIT
+21 SET FCOND="$L(VALUE("""_FIELDAB_"""))"
End DoDot:3
QUIT
+22 IF CONDVAL["range"
Begin DoDot:3
+23 IF CONDVAL["not"
SET FCOND="VALUE("""_FIELDAB_""")<"_+VALUE_"!(VALUE("""_FIELDAB_""")>"_+$PIECE(VALUE,"-",2)_")"
+24 SET FCOND="VALUE("""_FIELDAB_""")'<"_+VALUE_",VALUE("""_FIELDAB_""")'>"_+$PIECE(VALUE,"-",2)
End DoDot:3
QUIT
+25 IF TYPE="W"
IF CONDVAL["["
Begin DoDot:3
+26 IF CONDVAL="'["
SET FCOND="$$WPNC^FSCLDU("""_$SELECT(FIELDAB="DESC":30,FIELDAB="SUM":80,FIELDAB="STATHIST":110,1:50)_""",CALLNUM,"_VALUE_")"
QUIT
+27 SET FCOND="$$WPC^FSCLDU("""_$SELECT(FIELDAB="DESC":30,FIELDAB="SUM":80,FIELDAB="STATHIST":110,1:50)_""",CALLNUM,"_VALUE_")"
QUIT
End DoDot:3
QUIT
+28 SET FCOND="$P(VALUE("""_FIELDAB_"""),U)"_CONDVAL_VALUE
End DoDot:2
+29 SET ^XTMP("FSC LIST DEF",LISTNUM,"VAR",FIELD)=FIELDAB
+30 SET ^XTMP("FSC LIST DEF",LISTNUM,"Q",NUM)=FCOND
End DoDot:1
if 'OK
QUIT
+31 DO STORE
+32 SET XOP="0"
IF OK
SET LEVEL=0
FOR
SET LEVEL=$ORDER(^XTMP("FSC LIST DEF",LISTNUM,"X",LEVEL))
if LEVEL<1
QUIT
SET OP=$PIECE(^(LEVEL),U)
Begin DoDot:1
+33 SET XOP=XOP_$SELECT(OP="A":"!",OP="S":"&",1:"&'")_"X("_LEVEL_")"
End DoDot:1
IF $LENGTH(XOP)>245
SET OK=0
SET XOP="0"
QUIT
+34 SET ^XTMP("FSC LIST DEF",LISTNUM,"XOP")=XOP
+35 IF OK
DO CHECK(LISTNUM,.OK)
+36 QUIT
+37 ;
CHECK(LISTNUM,OK) ;
+1 NEW LEVEL,X
SET OK=1
+2 SET X="I "_^XTMP("FSC LIST DEF",LISTNUM,"XOP")
DO ^DIM
IF '$DATA(X)
SET OK=0
+3 SET LEVEL=0
FOR
SET LEVEL=$ORDER(^XTMP("FSC LIST DEF",LISTNUM,"X",LEVEL))
if LEVEL<1
QUIT
SET X="I "_$PIECE(^(LEVEL),U,2)
DO ^DIM
IF '$DATA(X)
SET OK=0
SET $PIECE(^XTMP("FSC LIST DEF",LISTNUM,"X",LEVEL),U,2)=0
+4 IF 'OK
SET ^XTMP("FSC LIST DEF",LISTNUM,"XOP")=0
+5 QUIT
+6 ;
STORE ;
+1 if '$LENGTH(EXE)
QUIT
+2 IF PAREN="open"
SET EXE=EXE_")"
SET PAREN="closed"
+3 SET LEVEL=LEVEL+1
+4 SET ^XTMP("FSC LIST DEF",LISTNUM,"X",LEVEL)=EXE
+5 NEW CRITERIA
KILL CRITERIA
SET FSCLNAME=$PIECE(^FSC("LIST",LISTNUM,0),U)
DO QDESC^FSCLMPMQ(.DEF,,.CRITERIA)
+6 MERGE ^XTMP("FSC LIST DEF",LISTNUM,"CRITERIA",LEVEL)=CRITERIA
+7 KILL DEF
SET DEFCNT=0
+8 QUIT
+9 ;
WPC(SUB,CALLNUM,VALUE) ; $$(wp subscript,call,value) -> 1 if wp entry contains value, else 0
+1 NEW CHECK,LINE
SET CHECK=0
+2 SET LINE=0
FOR
SET LINE=$ORDER(^FSCD("CALL",CALLNUM,SUB,LINE))
if LINE<1
QUIT
IF ^(LINE,0)[VALUE
SET CHECK=1
QUIT
+3 QUIT CHECK
+4 ;
WPNC(SUB,CALLNUM,VALUE) ; $$(wp subscript,call,value) -> 1 if wp entry exists but does not contain value, else 0
+1 IF '$ORDER(^FSCD("CALL",CALLNUM,SUB,0))
QUIT 0
+2 NEW CHECK,LINE
SET CHECK=1
+3 SET LINE=0
FOR
SET LINE=$ORDER(^FSCD("CALL",CALLNUM,SUB,LINE))
if LINE<1
QUIT
IF ^(LINE,0)[VALUE
SET CHECK=0
QUIT
+4 QUIT CHECK
