SDUL0 ;MJK/ALB - List Manager (cont.); 12/1/91
;;5.3;Scheduling;;Aug 13, 1993
;
INIT(NAME,PARMS) ;
D STACK
K SDULBCK,SDULQUIT,SDULHDR
S SDUL(0)=$G(PARMS)
I NAME["^",'$$SETUP(.NAME) S SDULQUIT="" G INITQ
I NAME'["^",'$$TEMP(.NAME) S SDULQUIT="" G INITQ
D TERM:'SDULEVL,CALC
INITQ K SDX,X Q
;
TERM ; -- set up term characteristics
I '$D(IOST(0)) D HOME^%ZIS
S SDULWD=IOM,X=$$IO D ENDR^%ZISS
Q
;
IO() ; -- what device params
Q "IORVON;IORVOFF;IOIL;IOSTBM;IOSC;IORC;IOEDEOP;IOINHI;IOINORM;IOUON;IOUOFF"
;
STACK ; -- stack vars
S SDULEVL=$S($D(SDULEVL):SDULEVL+1,1:0)
I 'SDULEVL K SDUL,^TMP("SDUL DATA",$J,SDULEVL) G STACKQ
;
; -- stack'em
K ^TMP("SDUL STACK",$J,SDULEVL)
I $O(^TMP("SDUL STACK",$J,SDULEVL,"SDUL",""))="" S X="" F S X=$O(SDUL(X)) Q:X="" S ^(X)=SDUL(X)
I $O(^TMP("SDUL STACK",$J,SDULEVL,"OTHER VARS",""))="" F X="SDULMENU","SDULCAP","SDULAR","SDULCNT","SDULBG","SDULST","SDULCC" S ^(X)=$G(@X)
K SDULBG,SDUL
STACKQ Q
;
POP ; -- clean up and unstack vars
K SDULMENU,SDULCAP,SDULHDR,SDULPGE,SDULUP,SDULDN,SDULDDF,SDULCC,SDULAR,SDULCNT,SDUL,SDULBG,SDULST,LN,^TMP("SDUL DATA",$J,SDULEVL)
I 'SDULEVL D G POPQ
.D CLEAR^SDUL1
.S Y=$$IO F I=1:1 S X=$P(Y,";",I) Q:X="" K @X
.K Y,X,I,SDULEVL,SDULWD,SDULFIND
;
; -- unstack'em
I $O(^TMP("SDUL STACK",$J,SDULEVL,"SDUL",""))]"" S X="" F S X=$O(^(X)) Q:X="" S SDUL(X)=^(X)
I $O(^TMP("SDUL STACK",$J,SDULEVL,"OTHER VARS",""))]"" S X="" F S X=$O(^(X)) Q:X="" S @X=^(X)
K ^TMP("SDUL STACK",$J,SDULEVL)
D COL^SDUL
S SDULEVL=$S(SDULEVL:SDULEVL-1,1:0),SDULBCK="R",(SDULUP,SDULDN)=""
POPQ Q
;
SETUP(NAME) ; -- on-the-fly list
D @NAME
S Y=1 F X="ARRAY" I '$D(SDUL(X)) S Y=0 G SETUPQ
I $E(SDUL("ARRAY"))'="" S SDUL("ARRAY")=" "_SDUL("ARRAY")
S SDUL("IFN")=0
S:'$D(SDUL("TM")) SDUL("TM")=$S('$D(SDUL("HDR")):2,1:5)
S:'$D(SDUL("BM")) SDUL("BM")=$S('$D(SDUL("HDR")):16,1:14)
S:'$D(SDUL("TYPE")) SDUL("TYPE")=2 ; def to display
S:'$D(SDUL("TITLE")) SDUL("TITLE")="Standard List Display"
I '$G(SDUL("MAX")) S SDUL("MAX")=1
S:'$D(SDULCC) SDULCC=1
SETUPQ Q Y
;
TEMP(NAME) ; -- use list template
N SDUL0,NODE
S SDUL=+$O(^SD(409.61,"B",NAME,0)),SDUL0=$G(^SD(409.61,SDUL,0))
G:SDUL0="" TEMPQ
;
F NODE="ARRAY","HDR","EXP","HLP","INIT","FNL" S SDUL(NODE)=$G(^SD(409.61,SDUL,NODE))
S SDUL("IFN")=SDUL D COL^SDUL
S SDUL("TYPE")=$P(SDUL0,U,2)
S SDUL("TM")=$P(SDUL0,U,5)
S SDUL("BM")=$P(SDUL0,U,6)
S SDULCC=+$P(SDUL0,U,8)
S SDUL("ENTITY")=$P(SDUL0,U,9)
S SDUL("PROTOCOL")=$P(SDUL0,U,10)
S SDUL("TITLE")=$S($P(SDUL0,U,11)]"":$P(SDUL0,U,11),1:$P(SDUL0,U))
S SDUL("MAX")=$S($P(SDUL0,U,12):$P(SDUL0,U,12),1:1)
S SDUL("DAYS")=$S($P(SDUL0,U,13):$P(SDUL0,U,13),1:30)
TEMPQ Q SDUL0]""
;
CALC ; -- calculate derived parmeters
N NODE,X,I,X,Y
F NODE="DAYS","EXP","HLP","INIT","FNL" I $G(SDUL(NODE))]"" S ^TMP("SDUL DATA",$J,SDULEVL,NODE)=SDUL(NODE) K SDUL(NODE)
S SDULAR=$E(SDUL("ARRAY"),2,50) K SDUL("ARRAY")
S SDUL("LINES")=(SDUL("BM")-SDUL("TM"))+1
S:SDUL("TM")<3 SDUL("TITLE")=" "_SDUL("TITLE")
; -- set up protocol
S X="SDUL DISPLAY" ; default protocol
I SDUL("TYPE")=1,SDUL("PROTOCOL")]"" S X=SDUL("PROTOCOL")
I SDUL("TYPE")=2,$D(^TMP("SDUL DATA",$J,SDULEVL,"EXP")) S X=X_" W/EXPAND"
S SDUL("PROTOCOL")=+$O(^ORD(101,"B",X,0))_";ORD(101,"
;
S (SDULUP,SDULDN)=""
I SDULCC S Y=$$IO F I=1:1 S X=$P(Y,";",I) Q:X="" I $G(@X)="" S SDULCC=0 Q
S SDULCAP=$$CAPTION^SDUL
S:$G(^DISV($S($D(DUZ)#2:DUZ,1:0),"SDULMENU",SDUL("PROTOCOL")))="" ^(SDUL("PROTOCOL"))=1 S SDULMENU=^(SDUL("PROTOCOL"))
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDUL0 3583 printed Dec 13, 2024@03:01:44 Page 2
SDUL0 ;MJK/ALB - List Manager (cont.); 12/1/91
+1 ;;5.3;Scheduling;;Aug 13, 1993
+2 ;
INIT(NAME,PARMS) ;
+1 DO STACK
+2 KILL SDULBCK,SDULQUIT,SDULHDR
+3 SET SDUL(0)=$GET(PARMS)
+4 IF NAME["^"
IF '$$SETUP(.NAME)
SET SDULQUIT=""
GOTO INITQ
+5 IF NAME'["^"
IF '$$TEMP(.NAME)
SET SDULQUIT=""
GOTO INITQ
+6 if 'SDULEVL
DO TERM
DO CALC
INITQ KILL SDX,X
QUIT
+1 ;
TERM ; -- set up term characteristics
+1 IF '$DATA(IOST(0))
DO HOME^%ZIS
+2 SET SDULWD=IOM
SET X=$$IO
DO ENDR^%ZISS
+3 QUIT
+4 ;
IO() ; -- what device params
+1 QUIT "IORVON;IORVOFF;IOIL;IOSTBM;IOSC;IORC;IOEDEOP;IOINHI;IOINORM;IOUON;IOUOFF"
+2 ;
STACK ; -- stack vars
+1 SET SDULEVL=$SELECT($DATA(SDULEVL):SDULEVL+1,1:0)
+2 IF 'SDULEVL
KILL SDUL,^TMP("SDUL DATA",$JOB,SDULEVL)
GOTO STACKQ
+3 ;
+4 ; -- stack'em
+5 KILL ^TMP("SDUL STACK",$JOB,SDULEVL)
+6 IF $ORDER(^TMP("SDUL STACK",$JOB,SDULEVL,"SDUL",""))=""
SET X=""
FOR
SET X=$ORDER(SDUL(X))
if X=""
QUIT
SET ^(X)=SDUL(X)
+7 IF $ORDER(^TMP("SDUL STACK",$JOB,SDULEVL,"OTHER VARS",""))=""
FOR X="SDULMENU","SDULCAP","SDULAR","SDULCNT","SDULBG","SDULST","SDULCC"
SET ^(X)=$GET(@X)
+8 KILL SDULBG,SDUL
STACKQ QUIT
+1 ;
POP ; -- clean up and unstack vars
+1 KILL SDULMENU,SDULCAP,SDULHDR,SDULPGE,SDULUP,SDULDN,SDULDDF,SDULCC,SDULAR,SDULCNT,SDUL,SDULBG,SDULST,LN,^TMP("SDUL DATA",$JOB,SDULEVL)
+2 IF 'SDULEVL
Begin DoDot:1
+3 DO CLEAR^SDUL1
+4 SET Y=$$IO
FOR I=1:1
SET X=$PIECE(Y,";",I)
if X=""
QUIT
KILL @X
+5 KILL Y,X,I,SDULEVL,SDULWD,SDULFIND
End DoDot:1
GOTO POPQ
+6 ;
+7 ; -- unstack'em
+8 IF $ORDER(^TMP("SDUL STACK",$JOB,SDULEVL,"SDUL",""))]""
SET X=""
FOR
SET X=$ORDER(^(X))
if X=""
QUIT
SET SDUL(X)=^(X)
+9 IF $ORDER(^TMP("SDUL STACK",$JOB,SDULEVL,"OTHER VARS",""))]""
SET X=""
FOR
SET X=$ORDER(^(X))
if X=""
QUIT
SET @X=^(X)
+10 KILL ^TMP("SDUL STACK",$JOB,SDULEVL)
+11 DO COL^SDUL
+12 SET SDULEVL=$SELECT(SDULEVL:SDULEVL-1,1:0)
SET SDULBCK="R"
SET (SDULUP,SDULDN)=""
POPQ QUIT
+1 ;
SETUP(NAME) ; -- on-the-fly list
+1 DO @NAME
+2 SET Y=1
FOR X="ARRAY"
IF '$DATA(SDUL(X))
SET Y=0
GOTO SETUPQ
+3 IF $EXTRACT(SDUL("ARRAY"))'=""
SET SDUL("ARRAY")=" "_SDUL("ARRAY")
+4 SET SDUL("IFN")=0
+5 if '$DATA(SDUL("TM"))
SET SDUL("TM")=$SELECT('$DATA(SDUL("HDR")):2,1:5)
+6 if '$DATA(SDUL("BM"))
SET SDUL("BM")=$SELECT('$DATA(SDUL("HDR")):16,1:14)
+7 ; def to display
if '$DATA(SDUL("TYPE"))
SET SDUL("TYPE")=2
+8 if '$DATA(SDUL("TITLE"))
SET SDUL("TITLE")="Standard List Display"
+9 IF '$GET(SDUL("MAX"))
SET SDUL("MAX")=1
+10 if '$DATA(SDULCC)
SET SDULCC=1
SETUPQ QUIT Y
+1 ;
TEMP(NAME) ; -- use list template
+1 NEW SDUL0,NODE
+2 SET SDUL=+$ORDER(^SD(409.61,"B",NAME,0))
SET SDUL0=$GET(^SD(409.61,SDUL,0))
+3 if SDUL0=""
GOTO TEMPQ
+4 ;
+5 FOR NODE="ARRAY","HDR","EXP","HLP","INIT","FNL"
SET SDUL(NODE)=$GET(^SD(409.61,SDUL,NODE))
+6 SET SDUL("IFN")=SDUL
DO COL^SDUL
+7 SET SDUL("TYPE")=$PIECE(SDUL0,U,2)
+8 SET SDUL("TM")=$PIECE(SDUL0,U,5)
+9 SET SDUL("BM")=$PIECE(SDUL0,U,6)
+10 SET SDULCC=+$PIECE(SDUL0,U,8)
+11 SET SDUL("ENTITY")=$PIECE(SDUL0,U,9)
+12 SET SDUL("PROTOCOL")=$PIECE(SDUL0,U,10)
+13 SET SDUL("TITLE")=$SELECT($PIECE(SDUL0,U,11)]"":$PIECE(SDUL0,U,11),1:$PIECE(SDUL0,U))
+14 SET SDUL("MAX")=$SELECT($PIECE(SDUL0,U,12):$PIECE(SDUL0,U,12),1:1)
+15 SET SDUL("DAYS")=$SELECT($PIECE(SDUL0,U,13):$PIECE(SDUL0,U,13),1:30)
TEMPQ QUIT SDUL0]""
+1 ;
CALC ; -- calculate derived parmeters
+1 NEW NODE,X,I,X,Y
+2 FOR NODE="DAYS","EXP","HLP","INIT","FNL"
IF $GET(SDUL(NODE))]""
SET ^TMP("SDUL DATA",$JOB,SDULEVL,NODE)=SDUL(NODE)
KILL SDUL(NODE)
+3 SET SDULAR=$EXTRACT(SDUL("ARRAY"),2,50)
KILL SDUL("ARRAY")
+4 SET SDUL("LINES")=(SDUL("BM")-SDUL("TM"))+1
+5 if SDUL("TM")<3
SET SDUL("TITLE")=" "_SDUL("TITLE")
+6 ; -- set up protocol
+7 ; default protocol
SET X="SDUL DISPLAY"
+8 IF SDUL("TYPE")=1
IF SDUL("PROTOCOL")]""
SET X=SDUL("PROTOCOL")
+9 IF SDUL("TYPE")=2
IF $DATA(^TMP("SDUL DATA",$JOB,SDULEVL,"EXP"))
SET X=X_" W/EXPAND"
+10 SET SDUL("PROTOCOL")=+$ORDER(^ORD(101,"B",X,0))_";ORD(101,"
+11 ;
+12 SET (SDULUP,SDULDN)=""
+13 IF SDULCC
SET Y=$$IO
FOR I=1:1
SET X=$PIECE(Y,";",I)
if X=""
QUIT
IF $GET(@X)=""
SET SDULCC=0
QUIT
+14 SET SDULCAP=$$CAPTION^SDUL
+15 if $GET(^DISV($SELECT($DATA(DUZ)#2
SET ^(SDUL("PROTOCOL"))=1
SET SDULMENU=^(SDUL("PROTOCOL"))
+16 QUIT
+17 ;
