SRCUSS3.m

SRCUSS3 ;TAMPA/CFB - SCREEN SERVER ; 9 Jan 1989  7:35 AM;

 ;;3.0; Surgery ;;24 Jun 93

1 S X="IOINHI;IOINLOW;IORVON;IORVOFF;IOEDEOP;IOELEOL" D ENDR^%ZISS

 K Q S Q("TEM")=1,(Q,Q(1,1),Q0(0,1),Q("ED"))=1,Q(1,2)=0,Q(0,1)=$P(Q1,";",2) G BQ^SRCUSS1:'$D(^DIC(Q(0,1),0,"GL")) S Q(8,1)=^DIC(Q(0,1),0,"GL")

 S:'$D(Q3(Q)) @("Q3(Q)=$P("_Q(8,1)_"0),U,1)") S:$P(Q6,U,2)'="" Q3(Q)=$E(Q3(Q)_"  ("_$P(Q6,U,2)_")",1,60) S (DA(1),Q(9,1))=DA,Q(8)=DA,Q(1)=""

 S Q(12,5)=Q7 D PAGE^SRCUSS4

 S Q("HI")=IOINHI,Q("LO")=IOINLOW

 I Q("ED") S Q(7)=IOST(0)

 I $T,+Q(7),IOBS'="",IOXY'="",IORVON'="",IORVOFF'="",IOEDEOP'=""

 I  S Q("BC")=IOBS,Q("XY")=IOXY_" "_^%ZOSF("XY"),Q("REV")=IORVON,Q("NOR")=IORVOFF,Q("EPE")=IOEDEOP

 I $T,IOELEOL'="" S Q("EOL")=IOELEOL

 I $T,'$D(Q3("VIEW")),$S('$D(Q3("FORMAT")):1,'Q3("FORMAT"):0,1:1) S:'$D(Q3("FORMAT")) Q3("FORMAT")=0 S Q("Q")=0 I Q3("FORMAT")

 E  S Q("ED")=0,Q("XY")="Q",(Q("REV"),Q("EPE"),Q("EOL"))="*0" S:'$D(Q("NOR")) Q("NOR")="*0"

 D KILL^%ZISS

 S Q(0)="K:'$D(Q(""SC"")) ^TMP(""SRCUSS"",$J) W @IOF S DY=1,DX=1 X Q(""XY"") F Q(0,""I"")=1:1:Q W Q(""HI""),?(8+(Q(0,""I"")*2)),Q3(Q(0,""I"")),Q(""LO"") W:Q(0,""I"")=1 Q(""HI""),?65,Q(""LO""),""PAGE "",Q0(0,Q) X Q(0,0) W !"

 S Q(0,0)="W:Q(0,""I"")=1&$D(Q(""P"",Q)) "" OF "",Q(""P"",Q)"

 S Q(13)=1 D RT X Q(0) Q

IX X Q("S",Q,"IX") Q

START ;

 S:'$D(Q6) Q6="" I '$D(DA) W @IOF K DIC("V") D ^DIC K DIC("S") Q:Y<1  S DA=+Y I '$D(DIE)#2 S DIE=DIC

 I DIE'?1N.PN,$D(@(DIE_"0)")) S DIE=+$P(^(0),"^",2)

 I '$D(^DD(DIE)) W "  ?" Q

 S Q1=";"_DIE_";"_DR,Q7="DR" Q

