Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SROCD4

SROCD4.m

Go to the documentation of this file.
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