- 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 Feb 19, 2025@00:28:14 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 ;