- 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 Feb 18, 2025@23:55:56 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 ;