SROPCEX ;BIR/ADM - CROSS REFERENCE LOGIC ; JAN 11,2006
;;3.0;Surgery;**58,62,69,86,119,142,204**;24 Jun 93;Build 3
Q
APCE ; send case data to PCE
N SRCASE,SRDIV,SRCLINIC,SRPDATE,SRQ,SRSITE,SRSR,SRWC,SRX,SRZ S SRQ=0 S:$D(SRTN) SRCASE=SRTN I '$D(SRCASE) S SRCASE=$S($G(DA(1)):DA(1),1:DA)
Q:($P($G(^SRF(SRCASE,30)),"^"))!($P($G(^SRF(SRCASE,37)),"^"))
S SRSR="",SRDIV=$P($G(^SRF(SRCASE,8)),"^") I SRDIV D Q:SRQ
.S SRSITE=$O(^SRO(133,"B",SRDIV,0)),SRWC=$P(^SRO(133,SRSITE,0),"^",15),SRSR=$P(^SRO(133,SRSITE,0),"^",19)
.S SRPDATE=$P(^SRO(133,SRSITE,0),"^",17) I SRPDATE,$P(^SRF(SRCASE,0),"^",9)<SRPDATE S SRQ=1 Q
.I $P(^SRO(133,SRSITE,0),"^",16),'$P(^SRF(SRCASE,0),"^",20) S SRQ=1 Q
.Q:SRWC="A" I "N"[SRWC S SRQ=1 Q
S SRCLINIC=$P(^SRF(SRCASE,0),"^",21)
S SRX=$G(^SRF(SRCASE,"NON")) I $P(SRX,"^")="Y" Q:'$P(SRX,"^",4)!'$P(SRX,"^",5)!'$P(SRX,"^",6)!((SRSR'=0)&('$P(SRX,"^",7))) S:SRCLINIC="" SRCLINIC=$P(SRX,"^",2) Q:SRCLINIC="" Q:'$$CLINIC^SROUTL(SRCLINIC,SRCASE) G SET
I $P(^SRF(SRCASE,0),"^",4),SRCLINIC="" S SRCLINIC=$P(^SRO(137.45,$P(^SRF(SRCASE,0),"^",4),0),"^",5)
I SRCLINIC="",$P(^SRF(SRCASE,0),"^",2) S SRCLINIC=$P(^SRS($P(^SRF(SRCASE,0),"^",2),0),"^")
Q:SRCLINIC="" I '$$CLINIC^SROUTL(SRCLINIC,SRCASE) Q
S SRX=$G(^SRF(SRCASE,.2)) Q:'$P(SRX,"^",10)!'$P(SRX,"^",12)
S SRX=$G(^SRF(SRCASE,.1)) Q:'$P(SRX,"^",4) I SRSR'=0,'$P(SRX,"^",13) Q
Q:SRQ
SET S SRZ=$P($G(^SRO(136,SRCASE,10)),"^") I SRZ S SRTN=SRCASE D
.N DE,DQ,DG,DIFLD ; SR*3.0*204; these are FM variables from the calling routine that must survive the call below:
.D START^SROPCEP
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROPCEX 1590 printed Nov 22, 2024@17:54:57 Page 2
SROPCEX ;BIR/ADM - CROSS REFERENCE LOGIC ; JAN 11,2006
+1 ;;3.0;Surgery;**58,62,69,86,119,142,204**;24 Jun 93;Build 3
+2 QUIT
APCE ; send case data to PCE
+1 NEW SRCASE,SRDIV,SRCLINIC,SRPDATE,SRQ,SRSITE,SRSR,SRWC,SRX,SRZ
SET SRQ=0
if $DATA(SRTN)
SET SRCASE=SRTN
IF '$DATA(SRCASE)
SET SRCASE=$SELECT($GET(DA(1)):DA(1),1:DA)
+2 if ($PIECE($GET(^SRF(SRCASE,30)),"^"))!($PIECE($GET(^SRF(SRCASE,37)),"^"))
QUIT
+3 SET SRSR=""
SET SRDIV=$PIECE($GET(^SRF(SRCASE,8)),"^")
IF SRDIV
Begin DoDot:1
+4 SET SRSITE=$ORDER(^SRO(133,"B",SRDIV,0))
SET SRWC=$PIECE(^SRO(133,SRSITE,0),"^",15)
SET SRSR=$PIECE(^SRO(133,SRSITE,0),"^",19)
+5 SET SRPDATE=$PIECE(^SRO(133,SRSITE,0),"^",17)
IF SRPDATE
IF $PIECE(^SRF(SRCASE,0),"^",9)<SRPDATE
SET SRQ=1
QUIT
+6 IF $PIECE(^SRO(133,SRSITE,0),"^",16)
IF '$PIECE(^SRF(SRCASE,0),"^",20)
SET SRQ=1
QUIT
+7 if SRWC="A"
QUIT
IF "N"[SRWC
SET SRQ=1
QUIT
End DoDot:1
if SRQ
QUIT
+8 SET SRCLINIC=$PIECE(^SRF(SRCASE,0),"^",21)
+9 SET SRX=$GET(^SRF(SRCASE,"NON"))
IF $PIECE(SRX,"^")="Y"
if '$PIECE(SRX,"^",4)!'$PIECE(SRX,"^",5)!'$PIECE(SRX,"^",6)!((SRSR'=0)&('$PIECE(SRX,"^",7)))
QUIT
if SRCLINIC=""
SET SRCLINIC=$PIECE(SRX,"^",2)
if SRCLINIC=""
QUIT
if '$$CLINIC^SROUTL(SRCLINIC,SRCASE)
QUIT
GOTO SET
+10 IF $PIECE(^SRF(SRCASE,0),"^",4)
IF SRCLINIC=""
SET SRCLINIC=$PIECE(^SRO(137.45,$PIECE(^SRF(SRCASE,0),"^",4),0),"^",5)
+11 IF SRCLINIC=""
IF $PIECE(^SRF(SRCASE,0),"^",2)
SET SRCLINIC=$PIECE(^SRS($PIECE(^SRF(SRCASE,0),"^",2),0),"^")
+12 if SRCLINIC=""
QUIT
IF '$$CLINIC^SROUTL(SRCLINIC,SRCASE)
QUIT
+13 SET SRX=$GET(^SRF(SRCASE,.2))
if '$PIECE(SRX,"^",10)!'$PIECE(SRX,"^",12)
QUIT
+14 SET SRX=$GET(^SRF(SRCASE,.1))
if '$PIECE(SRX,"^",4)
QUIT
IF SRSR'=0
IF '$PIECE(SRX,"^",13)
QUIT
+15 if SRQ
QUIT
SET SET SRZ=$PIECE($GET(^SRO(136,SRCASE,10)),"^")
IF SRZ
SET SRTN=SRCASE
Begin DoDot:1
+1 ; SR*3.0*204; these are FM variables from the calling routine that must survive the call below:
NEW DE,DQ,DG,DIFLD
+2 DO START^SROPCEP
End DoDot:1
+3 QUIT
