- 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 Mar 13, 2025@21:47:50 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
