- 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 Jan 18, 2025@03:40:16 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