- 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
- 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
