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

APCDPLFH.m

Go to the documentation of this file. 
  1. APCDPLFH ;IHS/CMI/LAB - UPDATE ICD CODE FROM BSTS ; 31 Jan 2017  8:51 AM
  1.  ;;2.0;IHS PCC SUITE;**11,15,19**;MAY 14, 2009;Build 5
  1.  ;; ;
  1.  ;
  1.  W !!,"This option is used to update the diagnosis on Problem List"
  1.  W !,"and family history entries when you first switch to ICD-10 from ICD-9",!,"or when a DTS upgrade with updated mappings is received.",!!
  1.  S APCDIMP=$$IMP^AUPNSICD(DT)
  1.  W !!,"Your system's ICD files are set to ",$S(APCDIMP=30:"ICD10",1:"ICD9")," when this runs it will ",!,"put ",$S(APCDIMP=30:"ICD10",1:"ICD9")," codes as the diagnosis on the Problem and Family History entries.",!!
  1.  S DIR(0)="Y",DIR("A")="Do you wish to continue",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) Q
  1.  I 'Y Q
  1.  ;S XBRP="",XBRC="QUEUE^APCDPLFH",XBNS="APCD*",XBRX="XIT^APCDPLFH"
  1.  ;D ^XBDBQUE
  1.  W !!,"Hold on..this may take a few minutes.."
  1.  D QUEUE
  1.  D XIT
  1.  Q
  1. XIT ;
  1.  D EN^XBVK("APCD")
  1.  Q
  1. QUEUE ;EP
  1.  S APCDIMP=$$IMP^AUPNSICD(DT)
  1.  I '$D(ZTQUEUED) W !,"Looping through Problem entries....."
  1.  S APCDX=0,APCDCNT=0
  1.  F  S APCDX=$O(^AUPNPROB(APCDX)) Q:APCDX'=+APCDX  D
  1.  .S APCDCNT=APCDCNT+1
  1.  .I '$D(ZTQUEUED) W:'(APCDCNT#1000) "."
  1.  .Q:'$D(^AUPNPROB(APCDX,0))
  1.  .S APCDCI=$P($G(^AUPNPROB(APCDX,800)),U)  ;only snomed coded problems
  1.  .Q:APCDCI=""
  1.  .Q:$P(^AUPNPROB(APCDX,0),U,12)="D"  ;SKIP DELETED PROBLEMS
  1.  .S APCDICDS=$P($$CONC^AUPNSICD(APCDCI_"^^"_DT_"^1^^PRB="_APCDX),U,5)  ;ALL ICD CODES CURRENT FROM BSTS
  1.  .S APCDO01=$P(^AUPNPROB(APCDX,0),U,1)  ;old .01
  1.  .S APCD001E=$$VAL^XBDIQ1(9000011,APCDX,.01) ;old .01 external value (code)
  1.  .S APCDOA=""  ;old additional, ":" delimited
  1.  .S X=0 F  S X=$O(^AUPNPROB(APCDX,12,X)) Q:X'=+X  D
  1.  ..S Y=$P($G(^AUPNPROB(APCDX,12,X,0)),U)
  1.  ..Q:'Y
  1.  ..I APCDIMP=30 S Y=$P($$ICDDX^ICDEX(Y,,,"I"),U,2)
  1.  ..I APCDIMP=1 S Y=$P($$ICDDX^ICDCODE(Y),U,2)
  1.  ..S APCDOA=APCDOA_$S(APCDOA]"":":",1:"")_Y
  1.  .S APCDOLDT=APCD001E_$S(APCDOA]"":";",1:"")_$TR(APCDOA,":",";")   ;all current codes formatted like return from BSTS with ";"
  1.  .Q:APCDICDS=APCDOLDT  ;nothing changed so don't bother updating anything
  1.  .;
  1.  .;update PROBLEM entry and the change log
  1.  .S APCDN01=$P(APCDICDS,";")  ;new .01 code
  1.  .I APCDIMP=30 S APCDN01=+$$CODEABA^ICDEX(APCDN01,80,30) ;new .01 internal
  1.  .I APCDIMP=1 S APCDN01=+$$CODEN^ICDCODE(APCDN01,80)  ;new .01 internal icd9
  1.  .I 'APCDN01 G ADDL  ;no valid new .01 value go do additional and skip .01
  1.  .I APCDN01=-1 G ADDL  ;Can't change it if it isn't in file 80
  1.  .I APCDN01=APCDO01 G ADDL  ;.01 new and old are the same so no need to update .01 but go check additional codes
  1.  .;now set AUPNPROB
  1.  .K DIE,DA,DR S DA=APCDX,DR=".01////"_APCDN01,DIE="^AUPNPROB(" D ^DIE K DIE,DA,DR
  1. ADDL .;ADDITIONAL MULTIPLE
  1.  .K APCDNA
  1.  .S APCDNA=$P(APCDICDS,";",2,999)  ;new addtional codes
  1.  .I APCDNA=$P(APCDOLDT,";",2,999) G LOG  ;additional codes did not change by order or value
  1.  .;DELETE OUT OLD ADDITIONAL MULTIPLE
  1.  .S APCDZ=0 F  S APCDZ=$O(^AUPNPROB(APCDX,12,APCDZ)) Q:APCDZ'=+APCDZ  D
  1.  ..S DIE="^AUPNPROB("_APCDX_",12,",DA=APCDZ,DA(1)=APCDX,DR=".01///@" D ^DIE K DIE,DA,DR
  1.  .;SET new 12 NODES
  1.  .S APCDFNUM=9000011.12
  1.  .S APCDNODE=12,APCDE=""
  1.  .F APCDZ=1:1 S APCDY=$P(APCDNA,";",APCDZ) Q:APCDY=""  D
  1.  ..I APCDIMP=30 S APCDP=+$$CODEABA^ICDEX(APCDY,80,30)
  1.  ..I APCDIMP=1 S APCDP=+$$CODEN^ICDCODE(APCDY,80)
  1.  ..Q:'APCDP
  1.  ..Q:APCDP=-1
  1.  ..K APCDFDA
  1.  ..S APCDFDA(APCDFNUM,"+2,"_APCDX_",",.01)=APCDP
  1.  ..D UPDATE^DIE("","APCDFDA","","ERR")
  1.  ..I $G(ERR("DIERR",1)) D SETE
  1. LOG .;update my log if either .01 or addiitional multiple changed
  1.  .K DIC,DD,D0,DO,DO
  1.  .S DIADD=1,DLAYGO=9001040.1,DIC(0)="L",DIC="^APCDPLMD("
  1.  .S X=DT,DIC("DR")=".02////"_APCDX_";.03////"_APCDO01_";.04////"_APCDN01_";.05////"_APCDOA_";.06////"_$TR(APCDNA,";",":")_";.07////9000011;.08////"_APCDCI
  1.  .D FILE^DICN
  1.  .K DIC,DIADD,DLAYGO
  1.  .S APCDLOGE=+Y
  1. FH ;
  1.  I '$D(ZTQUEUED) W !,"Now looping through Family History entries.."
  1.  S APCDX=0,APCDCNT=0
  1.  F  S APCDX=$O(^AUPNFH(APCDX)) Q:APCDX'=+APCDX  D
  1.  .S APCDCNT=APCDCNT+1
  1.  .I '$D(ZTQUEUED) W:'(APCDCNT#1000) "."
  1.  .Q:'$D(^AUPNFH(APCDX,0))
  1.  .S APCDCI=$P($G(^AUPNFH(APCDX,0)),U,13)  ;only snomed coded fh ENTRIES
  1.  .Q:APCDCI=""
  1.  .S APCDICDS=$P($$CONC^AUPNSICD(APCDCI_"^^"_DT_"^1^^FH="_APCDX),U,5)  ;ALL ICD CODES
  1.  .S APCDO01=$P(^AUPNFH(APCDX,0),U,1)
  1.  .S APCD001E=$$VAL^XBDIQ1(9000014,APCDX,.01)  ;EXTERNAL #.01
  1.  .S APCDOA=""
  1.  .S X=0 F  S X=$O(^AUPNFH(APCDX,11,X)) Q:X'=+X  D
  1.  ..S Y=$P($G(^AUPNFH(APCDX,11,X,0)),U)
  1.  ..Q:'Y
  1.  ..I APCDIMP=30 S Y=$P($$ICDDX^ICDEX(Y,,,"I"),U,2)
  1.  ..I APCDIMP=1 S Y=$P($$ICDDX^ICDCODE(Y),U,2)
  1.  ..S APCDOA=APCDOA_$S(APCDOA]"":":",1:"")_Y
  1.  .S APCDOLDT=APCD001E_$S(APCDOA]"":";",1:"")_$TR(APCDOA,":",";")   ;all current codes
  1.  .Q:APCDICDS=APCDOLDT  ;NOTHING CHANGED SO DON'T UPDATE ANYTHING
  1.  .;update fh entry and the log
  1.  .S APCDN01=$P(APCDICDS,";")
  1.  .I APCDIMP=30 S APCDN01=+$$CODEABA^ICDEX(APCDN01,80,30)
  1.  .I APCDIMP=1 S APCDN01=+$$CODEN^ICDCODE(APCDN01,80)
  1.  .I 'APCDN01 G ADDLFH  ;no valid new .01 value go do additional and skip .01
  1.  .I APCDN01=-1 G ADDLFH  ;Can't change it if it isn't in file 80
  1.  .I APCDN01=APCDO01 G ADDLFH  ;.01 new and old are the same so no need to update .01 but go check additional codes
  1.  .;now set AUPNFH .01
  1.  .K DIE,DA,DR S DA=APCDX,DR=".01////"_APCDN01,DIE="^AUPNFH(" D ^DIE K DIE,DA,DR
  1. ADDLFH .;
  1.  .K APCDNA
  1.  .S APCDNA=$P(APCDICDS,";",2,999)
  1.  .I APCDNA=$P(APCDOLDT,";",2,999) G LOGFH  ;additional codes did not change by order or value
  1.  .S APCDZ=0 F  S APCDZ=$O(^AUPNFH(APCDX,11,APCDZ)) Q:APCDZ'=+APCDZ  D
  1.  ..S DIE="^AUPNFH("_APCDX_",11,",DA=APCDZ,DA(1)=APCDX,DR=".01///@" D ^DIE K DIE,DA,DR
  1.  .;SET 11 NODES
  1.  .S APCDFNUM=9000014.11
  1.  .F APCDZ=1:1 S APCDY=$P(APCDNA,";",APCDZ) Q:APCDY=""  D
  1.  ..I APCDIMP=30 S APCDP=+$$CODEABA^ICDEX(APCDY,80,30)
  1.  ..I APCDIMP=1 S APCDP=+$$CODEN^ICDCODE(APCDY,80)
  1.  ..Q:'APCDP
  1.  ..Q:APCDP=-1
  1.  ..K APCDFDA
  1.  ..S APCDFDA(APCDFNUM,"+2,"_APCDX_",",.01)=APCDP
  1.  ..D UPDATE^DIE("","APCDFDA","","ERR")
  1.  ..I $G(ERR("DIERR",1)) D SETE
  1. LOGFH .;update log for FH
  1.  .K DIC,DD,D0,DO,DO
  1.  .S DIADD=1,DLAYGO=9001040.1,DIC(0)="L",DIC="^APCDPLMD("
  1.  .S X=DT,DIC("DR")=".02////"_APCDX_";.03////"_APCDO01_";.04////"_APCDN01_";.05////"_APCDOA_";.06////"_$TR(APCDNA,";",":")_";.07////9000014;.08////"_APCDCI
  1.  .D FILE^DICN
  1.  .K DIC,DIADD,DLAYGO
  1.  .S APCDLOGE=+Y
  1.  Q
  1. SETE ;
  1.  S DA=APCDLOGE,DIE="^APCDPLMD(",DR="1///"_ERR("DIERR",1)
  1.  Q