SRCUSS4 ;TAMPA/CFB - SCREEN SERVER ; 24 Jan 1989 7:40 AM
;;3.0; Surgery ;;24 Jun 93
PAGE S (Q("P",Q),Q8,Q6,Q("C"))=1 K Q0(Q) I Q=1,Q7="DR" S Q7="DR("_Q_","_+Q(0,Q) I '$D(@(Q7_")"))#2 S Q7="DR"
I $E(Q7,$L(Q7))=")" S Q7=$E(Q7,1,$L(Q7)-1)
S Q(12,6)=$S($D(@(Q7_$S(Q7["(":")",1:""))):@(Q7_$S(Q7["(":")",1:"")),1:".01;") S:Q(12,6)=".01" Q(12,6)=".01;" S Q0(Q,0)=$S(Q7["Q1":$P(Q(12,6),";",3,999),1:Q(12,6)) D PA1
F Q0(0)=0:0 S @("Q0(0)=$O("_Q7_$S(Q7["("&($E(Q7,$L(Q7))'="("):",",1:"(")_Q0(0)_"))") Q:Q0(0)<1 S Q(12,6)=@(Q7_$S(Q7["("&($E(Q7,$L(Q7))'="("):",",1:"(")_Q0(0)_")"),Q0(Q,0)=Q0(Q,0)_$S(Q7["Q1":$P(Q(12,6),";",3,999),1:Q(12,6)) D PA1
I $D(Q(14)),Q("TEM"),'$D(^TMP("SRCUSS",$J,Q(14),Q,+Q(0,Q))) S Q0(-1)=1000 F Q0(0)=0:0 S Q0(0)=$O(Q0(Q,Q0(0))) Q:Q0(0)<1 S ^TMP("SRCUSS",$J,Q(14),Q,+Q(0,Q),Q0(0))=$P(Q0(Q,Q0(0)),";",2,999) D PAGE0
Q
PAGE0 F Q0(-2)=0:0 S Q0(-2)=$O(Q0(Q,Q0(0),Q0(-2))) Q:Q0(-2)<1 S ^TMP("SRCUSS",$J,Q(14),Q,+Q(0,Q),Q0(-1))="Q0("_Q_","_Q0(0)_","_Q0(-2)_")",^(Q0(-1)+1000)=Q0(Q,Q0(0),Q0(-2)),Q0(-1)=Q0(-1)+1
Q
PA1 S (Q(2),Q(7))=$P(Q0(Q,0),";",1) Q:Q(7)=""!(+Q(7)=999999999) I (Q(2)[":"&(Q(2)?1NP.E))!($E(Q(2),1)="[") S Q0(Q,0)=$P(Q0(Q,0),";",2,999) D CO^SRCUSS0:Q(7)?1NP.E,TEM:$E(Q(7),1)="["
S Q("C1")=$P(Q0(Q,0),";",1) I $E(Q("C1"),1)?1U S Q0(Q,Q8,Q("C"))=$P(Q("C1"),";",1),Q("C1")="X Q0("_Q_","_Q8_","_Q("C")_")",Q("C")=Q("C")+1
S Q0(Q,Q8)=$S(Q6=1:Q3(Q)_";",1:Q0(Q,Q8))_Q("C1")_";",Q0(Q,0)=$P(Q0(Q,0),";",2,999),Q6=Q6+1 I Q0(Q,0)'="" S:Q6=(17-Q)!(Q(7)="H 0") (Q("P",Q),Q8)=Q8+1,(Q6,Q("C"))=1
G PA1
TEM S Q(2)=$E(Q(2),2,99),(Q(2),Q(12,9))=$P(Q(2),"]",1) Q:'$D(^DIE("B",Q(2)))#2
S Q(14)=$O(^DIE("B",Q(2),0)),Q0(Q)=Q(2),Q(12,5)=Q7
TEMC S Q7="^DIE("_Q(14)_",""DR"","_Q_","_+Q(0,Q)
I Q("TEM"),$D(^TMP("SRCUSS",$J,Q(14),"DATE")),$P(^DIE(Q(14),0),U,2)'=^TMP("SRCUSS",$J,Q(14),"DATE") K ^TMP("SRCUSS",$J,Q(14))
I Q("TEM"),'$D(^TMP("SRCUSS",$J,Q(14),"DATE")) S ^TMP("SRCUSS",$J,Q(14),"DATE")=$P(^DIE(Q(14),0),U,2)
I Q("TEM"),$D(^TMP("SRCUSS",$J,Q(14),Q,+Q(0,Q))) F Q8=0:0 S Q8=$O(^TMP("SRCUSS",$J,Q(14),Q,+Q(0,Q),Q8)) Q:'Q8!(Q8>1999) S:Q8<1000 Q0(Q,Q8)=Q3(Q)_";"_^(Q8),Q("P",Q)=Q8 S:Q8>999 @^(Q8)=^(Q8+1000)
I $T S Q(13)=1,Q7=Q(12,5) Q
D PAGE S Q(13)=1,Q7=Q(12,5) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSRCUSS4 2216 printed Oct 16, 2024@18:39:50 Page 2
SRCUSS4 ;TAMPA/CFB - SCREEN SERVER ; 24 Jan 1989 7:40 AM
+1 ;;3.0; Surgery ;;24 Jun 93
PAGE SET (Q("P",Q),Q8,Q6,Q("C"))=1
KILL Q0(Q)
IF Q=1
IF Q7="DR"
SET Q7="DR("_Q_","_+Q(0,Q)
IF '$DATA(@(Q7_")"))#2
SET Q7="DR"
+1 IF $EXTRACT(Q7,$LENGTH(Q7))=")"
SET Q7=$EXTRACT(Q7,1,$LENGTH(Q7)-1)
+2 SET Q(12,6)=$SELECT($DATA(@(Q7_$SELECT(Q7["(":")",1:""))):@(Q7_$SELECT(Q7["(":")",1:"")),1:".01;")
if Q(12,6)=".01"
SET Q(12,6)=".01;"
SET Q0(Q,0)=$SELECT(Q7["Q1":$PIECE(Q(12,6),";",3,999),1:Q(12,6))
DO PA1
+3 FOR Q0(0)=0:0
SET @("Q0(0)=$O("_Q7_$SELECT(Q7["("&($EXTRACT(Q7,$LENGTH(Q7))'="("):",",1:"(")_Q0(0)_"))")
if Q0(0)<1
QUIT
SET Q(12,6)=@(Q7_$SELECT(Q7["("&($EXTRACT(Q7,$LENGTH(Q7))'="("):",",1:"(")_Q0(0)_")")
SET Q0(Q,0)=Q0(Q,0)_$SELECT(Q7["Q1":$PIECE(Q(12,6),";",3,999),1:Q(12,6))
DO PA1
+4 IF $DATA(Q(14))
IF Q("TEM")
IF '$DATA(^TMP("SRCUSS",$JOB,Q(14),Q,+Q(0,Q)))
SET Q0(-1)=1000
FOR Q0(0)=0:0
SET Q0(0)=$ORDER(Q0(Q,Q0(0)))
if Q0(0)<1
QUIT
SET ^TMP("SRCUSS",$JOB,Q(14),Q,+Q(0,Q),Q0(0))=$PIECE(Q0(Q,Q0(0)),";",2,999)
DO PAGE0
+5 QUIT
PAGE0 FOR Q0(-2)=0:0
SET Q0(-2)=$ORDER(Q0(Q,Q0(0),Q0(-2)))
if Q0(-2)<1
QUIT
SET ^TMP("SRCUSS",$JOB,Q(14),Q,+Q(0,Q),Q0(-1))="Q0("_Q_","_Q0(0)_","_Q0(-2)_")"
SET ^(Q0(-1)+1000)=Q0(Q,Q0(0),Q0(-2))
SET Q0(-1)=Q0(-1)+1
+1 QUIT
PA1 SET (Q(2),Q(7))=$PIECE(Q0(Q,0),";",1)
if Q(7)=""!(+Q(7)=999999999)
QUIT
IF (Q(2)[":"&(Q(2)?1NP.E))!($EXTRACT(Q(2),1)="[")
SET Q0(Q,0)=$PIECE(Q0(Q,0),";",2,999)
if Q(7)?1NP.E
DO CO^SRCUSS0
if $EXTRACT(Q(7),1)="["
DO TEM
+1 SET Q("C1")=$PIECE(Q0(Q,0),";",1)
IF $EXTRACT(Q("C1"),1)?1U
SET Q0(Q,Q8,Q("C"))=$PIECE(Q("C1"),";",1)
SET Q("C1")="X Q0("_Q_","_Q8_","_Q("C")_")"
SET Q("C")=Q("C")+1
+2 SET Q0(Q,Q8)=$SELECT(Q6=1:Q3(Q)_";",1:Q0(Q,Q8))_Q("C1")_";"
SET Q0(Q,0)=$PIECE(Q0(Q,0),";",2,999)
SET Q6=Q6+1
IF Q0(Q,0)'=""
if Q6=(17-Q)!(Q(7)="H 0")
SET (Q("P",Q),Q8)=Q8+1
SET (Q6,Q("C"))=1
+3 GOTO PA1
TEM SET Q(2)=$EXTRACT(Q(2),2,99)
SET (Q(2),Q(12,9))=$PIECE(Q(2),"]",1)
if '$DATA(^DIE("B",Q(2)))#2
QUIT
+1 SET Q(14)=$ORDER(^DIE("B",Q(2),0))
SET Q0(Q)=Q(2)
SET Q(12,5)=Q7
TEMC SET Q7="^DIE("_Q(14)_",""DR"","_Q_","_+Q(0,Q)
+1 IF Q("TEM")
IF $DATA(^TMP("SRCUSS",$JOB,Q(14),"DATE"))
IF $PIECE(^DIE(Q(14),0),U,2)'=^TMP("SRCUSS",$JOB,Q(14),"DATE")
KILL ^TMP("SRCUSS",$JOB,Q(14))
+2 IF Q("TEM")
IF '$DATA(^TMP("SRCUSS",$JOB,Q(14),"DATE"))
SET ^TMP("SRCUSS",$JOB,Q(14),"DATE")=$PIECE(^DIE(Q(14),0),U,2)
+3 IF Q("TEM")
IF $DATA(^TMP("SRCUSS",$JOB,Q(14),Q,+Q(0,Q)))
FOR Q8=0:0
SET Q8=$ORDER(^TMP("SRCUSS",$JOB,Q(14),Q,+Q(0,Q),Q8))
if 'Q8!(Q8>1999)
QUIT
if Q8<1000
SET Q0(Q,Q8)=Q3(Q)_";"_^(Q8)
SET Q("P",Q)=Q8
if Q8>999
SET @^(Q8)=^(Q8+1000)
+4 IF $TEST
SET Q(13)=1
SET Q7=Q(12,5)
QUIT
+5 DO PAGE
SET Q(13)=1
SET Q7=Q(12,5)
QUIT