STOP S Q6=$S($D(Y)#2:Y,1:"") S:'$D(DIE) DIE=DIC I $E(DR)="[" S Q(1)=$E(DR,2,99),Q(1)=$P(Q(1),"]",1) I $O(^DIE("B",Q(1),0))>0 S Q(0)="^DIE("_($O(^(0)))_","

 E  S Q(0)="DR(",Q1=DIE_";"_DR

 S Q(2)=1,Q(4,1)="",Q(3,Q(2))="Q(4,1)"

2 S Q(4,Q(2))=$O(@(Q(0)_Q(3,Q(2))_")")) G 3:Q(4,Q(2))="" S Q(5)=$D(@(Q(0)_Q(3,Q(2))_")")) Q:Q(4,1)=""

 I Q(5)#2,@(Q(0)_Q(3,Q(2))_")")["S Y=" S Q("DIE")="" Q

 I $O(@(Q(0)_Q(3,Q(2))_","""")"))'="" S Q(2)=Q(2)+1,Q(4,Q(2))="",Q(3,Q(2))=Q(3,Q(2)-1)_",Q(4,"_Q(2)_")"

 G 2

3 S Q(2)=Q(2)-1 Q:Q(2)=0  G 2

 Q

OUTED ;

 S ^TMP("SRCUSS",$J,Q(1,Q)-1,1)="S DY=$S($D(^TMP(""SRCUSS"",$J,"_(Q(1,Q)-1)_",0)):$P(^(0),U,1),1:$Y),DX=1 X Q(""XY"") W !,Q(""HI""),"_(Q(1,Q)-1)_",?6,Q(""LO""),"_$C(34)_$P(Q(3),U,1)_$C(34)_","": "",?30"

 S:'$D(^TMP("SRCUSS",$J,Q(1,Q)-1,2)) ^TMP("SRCUSS",$J,0)=Q(1,Q)-1

 I $D(Q(11)) K:'$D(Q(10)) Q(11)

 S ^TMP("SRCUSS",$J,Q(1,Q)-1,2)="S DX=$P(^(0),U,2),DY=+^(0)+1 X Q(""XY"") W Q(""HI"")"_","_$S($E(Q(7),1)=$C(34):$C(34),1:"")_$C(34)_Q(7)_$S($E(Q(7),$L(Q(7)))=$C(34):$C(34),1:"")_$C(34)_",Q(""LO""),Q(""EOL"")"

 W @$P(^TMP("SRCUSS",$J,Q(1,Q)-1,1)," W ",2) S ^(0)=($Y-1)_U_$X X ^(2) Q

RT ; stop RT logging

 I $D(XRT0) S:'$D(XRTN) XRTN="SRCUSS" D T1^%ZOSV

 Q

SRCUSS3   ;TAMPA/CFB - SCREEN SERVER ; 9 Jan 1989  7:35 AM;

 +1       ;;3.0; Surgery ;;24 Jun 93

1          SET X="IOINHI;IOINLOW;IORVON;IORVOFF;IOEDEOP;IOELEOL"

           DO ENDR^%ZISS

 +1        KILL Q

           SET Q("TEM")=1

           SET (Q,Q(1,1),Q0(0,1),Q("ED"))=1

           SET Q(1,2)=0

           SET Q(0,1)=$PIECE(Q1,";",2)

           IF '$DATA(^DIC(Q(0,1),0,"GL"))

               GOTO BQ^SRCUSS1

           SET Q(8,1)=^DIC(Q(0,1),0,"GL")

 +2        IF '$DATA(Q3(Q))

               SET @("Q3(Q)=$P("_Q(8,1)_"0),U,1)")

           IF $PIECE(Q6,U,2)'=""

               SET Q3(Q)=$EXTRACT(Q3(Q)_"  ("_$PIECE(Q6,U,2)_")",1,60)

           SET (DA(1),Q(9,1))=DA

           SET Q(8)=DA

           SET Q(1)=""

 +3        SET Q(12,5)=Q7

           DO PAGE^SRCUSS4

 +4        SET Q("HI")=IOINHI

           SET Q("LO")=IOINLOW

 +5        IF Q("ED")

               SET Q(7)=IOST(0)

 +6        IF $TEST

               IF +Q(7)

                   IF IOBS'=""

                       IF IOXY'=""

                           IF IORVON'=""

                               IF IORVOFF'=""

                                   IF IOEDEOP'=""

 +7       IF $TEST

               SET Q("BC")=IOBS

               SET Q("XY")=IOXY_" "_^%ZOSF("XY")

               SET Q("REV")=IORVON

               SET Q("NOR")=IORVOFF

               SET Q("EPE")=IOEDEOP

 +8        IF $TEST

               IF IOELEOL'=""

                   SET Q("EOL")=IOELEOL

 +9        IF $TEST

               IF '$DATA(Q3("VIEW"))

                   IF $SELECT('$DATA(Q3("FORMAT")):1,'Q3("FORMAT"):0,1:1)

                       IF '$DATA(Q3("FORMAT"))

                           SET Q3("FORMAT")=0

                       SET Q("Q")=0

                       IF Q3("FORMAT")

 +10      IF '$TEST

               SET Q("ED")=0

               SET Q("XY")="Q"

               SET (Q("REV"),Q("EPE"),Q("EOL"))="*0"

               IF '$DATA(Q("NOR"))

                   SET Q("NOR")="*0"

 +11       DO KILL^%ZISS

 +12       SET Q(0)="K:'$D(Q(""SC"")) ^TMP(""SRCUSS"",$J) W @IOF S DY=1,DX=1 X Q(""XY"") F Q(0,""I"")=1:1:Q W Q(""HI""),?(8+(Q(0,""I"")*2)),Q3(Q(0,""I"")),Q(""LO"") W:Q(0,""I"")=1 Q(""HI""),?65,Q(""LO""),""PAGE "",Q0(0,Q) X Q(0,0) W !"

 +13       SET Q(0,0)="W:Q(0,""I"")=1&$D(Q(""P"",Q)) "" OF "",Q(""P"",Q)"

 +14       SET Q(13)=1

           DO RT

           XECUTE Q(0)

           QUIT 

IX         XECUTE Q("S",Q,"IX")

           QUIT 

START     ;

 +1        IF '$DATA(Q6)

               SET Q6=""

           IF '$DATA(DA)

               WRITE @IOF

               KILL DIC("V")

               DO ^DIC

               KILL DIC("S")

               IF Y<1

                   QUIT 

               SET DA=+Y

               IF '$DATA(DIE)#2

                   SET DIE=DIC

 +2        IF DIE'?1N.PN

               IF $DATA(@(DIE_"0)"))

                   SET DIE=+$PIECE(^(0),"^",2)

 +3        IF '$DATA(^DD(DIE))

               WRITE "  ?"

               QUIT 

 +4        SET Q1=";"_DIE_";"_DR

           SET Q7="DR"

           QUIT 

STOP       SET Q6=$SELECT($DATA(Y)#2:Y,1:"")

           IF '$DATA(DIE)

               SET DIE=DIC

           IF $EXTRACT(DR)="["

               SET Q(1)=$EXTRACT(DR,2,99)

               SET Q(1)=$PIECE(Q(1),"]",1)

               IF $ORDER(^DIE("B",Q(1),0))>0

                   SET Q(0)="^DIE("_($ORDER(^(0)))_","

 +1       IF '$TEST

               SET Q(0)="DR("

               SET Q1=DIE_";"_DR

 +2        SET Q(2)=1

           SET Q(4,1)=""

           SET Q(3,Q(2))="Q(4,1)"

2          SET Q(4,Q(2))=$ORDER(@(Q(0)_Q(3,Q(2))_")"))

           IF Q(4,Q(2))=""

               GOTO 3

           SET Q(5)=$DATA(@(Q(0)_Q(3,Q(2))_")"))

           IF Q(4,1)=""

               QUIT 

 +1        IF Q(5)#2

               IF @(Q(0)_Q(3,Q(2))_")")["S Y="

                   SET Q("DIE")=""

                   QUIT 

 +2        IF $ORDER(@(Q(0)_Q(3,Q(2))_","""")"))'=""

               SET Q(2)=Q(2)+1

               SET Q(4,Q(2))=""

               SET Q(3,Q(2))=Q(3,Q(2)-1)_",Q(4,"_Q(2)_")"

 +3        GOTO 2

3          SET Q(2)=Q(2)-1

           IF Q(2)=0

               QUIT 

           GOTO 2

 +1        QUIT 

OUTED     ;

 +1        SET ^TMP("SRCUSS",$JOB,Q(1,Q)-1,1)="S DY=$S($D(^TMP(""SRCUSS"",$J,"_(Q(1,Q)-1)_",0)):$P(^(0),U,1),1:$Y),DX=1 X Q(""XY"") W !,Q(""HI""),"_(Q(1,Q)-1)_",?6,Q(""LO""),"_$CHAR(34)_$PIECE(Q(3),U,1)_$CHAR(34)_","": "",?30"

 +2        IF '$DATA(^TMP("SRCUSS",$JOB,Q(1,Q)-1,2))

               SET ^TMP("SRCUSS",$JOB,0)=Q(1,Q)-1

 +3        IF $DATA(Q(11))

               IF '$DATA(Q(10))

                   KILL Q(11)

 +4       SET ^TMP("SRCUSS",$JOB,Q(1,Q)-1,2)="S DX=$P(^(0),U,2),DY=+^(0)+1 X Q(""XY"") W Q(""HI"")"_","_$SELECT($EXTRACT(Q(7),1)=$CHAR(34):$CHAR(34),1:"")_$CHAR(34)_Q(7)_$SELECT($EXTRACT(Q(7),$LENGTH(Q(7)))=$CHAR(34):...

           ... $CHAR(34),1:"")_$CHAR(34)_",Q(""LO""),Q(""EOL"")"

 +5        WRITE @$PIECE(^TMP("SRCUSS",$JOB,Q(1,Q)-1,1)," W ",2)

           SET ^(0)=($Y-1)_U_$X

           XECUTE ^(2)

           QUIT 

RT        ; stop RT logging

 +1        IF $DATA(XRT0)

               IF '$DATA(XRTN)

                   SET XRTN="SRCUSS"

               DO T1^%ZOSV

 +2        QUIT