FSCLDS ;SLC/STAFF-NOIS List Definition Save ;1/3/97 17:03
;;1.1;NOIS;;Sep 06, 1998
;
SAVE(FSCLNAME,FSCLNUM,OWNER,DESC,TYPE,NOTIFY) ; from FSCLD
N CNT,DA,DIC,DIE,DLAYGO,DR,EXT,FCOND,FCV,LINE,NUM,OK,OP,OPER,QDESC,STEP,X,Y K DIC
S OWNER=$G(OWNER) I 'OWNER S OWNER=DUZ
I 'FSCLNUM D
.S (DIC,DLAYGO)=7107.1,DIC(0)="L",X=FSCLNAME D ^DIC K DIC I '$P(Y,U,3) W !,"Not defined.",$C(7) H 2 Q
.S FSCLNUM=+Y
I 'FSCLNUM Q
S DA=+FSCLNUM,DIE=7107.1,DR=$S(FSCLNAME'=$P(^FSC("LIST",FSCLNUM,0),U):".01///"_FSCLNAME_";",1:"")
S DR=DR_"1///`"_OWNER_$S($D(TYPE):";2///"_TYPE,1:"")
I $L($G(NOTIFY)) S DR=DR_";5///"_$P(NOTIFY,U)_";6///"_$P(NOTIFY,U,2)
I TYPE="A" S DR=DR_";7///WEEKLY"
L +^FSC("LIST",FSCLNUM):30 I '$T D BAD Q
D ^DIE
I $D(DESC) D
.K ^FSC("LIST",FSCLNUM,2)
.S CNT=0 F S CNT=$O(DESC(CNT)) Q:CNT<1 S ^FSC("LIST",FSCLNUM,2,CNT,0)=DESC(CNT,0)
.I $O(^FSC("LIST",FSCLNUM,2,0)) S ^(0)="^^"_CNT_U_CNT_U_DT_U
I $G(TYPE)="S"!$D(^TMP("FSC DEFINE",$J)) D
.K ^FSC("LIST",FSCLNUM,1),^(3)
.I '($G(TYPE)="A"!($G(TYPE)="M")) Q
.S (NUM,OP)=0 F S OP=$O(^TMP("FSC DEFINE",$J,OP)) Q:OP<1 S OPER=$E(^(OP,0)) D
..Q:'$L(OPER)
..S STEP=0 F S STEP=$O(^TMP("FSC DEFINE",$J,OP,STEP)) Q:STEP<1 D
...S FCOND=0 F S FCOND=$O(^TMP("FSC DEFINE",$J,OP,STEP,FCOND)) Q:FCOND<1 S FCV=^(FCOND),EXT=$G(^(FCOND,1)) D
....S EXT=$S(EXT="and":"A",EXT="or":"O",1:"")
....S NUM=NUM+1,^FSC("LIST",FSCLNUM,1,NUM,0)=NUM_U_OPER_U_EXT_U_$P(FCV,U)_U_+$O(^FSC("COND","C",$P(FCV,U,2),0))_U_$P(FCV,U,3)
....S ^FSC("LIST",FSCLNUM,1,"B",NUM,NUM)=""
....S OPER=""
.S ^FSC("LIST",FSCLNUM,1,0)="^7107.11^"_NUM_U_NUM
.S (CNT,LINE)=0 F S LINE=$O(^TMP("FSC DEFINE",$J,"DESC",LINE)) Q:LINE<1 S QDESC=^(LINE) D
..S CNT=CNT+1,^FSC("LIST",FSCLNUM,3,CNT,0)=QDESC
.S ^FSC("LIST",FSCLNUM,3,0)="^^"_CNT_U_CNT_U_DT_U
L -^FSC("LIST",FSCLNUM)
L +^XTMP("FSC LIST DEF",FSCLNUM):20 I '$T D BAD Q
E D BUILD^FSCLDU(FSCLNUM,.OK) I 'OK D BAD
L -^XTMP("FSC LIST DEF",FSCLNUM)
I $D(VALMAR) D ENTRY^FSCLMM,HEADER^FSCLMM
Q
;
BAD ; from FSCLMPMS, FSCLMPS
W !,"This list appears to be defined incorrectly, please recheck.",!,$C(7)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFSCLDS 2136 printed Dec 13, 2024@02:18:01 Page 2
FSCLDS ;SLC/STAFF-NOIS List Definition Save ;1/3/97 17:03
+1 ;;1.1;NOIS;;Sep 06, 1998
+2 ;
SAVE(FSCLNAME,FSCLNUM,OWNER,DESC,TYPE,NOTIFY) ; from FSCLD
+1 NEW CNT,DA,DIC,DIE,DLAYGO,DR,EXT,FCOND,FCV,LINE,NUM,OK,OP,OPER,QDESC,STEP,X,Y
KILL DIC
+2 SET OWNER=$GET(OWNER)
IF 'OWNER
SET OWNER=DUZ
+3 IF 'FSCLNUM
Begin DoDot:1
+4 SET (DIC,DLAYGO)=7107.1
SET DIC(0)="L"
SET X=FSCLNAME
DO ^DIC
KILL DIC
IF '$PIECE(Y,U,3)
WRITE !,"Not defined.",$CHAR(7)
HANG 2
QUIT
+5 SET FSCLNUM=+Y
End DoDot:1
+6 IF 'FSCLNUM
QUIT
+7 SET DA=+FSCLNUM
SET DIE=7107.1
SET DR=$SELECT(FSCLNAME'=$PIECE(^FSC("LIST",FSCLNUM,0),U):".01///"_FSCLNAME_";",1:"")
+8 SET DR=DR_"1///`"_OWNER_$SELECT($DATA(TYPE):";2///"_TYPE,1:"")
+9 IF $LENGTH($GET(NOTIFY))
SET DR=DR_";5///"_$PIECE(NOTIFY,U)_";6///"_$PIECE(NOTIFY,U,2)
+10 IF TYPE="A"
SET DR=DR_";7///WEEKLY"
+11 LOCK +^FSC("LIST",FSCLNUM):30
IF '$TEST
DO BAD
QUIT
+12 DO ^DIE
+13 IF $DATA(DESC)
Begin DoDot:1
+14 KILL ^FSC("LIST",FSCLNUM,2)
+15 SET CNT=0
FOR
SET CNT=$ORDER(DESC(CNT))
if CNT<1
QUIT
SET ^FSC("LIST",FSCLNUM,2,CNT,0)=DESC(CNT,0)
+16 IF $ORDER(^FSC("LIST",FSCLNUM,2,0))
SET ^(0)="^^"_CNT_U_CNT_U_DT_U
End DoDot:1
+17 IF $GET(TYPE)="S"!$DATA(^TMP("FSC DEFINE",$JOB))
Begin DoDot:1
+18 KILL ^FSC("LIST",FSCLNUM,1),^(3)
+19 IF '($GET(TYPE)="A"!($GET(TYPE)="M"))
QUIT
+20 SET (NUM,OP)=0
FOR
SET OP=$ORDER(^TMP("FSC DEFINE",$JOB,OP))
if OP<1
QUIT
SET OPER=$EXTRACT(^(OP,0))
Begin DoDot:2
+21 if '$LENGTH(OPER)
QUIT
+22 SET STEP=0
FOR
SET STEP=$ORDER(^TMP("FSC DEFINE",$JOB,OP,STEP))
if STEP<1
QUIT
Begin DoDot:3
+23 SET FCOND=0
FOR
SET FCOND=$ORDER(^TMP("FSC DEFINE",$JOB,OP,STEP,FCOND))
if FCOND<1
QUIT
SET FCV=^(FCOND)
SET EXT=$GET(^(FCOND,1))
Begin DoDot:4
+24 SET EXT=$SELECT(EXT="and":"A",EXT="or":"O",1:"")
+25 SET NUM=NUM+1
SET ^FSC("LIST",FSCLNUM,1,NUM,0)=NUM_U_OPER_U_EXT_U_$PIECE(FCV,U)_U_+$ORDER(^FSC("COND","C",$PIECE(FCV,U,2),0))_U_$PIECE(FCV,U,3)
+26 SET ^FSC("LIST",FSCLNUM,1,"B",NUM,NUM)=""
+27 SET OPER=""
End DoDot:4
End DoDot:3
End DoDot:2
+28 SET ^FSC("LIST",FSCLNUM,1,0)="^7107.11^"_NUM_U_NUM
+29 SET (CNT,LINE)=0
FOR
SET LINE=$ORDER(^TMP("FSC DEFINE",$JOB,"DESC",LINE))
if LINE<1
QUIT
SET QDESC=^(LINE)
Begin DoDot:2
+30 SET CNT=CNT+1
SET ^FSC("LIST",FSCLNUM,3,CNT,0)=QDESC
End DoDot:2
+31 SET ^FSC("LIST",FSCLNUM,3,0)="^^"_CNT_U_CNT_U_DT_U
End DoDot:1
+32 LOCK -^FSC("LIST",FSCLNUM)
+33 LOCK +^XTMP("FSC LIST DEF",FSCLNUM):20
IF '$TEST
DO BAD
QUIT
+34 IF '$TEST
DO BUILD^FSCLDU(FSCLNUM,.OK)
IF 'OK
DO BAD
+35 LOCK -^XTMP("FSC LIST DEF",FSCLNUM)
+36 IF $DATA(VALMAR)
DO ENTRY^FSCLMM
DO HEADER^FSCLMM
+37 QUIT
+38 ;
BAD ; from FSCLMPMS, FSCLMPS
+1 WRITE !,"This list appears to be defined incorrectly, please recheck.",!,$CHAR(7)
+2 QUIT
