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