SROCD4 ;BIR/ADM - MARK CASE CODING COMPLETE ;10/17/05
;;3.0;Surgery;**142,177**;24 Jun 93;Build 89
;
; Reference to CL^SDCO21 supported by DBIA #406
;
N SR,SRCL,SRDATA,SRDX,SRK,SRMISS,SROTH,SRSDATE,SRTYPE
S SR(0)=^SRO(136,SRTN,0) S SRSOUT=0,SREDIT=1
I $P(SR(0),"^",2)="" S SRMISS("PRINCIPAL PROCEDURE CODE")=""
I $P(SR(0),"^",3)="" S SRMISS("PRINCIPAL POSTOP DIAGNOSIS CODE")=""
S DFN=$P(^SRF(SRTN,0),"^"),SRSDATE=$P(^SRF(SRTN,0),"^",9) D CL^SDCO21(DFN,SRSDATE,,.SRCL) I $D(SRCL) D PSCEI
I '$O(^SRO(136,SRTN,2,0)) S SRMISS("PRINCIPAL ASSOCIATED DIAGNOSIS")=""
S SROTH=0 F S SROTH=$O(^SRO(136,SRTN,3,SROTH)) Q:'SROTH I '$O(^SRO(136,SRTN,3,SROTH,2,0)) S SRMISS("OTHER ASSOCIATED DIAGNOSIS")="" Q
S SROTH=0 F S SROTH=$O(^SRO(136,SRTN,4,SROTH)) Q:'SROTH I $D(SRCL) S SRDX=^SRO(136,SRTN,4,SROTH,0) D OSCEI
I $D(SRMISS) D MISS Q
I $P($G(^SRO(136,SRTN,10)),"^"),'$$CHNG^SROCD1 D Q
.I '$P(^SRF(SRTN,0),"^",15) D FILE Q
I '$P($G(^SRO(136,SRTN,10)),"^") D D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y Q
.W ! K DIR S DIR("A")="Is the coding of this case complete and ready to send to PCE",DIR("B")="NO",DIR(0)="Y"
FILE D NOW^%DTC S SRNOW=$E(%,1,12) D
.K DA,DIE,DR S DA=SRTN,DIE=136,DR="10////1" D ^DIE K DA,DIE,DR
.K DD,DO S DIC="^SRO(136,SRTN,11,",DIC(0)="L",X=DUZ,DIC("DR")="1////"_SRNOW D FILE^DICN K DA,DD,DIC,DO,DR
.W !!,"Processing data to be sent to PCE..." D CHKIN I SRK D K SRK Q
..W !!,"Information needed to send the case to PCE is missing. Use the PCE"
..W !,"Filing Status Report to review missing information. The case will be"
..W !,"sent to PCE upon completion of the missing information.",! D PAGE
.D START^SROPCEP ; send to PCE
.W !!,"Coding completed and sent to PCE.",! D PAGE
Q
CHKIN ; check for items in file 130 required by PCE
N SR,SRAO,SRATT,SRCHK,SRCPT,SRCV,SRDATE,SRDEPC,SRDIAG,SRDXF,SREC,SRHNC,SRINOUT,SRIR,SRLOC,SRMST,SRNON,SRO,SRODIAG,SRPROV,SRRPROV,SRSC,SRUP,SRX
D UTIL^SROPCEP
Q
MISS W !!,"Coding of this surgical case is not complete.",!,"The following items are missing:",!
S SRDATA="" F S SRDATA=$O(SRMISS(SRDATA)) Q:SRDATA="" W ?5,SRDATA,!
W !,"This case cannot be sent to PCE until all missing information is supplied.",!
PAGE K DIR S DIR(0)="FOA",DIR("A")="Press Enter/Return key to continue " D ^DIR K DIR
Q
PSCEI S SRTYPE="PRINCIPAL"
I $D(SRCL(1)),$P(SR(0),"^",5)="" D SRSET Q
I $D(SRCL(2)),$P(SR(0),"^",6)="" D SRSET Q
I $D(SRCL(3)),$P(SR(0),"^",4)="" D SRSET Q
I $D(SRCL(4)),$P(SR(0),"^",7)="" D SRSET Q
I $D(SRCL(5)),$P(SR(0),"^",8)="" D SRSET Q
I $D(SRCL(6)),$P(SR(0),"^",9)="" D SRSET Q
I $D(SRCL(7)),$P(SR(0),"^",10)="" D SRSET
Q
OSCEI S SRTYPE="OTHER DIAGNOSIS"
I $D(SRCL(1)),$P(SRDX,"^",3)="" D SRSET Q
I $D(SRCL(2)),$P(SRDX,"^",4)="" D SRSET Q
I $D(SRCL(3)),$P(SRDX,"^",2)="" D SRSET Q
I $D(SRCL(4)),$P(SRDX,"^",7)="" D SRSET Q
I $D(SRCL(5)),$P(SRDX,"^",5)="" D SRSET Q
I $D(SRCL(6)),$P(SRDX,"^",6)="" D SRSET Q
I $D(SRCL(7)),$P(SRDX,"^",8)="" D SRSET
Q
SRSET S SRMISS(SRTYPE_" SC/EI")=""
Q
CONV ; convert coding data from file 130 to file 136
I $O(^SRO(136,0)) D MES^XPDUTL("Conversion has already run.") Q
D NITE^SROPCE
C2 N SRCT,SRD,SRODX,SRPDX,SRPP,SROP,SRP,SRTN
D MES^XPDUTL(" Converting coding data from file 130 to file 136...")
S (SRCT,SRTN)=0 F S SRTN=$O(^SRF(SRTN)) Q:'SRTN D
.I '$P($G(^SRF(SRTN,.2)),"^",12)&'$P($G(^SRF(SRTN,"NON")),"^",5) Q
.S SRPP=$P($G(^SRF(SRTN,"OP")),"^",2),(SROP,SRP)=0 F S SRP=$O(^SRF(SRTN,13,SRP)) Q:'SRP I $P($G(^SRF(SRTN,13,SRP,2)),"^") S SROP=1 Q
.S SRPDX=$P($G(^SRF(SRTN,34)),"^",2),(SRODX,SRD)=0 F S SRD=$O(^SRF(SRTN,15,SRD)) Q:'SRD I $P($G(^SRF(SRTN,15,SRD,0)),"^",3) S SRODX=1 Q
.I SRPP!SROP!SRPDX!SRODX D
..Q:$D(^SRO(136,SRTN,0))
..D ^SROCD1 S SRCT=SRCT+1 I '(SRCT#10000) D MES^XPDUTL(SRCT_" cases converted... ")
D MES^XPDUTL("Total cases converted: "_SRCT)
Q
PRE ; pre-install entry
; delete APCE x-refs
K DIE,DR,DIK,DA S DIK="^DD(130.16,3,1,",DA=1,DA(1)=3,DA(2)=130.16 D ^DIK
K DIK,DA S DIK="^DD(130.165,.01,1,",DA=2,DA(1)=.01,DA(2)=130.165 D ^DIK
K DIK,DA S DIK="^DD(130.18,.01,1,",DA=9,DA(1)=.01,DA(2)=130.18 D ^DIK
K DIK,DA S DIK="^DD(130.18,3,1,",DA=1,DA(1)=3,DA(2)=130.18 D ^DIK
K DIK,DA S DIK="^DD(130,27,1,",DA=1,DA(1)=27,DA(2)=130 D ^DIK
K DIK,DA S DIK="^DD(130.275,.01,1,",DA=1,DA(1)=.01,DA(2)=130.275 D ^DIK
K DIK,DA S DIK="^DD(130,32.5,1,",DA=1,DA(1)=32.5,DA(2)=130 D ^DIK
K DIK,DA S DIK="^DD(130,66,1,",DA=1,DA(1)=66,DA(2)=130 D ^DIK K DIK,DA
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROCD4 4503 printed Sep 23, 2025@20:19:04 Page 2
SROCD4 ;BIR/ADM - MARK CASE CODING COMPLETE ;10/17/05
+1 ;;3.0;Surgery;**142,177**;24 Jun 93;Build 89
+2 ;
+3 ; Reference to CL^SDCO21 supported by DBIA #406
+4 ;
+5 NEW SR,SRCL,SRDATA,SRDX,SRK,SRMISS,SROTH,SRSDATE,SRTYPE
+6 SET SR(0)=^SRO(136,SRTN,0)
SET SRSOUT=0
SET SREDIT=1
+7 IF $PIECE(SR(0),"^",2)=""
SET SRMISS("PRINCIPAL PROCEDURE CODE")=""
+8 IF $PIECE(SR(0),"^",3)=""
SET SRMISS("PRINCIPAL POSTOP DIAGNOSIS CODE")=""
+9 SET DFN=$PIECE(^SRF(SRTN,0),"^")
SET SRSDATE=$PIECE(^SRF(SRTN,0),"^",9)
DO CL^SDCO21(DFN,SRSDATE,,.SRCL)
IF $DATA(SRCL)
DO PSCEI
+10 IF '$ORDER(^SRO(136,SRTN,2,0))
SET SRMISS("PRINCIPAL ASSOCIATED DIAGNOSIS")=""
+11 SET SROTH=0
FOR
SET SROTH=$ORDER(^SRO(136,SRTN,3,SROTH))
if 'SROTH
QUIT
IF '$ORDER(^SRO(136,SRTN,3,SROTH,2,0))
SET SRMISS("OTHER ASSOCIATED DIAGNOSIS")=""
QUIT
+12 SET SROTH=0
FOR
SET SROTH=$ORDER(^SRO(136,SRTN,4,SROTH))
if 'SROTH
QUIT
IF $DATA(SRCL)
SET SRDX=^SRO(136,SRTN,4,SROTH,0)
DO OSCEI
+13 IF $DATA(SRMISS)
DO MISS
QUIT
+14 IF $PIECE($GET(^SRO(136,SRTN,10)),"^")
IF '$$CHNG^SROCD1
Begin DoDot:1
+15 IF '$PIECE(^SRF(SRTN,0),"^",15)
DO FILE
QUIT
End DoDot:1
QUIT
+16 IF '$PIECE($GET(^SRO(136,SRTN,10)),"^")
Begin DoDot:1
+17 WRITE !
KILL DIR
SET DIR("A")="Is the coding of this case complete and ready to send to PCE"
SET DIR("B")="NO"
SET DIR(0)="Y"
End DoDot:1
DO ^DIR
KILL DIR
IF $DATA(DTOUT)!$DATA(DUOUT)!'Y
QUIT
FILE DO NOW^%DTC
SET SRNOW=$EXTRACT(%,1,12)
Begin DoDot:1
+1 KILL DA,DIE,DR
SET DA=SRTN
SET DIE=136
SET DR="10////1"
DO ^DIE
KILL DA,DIE,DR
+2 KILL DD,DO
SET DIC="^SRO(136,SRTN,11,"
SET DIC(0)="L"
SET X=DUZ
SET DIC("DR")="1////"_SRNOW
DO FILE^DICN
KILL DA,DD,DIC,DO,DR
+3 WRITE !!,"Processing data to be sent to PCE..."
DO CHKIN
IF SRK
Begin DoDot:2
+4 WRITE !!,"Information needed to send the case to PCE is missing. Use the PCE"
+5 WRITE !,"Filing Status Report to review missing information. The case will be"
+6 WRITE !,"sent to PCE upon completion of the missing information.",!
DO PAGE
End DoDot:2
KILL SRK
QUIT
+7 ; send to PCE
DO START^SROPCEP
+8 WRITE !!,"Coding completed and sent to PCE.",!
DO PAGE
End DoDot:1
+9 QUIT
CHKIN ; check for items in file 130 required by PCE
+1 NEW SR,SRAO,SRATT,SRCHK,SRCPT,SRCV,SRDATE,SRDEPC,SRDIAG,SRDXF,SREC,SRHNC,SRINOUT,SRIR,SRLOC,SRMST,SRNON,SRO,SRODIAG,SRPROV,SRRPROV,SRSC,SRUP,SRX
+2 DO UTIL^SROPCEP
+3 QUIT
MISS WRITE !!,"Coding of this surgical case is not complete.",!,"The following items are missing:",!
+1 SET SRDATA=""
FOR
SET SRDATA=$ORDER(SRMISS(SRDATA))
if SRDATA=""
QUIT
WRITE ?5,SRDATA,!
+2 WRITE !,"This case cannot be sent to PCE until all missing information is supplied.",!
PAGE KILL DIR
SET DIR(0)="FOA"
SET DIR("A")="Press Enter/Return key to continue "
DO ^DIR
KILL DIR
+1 QUIT
PSCEI SET SRTYPE="PRINCIPAL"
+1 IF $DATA(SRCL(1))
IF $PIECE(SR(0),"^",5)=""
DO SRSET
QUIT
+2 IF $DATA(SRCL(2))
IF $PIECE(SR(0),"^",6)=""
DO SRSET
QUIT
+3 IF $DATA(SRCL(3))
IF $PIECE(SR(0),"^",4)=""
DO SRSET
QUIT
+4 IF $DATA(SRCL(4))
IF $PIECE(SR(0),"^",7)=""
DO SRSET
QUIT
+5 IF $DATA(SRCL(5))
IF $PIECE(SR(0),"^",8)=""
DO SRSET
QUIT
+6 IF $DATA(SRCL(6))
IF $PIECE(SR(0),"^",9)=""
DO SRSET
QUIT
+7 IF $DATA(SRCL(7))
IF $PIECE(SR(0),"^",10)=""
DO SRSET
+8 QUIT
OSCEI SET SRTYPE="OTHER DIAGNOSIS"
+1 IF $DATA(SRCL(1))
IF $PIECE(SRDX,"^",3)=""
DO SRSET
QUIT
+2 IF $DATA(SRCL(2))
IF $PIECE(SRDX,"^",4)=""
DO SRSET
QUIT
+3 IF $DATA(SRCL(3))
IF $PIECE(SRDX,"^",2)=""
DO SRSET
QUIT
+4 IF $DATA(SRCL(4))
IF $PIECE(SRDX,"^",7)=""
DO SRSET
QUIT
+5 IF $DATA(SRCL(5))
IF $PIECE(SRDX,"^",5)=""
DO SRSET
QUIT
+6 IF $DATA(SRCL(6))
IF $PIECE(SRDX,"^",6)=""
DO SRSET
QUIT
+7 IF $DATA(SRCL(7))
IF $PIECE(SRDX,"^",8)=""
DO SRSET
+8 QUIT
SRSET SET SRMISS(SRTYPE_" SC/EI")=""
+1 QUIT
CONV ; convert coding data from file 130 to file 136
+1 IF $ORDER(^SRO(136,0))
DO MES^XPDUTL("Conversion has already run.")
QUIT
+2 DO NITE^SROPCE
C2 NEW SRCT,SRD,SRODX,SRPDX,SRPP,SROP,SRP,SRTN
+1 DO MES^XPDUTL(" Converting coding data from file 130 to file 136...")
+2 SET (SRCT,SRTN)=0
FOR
SET SRTN=$ORDER(^SRF(SRTN))
if 'SRTN
QUIT
Begin DoDot:1
+3 IF '$PIECE($GET(^SRF(SRTN,.2)),"^",12)&'$PIECE($GET(^SRF(SRTN,"NON")),"^",5)
QUIT
+4 SET SRPP=$PIECE($GET(^SRF(SRTN,"OP")),"^",2)
SET (SROP,SRP)=0
FOR
SET SRP=$ORDER(^SRF(SRTN,13,SRP))
if 'SRP
QUIT
IF $PIECE($GET(^SRF(SRTN,13,SRP,2)),"^")
SET SROP=1
QUIT
+5 SET SRPDX=$PIECE($GET(^SRF(SRTN,34)),"^",2)
SET (SRODX,SRD)=0
FOR
SET SRD=$ORDER(^SRF(SRTN,15,SRD))
if 'SRD
QUIT
IF $PIECE($GET(^SRF(SRTN,15,SRD,0)),"^",3)
SET SRODX=1
QUIT
+6 IF SRPP!SROP!SRPDX!SRODX
Begin DoDot:2
+7 if $DATA(^SRO(136,SRTN,0))
QUIT
+8 DO ^SROCD1
SET SRCT=SRCT+1
IF '(SRCT#10000)
DO MES^XPDUTL(SRCT_" cases converted... ")
End DoDot:2
End DoDot:1
+9 DO MES^XPDUTL("Total cases converted: "_SRCT)
+10 QUIT
PRE ; pre-install entry
+1 ; delete APCE x-refs
+2 KILL DIE,DR,DIK,DA
SET DIK="^DD(130.16,3,1,"
SET DA=1
SET DA(1)=3
SET DA(2)=130.16
DO ^DIK
+3 KILL DIK,DA
SET DIK="^DD(130.165,.01,1,"
SET DA=2
SET DA(1)=.01
SET DA(2)=130.165
DO ^DIK
+4 KILL DIK,DA
SET DIK="^DD(130.18,.01,1,"
SET DA=9
SET DA(1)=.01
SET DA(2)=130.18
DO ^DIK
+5 KILL DIK,DA
SET DIK="^DD(130.18,3,1,"
SET DA=1
SET DA(1)=3
SET DA(2)=130.18
DO ^DIK
+6 KILL DIK,DA
SET DIK="^DD(130,27,1,"
SET DA=1
SET DA(1)=27
SET DA(2)=130
DO ^DIK
+7 KILL DIK,DA
SET DIK="^DD(130.275,.01,1,"
SET DA=1
SET DA(1)=.01
SET DA(2)=130.275
DO ^DIK
+8 KILL DIK,DA
SET DIK="^DD(130,32.5,1,"
SET DA=1
SET DA(1)=32.5
SET DA(2)=130
DO ^DIK
+9 KILL DIK,DA
SET DIK="^DD(130,66,1,"
SET DA=1
SET DA(1)=66
SET DA(2)=130
DO ^DIK
KILL DIK,DA
+10 QUIT
