SRCUSS1.m

SRCUSS1 ;TAMPA/CFB - SCREEN SERVER ; [ 03/11/02  13:40 PM ]

 ;;3.0; Surgery ;**14,31,48,66,108**;24 Jun 93

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

SRCUSS1   ;TAMPA/CFB - SCREEN SERVER ; [ 03/11/02  13:40 PM ]

 +1       ;;3.0; Surgery ;**14,31,48,66,108**;24 Jun 93

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

               SET SRCUSS("OUT")=1

               DO RET

               QUIT 

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