- SRCUSS0 ;TAMPA/CFB - SCREEN SERVER ; [ 03/11/02 13:37 PM ]
- ;;3.0; Surgery ;**66,108,118,130**;24 Jun 93
- CO S Q(12,1)=$P(Q(2),":",1),Q(12,2)=$P(Q(2),":",2),Q(12,0)="",Q(12,8)=0 F Q(12,7)=+Q(12,1):0:+Q(12,2) D COM Q:Q(12,8)!(Q(12,7)>+Q(12,2)) I $L(Q(12,0))+$L(Q0(Q,0))>100 D COM1 Q
- S Q(2)=Q(12,1),Q0(Q,0)=Q(12,1)_";"_Q(12,0)_Q(12,2)_";"_Q0(Q,0) Q
- COM S Q(12,7)=$O(@("^DD("_+Q(0,Q)_","_Q(12,7)_")")) S:Q(12,7)'?1NP.NP!(Q(12,7)="")!(Q(12,7)'<Q(12,2)) Q(12,8)=1 Q:Q(12,8) S Q(12,0)=Q(12,0)_Q(12,7)_";" Q
- COM1 S Q(12,0)=$E(Q(12,0),1,$L(Q(12,0))-1)_":" Q
- M S Q("LIMIT")=75,Q("LINE")=0
- W:Q("ED") Q("NOR") S Q=Q+1,(Q(1,Q),Q(13),Q0(0,Q))=1,Q(0,Q)=$P(Q(3),U,2)
- I $D(^DD(+Q(0,Q),.01,12.1)) X ^(12.1) S Q("S",Q,"MUL")=DIC("S") K DIC("S")
- S Q(8,Q)=Q(8,Q-1)_Q(9,Q-1)_","_$C(34)_$P($P(Q(3),U,4),";",1)_$C(34)_",",Q3(Q)=$P(Q(3),U,1),Q0(Q,Q0(0,Q))=Q3(Q)_";.01;",Q(10,Q)=0
- K:$S('$D(Q(12,4)):0,+Q(12,4)=Q&(Q(12,4)["S"):1,1:0) Q(12,4) G:$D(Q(12,4)) MQ1
- I @("'($D("_Q(8,Q)_"0))#2)") S @(Q(8,Q)_"0)")=$P(Q(3),U,1,2)
- I $D(Q(14)),'$D(^DIE(Q(14),"DR",Q,+Q(0,Q))) G MQ1
- M00 X Q(0)
- I Q("LIMIT")=19,$P(@(Q(8,Q)_"0)"),U,4)>14 W Q("HI") S DIC=Q(8,Q),DIC(0)="QAEM" K DIC("V") D ^DIC G MP
- M0 I Q("LIMIT")>19,Q("1",Q)>16 D CONT G:+Q(1)>0 M11A I Q(1)="^" S Q(13)=1 K Q(11),Q(13,0) G M11
- K Q(13,0) G:Q(10,Q)'=+Q(10,Q) MQ1 S (DA(Q),Q(7,Q(1,Q)),Q(9,Q),Q(10,Q))=$O(@(Q(8,Q)_Q(10,Q)_")")) G:Q(10,Q)'=+Q(10,Q)!(Q(10,Q)<1) M1 D A^SRCUSS S Q4(-4,Q(1,Q)-1)=Q(7) I Q(13)#Q("LIMIT") G M0
- M1 W !,Q(1,Q),?5,"NEW ENTRY" S Q(7,Q(1,Q))=$S(Q(1,Q)=1:1,1:Q(7,Q(1,Q)-1)+1),Q(13)=1 K Q(11),Q(13,0)
- S:$P(Q(3),"^",5,99)["D IX^DIC" Q("S",Q,"IX")=$P(Q(3),"^",5,99)
- M11 K QPQPQ W Q("HI") W !!,"Enter Screen Server Function: " R Q(1):DTIME S:'$T Q(1)="" S:Q(1)=0 Q(1)="?" S:Q(1)="a" Q(1)="A" I Q("LIMIT")=19,Q(1)>15 S Q(1)="?"
- M11A S:Q(1)?.E1C.E Q(1)="?" I Q(1)["?"!(Q(1)?2.99A) D QUES^SRCUSS5 G MQ
- S:$S(Q(1)="^^":1,$E(Q(1))'="L":0,+$E(Q(1),2,99)<Q:1,1:0) Q(12,4)=$E(Q(1),2,99) G:$D(Q(13,0))&(Q(1)="") M00 K Q(13,0)
- S Q8(2)=0 I Q(1,Q)=+Q(1),Q(1)["N" S Q8(2)=1 S:+Q(1)=1 Q(3)=^DD(+$P(Q(3),U,2),.01,0) G M110
- I +Q(1)>0,$E(Q(1),$L(Q(1)))="R",+Q(1)<Q(1,Q),$D(Q4(-4,+Q(1))) G M110
- I (Q(1)=""&(Q(13)=1))!(Q(1)[U) G MQ1
- G M11:Q(1)'=+Q(1)!(Q(1)<1)!(Q(1)>Q(1,Q)),M0:Q(1)="" S (DA(Q),Q(9,Q))=Q(7,Q(1)),Q(13)=1
- M110 I '$D(Q3("VIEW")),(+Q(1)=Q(1,Q)!(Q(1)["R")) S:Q(1)=1 @("Q(3)=^DD("_+$P(Q(3),U,2)_",.01,0)") S DIC=Q(8,Q),DIC(0)="ZMEL"_$S(Q(1)'["R":"QA",1:""),DIC("DR")=.01
- S Q(1)=+Q(1)
- I $T S:$D(Q("S",Q,"MUL")) DIC("S")=Q("S",Q,"MUL")
- I $T S:$D(Q4(-4,Q(1))) X=$C(34)_Q4(-4,Q(1))_$C(34) K DIC("V") D SET,^DIC K DIC("S") G MQ:+Y<1 G SET2
- M111 ;
- I $D(Q3("VIEW")),Q(1)=Q(1,Q) G MQ
- S Q3(Q)=$E(Q3(Q)_" ("_Q4(-4,Q(1)),1,60)_")" K Q4
- M12 I $D(Q(14)) K Q(10) S (Q(1,Q),Q(13),Q0(0,Q))=1 X Q(0) D TEMC^SRCUSS4,A^SRCUSS:'(+$P(Q0(Q,1),";",2)'=".01"&($P(Q0(Q,1),";",3)="")) G MQ
- I $E(Q(12,5),1,2)="DR",$D(DR(Q,+Q(0,Q)))#2 K Q(10) S Q7="DR("_Q_","_+Q(0,Q)_")",(Q(1,Q),Q(13),Q0(0,Q))=1 X Q(0) D PAGE^SRCUSS4,A^SRCUSS:'($P(Q0(Q,1),";",2)=".01"&($P(Q0(Q,1),";",3)="")) G MQ
- S (Q("P",Q),Q8,Q6)=1,Q0(Q,0)=".01:999999999" D PA1^SRCUSS4
- M2 K Q(10,Q) S (Q(1,Q),Q(13))=1 X Q(0) D A^SRCUSS K Q(1,Q) S Q=Q-1,Q(1,Q)=1 S Q(1)="Q",Q(3)=Q(2,Q,Q2(Q,1)) G M
- MQ W:Q("ED") Q("HI") K Q8(2),Q(10,Q),Q0(Q),Q("S",Q) S Q=Q-1,Q(1)="Q",Q(13)=1,Q(3)=Q(2,Q,Q2(Q,1)),Q(0,Q+1)=$P(Q(3),U,2) G M
- MQ1 W:Q("ED") Q("HI") K Q8(2),Q(10,Q),Q0(Q),Q("S",Q) S Q=Q-1,Q(1)="Q",Q(13)=1,Q(12,12)="" Q
- MP X Q(0) S Q(1,Q)=1 G M1:Y<1 S (DA(Q),Q(7,Q(1,Q)),Q(9,Q),Q(10,Q))=+Y D A^SRCUSS S Q4(-4,Q(1,Q)-1)=Q(7) G M1
- SET S QQ=$S(Q>1:Q-1,1:1) F Q8=1:1:QQ S QQQ=$S(Q>1:Q-Q8,1:1),DA(Q8)=Q(9,QQQ)
- Q
- SET2 I Q(5)="P"&(Q(7,Q(1))'=+Y) D G M11A:'$D(Y)
- .S Q(999)=0
- .F S Q(999)=$O(Q(7,Q(999))) Q:'Q(999) D
- ..S PSDPTR=Q(7,Q(999))
- ..S:PSDPTR=+Y Q(1)=Q(999),Q(999)=99
- .K Y,Q(999),PSDPTR
- S @("Q(9,Q)=$P("_DIC_"0),U,3)"),Q4(-4,Q(1))=+Y(0),Q(7)=Q4(-4,Q(1)),Q("BP")="" D:$P(Q(3),U,2)["P" P^SRCUSS S Q4(-4,Q(1))=Q(7) K Q("BP") G M110:Q8(2)
- G M111
- Q
- CONT ;
- S:Q("LINE")>15 Q("LINE")=0
- I Q("LINE")=0 W !!,"Press <RETURN> to see more, '^' to exit this list, OR",!,"CHOOSE 1-",Q("1",Q)-1,": " R Q(1):DTIME S:'$T Q(1)="" S:+Q(1)'>0&(Q(1)'="^") Q(1)=""
- S Q("LINE")=Q("LINE")+1
- S:Q(1)>(Q("1",Q)-1) Q(1)=""
- Q
- SRCUSS0 ;TAMPA/CFB - SCREEN SERVER ; [ 03/11/02 13:37 PM ]
- +1 ;;3.0; Surgery ;**66,108,118,130**;24 Jun 93
- CO SET Q(12,1)=$PIECE(Q(2),":",1)
- SET Q(12,2)=$PIECE(Q(2),":",2)
- SET Q(12,0)=""
- SET Q(12,8)=0
- FOR Q(12,7)=+Q(12,1):0:+Q(12,2)
- DO COM
- IF Q(12,8)!(Q(12,7)>+Q(12,2))
- QUIT
- IF $LENGTH(Q(12,0))+$LENGTH(Q0(Q,0))>100
- DO COM1
- QUIT
- +1 SET Q(2)=Q(12,1)
- SET Q0(Q,0)=Q(12,1)_";"_Q(12,0)_Q(12,2)_";"_Q0(Q,0)
- QUIT
- COM SET Q(12,7)=$ORDER(@("^DD("_+Q(0,Q)_","_Q(12,7)_")"))
- IF Q(12,7)'?1NP.NP!(Q(12,7)="")!(Q(12,7)'<Q(12,2))
- SET Q(12,8)=1
- IF Q(12,8)
- QUIT
- SET Q(12,0)=Q(12,0)_Q(12,7)_";"
- QUIT
- COM1 SET Q(12,0)=$EXTRACT(Q(12,0),1,$LENGTH(Q(12,0))-1)_":"
- QUIT
- M SET Q("LIMIT")=75
- SET Q("LINE")=0
- +1 IF Q("ED")
- WRITE Q("NOR")
- SET Q=Q+1
- SET (Q(1,Q),Q(13),Q0(0,Q))=1
- SET Q(0,Q)=$PIECE(Q(3),U,2)
- +2 IF $DATA(^DD(+Q(0,Q),.01,12.1))
- XECUTE ^(12.1)
- SET Q("S",Q,"MUL")=DIC("S")
- KILL DIC("S")
- +3 SET Q(8,Q)=Q(8,Q-1)_Q(9,Q-1)_","_$CHAR(34)_$PIECE($PIECE(Q(3),U,4),";",1)_$CHAR(34)_","
- SET Q3(Q)=$PIECE(Q(3),U,1)
- SET Q0(Q,Q0(0,Q))=Q3(Q)_";.01;"
- SET Q(10,Q)=0
- +4 IF $SELECT('$DATA(Q(12,4))
- KILL Q(12,4)
- IF $DATA(Q(12,4))
- GOTO MQ1
- +5 IF @("'($D("_Q(8,Q)_"0))#2)")
- SET @(Q(8,Q)_"0)")=$PIECE(Q(3),U,1,2)
- +6 IF $DATA(Q(14))
- IF '$DATA(^DIE(Q(14),"DR",Q,+Q(0,Q)))
- GOTO MQ1
- M00 XECUTE Q(0)
- +1 IF Q("LIMIT")=19
- IF $PIECE(@(Q(8,Q)_"0)"),U,4)>14
- WRITE Q("HI")
- SET DIC=Q(8,Q)
- SET DIC(0)="QAEM"
- KILL DIC("V")
- DO ^DIC
- GOTO MP
- M0 IF Q("LIMIT")>19
- IF Q("1",Q)>16
- DO CONT
- IF +Q(1)>0
- GOTO M11A
- IF Q(1)="^"
- SET Q(13)=1
- KILL Q(11),Q(13,0)
- GOTO M11
- +1 KILL Q(13,0)
- IF Q(10,Q)'=+Q(10,Q)
- GOTO MQ1
- SET (DA(Q),Q(7,Q(1,Q)),Q(9,Q),Q(10,Q))=$ORDER(@(Q(8,Q)_Q(10,Q)_")"))
- IF Q(10,Q)'=+Q(10,Q)!(Q(10,Q)<1)
- GOTO M1
- DO A^SRCUSS
- SET Q4(-4,Q(1,Q)-1)=Q(7)
- IF Q(13)#Q("LIMIT")
- GOTO M0
- M1 WRITE !,Q(1,Q),?5,"NEW ENTRY"
- SET Q(7,Q(1,Q))=$SELECT(Q(1,Q)=1:1,1:Q(7,Q(1,Q)-1)+1)
- SET Q(13)=1
- KILL Q(11),Q(13,0)
- +1 IF $PIECE(Q(3),"^",5,99)["D IX^DIC"
- SET Q("S",Q,"IX")=$PIECE(Q(3),"^",5,99)
- M11 KILL QPQPQ
- WRITE Q("HI")
- WRITE !!,"Enter Screen Server Function: "
- READ Q(1):DTIME
- IF '$TEST
- SET Q(1)=""
- IF Q(1)=0
- SET Q(1)="?"
- IF Q(1)="a"
- SET Q(1)="A"
- IF Q("LIMIT")=19
- IF Q(1)>15
- SET Q(1)="?"
- M11A IF Q(1)?.E1C.E
- SET Q(1)="?"
- IF Q(1)["?"!(Q(1)?2.99A)
- DO QUES^SRCUSS5
- GOTO MQ
- +1 IF $SELECT(Q(1)="^^"
- SET Q(12,4)=$EXTRACT(Q(1),2,99)
- IF $DATA(Q(13,0))&(Q(1)="")
- GOTO M00
- KILL Q(13,0)
- +2 SET Q8(2)=0
- IF Q(1,Q)=+Q(1)
- IF Q(1)["N"
- SET Q8(2)=1
- IF +Q(1)=1
- SET Q(3)=^DD(+$PIECE(Q(3),U,2),.01,0)
- GOTO M110
- +3 IF +Q(1)>0
- IF $EXTRACT(Q(1),$LENGTH(Q(1)))="R"
- IF +Q(1)<Q(1,Q)
- IF $DATA(Q4(-4,+Q(1)))
- GOTO M110
- +4 IF (Q(1)=""&(Q(13)=1))!(Q(1)[U)
- GOTO MQ1
- +5 IF Q(1)'=+Q(1)!(Q(1)<1)!(Q(1)>Q(1,Q))
- GOTO M11
- IF Q(1)=""
- GOTO M0
- SET (DA(Q),Q(9,Q))=Q(7,Q(1))
- SET Q(13)=1
- M110 IF '$DATA(Q3("VIEW"))
- IF (+Q(1)=Q(1,Q)!(Q(1)["R"))
- IF Q(1)=1
- SET @("Q(3)=^DD("_+$PIECE(Q(3),U,2)_",.01,0)")
- SET DIC=Q(8,Q)
- SET DIC(0)="ZMEL"_$SELECT(Q(1)'["R":"QA",1:"")
- SET DIC("DR")=.01
- +1 SET Q(1)=+Q(1)
- +2 IF $TEST
- IF $DATA(Q("S",Q,"MUL"))
- SET DIC("S")=Q("S",Q,"MUL")
- +3 IF $TEST
- IF $DATA(Q4(-4,Q(1)))
- SET X=$CHAR(34)_Q4(-4,Q(1))_$CHAR(34)
- KILL DIC("V")
- DO SET
- DO ^DIC
- KILL DIC("S")
- IF +Y<1
- GOTO MQ
- GOTO SET2
- M111 ;
- +1 IF $DATA(Q3("VIEW"))
- IF Q(1)=Q(1,Q)
- GOTO MQ
- +2 SET Q3(Q)=$EXTRACT(Q3(Q)_" ("_Q4(-4,Q(1)),1,60)_")"
- KILL Q4
- M12 IF $DATA(Q(14))
- KILL Q(10)
- SET (Q(1,Q),Q(13),Q0(0,Q))=1
- XECUTE Q(0)
- DO TEMC^SRCUSS4
- IF '(+$PIECE(Q0(Q,1),";",2)'=".01"&($PIECE(Q0(Q,1),";",3)=""))
- DO A^SRCUSS
- GOTO MQ
- +1 IF $EXTRACT(Q(12,5),1,2)="DR"
- IF $DATA(DR(Q,+Q(0,Q)))#2
- KILL Q(10)
- SET Q7="DR("_Q_","_+Q(0,Q)_")"
- SET (Q(1,Q),Q(13),Q0(0,Q))=1
- XECUTE Q(0)
- DO PAGE^SRCUSS4
- IF '($PIECE(Q0(Q,1),";",2)=".01"&($PIECE(Q0(Q,1),";",3)=""))
- DO A^SRCUSS
- GOTO MQ
- +2 SET (Q("P",Q),Q8,Q6)=1
- SET Q0(Q,0)=".01:999999999"
- DO PA1^SRCUSS4
- M2 KILL Q(10,Q)
- SET (Q(1,Q),Q(13))=1
- XECUTE Q(0)
- DO A^SRCUSS
- KILL Q(1,Q)
- SET Q=Q-1
- SET Q(1,Q)=1
- SET Q(1)="Q"
- SET Q(3)=Q(2,Q,Q2(Q,1))
- GOTO M
- MQ IF Q("ED")
- WRITE Q("HI")
- KILL Q8(2),Q(10,Q),Q0(Q),Q("S",Q)
- SET Q=Q-1
- SET Q(1)="Q"
- SET Q(13)=1
- SET Q(3)=Q(2,Q,Q2(Q,1))
- SET Q(0,Q+1)=$PIECE(Q(3),U,2)
- GOTO M
- MQ1 IF Q("ED")
- WRITE Q("HI")
- KILL Q8(2),Q(10,Q),Q0(Q),Q("S",Q)
- SET Q=Q-1
- SET Q(1)="Q"
- SET Q(13)=1
- SET Q(12,12)=""
- QUIT
- MP XECUTE Q(0)
- SET Q(1,Q)=1
- IF Y<1
- GOTO M1
- SET (DA(Q),Q(7,Q(1,Q)),Q(9,Q),Q(10,Q))=+Y
- DO A^SRCUSS
- SET Q4(-4,Q(1,Q)-1)=Q(7)
- GOTO M1
- SET SET QQ=$SELECT(Q>1:Q-1,1:1)
- FOR Q8=1:1:QQ
- SET QQQ=$SELECT(Q>1:Q-Q8,1:1)
- SET DA(Q8)=Q(9,QQQ)
- +1 QUIT
- SET2 IF Q(5)="P"&(Q(7,Q(1))'=+Y)
- Begin DoDot:1
- +1 SET Q(999)=0
- +2 FOR
- SET Q(999)=$ORDER(Q(7,Q(999)))
- IF 'Q(999)
- QUIT
- Begin DoDot:2
- +3 SET PSDPTR=Q(7,Q(999))
- +4 IF PSDPTR=+Y
- SET Q(1)=Q(999)
- SET Q(999)=99
- End DoDot:2
- +5 KILL Y,Q(999),PSDPTR
- End DoDot:1
- IF '$DATA(Y)
- GOTO M11A
- +6 SET @("Q(9,Q)=$P("_DIC_"0),U,3)")
- SET Q4(-4,Q(1))=+Y(0)
- SET Q(7)=Q4(-4,Q(1))
- SET Q("BP")=""
- IF $PIECE(Q(3),U,2)["P"
- DO P^SRCUSS
- SET Q4(-4,Q(1))=Q(7)
- KILL Q("BP")
- IF Q8(2)
- GOTO M110
- +7 GOTO M111
- +8 QUIT
- CONT ;
- +1 IF Q("LINE")>15
- SET Q("LINE")=0
- +2 IF Q("LINE")=0
- WRITE !!,"Press <RETURN> to see more, '^' to exit this list, OR",!,"CHOOSE 1-",Q("1",Q)-1,": "
- READ Q(1):DTIME
- IF '$TEST
- SET Q(1)=""
- IF +Q(1)'>0&(Q(1)'="^")
- SET Q(1)=""
- +3 SET Q("LINE")=Q("LINE")+1
- +4 IF Q(1)>(Q("1",Q)-1)
- SET Q(1)=""
- +5 QUIT
