- 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 Feb 18, 2025@23:44:29 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
