SRCUSS ;TAMPA/CFB - SCREEN SERVER ;27 Sep 2013 1:22 PM
;;3.0;Surgery;**66,108,177**;24 Jun 93;Build 89
;
; Reference to $$CSI^ICDEX supported by DBIA #5747
; Reference to $$CODEN^ICDEX supported by DBIA #5747
;
K ^TMP("SRCUSS",$J)
S SRCUSS("OUT")=1
I '$D(IOF) S IOP="" D ^%ZIS K IOP
S Q=1 I '$D(Q1) K Q D STOP^SRCUSS3 I $D(Q("DIE")) S Q=1 D BQ^SRCUSS1 S SRCUSS("SRCUSS")="" D ^DIE K SRCUSS("SRCUSS"),Q5 Q
0 S SRCUSS("SRCUSS")="" D START^SRCUSS3
1 S IOP="" D DT^DICRW:'$D(DT),^%ZIS K IOP D 1^SRCUSS3 I $D(Q("Q")) G:Q("Q") BQ^SRCUSS1 K Q("Q")
A S QPQPQ=1,SRCUSS("OUT")=1 K Q("S",Q,Q0(0,Q),Q(1,Q)+1) X:$S('$D(Q(12,4)):0,Q[Q(12,4):1,1:0) Q(0) K:$S('$D(Q(12,4)):0,Q(12,4)=Q:1,1:0) Q(12,4) G BQ^SRCUSS1:$D(Q(12,4))
I Q=1,$D(Q3("DIVE")),+Q3("DIVE")>1 S Q0(0,Q)=+Q3("DIVE"),Q3("DIVE")="P"_$P(Q3("DIVE"),"P",2) X Q(0)
S Q(1,Q)=Q(1,Q)+1,Q(13)=Q(13)+1 G:$D(Q(10,Q))&(Q(1,Q)>2) A1 S Q(2)=$P(Q0(Q,Q0(0,Q)),";",Q(1,Q)) G B^SRCUSS1:Q(2)="",X:Q(2)?1U.E
I Q("ED"),$D(Q("X")),Q("X"),(Q("X")+2=Q(1,Q)) S Q8=$O(^TMP("SRCUSS",$J,Q("X"))) Q:Q8="" S Q8=$P(^(Q("X"),0),U,1)-$Y+1 G:Q8 ED1^SRCUSS2 Q
S Q(2)=+Q(2),Q7="^DD("_+Q(0,Q)_",Q(2),0)" G:'$D(@(Q7)) A I $D(@(Q7)) X:$D(^(12.1)) ^(12.1) S:$D(DIC("S")) Q("S",Q,Q0(0,Q),Q(1,Q))=DIC("S") K DIC("S") S Q(3)=@(Q7),Q(4)=$P(Q(3),U,2),Q(1)="" K Q(11)
A0 I "IMRQ*"[$E(Q(4),1) S Q(4)=$E(Q(4),2,99) S:$E(Q(4))="X"!($E(Q(4))="O") Q(4)="F"_Q(4) S:Q(4)="" Q(4)="F" G A0
S Q("O")=Q(4),Q(5)=$E(Q(4),1) S:Q(5)="" Q(5)="F" G:Q(5)="C" C S:Q(5)'?1N Q(4)=$E(Q(4),2,99) S Q(6)=$P(Q(3),U,4),Q3="(WORD PROCESSING)" K Q(2,Q,Q(1,Q)-1)
I Q(5)="D",$E(Q(4),1)="C" G C
I Q(5)?1N S Q(5)=@("^DD("_+Q(4)_",.01,0)"),Q(7)=$S($P(Q(5),U,2)["W":Q3,1:"(MULTIPLE)"),Q(7)=$S($O(@(Q(8,Q)_Q(9,Q)_","_$C(34)_$P(Q(6),";",1)_$C(34)_",0)"))>0:Q(7)_"(DATA)",1:Q(7)),Q(2,Q,Q(1,Q)-1)=Q(3) D OUT:'$D(Q3("DIVE")) G A2
A1 I '$D(Q(11)) S Q(11)=-1 D:Q(5)="P" ID^SRCUSS1 K:Q(11)=-1!(Q(11)="") Q(11)
S Q(7)=$P(Q(6),";",1),Q(7)=$C(34)_Q(7)_$C(34),Q(7)=$S($D(@(Q(8,Q)_Q(9,Q)_","_Q(7)_")"))#2:$P(@("^("_Q(7)_")"),U,$P(Q(6),";",2)),1:"") D @Q(5):'$D(Q3("DIVE"))
K SHEMP F MOE=2:1:8 S PIECE=$P(Q(7),";",MOE) I PIECE?1U.E S SHEMP=1
I $D(SHEMP) S Q(7)=$P(Q(7),";")
K SHEMP,MOE,PIECE
A2 Q:$D(Q(10,Q)) G A
C D:+Q V X $P(Q(3),U,5,999) S Q(7)=X Q:'+Q D D:Q(5)="D",OUT:Q(5)'="D" G A
COM S Q7=$O(@("^DD("_+Q(0,Q)_","_Q7_")")) S:Q7'?1NP.NP!(Q7="") Q8=1 Q:Q8!(Q7=+Q(12,2)) S:$E($P(^(Q7,0),U,2),1)'="C" Q(12,0)=Q(12,0)_Q7_";" Q
D G:Q(7)="" OUT S Q6=Q(7),Q(7)="" I $E(Q6,4,5)'="00" S Q(7)=$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Q6,4,5))_" "
I $E(Q6,6,7)'="00" S Q(7)=Q(7)_$E(Q6,6,7)_", "
K Q7 S Q7=$P(Q6,".",2) S:$L(Q7)=1 Q7=Q7_"0" S:Q7 Q7=$E(Q7,1,2)_":"_$E(Q7,3,4) S Q7=$S($L(Q7)=3:Q7_"00",$L(Q7)=4:Q7_"0",1:Q7) I Q7="" K Q7
S Q6=Q6\10000+1700,Q(7)=Q(7)_Q6 S:$D(Q7) Q(7)=Q(7)_" AT "_Q7 G OUT
DIE K Q D STOP^SRCUSS3 G:$D(Q("DIE")) DIED S %X="DR(",%Y="Q5(",Q5=DR D %XY^%RCR S Q=$O(DR(1,-1)) S:$E(DR,1,5)="S:DIA" (DR,DR(1,Q))=$P(DR,";",2,999) S @("Q6=$P("_DIE_DA_",0),U,1)"),Q6=DA_U_Q6
D 0 S:$D(Q5)#2 DR=Q5 I $D(Q5)>9 S %X="Q5(",%Y="DR(" D %XY^%RCR
K Q5 Q
DIED ; K Q S SRCUSS("SRCUSS")="" D GO^DIE K SRCUSS Q
Q
EN1 ;N
S Q7="Q1",Q6=Y G 1
F G OUT
N G OUT
OUT ;
; JAS - 3/18/14 - PATCH 177 - Added next line for display issues.
N SRDXHLD I $P(Q(3),U,2)["P80" S SRDXHLD=Q(7)
Q:$D(Q("BP")) D:$D(Q("O")) XO:Q("O")["O" G:Q("ED")&('$D(Q(10))) OUTED^SRCUSS3
; RBD/JAS - 3/11/14 - PATCH 177 - Code set labeling issue fixed
;N SRICDV2 I $P(Q(3),U,2)["P80",$G(Q(7))'="" D
N SRICDV2 I $P(Q(3),U,2)["P80" D
. S SRICDV2=$$ICDSTR^SROICD(Q(8))
. I SRICDV2'=$G(SRICDV) S SRICDV=SRICDV2
; End 177
W Q("HI"),!,Q(1,Q)-1,?5,Q("LO"),$P(Q(3),U,1),$S($P(Q(3),U,2)["P80":" "_$G(SRICDV),1:""),": ",?30 I $D(Q(11)) K:'$D(Q(10)) Q(11)
; -- line below writes the value in the field
; JAS - 3/11/14 - PATCH 177 - Add logic to display codeset versioning issues
I $P(Q(3),U,2)'["P80" W Q("HI"),?30,Q(7),Q("LO") Q
I Q(7)["Invalid" W Q("HI"),?30,SRDXHLD," - ",Q(7) K SRDXHLD Q
W Q("HI"),?30,Q(7)
N SRDXOUT S SRDXOUT=$$OUT^SROICD(Q(7))
I SRDXOUT["Invalid" W " - "_SRDXOUT
K SRDXOUT,SRDXHLD
W Q("LO") Q
; End 177
P S Q8=Q(3) K:Q(7)="" Q(11) G:Q(7)="" OUT I $D(Q(11)),$D(@(U_$P(Q(3),U,3)_Q(7)_",0)")) S @("Q(7)=$P"_$P(Q(11),"$P",2)) G OUT
P1 S Q7=U_$P(Q8,U,3),@("Q1=$D("_Q7_"Q("_7_")))"),Q(7)=$S(Q1:$P(^(Q(7),0),U,1),1:Q(7)),@("Q8=^DD("_+$P(@(Q7_"0)"),U,2)_",.01,0)") G P1:$P(Q8,U,2)["P"&(Q1),OUT
S G:Q(7)="" OUT S Q7=$P(Q(3),U,3) F Q8=1:1 Q:Q(7)=$P($P(Q7,";",Q8),":",1) Q:Q8=50
G:Q8=50 OUT S Q(7)=$P($P(Q7,";",Q8),":",2) G OUT
V F Q(4)=0:1 Q:'$D(Q(9,Q(4)+1)) Q:'+Q(9,Q(4)+1) S @("D"_Q(4)_"="_Q(9,Q(4)+1))
S DA=Q(9,Q) Q
X X Q(2) G A
Q
XO Q:Q(7)="" D:+Q V S:$D(Y)#2 Q6(1)=Y S Y=Q(7) X @("^DD("_+Q(0,Q)_","_Q(2)_",2)") S Q(7)=Y S:$D(Q6(1)) Y=Q6(1) K Q6(1) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSRCUSS 4822 printed Oct 16, 2024@18:39:45 Page 2
SRCUSS ;TAMPA/CFB - SCREEN SERVER ;27 Sep 2013 1:22 PM
+1 ;;3.0;Surgery;**66,108,177**;24 Jun 93;Build 89
+2 ;
+3 ; Reference to $$CSI^ICDEX supported by DBIA #5747
+4 ; Reference to $$CODEN^ICDEX supported by DBIA #5747
+5 ;
+6 KILL ^TMP("SRCUSS",$JOB)
+7 SET SRCUSS("OUT")=1
+8 IF '$DATA(IOF)
SET IOP=""
DO ^%ZIS
KILL IOP
+9 SET Q=1
IF '$DATA(Q1)
KILL Q
DO STOP^SRCUSS3
IF $DATA(Q("DIE"))
SET Q=1
DO BQ^SRCUSS1
SET SRCUSS("SRCUSS")=""
DO ^DIE
KILL SRCUSS("SRCUSS"),Q5
QUIT
0 SET SRCUSS("SRCUSS")=""
DO START^SRCUSS3
1 SET IOP=""
if '$DATA(DT)
DO DT^DICRW
DO ^%ZIS
KILL IOP
DO 1^SRCUSS3
IF $DATA(Q("Q"))
if Q("Q")
GOTO BQ^SRCUSS1
KILL Q("Q")
A SET QPQPQ=1
SET SRCUSS("OUT")=1
KILL Q("S",Q,Q0(0,Q),Q(1,Q)+1)
if $SELECT('$DATA(Q(12,4))
XECUTE Q(0)
if $SELECT('$DATA(Q(12,4))
KILL Q(12,4)
if $DATA(Q(12,4))
GOTO BQ^SRCUSS1
+1 IF Q=1
IF $DATA(Q3("DIVE"))
IF +Q3("DIVE")>1
SET Q0(0,Q)=+Q3("DIVE")
SET Q3("DIVE")="P"_$PIECE(Q3("DIVE"),"P",2)
XECUTE Q(0)
+2 SET Q(1,Q)=Q(1,Q)+1
SET Q(13)=Q(13)+1
if $DATA(Q(10,Q))&(Q(1,Q)>2)
GOTO A1
SET Q(2)=$PIECE(Q0(Q,Q0(0,Q)),";",Q(1,Q))
if Q(2)=""
GOTO B^SRCUSS1
if Q(2)?1U.E
GOTO X
+3 IF Q("ED")
IF $DATA(Q("X"))
IF Q("X")
IF (Q("X")+2=Q(1,Q))
SET Q8=$ORDER(^TMP("SRCUSS",$JOB,Q("X")))
if Q8=""
QUIT
SET Q8=$PIECE(^(Q("X"),0),U,1)-$Y+1
if Q8
GOTO ED1^SRCUSS2
QUIT
+4 SET Q(2)=+Q(2)
SET Q7="^DD("_+Q(0,Q)_",Q(2),0)"
if '$DATA(@(Q7))
GOTO A
IF $DATA(@(Q7))
if $DATA(^(12.1))
XECUTE ^(12.1)
if $DATA(DIC("S"))
SET Q("S",Q,Q0(0,Q),Q(1,Q))=DIC("S")
KILL DIC("S")
SET Q(3)=@(Q7)
SET Q(4)=$PIECE(Q(3),U,2)
SET Q(1)=""
KILL Q(11)
A0 IF "IMRQ*"[$EXTRACT(Q(4),1)
SET Q(4)=$EXTRACT(Q(4),2,99)
if $EXTRACT(Q(4))="X"!($EXTRACT(Q(4))="O")
SET Q(4)="F"_Q(4)
if Q(4)=""
SET Q(4)="F"
GOTO A0
+1 SET Q("O")=Q(4)
SET Q(5)=$EXTRACT(Q(4),1)
if Q(5)=""
SET Q(5)="F"
if Q(5)="C"
GOTO C
if Q(5)'?1N
SET Q(4)=$EXTRACT(Q(4),2,99)
SET Q(6)=$PIECE(Q(3),U,4)
SET Q3="(WORD PROCESSING)"
KILL Q(2,Q,Q(1,Q)-1)
+2 IF Q(5)="D"
IF $EXTRACT(Q(4),1)="C"
GOTO C
+3 IF Q(5)?1N
SET Q(5)=@("^DD("_+Q(4)_",.01,0)")
SET Q(7)=$SELECT($PIECE(Q(5),U,2)["W":Q3,1:"(MULTIPLE)")
SET Q(7)=$SELECT($ORDER(@(Q(8,Q)_Q(9,Q)_","_$CHAR(34)_$PIECE(Q(6),";",1)_$CHAR(34)_",0)"))>0:Q(7)_"(DATA)",1:Q(7))
SET Q(2,Q,Q(1,Q)-1)=Q(3)
if '$DATA(Q3("DIVE"))
DO OUT
GOTO A2
A1 IF '$DATA(Q(11))
SET Q(11)=-1
if Q(5)="P"
DO ID^SRCUSS1
if Q(11)=-1!(Q(11)="")
KILL Q(11)
+1 SET Q(7)=$PIECE(Q(6),";",1)
SET Q(7)=$CHAR(34)_Q(7)_$CHAR(34)
SET Q(7)=$SELECT($DATA(@(Q(8,Q)_Q(9,Q)_","_Q(7)_")"))#2:$PIECE(@("^("_Q(7)_")"),U,$PIECE(Q(6),";",2)),1:"")
if '$DATA(Q3("DIVE"))
DO @Q(5)
+2 KILL SHEMP
FOR MOE=2:1:8
SET PIECE=$PIECE(Q(7),";",MOE)
IF PIECE?1U.E
SET SHEMP=1
+3 IF $DATA(SHEMP)
SET Q(7)=$PIECE(Q(7),";")
+4 KILL SHEMP,MOE,PIECE
A2 if $DATA(Q(10,Q))
QUIT
GOTO A
C if +Q
DO V
XECUTE $PIECE(Q(3),U,5,999)
SET Q(7)=X
if '+Q
QUIT
if Q(5)="D"
DO D
if Q(5)'="D"
DO OUT
GOTO A
COM SET Q7=$ORDER(@("^DD("_+Q(0,Q)_","_Q7_")"))
if Q7'?1NP.NP!(Q7="")
SET Q8=1
if Q8!(Q7=+Q(12,2))
QUIT
if $EXTRACT($PIECE(^(Q7,0),U,2),1)'="C"
SET Q(12,0)=Q(12,0)_Q7_";"
QUIT
D if Q(7)=""
GOTO OUT
SET Q6=Q(7)
SET Q(7)=""
IF $EXTRACT(Q6,4,5)'="00"
SET Q(7)=$PIECE("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$EXTRACT(Q6,4,5))_" "
+1 IF $EXTRACT(Q6,6,7)'="00"
SET Q(7)=Q(7)_$EXTRACT(Q6,6,7)_", "
+2 KILL Q7
SET Q7=$PIECE(Q6,".",2)
if $LENGTH(Q7)=1
SET Q7=Q7_"0"
if Q7
SET Q7=$EXTRACT(Q7,1,2)_":"_$EXTRACT(Q7,3,4)
SET Q7=$SELECT($LENGTH(Q7)=3:Q7_"00",$LENGTH(Q7)=4:Q7_"0",1:Q7)
IF Q7=""
KILL Q7
+3 SET Q6=Q6\10000+1700
SET Q(7)=Q(7)_Q6
if $DATA(Q7)
SET Q(7)=Q(7)_" AT "_Q7
GOTO OUT
DIE KILL Q
DO STOP^SRCUSS3
if $DATA(Q("DIE"))
GOTO DIED
SET %X="DR("
SET %Y="Q5("
SET Q5=DR
DO %XY^%RCR
SET Q=$ORDER(DR(1,-1))
if $EXTRACT(DR,1,5)="S
SET (DR,DR(1,Q))=$PIECE(DR,";",2,999)
SET @("Q6=$P("_DIE_DA_",0),U,1)")
SET Q6=DA_U_Q6
+1 DO 0
if $DATA(Q5)#2
SET DR=Q5
IF $DATA(Q5)>9
SET %X="Q5("
SET %Y="DR("
DO %XY^%RCR
+2 KILL Q5
QUIT
DIED ; K Q S SRCUSS("SRCUSS")="" D GO^DIE K SRCUSS Q
+1 QUIT
EN1 ;N
+1 SET Q7="Q1"
SET Q6=Y
GOTO 1
F GOTO OUT
N GOTO OUT
OUT ;
+1 ; JAS - 3/18/14 - PATCH 177 - Added next line for display issues.
+2 NEW SRDXHLD
IF $PIECE(Q(3),U,2)["P80"
SET SRDXHLD=Q(7)
+3 if $DATA(Q("BP"))
QUIT
if $DATA(Q("O"))
if Q("O")["O"
DO XO
if Q("ED")&('$DATA(Q(10)))
GOTO OUTED^SRCUSS3
+4 ; RBD/JAS - 3/11/14 - PATCH 177 - Code set labeling issue fixed
+5 ;N SRICDV2 I $P(Q(3),U,2)["P80",$G(Q(7))'="" D
+6 NEW SRICDV2
IF $PIECE(Q(3),U,2)["P80"
Begin DoDot:1
+7 SET SRICDV2=$$ICDSTR^SROICD(Q(8))
+8 IF SRICDV2'=$GET(SRICDV)
SET SRICDV=SRICDV2
End DoDot:1
+9 ; End 177
+10 WRITE Q("HI"),!,Q(1,Q)-1,?5,Q("LO"),$PIECE(Q(3),U,1),$SELECT($PIECE(Q(3),U,2)["P80":" "_$GET(SRICDV),1:""),": ",?30
IF $DATA(Q(11))
if '$DATA(Q(10))
KILL Q(11)
+11 ; -- line below writes the value in the field
+12 ; JAS - 3/11/14 - PATCH 177 - Add logic to display codeset versioning issues
+13 IF $PIECE(Q(3),U,2)'["P80"
WRITE Q("HI"),?30,Q(7),Q("LO")
QUIT
+14 IF Q(7)["Invalid"
WRITE Q("HI"),?30,SRDXHLD," - ",Q(7)
KILL SRDXHLD
QUIT
+15 WRITE Q("HI"),?30,Q(7)
+16 NEW SRDXOUT
SET SRDXOUT=$$OUT^SROICD(Q(7))
+17 IF SRDXOUT["Invalid"
WRITE " - "_SRDXOUT
+18 KILL SRDXOUT,SRDXHLD
+19 WRITE Q("LO")
QUIT
+20 ; End 177
P SET Q8=Q(3)
if Q(7)=""
KILL Q(11)
if Q(7)=""
GOTO OUT
IF $DATA(Q(11))
IF $DATA(@(U_$PIECE(Q(3),U,3)_Q(7)_",0)"))
SET @("Q(7)=$P"_$PIECE(Q(11),"$P",2))
GOTO OUT
P1 SET Q7=U_$PIECE(Q8,U,3)
SET @("Q1=$D("_Q7_"Q("_7_")))")
SET Q(7)=$SELECT(Q1:$PIECE(^(Q(7),0),U,1),1:Q(7))
SET @("Q8=^DD("_+$PIECE(@(Q7_"0)"),U,2)_",.01,0)")
if $PIECE(Q8,U,2)["P"&(Q1)
GOTO P1
GOTO OUT
S if Q(7)=""
GOTO OUT
SET Q7=$PIECE(Q(3),U,3)
FOR Q8=1:1
if Q(7)=$PIECE($PIECE(Q7,";",Q8),"
QUIT
if Q8=50
QUIT
+1 if Q8=50
GOTO OUT
SET Q(7)=$PIECE($PIECE(Q7,";",Q8),":",2)
GOTO OUT
V FOR Q(4)=0:1
if '$DATA(Q(9,Q(4)+1))
QUIT
if '+Q(9,Q(4)+1)
QUIT
SET @("D"_Q(4)_"="_Q(9,Q(4)+1))
+1 SET DA=Q(9,Q)
QUIT
X XECUTE Q(2)
GOTO A
+1 QUIT
XO if Q(7)=""
QUIT
if +Q
DO V
if $DATA(Y)#2
SET Q6(1)=Y
SET Y=Q(7)
XECUTE @("^DD("_+Q(0,Q)_","_Q(2)_",2)")
SET Q(7)=Y
if $DATA(Q6(1))
SET Y=Q6(1)
KILL Q6(1)
QUIT
