source: WorldVistAEHR/trunk/r/SURGERY-SR/SRCUSS4.m@ 1351

Last change on this file since 1351 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 2.1 KB
RevLine 
[613]1SRCUSS4 ;TAMPA/CFB - SCREEN SERVER ; 24 Jan 1989 7:40 AM
2 ;;3.0; Surgery ;;24 Jun 93
3PAGE 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"
4 I $E(Q7,$L(Q7))=")" S Q7=$E(Q7,1,$L(Q7)-1)
5 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
6 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
7 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
8 Q
9PAGE0 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
10 Q
11PA1 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)="["
12 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
13 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
14 G PA1
15TEM S Q(2)=$E(Q(2),2,99),(Q(2),Q(12,9))=$P(Q(2),"]",1) Q:'$D(^DIE("B",Q(2)))#2
16 S Q(14)=$O(^DIE("B",Q(2),0)),Q0(Q)=Q(2),Q(12,5)=Q7
17TEMC S Q7="^DIE("_Q(14)_",""DR"","_Q_","_+Q(0,Q)
18 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))
19 I Q("TEM"),'$D(^TMP("SRCUSS",$J,Q(14),"DATE")) S ^TMP("SRCUSS",$J,Q(14),"DATE")=$P(^DIE(Q(14),0),U,2)
20 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)
21 I $T S Q(13)=1,Q7=Q(12,5) Q
22 D PAGE S Q(13)=1,Q7=Q(12,5) Q
Note: See TracBrowser for help on using the repository browser.