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

BGOCPTP3.m

Go to the documentation of this file. 
  1. BGOCPTP3 ; IHS/MSC/MGH - Store a SNOMED association ;14-Apr-2016 12:37;du
  1.  ;;1.1;BGO COMPONENTS;**14,19,20**;Mar 20, 2007;Build 6
  1.  ;---------------------------------------------
  1.  ;Store a SNOMED association
  1.  ;Input = DFN [1] ^ VIEN [2] SNOMED CT [3] ^ ICD [4] ^LOCATION [5] ^ PROVIDER [6] ^ normal/abnormal [7]
  1.  ;Patch 19 added NORM to input
  1. STORE(RET,INP) ;EP Store POV and possibly problem
  1.  N DFN,VIEN,SNOMED,DESC,ICD,FAC,CANDUP,ICDIEN,VDT,PROB,VPOV,FOUND,X,ICD2,STRING,PRV
  1.  N DEL,MATCH,SPROB,TYPE,SNODATA,NORM,STAT
  1.  S DFN=$P(INP,U,1)
  1.  Q:'DFN
  1.  S VIEN=$P(INP,U,2)
  1.  Q:'VIEN
  1.  S SNO=$P(INP,U,3)
  1.  Q:'SNO
  1.  S ICD=$P(INP,U,4)
  1.  S FAC=$$GET1^DIQ(9000010,VIEN,.06,"I")
  1.  S PRV=$P(INP,U,6)
  1.  S VDT=+$G(^AUPNVSIT(VIEN,0))
  1.  S NORM=$P(INP,U,7)
  1.  ;IHS/MSC/MGH Changed to use new API P14
  1.  ;S X=$$CONC^BSTSAPI(SNO_"^^^1")
  1.  S X=$$CONC^AUPNSICD(SNO_"^^^1")
  1.  S STAT=$P(X,U,9)
  1.  S DESC=$P(X,U,3)
  1.  S ICD2=$P($P(X,U,5),";",1)
  1.  I ICD2'["." S ICD2=ICD2_"."
  1.  I ICD2'=""&(ICD2'=ICD) S ICD=ICD2
  1.  S SNODATA=$TR($P(X,U,5),";","|")
  1.  ;Validate its a good code
  1.  I $$AICD^BGOUTL2 D
  1.  .S ICDIEN=$P($$CODEN^ICDEX(ICD,80),"~",1)
  1.  E  D
  1.  .S ICDIEN=$S($E(ICD)="`":$E(TYPE,2,99),1:$O(^ICD9("AB",TYPE_" "),0))
  1.  I 'ICDIEN S RET=$$ERR^BGOUTL(1094) Q
  1.  D CHECK^BGOVPOV(.RET,ICDIEN_U_DFN_U_VDT_U_SNO_U_"")
  1.  Q:RET
  1.  ;Check for duplicate visits
  1.  S FOUND=0
  1.  S VPOV="" F  S VPOV=$O(^AUPNVPOV("AD",VIEN,VPOV))  Q:'+VPOV!(FOUND=1)  D
  1.  .I $P($G(^AUPNVPOV(VPOV,0)),U,1)=ICDIEN S FOUND=1
  1.  I FOUND=1 S RET="-1^Duplicate. Snomed/code already recorded as POV for this visit"
  1.  Q:RET
  1.  ;Next, see if this already exists as a problem on the patients list
  1.  S MATCH=0,SPROB=""
  1.  S PROB="" F  S PROB=$O(^AUPNPROB("APCT",DFN,SNO,PROB)) Q:PROB=""!(MATCH=1)  D
  1.  .S DEL=$$GET1^DIQ(9000011,PROB,2.02)
  1.  .I DEL="" S MATCH=1,SPROB=PROB
  1.  I 'SPROB S SPROB=$$ADDPROB(DFN,SNO,DESC,SNODATA,FAC,"",STAT)
  1.  Q:'SPROB
  1.  S STRING=""_U_VIEN_U_SPROB_U_DFN_U_""_U_DESC_U_SNO_U_SNODATA_U_U_PRV
  1.  I NORM="" D SET^BGOVPOV(.RET,STRING)
  1.  E  D SET^BGOVPOV(.RET,STRING,"","",NORM)
  1.  Q
  1.  ;
  1. ADDPROB(DFN,SNO,DESC,ICD,FAC,SPEC,STAT) ;Add the problem is it isn't in the list
  1.  N DATA,LIST
  1.  ;IHS/MSC/MGH added routine status P20
  1.  I STAT="" S STAT="Episodic"
  1.  S LIST(0)="P"_U_SNO_U_DESC_U_""_U_ICD_U_FAC_U_""_U_STAT
  1.  D SET^BGOPROB(.DATA,DFN,"",VIEN,.LIST,.SPEC)
  1.  Q DATA
  1.  ;
  1. TMPGBL(X) ;EP
  1.  K ^TMP("BGOMAP",$J) Q $NA(^($J))
  1. RPT ; EP Report to return codes that are unmapped to SNOMED or are still ICD9  procedure codes
  1.  N BGORPT,DIR,Y,ZTRTN
  1.  W @IOF
  1.  W !,"Unconverted ICD9 diagnosis or procedure codes",!!
  1.  S DIR(0)="SO^D:Diagnosis Missing SNOMED;P:ICD-9 Procedure Codes"
  1.  S DIR("A")="Select Report to Run "
  1.  S DIR("B")="D"
  1.  S DIR("?")="Running the diagnosis report will find ICD associations not mapped to SNOMED, Report P will find ICD diagnosis codes that are ICD-9"
  1.  D ^DIR
  1.  S BGORPT=Y
  1.  S ZTRTN="OUT^BGOCPTP3"
  1.  D DEVICE
  1.  Q
  1. DEVICE ; Device handling
  1.  ; Call with: ZTRTN
  1.  N %ZIS
  1.  S %ZIS="Q" D ^%ZIS Q:POP
  1.  G:$D(IO("Q")) QUE
  1. NOQUE ; Call report directly
  1.  D @ZTRTN
  1.  Q
  1. QUE ; Queue output
  1.  N %,ZTDTH,ZTIO,ZTSAVE,ZTSK
  1.  Q:'$D(ZTRTN)
  1.  K IO("Q") S ZTSAVE("BGORPT")=""
  1.  S:'$D(ZTDESC) ZTDESC="Pring Unconverted ICD9 DX or procedure codes report" S ZTIO=ION
  1.  D ^%ZTLOAD W !,$S($D(ZTSK):"Request Queued!",1:"Request Cancelled!")
  1.  K ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
  1.  D HOME^%ZIS
  1.  Q
  1. OUT ;Run the report
  1.  N I,J,NAME,CPT,CNAME,PNAME,PCPT,ASSOC
  1.  D HDR(BGORPT)
  1.  S I=0 F  S I=$O(^BGOCPTPR(I)) Q:I=""  D
  1.  .S NAME=$P($G(^BGOCPTPR(I,0)),U,1)
  1.  .S PNAME=0
  1.  .S J=0 F  S J=$O(^BGOCPTPR(I,1,J)) Q:J=""  D
  1.  ..S CPT=$P($G(^BGOCPTPR(I,1,J,0)),U,1)
  1.  ..S CNAME=$P($G(^BGOCPTPR(I,1,J,0)),U,2)
  1.  ..S PCPT=0
  1.  ..S K="" F  S K=$O(^BGOCPTPR(I,1,J,1,K)) Q:K=""  D
  1.  ...S ASSOC=$P($G(^BGOCPTPR(I,1,J,1,K,0)),U,1)
  1.  ...I $P(ASSOC,";",2)="ICD9("&(BGORPT="D") D SNOMED
  1.  ...I $P(ASSOC,";",2)="ICD0("&(BGORPT="P") D PROC
  1.  Q
  1. HDR(TYP) ;PRINT HEADER
  1.  N LIN,DTYP
  1.  S DTYP=$S(TYP="D":"ICD DX to SNOMED",TYP="P":"ICD9 to ICD10 procedures",1:"")
  1.  I IOST["C-" W @IOF
  1.  W !,"Unconverted codes report for "_DTYP,!
  1.  W !,"Superbill",?20,"CPT IEN",?30,"Code",?40,"ICD",?50,"Text"
  1.  W ! F LIN=1:1:72 W "-"
  1.  W !
  1.  Q
  1. SNOMED ;If SNOMED fields are not filled in add this to the report list
  1.  N TXT,ICDIEN,ICDCODE,TXT,CPTCODE
  1.  I $P($G(^BGOCPTPR(I,1,J,1,K,0)),U,8)="" D
  1.  .S ICDIEN=$P(ASSOC,";",1)
  1.  .S CPTCODE=$$GET1^DIQ(81,CPT,.01)
  1.  .I $$AICD^BGOUTL2 D
  1.  ..S TXT=$P($$ICDDX^ICDEX(ICDIEN,$$NOW^XLFDT,"","I"),U,4)
  1.  ..S ICDCODE=$P($$ICDDX^ICDEX(ICDIEN,$$NOW^XLFDT,"","I"),U,2)
  1.  .E  D
  1.  ..S TXT=$P($$ICDDX^ICDCODE(ICDIEN,$$NOW^XLFDT),U,4)
  1.  ..S ICDCODE=$P($$ICDDX^ICDCODE(ICDIEN,$$NOW^XLFDT),U,2)
  1.  .I $Y+4>IOSL,IOST["P-" W @IOF D HDR
  1.  .W !,NAME,?20,J,?30,CPTCODE,?40,ICDCODE,?50,TXT
  1.  Q
  1.  ;If the selected item is an ICD-9 procedure add it to the report list
  1. PROC ;If procedures is ICD-9 code add to report list
  1.  N TXT,ICDIEN,ICDCODE,TXT,CPTCODE
  1.  I $P($G(^BGOCPTPR(I,1,J,1,K,0)),U,8)="" D
  1.  .S ICDIEN=$P(ASSOC,";",1)
  1.  .S CPTCODE=$$GET1^DIQ(81,CPT,.01)
  1.  .I $$AICD^BGOUTL2 D
  1.  ..S DATA=$$ICDOP^ICDEX(ICDIEN,$$NOW^XLFDT,"","I")
  1.  .E  S DATA=$$ICDOP^ICDCODE(ICDIEN,$$NOW^XLFDT,"","I")
  1.  .I $P(DATA,U,15)=2 D
  1.  ..S TXT=$P(DATA,U,5)
  1.  ..S ICDCODE=$P(DATA,U,2)
  1.  ..I $Y+4>IOSL,IOST["P-" W @IOF D HDR
  1.  ..W !,NAME,?20,J,?30,CPTCODE,?40,ICDCODE,?50,TXT
  1.  Q
  1. AUTOQ ;Queue this item to run
  1.  S IMP=$$IMP^ICDEX("10D",DT)
  1.  I $$NOW^XLFDT<IMP D
  1.  .W !,"Implementation date has not occurred."
  1.  .W !,"Schedule the task to run within 6hrs of Implementation date."
  1.  Q:'$$FIND1^DIC(19,"","MX","BGO CPT UPDATE ASSOCIATIONS")
  1.  I $$FIND1^DIC(19.2,"","MX","BGO CPT UPDATE ASSOCIATONS") D
  1.  .D EDIT^XUTMOPT("BGO CPT UPDATE ASSOCIATONS")
  1.  E  D
  1.  .D RESCH^XUTMOPT("BGO CPT UPDATE ASSOCIATIONS","","","","L")
  1.  .D EDIT^XUTMOPT("BGO CPT UPDATE ASSOCIATIONS")
  1.  Q
  1.  Q
  1. CHANGE ; Update and change all SNOMED ICD associations over to ICD-10 codes
  1.  D ICD10^BGOCPTP3
  1.  Q
  1. ICD10 ;EP Entry to update SNOMED ICD associations
  1.  N I,J,NAME,CPT,CNAME,PNAME,PCPT,IMP
  1.  S IMP=$$IMP^ICDEX("10D",DT)
  1.  I $$NOW^XLFDT<IMP W !,"Implementation date has not occurred. Cannot update items" Q
  1.  D HDR2
  1.  S I=0 F  S I=$O(^BGOCPTPR(I)) Q:I=""  D
  1.  .S NAME=$P($G(^BGOCPTPR(I,0)),U,1)
  1.  .S PNAME=0
  1.  .S J=0 F  S J=$O(^BGOCPTPR(I,1,J)) Q:J=""  D
  1.  ..S CPT=$P($G(^BGOCPTPR(I,1,J,0)),U,1)
  1.  ..S CNAME=$P($G(^BGOCPTPR(I,1,J,0)),U,2)
  1.  ..S PCPT=0
  1.  ..S K="" F  S K=$O(^BGOCPTPR(I,1,J,1,K)) Q:K=""  D
  1.  ...S ASSOC=$P($G(^BGOCPTPR(I,1,J,1,K,0)),U,1)
  1.  ...I $P(ASSOC,";",2)="ICD9("&(BGORPT="D") D SNOUP
  1.  Q
  1. HDR2 ;EP
  1.  N LIN,DTYP
  1.  I IOST["C-" W @IOF
  1.  W !,"List of ICD-9 codes updated to ICD-10 for Super Bill Associations",!
  1.  W !,"Superbill",?20,"CPT IEN",?30,"Code",?40,"ICD",?50,"Text"
  1.  W ! F LIN=1:1:72 W "-"
  1.  W !
  1.  Q
  1. SNOUP ;Update the association
  1.  N TXT,ICD,ICDCODE,TXT,CPTCODE,SNO
  1.  Q:$P($G(^BGOCPTPR(I,1,J,1,K,0)),U,8)=""   ;Must have been converted to snomed
  1.  S SNO=$P($G(^BGOCPTPR(I,1,J,1,K,0)),U,8)
  1.  ;IHS/MSC/MGH Changed to use new api
  1.  ;S SNODATA=$$CONC^BSTSAPI(SNO_"^^^1")
  1.  S SNODATA=$$CONC^AUPNSICD(SNO_"^^^1")
  1.  S ICD=$P($P(SNODATA,U,5),";",1)
  1.  I ICD="" S ICD="ZZZ.999"
  1.  S ICDIEN=$P($$CODEN^ICDEX(ICD,80),"~",1)
  1.  S CPTCODE=$$GET1^DIQ(81,CPT,.01)
  1.  S TXT=$P($$ICDDX^ICDEX(ICDIEN,$$NOW^XLFDT,"","I"),U,4)
  1.  S ICDCODE=$P($$ICDDX^ICDEX(ICDIEN,$$NOW^XLFDT,"","I"),U,2)
  1.  S IENS=K_","_J_","_I_","
  1.  S FDA=$NA(FDA(90362.3121,IENS))
  1.  S @FDA@(.01)=NEWCODE_";ICD0("
  1.  S RET2=$$UPDATE^BGOUTL(.FDA,"@",.IEN)
  1.  I 'RET2 D
  1.  .I $Y+4>IOSL,IOST["P-" W @IOF D HDR2
  1.  .W !,NAME,?20,J,?30,CPTCODE,?40,ICDCODE,?50,TXT
  1.  Q