PXMCICHK ;SLC/PKR - Search for and display inactive mapped codes. ;04/12/2017
;;1.0;PCE PATIENT CARE ENCOUNTER;**211**;Aug 12, 1996;Build 454
;
;==========================================
CSU(TYPE) ;Entry point for code set update, called by CPTE and ICDE^PXCSPE.
N IND,NL,PTYPE,SUBJECT,TEXT,TMPNODE
S PTYPE=$S(TYPE="CPT":"a CPT",TYPE="ICD":"an ICD")
S TMPNODE="PXINMC"
D MCICHK(TMPNODE,.TEXT)
K ^TMP("PXXMZ",$J)
S ^TMP("PXXMZ",$J,1,0)="There was "_PTYPE_" code set update on "_$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
S ^TMP("PXXMZ",$J,2,0)="Please review the affected code mappings and take appropriate action."
S ^TMP("PXXMZ",$J,3,0)=""
S IND=0,NL=3
F S IND=+$O(TEXT(IND)) Q:IND=0 S NL=NL+1,^TMP("PXXMZ",$J,NL,0)=TEXT(IND)
S SUBJECT="PCE inactive mapped codes report"
D SEND^PXMSG("PXXMZ",SUBJECT)
Q
;
;==========================================
BROWSE ;Display the inactive mapped codes in the Browser.
N TEXT,TMPNODE,X
S TMPNODE="PXINMC"
D MCICHK(TMPNODE,.TEXT)
S X="IORESET"
D ENDR^%ZISS
D BROWSE^DDBR("TEXT","NR","Inactive Mapped Codes")
W IORESET
D KILL^%ZISS
K ^TMP($J,TMPNODE)
Q
;
;==========================================
EDU(NODE) ;Search Education Topics for mapped codes that are inactive and
;produce a list.
N CODE,CODESYS,IEN,INACTDT,IND,NAME,TEMP
S NAME=""
F S NAME=$O(^AUTTEDT("B",NAME)) Q:NAME="" D
. S IEN=$O(^AUTTEDT("B",NAME,""))
. I '$D(^AUTTEDT(IEN,210)) Q
. S IND=0
. F S IND=+$O(^AUTTEDT(IEN,210,IND)) Q:IND=0 D
.. S TEMP=^AUTTEDT(IEN,210,IND,0)
.. S CODESYS=$P(TEMP,U,1),CODE=$P(TEMP,U,2)
.. I CODE'="" D
... S INACTDT=$$INACTDT(CODESYS,CODE)
... I INACTDT'="" S ^TMP($J,NODE,"EDU",NAME,IEN,CODESYS,CODE)=INACTDT
Q
;
;==========================================
EXAM(NODE) ;Search Exams for mapped codes that are inactive and produce a list.
N CODE,CODESYS,IEN,INACTDT,IND,NAME,TEMP
S NAME=""
F S NAME=$O(^AUTTEXAM("B",NAME)) Q:NAME="" D
. S IEN=$O(^AUTTEXAM("B",NAME,""))
. I '$D(^AUTTEXAM(IEN,210)) Q
. S IND=0
. F S IND=+$O(^AUTTEXAM(IEN,210,IND)) Q:IND=0 D
.. S TEMP=^AUTTEXAM(IEN,210,IND,0)
.. S CODESYS=$P(TEMP,U,1),CODE=$P(TEMP,U,2)
.. I CODE'="" D
... S INACTDT=$$INACTDT(CODESYS,CODE)
... I INACTDT'="" S ^TMP($J,NODE,"EXAM",NAME,IEN,CODESYS,CODE)=INACTDT
Q
;
;==========================================
HF(NODE) ;Search Health Factors for mapped codes that are inactive and produce
;a list.
N CODE,CODESYS,IEN,INACTDT,IND,NAME,TEMP
S NAME=""
F S NAME=$O(^AUTTHF("B",NAME)) Q:NAME="" D
. S IEN=$O(^AUTTHF("B",NAME,""))
. I '$D(^AUTTHF(IEN,210)) Q
. S IND=0
. F S IND=+$O(^AUTTHF(IEN,210,IND)) Q:IND=0 D
.. S TEMP=^AUTTHF(IEN,210,IND,0)
.. S CODESYS=$P(TEMP,U,1),CODE=$P(TEMP,U,2)
.. I CODE'="" D
... S INACTDT=$$INACTDT(CODESYS,CODE)
... I INACTDT'="" S ^TMP($J,NODE,"HF",NAME,IEN,CODESYS,CODE)=INACTDT
Q
;
;==========================================
IMM(NODE) ;Search Immunizations for mapped codes that are inactive and produce
;a list.
N CODE,CODESYS,IEN,INACTDT,IND,JND,NAME,TEMP
S NAME=""
F S NAME=$O(^AUTTIMM("B",NAME)) Q:NAME="" D
. S IEN=$O(^AUTTIMM("B",NAME,""))
. S IND=0
. F S IND=+$O(^AUTTIMM(IEN,3,IND)) Q:IND=0 D
.. S CODESYS=^AUTTIMM(IEN,3,IND,0)
.. S JND=0
.. F S JND=+$O(^AUTTIMM(IEN,3,IND,1,JND)) Q:JND=0 D
... S CODE=^AUTTIMM(IEN,3,IND,1,JND,0)
... S INACTDT=$$INACTDT(CODESYS,CODE)
... I INACTDT'="" S ^TMP($J,NODE,"IMM",NAME,IEN,CODESYS,CODE)=INACTDT
Q
;
;==========================================
INACTDT(CODESYS,CODE) ;Given a coding system and a code, check and if the
;code is inactive return the inactivation date otherwise return null.
N ACTDT,INACTDT,RESULT,PDATA
;ICR #5679
S RESULT=$$PERIOD^LEXU(CODE,CODESYS,.PDATA)
I +RESULT=-1 D
.;DBIA #1997, #3991
. I (CODESYS="CPC")!(CODESYS="CPT") D PERIOD^ICPTAPIU(CODE,.PDATA)
. I (CODESYS="ICD")!(CODESYS="ICP") D PERIOD^ICDAPIU(CODE,.PDATA)
S ACTDT=1000101,INACTDT=""
F S ACTDT=$O(PDATA(ACTDT)) Q:(ACTDT="")!(INACTDT'="") D
. S INACTDT=$P(PDATA(ACTDT),U,1)
Q INACTDT
;
;==========================================
MCICHK(TMPNODE,TEXT) ;Search Education Topics, Exams, Health Factors,
;Immunizations, and Skin Tests for mapped codes that are inactive
;and produce a list.
N CODE,CODESYS,FILE,FNAME,IEN,INACTDT,NAME,NL
S FNAME("EDU")="EDUCATION TOPICS",FNAME("EXAM")="EXAM"
S FNAME("HF")="HEALTH FACTORS",FNAME("IMM")="IMMUNIZATION"
S FNAME("SKIN")="SKIN TEST"
K ^TMP($J,TMPNODE)
D EDU(TMPNODE),EXAM(TMPNODE),HF(TMPNODE),IMM(TMPNODE),SKIN(TMPNODE)
;Create the report.
S FILE="",NL=0
F S FILE=$O(^TMP($J,TMPNODE,FILE)) Q:FILE="" D
. I NL>0 S NL=NL+1,TEXT(NL)="",NL=NL+1,TEXT(NL)="-----------------------------"
. S NL=NL+1,TEXT(NL)=FNAME(FILE)_" inactive mapped codes."
. S NAME=""
. F S NAME=$O(^TMP($J,TMPNODE,FILE,NAME)) Q:NAME="" D
.. S IEN=$O(^TMP($J,TMPNODE,FILE,NAME,""))
.. S NL=NL+1,TEXT(NL)=""
.. S NL=NL+1,TEXT(NL)=" "_NAME_" (IEN="_IEN_")"
.. S CODESYS=""
.. F S CODESYS=$O(^TMP($J,TMPNODE,FILE,NAME,IEN,CODESYS)) Q:CODESYS="" D
... S CODE=""
... F S CODE=$O(^TMP($J,TMPNODE,FILE,NAME,IEN,CODESYS,CODE)) Q:CODE="" D
.... S INACTDT=^TMP($J,TMPNODE,FILE,NAME,IEN,CODESYS,CODE)
.... S NL=NL+1,TEXT(NL)=" "_CODESYS_" "_CODE_", inactivated: "_$$FMTE^XLFDT(INACTDT,"5Z")
K ^TMP($J,TMPNODE)
Q
;
;==========================================
SKIN(NODE) ;Search Skin Tests for mapped codes that are inactive and produce
;a list.
N CODE,CODESYS,IEN,INACTDT,IND,JND,NAME,TEMP
S NAME=""
F S NAME=$O(^AUTTSK("B",NAME)) Q:NAME="" D
. S IEN=$O(^AUTTSK("B",NAME,""))
. S IND=0
. F S IND=+$O(^AUTTSK(IEN,3,IND)) Q:IND=0 D
.. S CODESYS=^AUTTSK(IEN,3,IND,0)
.. S JND=0
.. F S JND=+$O(^AUTTSK(IEN,3,IND,1,JND)) Q:JND=0 D
... S CODE=^AUTTSK(IEN,3,IND,1,JND,0)
... S INACTDT=$$INACTDT(CODESYS,CODE)
... I INACTDT'="" S ^TMP($J,NODE,"SKIN",NAME,IEN,CODESYS,CODE)=INACTDT
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXMCICHK 6008 printed Apr 09, 2024@21:27:30 Page 2
PXMCICHK ;SLC/PKR - Search for and display inactive mapped codes. ;04/12/2017
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**211**;Aug 12, 1996;Build 454
+2 ;
+3 ;==========================================
CSU(TYPE) ;Entry point for code set update, called by CPTE and ICDE^PXCSPE.
+1 NEW IND,NL,PTYPE,SUBJECT,TEXT,TMPNODE
+2 SET PTYPE=$SELECT(TYPE="CPT":"a CPT",TYPE="ICD":"an ICD")
+3 SET TMPNODE="PXINMC"
+4 DO MCICHK(TMPNODE,.TEXT)
+5 KILL ^TMP("PXXMZ",$JOB)
+6 SET ^TMP("PXXMZ",$JOB,1,0)="There was "_PTYPE_" code set update on "_$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
+7 SET ^TMP("PXXMZ",$JOB,2,0)="Please review the affected code mappings and take appropriate action."
+8 SET ^TMP("PXXMZ",$JOB,3,0)=""
+9 SET IND=0
SET NL=3
+10 FOR
SET IND=+$ORDER(TEXT(IND))
if IND=0
QUIT
SET NL=NL+1
SET ^TMP("PXXMZ",$JOB,NL,0)=TEXT(IND)
+11 SET SUBJECT="PCE inactive mapped codes report"
+12 DO SEND^PXMSG("PXXMZ",SUBJECT)
+13 QUIT
+14 ;
+15 ;==========================================
BROWSE ;Display the inactive mapped codes in the Browser.
+1 NEW TEXT,TMPNODE,X
+2 SET TMPNODE="PXINMC"
+3 DO MCICHK(TMPNODE,.TEXT)
+4 SET X="IORESET"
+5 DO ENDR^%ZISS
+6 DO BROWSE^DDBR("TEXT","NR","Inactive Mapped Codes")
+7 WRITE IORESET
+8 DO KILL^%ZISS
+9 KILL ^TMP($JOB,TMPNODE)
+10 QUIT
+11 ;
+12 ;==========================================
EDU(NODE) ;Search Education Topics for mapped codes that are inactive and
+1 ;produce a list.
+2 NEW CODE,CODESYS,IEN,INACTDT,IND,NAME,TEMP
+3 SET NAME=""
+4 FOR
SET NAME=$ORDER(^AUTTEDT("B",NAME))
if NAME=""
QUIT
Begin DoDot:1
+5 SET IEN=$ORDER(^AUTTEDT("B",NAME,""))
+6 IF '$DATA(^AUTTEDT(IEN,210))
QUIT
+7 SET IND=0
+8 FOR
SET IND=+$ORDER(^AUTTEDT(IEN,210,IND))
if IND=0
QUIT
Begin DoDot:2
+9 SET TEMP=^AUTTEDT(IEN,210,IND,0)
+10 SET CODESYS=$PIECE(TEMP,U,1)
SET CODE=$PIECE(TEMP,U,2)
+11 IF CODE'=""
Begin DoDot:3
+12 SET INACTDT=$$INACTDT(CODESYS,CODE)
+13 IF INACTDT'=""
SET ^TMP($JOB,NODE,"EDU",NAME,IEN,CODESYS,CODE)=INACTDT
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
+16 ;==========================================
EXAM(NODE) ;Search Exams for mapped codes that are inactive and produce a list.
+1 NEW CODE,CODESYS,IEN,INACTDT,IND,NAME,TEMP
+2 SET NAME=""
+3 FOR
SET NAME=$ORDER(^AUTTEXAM("B",NAME))
if NAME=""
QUIT
Begin DoDot:1
+4 SET IEN=$ORDER(^AUTTEXAM("B",NAME,""))
+5 IF '$DATA(^AUTTEXAM(IEN,210))
QUIT
+6 SET IND=0
+7 FOR
SET IND=+$ORDER(^AUTTEXAM(IEN,210,IND))
if IND=0
QUIT
Begin DoDot:2
+8 SET TEMP=^AUTTEXAM(IEN,210,IND,0)
+9 SET CODESYS=$PIECE(TEMP,U,1)
SET CODE=$PIECE(TEMP,U,2)
+10 IF CODE'=""
Begin DoDot:3
+11 SET INACTDT=$$INACTDT(CODESYS,CODE)
+12 IF INACTDT'=""
SET ^TMP($JOB,NODE,"EXAM",NAME,IEN,CODESYS,CODE)=INACTDT
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
+15 ;==========================================
HF(NODE) ;Search Health Factors for mapped codes that are inactive and produce
+1 ;a list.
+2 NEW CODE,CODESYS,IEN,INACTDT,IND,NAME,TEMP
+3 SET NAME=""
+4 FOR
SET NAME=$ORDER(^AUTTHF("B",NAME))
if NAME=""
QUIT
Begin DoDot:1
+5 SET IEN=$ORDER(^AUTTHF("B",NAME,""))
+6 IF '$DATA(^AUTTHF(IEN,210))
QUIT
+7 SET IND=0
+8 FOR
SET IND=+$ORDER(^AUTTHF(IEN,210,IND))
if IND=0
QUIT
Begin DoDot:2
+9 SET TEMP=^AUTTHF(IEN,210,IND,0)
+10 SET CODESYS=$PIECE(TEMP,U,1)
SET CODE=$PIECE(TEMP,U,2)
+11 IF CODE'=""
Begin DoDot:3
+12 SET INACTDT=$$INACTDT(CODESYS,CODE)
+13 IF INACTDT'=""
SET ^TMP($JOB,NODE,"HF",NAME,IEN,CODESYS,CODE)=INACTDT
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
+16 ;==========================================
IMM(NODE) ;Search Immunizations for mapped codes that are inactive and produce
+1 ;a list.
+2 NEW CODE,CODESYS,IEN,INACTDT,IND,JND,NAME,TEMP
+3 SET NAME=""
+4 FOR
SET NAME=$ORDER(^AUTTIMM("B",NAME))
if NAME=""
QUIT
Begin DoDot:1
+5 SET IEN=$ORDER(^AUTTIMM("B",NAME,""))
+6 SET IND=0
+7 FOR
SET IND=+$ORDER(^AUTTIMM(IEN,3,IND))
if IND=0
QUIT
Begin DoDot:2
+8 SET CODESYS=^AUTTIMM(IEN,3,IND,0)
+9 SET JND=0
+10 FOR
SET JND=+$ORDER(^AUTTIMM(IEN,3,IND,1,JND))
if JND=0
QUIT
Begin DoDot:3
+11 SET CODE=^AUTTIMM(IEN,3,IND,1,JND,0)
+12 SET INACTDT=$$INACTDT(CODESYS,CODE)
+13 IF INACTDT'=""
SET ^TMP($JOB,NODE,"IMM",NAME,IEN,CODESYS,CODE)=INACTDT
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
+16 ;==========================================
INACTDT(CODESYS,CODE) ;Given a coding system and a code, check and if the
+1 ;code is inactive return the inactivation date otherwise return null.
+2 NEW ACTDT,INACTDT,RESULT,PDATA
+3 ;ICR #5679
+4 SET RESULT=$$PERIOD^LEXU(CODE,CODESYS,.PDATA)
+5 IF +RESULT=-1
Begin DoDot:1
+6 ;DBIA #1997, #3991
+7 IF (CODESYS="CPC")!(CODESYS="CPT")
DO PERIOD^ICPTAPIU(CODE,.PDATA)
+8 IF (CODESYS="ICD")!(CODESYS="ICP")
DO PERIOD^ICDAPIU(CODE,.PDATA)
End DoDot:1
+9 SET ACTDT=1000101
SET INACTDT=""
+10 FOR
SET ACTDT=$ORDER(PDATA(ACTDT))
if (ACTDT="")!(INACTDT'="")
QUIT
Begin DoDot:1
+11 SET INACTDT=$PIECE(PDATA(ACTDT),U,1)
End DoDot:1
+12 QUIT INACTDT
+13 ;
+14 ;==========================================
MCICHK(TMPNODE,TEXT) ;Search Education Topics, Exams, Health Factors,
+1 ;Immunizations, and Skin Tests for mapped codes that are inactive
+2 ;and produce a list.
+3 NEW CODE,CODESYS,FILE,FNAME,IEN,INACTDT,NAME,NL
+4 SET FNAME("EDU")="EDUCATION TOPICS"
SET FNAME("EXAM")="EXAM"
+5 SET FNAME("HF")="HEALTH FACTORS"
SET FNAME("IMM")="IMMUNIZATION"
+6 SET FNAME("SKIN")="SKIN TEST"
+7 KILL ^TMP($JOB,TMPNODE)
+8 DO EDU(TMPNODE)
DO EXAM(TMPNODE)
DO HF(TMPNODE)
DO IMM(TMPNODE)
DO SKIN(TMPNODE)
+9 ;Create the report.
+10 SET FILE=""
SET NL=0
+11 FOR
SET FILE=$ORDER(^TMP($JOB,TMPNODE,FILE))
if FILE=""
QUIT
Begin DoDot:1
+12 IF NL>0
SET NL=NL+1
SET TEXT(NL)=""
SET NL=NL+1
SET TEXT(NL)="-----------------------------"
+13 SET NL=NL+1
SET TEXT(NL)=FNAME(FILE)_" inactive mapped codes."
+14 SET NAME=""
+15 FOR
SET NAME=$ORDER(^TMP($JOB,TMPNODE,FILE,NAME))
if NAME=""
QUIT
Begin DoDot:2
+16 SET IEN=$ORDER(^TMP($JOB,TMPNODE,FILE,NAME,""))
+17 SET NL=NL+1
SET TEXT(NL)=""
+18 SET NL=NL+1
SET TEXT(NL)=" "_NAME_" (IEN="_IEN_")"
+19 SET CODESYS=""
+20 FOR
SET CODESYS=$ORDER(^TMP($JOB,TMPNODE,FILE,NAME,IEN,CODESYS))
if CODESYS=""
QUIT
Begin DoDot:3
+21 SET CODE=""
+22 FOR
SET CODE=$ORDER(^TMP($JOB,TMPNODE,FILE,NAME,IEN,CODESYS,CODE))
if CODE=""
QUIT
Begin DoDot:4
+23 SET INACTDT=^TMP($JOB,TMPNODE,FILE,NAME,IEN,CODESYS,CODE)
+24 SET NL=NL+1
SET TEXT(NL)=" "_CODESYS_" "_CODE_", inactivated: "_$$FMTE^XLFDT(INACTDT,"5Z")
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+25 KILL ^TMP($JOB,TMPNODE)
+26 QUIT
+27 ;
+28 ;==========================================
SKIN(NODE) ;Search Skin Tests for mapped codes that are inactive and produce
+1 ;a list.
+2 NEW CODE,CODESYS,IEN,INACTDT,IND,JND,NAME,TEMP
+3 SET NAME=""
+4 FOR
SET NAME=$ORDER(^AUTTSK("B",NAME))
if NAME=""
QUIT
Begin DoDot:1
+5 SET IEN=$ORDER(^AUTTSK("B",NAME,""))
+6 SET IND=0
+7 FOR
SET IND=+$ORDER(^AUTTSK(IEN,3,IND))
if IND=0
QUIT
Begin DoDot:2
+8 SET CODESYS=^AUTTSK(IEN,3,IND,0)
+9 SET JND=0
+10 FOR
SET JND=+$ORDER(^AUTTSK(IEN,3,IND,1,JND))
if JND=0
QUIT
Begin DoDot:3
+11 SET CODE=^AUTTSK(IEN,3,IND,1,JND,0)
+12 SET INACTDT=$$INACTDT(CODESYS,CODE)
+13 IF INACTDT'=""
SET ^TMP($JOB,NODE,"SKIN",NAME,IEN,CODESYS,CODE)=INACTDT
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
