SRCUSS1 ;TAMPA/CFB - SCREEN SERVER ; [ 03/11/02 13:40 PM ]
;;3.0;Surgery;**14,31,48,66,108,177**;24 Jun 93;Build 89
B G BQ:Q(13)=2 Q:$D(Q("X")) S DR="" W:'Q("ED") !! I Q(1)="Q" S Q(1)="" Q
I '$D(Q(12,12)),Q(1,Q)=3,Q(7)["(MULTIPLE)" S Q7=1 G BP2
I Q=1,$D(Q3("DIVE")) S Q7=$P(Q3("DIVE"),"P",2) K Q3("DIVE") G BP10
BP1 S DX=1,DY=22 X:Q("ED") Q("XY") I $D(Q3("VIEW")) S Q3("VIEW")=""
K QPQPQ W "Enter Screen Server Function: " R Q7:DTIME S:'$T Q7="^^" I Q7?.N S:$L(Q7)>2 Q7="?" S:Q7>15 Q7="?"
S:Q7="a" Q7="A" S:$E(Q7)="p" Q7="P"_$E(Q7,2,99)
S:$L(Q7)&("^-+123456789AP"'[$E(Q7)) Q7="?" S:$P(Q7,":",2)>15 Q7="?" S:Q7?.E1C.E Q7="?"
I Q7[";" F Q8=2:1 S QQ=$P(Q7,";",Q8) S:"123456789"'[$E(QQ) Q7="?" Q:'QQ
I Q7["?" D QUES G BP2
K SRCUSS("OUT")
I Q7'?.N1";".E,(Q7'?.N),(Q7'?.N1":".E),(Q7'="A"),("^^"'[Q7),(Q7'?1"+".N),(Q7'?1"-".N),(Q7'?1"P"1N.N) D QUES G BP2
W Q("LO")
BP10 I Q7="A" S Q7="1:"_(Q(1,Q)-1)
S:$S(Q7="^^":1,$E(Q7)'="L":0,+$E(Q7,2,99)<Q:1,1:0) Q(12,4)=$E(Q7,2,99) S Q(13)=1 G BQ:((Q7=""&('$D(Q0(Q,Q0(0,Q)+1))))!(Q7[U))
I $E(Q7)="P",$L(Q7)>1,('+$E(Q7,2,99)!('$D(Q0(Q,+$E(Q7,2,99))))) D QUES G BP2
I $E(Q7)="P",$L(Q7)>1,+$E(Q7,2,99) S Q0(0,Q)=$E(Q7,2,99),Q(1,Q)=1 X Q(0) G A^SRCUSS
S:Q7="" Q7="+1" I $E(Q7,1)="+" S Q0(0,Q)=Q0(0,Q)+Q7,Q(1,Q)=1 G BQ:'$D(Q0(Q,Q0(0,Q))) X Q(0) G A^SRCUSS
K Q(12,12) I $E(Q7,1)="-" S:Q7="-" Q7="-1" S Q0(0,Q)=$S(Q0(0,Q)+Q7<2:1,1:Q0(0,Q)+Q7),Q(1,Q)=1 X Q(0) G A^SRCUSS
BP2 S (Q2(Q),DR)="" F Q8=1:1 S Q6=$P(Q7,";",Q8) D:Q6[":" BCOM Q:Q6=""!(Q6'=+Q6) I $P(Q0(Q,Q0(0,Q)),";",Q6+1)'="" D BM
S:$D(Q("S",Q,Q0(0,Q),Q(1,Q))) DIC("S")=Q("S",Q,Q0(0,Q),Q(1,Q)) D CNG K DIC("S") S @("Q(7)=$D("_Q(8,Q)_Q(9,Q)_",0))") I 'Q(7) G BQ
I Q2(Q)="",Q("ED") X ^TMP("SRCUSS",$J,^TMP("SRCUSS",$J,0),1),^(2) W !,Q("EPE") G B
S QPQPQ=1,Q(1,Q)=1 F EMILY=1:1 S Q2(Q,1)=+$P(Q2(Q),U,1),Q2(Q)=$P(Q2(Q),U,2,99) Q:Q2(Q,1)<1 S Q(3)=Q(2,Q,Q2(Q,1)) D M^SRCUSS0 S Q(1,Q)=1
X:$S('$D(Q(12,4)):1,+Q(12,4)=Q:1,1:0) Q(0) G A^SRCUSS
BCOM S Q(12,2)=+$P(Q6,":",2),Q6=+Q6,Q(12,1)=0 Q:Q(12,2)'>Q6 F Q(12,0)=Q6:1:Q(12,2) S Q7=$S(Q(12,1)+Q8>1:$P(Q7,";",1,Q8+Q(12,1)-1)_";",1:"")_Q(12,0)_";"_$P(Q7,";",Q(12,1)+Q8+$S(Q(12,1)=0:1,1:0),99) S Q(12,1)=Q(12,1)+1
Q
BM I $D(Q(2,Q,Q6)),$P(@("^DD("_+$P(Q(2,Q,Q6),U,2)_",.01,0)"),U,2)'["W" S Q2(Q)=Q2(Q)_Q6_U Q
I $D(Q(2,Q,Q6)),$P(@("^DD("_+$P(Q(2,Q,Q6),U,2)_",.01,0)"),U,2)["W",$D(Q3("VIEW")) S Q3("VIEW")=Q3("VIEW")_$P($P(Q(2,Q,Q6),U,4),";",1)_";"
S DR=DR_$P(Q0(Q,Q0(0,Q)),";",Q6+1)_";Q;" Q
BQ W:Q=1 @IOF W:$D(Q("NOR")) Q("NOR") K:$D(Q0(0,Q)) Q("S",Q,Q0(0,Q)) K:Q=1 Q,Q0,Q1,DE,DP,DQ,Q2,Q3,Q4,Q5,Q6,Q7,Q8,QQ,QQQ,DX,DY,SRCUSS K ^TMP("SRCUSS",$J) Q ;WITH NEW K:Q=1 Q
CNG W Q("HI") S (DIE,DIC)=Q(8,Q),DA=Q(9,Q) I $D(Q3("VIEW")) Q:Q3("VIEW")="" S DR=Q3("VIEW") D EN^DIQ R !!,"Press <RET> to continue ",Q8:DTIME Q
I $D(Q("S",Q,"IX")) D IX Q
I 'Q("ED") D SET,ICD
I 'Q("ED") D ^DIE S SRCUSS("OUT")=1 D RET Q
G ^SRCUSS2
ID Q:'$D(^DD(+Q(4))) Q:('(+Q(4)\1=80!(+Q(4)=45.3)))&'($P(^DD(+Q(4),.01,0),U,2)["N"&($D(^DD(+Q(4),0,"ID")))) S Q(11)=$O(@("^DD("_$S(+Q(4)'="":+Q(4),1:+Q(0,Q))_",0,""ID"","_Q(11)_")")) Q:Q(11)="" I ^(Q(11))["^(""0"")" S Q(11)=^(Q(11)) Q
G ID
IX X Q("S",Q,"IX") Q:Q6<1 S DR=".01///"_$P(Q6,U,2) D ^DIE,SET Q
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
QUES ;
W:'$D(Q3("VIEW")) !,"To change entries, enter your choices (numbers) separated by a ';', or use",!,"a ':' for ranges. i.e. 2;3 or 1:3. Enter 'A' to enter/edit all.",!
W !,"If there is more than one page to this screen, entering '+' or '-' followed",!,"by the number of pages or entering 'P' followed by the page number will",!,"take you to the desired page."
W !!,"Enter '^' to quit, or '^^' to return to the menu options."
R !!,"Press <RET> to continue ",Q("QUESTION"):DTIME I Q("QUESTION")["?" W !!,"Forget it." H 2
S Q7="?" Q
RET ; pause for display
I ($D(DR(1,130))&($E(DR,$L(DR)-6,$L(DR)-4)="27T"))!($D(DR(1,130.16))&($E(DR,$L(DR)-5,$L(DR)-4)="3T")) W Q("NOR"),!!,"Press <RET> to continue " R Q8:DTIME
Q
ICD I $G(DIE)["^SRF(" D
. N SRALAN,SRALAN1,SRALAN2
.I DIE'="^SRF(",$G(DR) I $P($G(^DD(+Q("0","2"),+DR,0)),U,2)["P80" S DR=+DR_$G(^DD(+Q("0","2"),+DR,.1))_" "_$G(SRICDV)_";Q;"
. I DIE="^SRF(",$G(DR) F SRALAN=1:2 S SRALAN1=$P(DR,";",SRALAN,SRALAN+1) Q:SRALAN1="" D
.. I $P($G(^DD(130,+SRALAN1,0)),U,2)["P80" D
... S (SRALAN2,SRALAN2(1,130))=+SRALAN1_$G(^DD(130,+SRALAN1,.1))_" "_$G(SRICDV)_";Q"
... S $P(DR,";",SRALAN,SRALAN+1)=SRALAN2
... S $P(DR(1,130),";",SRALAN,SRALAN+1)=SRALAN2
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSRCUSS1 4532 printed Nov 22, 2024@17:49:06 Page 2
SRCUSS1 ;TAMPA/CFB - SCREEN SERVER ; [ 03/11/02 13:40 PM ]
+1 ;;3.0;Surgery;**14,31,48,66,108,177**;24 Jun 93;Build 89
B if Q(13)=2
GOTO BQ
if $DATA(Q("X"))
QUIT
SET DR=""
if 'Q("ED")
WRITE !!
IF Q(1)="Q"
SET Q(1)=""
QUIT
+1 IF '$DATA(Q(12,12))
IF Q(1,Q)=3
IF Q(7)["(MULTIPLE)"
SET Q7=1
GOTO BP2
+2 IF Q=1
IF $DATA(Q3("DIVE"))
SET Q7=$PIECE(Q3("DIVE"),"P",2)
KILL Q3("DIVE")
GOTO BP10
BP1 SET DX=1
SET DY=22
if Q("ED")
XECUTE Q("XY")
IF $DATA(Q3("VIEW"))
SET Q3("VIEW")=""
+1 KILL QPQPQ
WRITE "Enter Screen Server Function: "
READ Q7:DTIME
if '$TEST
SET Q7="^^"
IF Q7?.N
if $LENGTH(Q7)>2
SET Q7="?"
if Q7>15
SET Q7="?"
+2 if Q7="a"
SET Q7="A"
if $EXTRACT(Q7)="p"
SET Q7="P"_$EXTRACT(Q7,2,99)
+3 if $LENGTH(Q7)&("^-+123456789AP"'[$EXTRACT(Q7))
SET Q7="?"
if $PIECE(Q7,"
SET Q7="?"
if Q7?.E1C.E
SET Q7="?"
+4 IF Q7[";"
FOR Q8=2:1
SET QQ=$PIECE(Q7,";",Q8)
if "123456789"'[$EXTRACT(QQ)
SET Q7="?"
if 'QQ
QUIT
+5 IF Q7["?"
DO QUES
GOTO BP2
+6 KILL SRCUSS("OUT")
+7 IF Q7'?.N1";".E
IF (Q7'?.N)
IF (Q7'?.N1":".E)
IF (Q7'="A")
IF ("^^"'[Q7)
IF (Q7'?1"+".N)
IF (Q7'?1"-".N)
IF (Q7'?1"P"1N.N)
DO QUES
GOTO BP2
+8 WRITE Q("LO")
BP10 IF Q7="A"
SET Q7="1:"_(Q(1,Q)-1)
+1 if $SELECT(Q7="^^"
SET Q(12,4)=$EXTRACT(Q7,2,99)
SET Q(13)=1
if ((Q7=""&('$DATA(Q0(Q,Q0(0,Q)+1))))!(Q7[U))
GOTO BQ
+2 IF $EXTRACT(Q7)="P"
IF $LENGTH(Q7)>1
IF ('+$EXTRACT(Q7,2,99)!('$DATA(Q0(Q,+$EXTRACT(Q7,2,99)))))
DO QUES
GOTO BP2
+3 IF $EXTRACT(Q7)="P"
IF $LENGTH(Q7)>1
IF +$EXTRACT(Q7,2,99)
SET Q0(0,Q)=$EXTRACT(Q7,2,99)
SET Q(1,Q)=1
XECUTE Q(0)
GOTO A^SRCUSS
+4 if Q7=""
SET Q7="+1"
IF $EXTRACT(Q7,1)="+"
SET Q0(0,Q)=Q0(0,Q)+Q7
SET Q(1,Q)=1
if '$DATA(Q0(Q,Q0(0,Q)))
GOTO BQ
XECUTE Q(0)
GOTO A^SRCUSS
+5 KILL Q(12,12)
IF $EXTRACT(Q7,1)="-"
if Q7="-"
SET Q7="-1"
SET Q0(0,Q)=$SELECT(Q0(0,Q)+Q7<2:1,1:Q0(0,Q)+Q7)
SET Q(1,Q)=1
XECUTE Q(0)
GOTO A^SRCUSS
BP2 SET (Q2(Q),DR)=""
FOR Q8=1:1
SET Q6=$PIECE(Q7,";",Q8)
if Q6["
DO BCOM
if Q6=""!(Q6'=+Q6)
QUIT
IF $PIECE(Q0(Q,Q0(0,Q)),";",Q6+1)'=""
DO BM
+1 if $DATA(Q("S",Q,Q0(0,Q),Q(1,Q)))
SET DIC("S")=Q("S",Q,Q0(0,Q),Q(1,Q))
DO CNG
KILL DIC("S")
SET @("Q(7)=$D("_Q(8,Q)_Q(9,Q)_",0))")
IF 'Q(7)
GOTO BQ
+2 IF Q2(Q)=""
IF Q("ED")
XECUTE ^TMP("SRCUSS",$JOB,^TMP("SRCUSS",$JOB,0),1)
XECUTE ^(2)
WRITE !,Q("EPE")
GOTO B
+3 SET QPQPQ=1
SET Q(1,Q)=1
FOR EMILY=1:1
SET Q2(Q,1)=+$PIECE(Q2(Q),U,1)
SET Q2(Q)=$PIECE(Q2(Q),U,2,99)
if Q2(Q,1)<1
QUIT
SET Q(3)=Q(2,Q,Q2(Q,1))
DO M^SRCUSS0
SET Q(1,Q)=1
+4 if $SELECT('$DATA(Q(12,4))
XECUTE Q(0)
GOTO A^SRCUSS
BCOM SET Q(12,2)=+$PIECE(Q6,":",2)
SET Q6=+Q6
SET Q(12,1)=0
if Q(12,2)'>Q6
QUIT
FOR Q(12,0)=Q6:1:Q(12,2)
SET Q7=$SELECT(Q(12,1)+Q8>1:$PIECE(Q7,";",1,Q8+Q(12,1)-1)_";",1:"")_Q(12,0)_";"_$PIECE(Q7,";",Q(12,1)+Q8+$SELECT(Q(12,1)=0:1,1:0),99)
SET Q(12,1)=Q(12,1)+1
+1 QUIT
BM IF $DATA(Q(2,Q,Q6))
IF $PIECE(@("^DD("_+$PIECE(Q(2,Q,Q6),U,2)_",.01,0)"),U,2)'["W"
SET Q2(Q)=Q2(Q)_Q6_U
QUIT
+1 IF $DATA(Q(2,Q,Q6))
IF $PIECE(@("^DD("_+$PIECE(Q(2,Q,Q6),U,2)_",.01,0)"),U,2)["W"
IF $DATA(Q3("VIEW"))
SET Q3("VIEW")=Q3("VIEW")_$PIECE($PIECE(Q(2,Q,Q6),U,4),";",1)_";"
+2 SET DR=DR_$PIECE(Q0(Q,Q0(0,Q)),";",Q6+1)_";Q;"
QUIT
BQ ;WITH NEW K:Q=1 Q
if Q=1
WRITE @IOF
if $DATA(Q("NOR"))
WRITE Q("NOR")
if $DATA(Q0(0,Q))
KILL Q("S",Q,Q0(0,Q))
if Q=1
KILL Q,Q0,Q1,DE,DP,DQ,Q2,Q3,Q4,Q5,Q6,Q7,Q8,QQ,QQQ,DX,DY,SRCUSS
KILL ^TMP("SRCUSS",$JOB)
QUIT
CNG WRITE Q("HI")
SET (DIE,DIC)=Q(8,Q)
SET DA=Q(9,Q)
IF $DATA(Q3("VIEW"))
if Q3("VIEW")=""
QUIT
SET DR=Q3("VIEW")
DO EN^DIQ
READ !!,"Press <RET> to continue ",Q8:DTIME
QUIT
+1 IF $DATA(Q("S",Q,"IX"))
DO IX
QUIT
+2 IF 'Q("ED")
DO SET
DO ICD
+3 IF 'Q("ED")
DO ^DIE
SET SRCUSS("OUT")=1
DO RET
QUIT
+4 GOTO ^SRCUSS2
ID if '$DATA(^DD(+Q(4)))
QUIT
if ('(+Q(4)\1=80!(+Q(4)=45.3)))&'($PIECE(^DD(+Q(4),.01,0),U,2)["N"&($DATA(^DD(+Q(4),0,"ID"))))
QUIT
SET Q(11)=$ORDER(@("^DD("_$SELECT(+Q(4)'="":+Q(4),1:+Q(0,Q))_",0,""ID"","_Q(11)_")"))
if Q(11)=""
QUIT
IF ^(Q(11))["^(""0"")"
SET Q(11)=^(Q(11))
QUIT
+1 GOTO ID
IX XECUTE Q("S",Q,"IX")
if Q6<1
QUIT
SET DR=".01///"_$PIECE(Q6,U,2)
DO ^DIE
DO SET
QUIT
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
QUES ;
+1 if '$DATA(Q3("VIEW"))
WRITE !,"To change entries, enter your choices (numbers) separated by a ';', or use",!,"a ':' for ranges. i.e. 2;3 or 1:3. Enter 'A' to enter/edit all.",!
+2 WRITE !,"If there is more than one page to this screen, entering '+' or '-' followed",!,"by the number of pages or entering 'P' followed by the page number will",!,"take you to the desired page."
+3 WRITE !!,"Enter '^' to quit, or '^^' to return to the menu options."
+4 READ !!,"Press <RET> to continue ",Q("QUESTION"):DTIME
IF Q("QUESTION")["?"
WRITE !!,"Forget it."
HANG 2
+5 SET Q7="?"
QUIT
RET ; pause for display
+1 IF ($DATA(DR(1,130))&($EXTRACT(DR,$LENGTH(DR)-6,$LENGTH(DR)-4)="27T"))!($DATA(DR(1,130.16))&($EXTRACT(DR,$LENGTH(DR)-5,$LENGTH(DR)-4)="3T"))
WRITE Q("NOR"),!!,"Press <RET> to continue "
READ Q8:DTIME
+2 QUIT
ICD IF $GET(DIE)["^SRF("
Begin DoDot:1
+1 NEW SRALAN,SRALAN1,SRALAN2
+2 IF DIE'="^SRF("
IF $GET(DR)
IF $PIECE($GET(^DD(+Q("0","2"),+DR,0)),U,2)["P80"
SET DR=+DR_$GET(^DD(+Q("0","2"),+DR,.1))_" "_$GET(SRICDV)_";Q;"
+3 IF DIE="^SRF("
IF $GET(DR)
FOR SRALAN=1:2
SET SRALAN1=$PIECE(DR,";",SRALAN,SRALAN+1)
if SRALAN1=""
QUIT
Begin DoDot:2
+4 IF $PIECE($GET(^DD(130,+SRALAN1,0)),U,2)["P80"
Begin DoDot:3
+5 SET (SRALAN2,SRALAN2(1,130))=+SRALAN1_$GET(^DD(130,+SRALAN1,.1))_" "_$GET(SRICDV)_";Q"
+6 SET $PIECE(DR,";",SRALAN,SRALAN+1)=SRALAN2
+7 SET $PIECE(DR(1,130),";",SRALAN,SRALAN+1)=SRALAN2
End DoDot:3
End DoDot:2
End DoDot:1
+8 QUIT
