source: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDUL0.m@ 1578

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
 ;