- PXMCODES ;SLC/PKR - Mapped codes listing for inquire. ;02/26/2016
- ;;1.0;PCE PATIENT CARE ENCOUNTER;**211**;Aug 12, 1996;Build 454
- ;
- ;Reference to LEXU supported by ICR #5679.
- ;
- ;==========================================
- MCDISP(CODELIST,NL,OUTPUT) ;Mapped codes display.
- N ACTDT,CHDR,CODE,CODESYS,DATE,DESC,FMTSTR,INACTDT,IND,INDXDT
- N MAPDT,NOLEX,NOUT,NP,PDATA,RESULT,TEXT,TEXTOUT
- S FMTSTR(1)="10L1^10C2^10C2^19C2^19C2"
- S FMTSTR(2)="15L1^60L"
- S CHDR(1)="Code Activation Inactivation Mapped Linked"
- S CHDR(2)="---------- ---------- ------------ ------------------- -------------------"
- S CHDR(3)="Code Description"
- S CHDR(4)="-------------- -----------"
- S NL=NL+1,OUTPUT(NL)=""
- S NL=NL+1,OUTPUT(NL)=" Code Mappings"
- I '$D(CODELIST) S NL=NL+1,OUTPUT(NL)="No codes are mapped" Q
- S CODESYS=""
- F S CODESYS=$O(CODELIST(CODESYS)) Q:CODESYS="" D
- . K DESC
- . S NL=NL+1,OUTPUT(NL)=""
- .;ICR #5679
- . S NL=NL+1,OUTPUT(NL)="Coding System: "_CODESYS_" = "_$P($$CSYS^LEXU(CODESYS),U,4)
- . S NL=NL+1,OUTPUT(NL)=CHDR(1)
- . S NL=NL+1,OUTPUT(NL)=CHDR(2)
- . S CODE=""
- . F S CODE=$O(CODELIST(CODESYS,CODE)) Q:CODE="" D
- .. S MAPDT=$$FMTE^XLFDT($P(CODELIST(CODESYS,CODE),U,1),"5Z")
- .. S INDXDT=$$FMTE^XLFDT($P(CODELIST(CODESYS,CODE),U,2),"5Z")
- ..;DBIA #5679
- .. K PDATA
- .. S NOLEX=0
- .. S RESULT=$$PERIOD^LEXU(CODE,CODESYS,.PDATA)
- .. I +RESULT=-1 D
- ... S NOLEX=1
- ...;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,NP=0
- .. F S ACTDT=$O(PDATA(ACTDT)) Q:ACTDT="" D
- ... S NP=NP+1
- ... S INACTDT=$$FMTE^XLFDT($P(PDATA(ACTDT),U,1),"5Z")
- ... S DESC(CODE)=CODE_U_$S(NOLEX=1:$P(PDATA(ACTDT),U,2),1:PDATA(ACTDT,0))
- ... I CODESYS="SCT" S DESC(CODE)=DESC(CODE)_" "_$$SCTHIER(CODE,ACTDT)
- ... I NP=1 S TEXT=CODE_U_$$FMTE^XLFDT(ACTDT,"5Z")_U_INACTDT_U_MAPDT_U_INDXDT
- ... I NP>1 S TEXT=U_$$FMTE^XLFDT(ACTDT,"5Z")_U_INACTDT
- ... D COLFMT^PXRMTEXT(FMTSTR(1),TEXT," ",.NOUT,.TEXTOUT)
- ... F IND=1:1:NOUT S NL=NL+1,OUTPUT(NL)=TEXTOUT(IND)
- .;Display the code descriptions.
- . S CODE="",NP=0
- . F S CODE=$O(DESC(CODE)) Q:CODE="" D
- .. S NP=NP+1
- .. I NP=1 D
- ... S NL=NL+1,OUTPUT(NL)=""
- ... S NL=NL+1,OUTPUT(NL)=CHDR(3)
- ... S NL=NL+1,OUTPUT(NL)=CHDR(4)
- .. D COLFMT^PXRMTEXT(FMTSTR(2),DESC(CODE)," ",.NOUT,.TEXTOUT)
- .. F IND=1:1:NOUT S NL=NL+1,OUTPUT(NL)=TEXTOUT(IND)
- Q
- ;
- ;==========================================
- SCTHIER(CODE,ACTDT) ;Return the SNOMED hierarchy.
- N FSN,HE,HIER,HS
- ;DBIA #5007
- S FSN=$$GETFSN^LEXTRAN1("SCT",CODE,ACTDT)
- S HS=$F(FSN,"(")
- S HE=$F(FSN,")",HS)
- S HIER=$E(FSN,HS-1,HE-1)
- Q HIER
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXMCODES 2779 printed Jan 18, 2025@03:30:41 Page 2
- PXMCODES ;SLC/PKR - Mapped codes listing for inquire. ;02/26/2016
- +1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**211**;Aug 12, 1996;Build 454
- +2 ;
- +3 ;Reference to LEXU supported by ICR #5679.
- +4 ;
- +5 ;==========================================
- MCDISP(CODELIST,NL,OUTPUT) ;Mapped codes display.
- +1 NEW ACTDT,CHDR,CODE,CODESYS,DATE,DESC,FMTSTR,INACTDT,IND,INDXDT
- +2 NEW MAPDT,NOLEX,NOUT,NP,PDATA,RESULT,TEXT,TEXTOUT
- +3 SET FMTSTR(1)="10L1^10C2^10C2^19C2^19C2"
- +4 SET FMTSTR(2)="15L1^60L"
- +5 SET CHDR(1)="Code Activation Inactivation Mapped Linked"
- +6 SET CHDR(2)="---------- ---------- ------------ ------------------- -------------------"
- +7 SET CHDR(3)="Code Description"
- +8 SET CHDR(4)="-------------- -----------"
- +9 SET NL=NL+1
- SET OUTPUT(NL)=""
- +10 SET NL=NL+1
- SET OUTPUT(NL)=" Code Mappings"
- +11 IF '$DATA(CODELIST)
- SET NL=NL+1
- SET OUTPUT(NL)="No codes are mapped"
- QUIT
- +12 SET CODESYS=""
- +13 FOR
- SET CODESYS=$ORDER(CODELIST(CODESYS))
- if CODESYS=""
- QUIT
- Begin DoDot:1
- +14 KILL DESC
- +15 SET NL=NL+1
- SET OUTPUT(NL)=""
- +16 ;ICR #5679
- +17 SET NL=NL+1
- SET OUTPUT(NL)="Coding System: "_CODESYS_" = "_$PIECE($$CSYS^LEXU(CODESYS),U,4)
- +18 SET NL=NL+1
- SET OUTPUT(NL)=CHDR(1)
- +19 SET NL=NL+1
- SET OUTPUT(NL)=CHDR(2)
- +20 SET CODE=""
- +21 FOR
- SET CODE=$ORDER(CODELIST(CODESYS,CODE))
- if CODE=""
- QUIT
- Begin DoDot:2
- +22 SET MAPDT=$$FMTE^XLFDT($PIECE(CODELIST(CODESYS,CODE),U,1),"5Z")
- +23 SET INDXDT=$$FMTE^XLFDT($PIECE(CODELIST(CODESYS,CODE),U,2),"5Z")
- +24 ;DBIA #5679
- +25 KILL PDATA
- +26 SET NOLEX=0
- +27 SET RESULT=$$PERIOD^LEXU(CODE,CODESYS,.PDATA)
- +28 IF +RESULT=-1
- Begin DoDot:3
- +29 SET NOLEX=1
- +30 ;DBIA #1997, #3991
- +31 IF (CODESYS="CPC")!(CODESYS="CPT")
- DO PERIOD^ICPTAPIU(CODE,.PDATA)
- +32 IF (CODESYS="ICD")!(CODESYS="ICP")
- DO PERIOD^ICDAPIU(CODE,.PDATA)
- End DoDot:3
- +33 SET ACTDT=1000101
- SET NP=0
- +34 FOR
- SET ACTDT=$ORDER(PDATA(ACTDT))
- if ACTDT=""
- QUIT
- Begin DoDot:3
- +35 SET NP=NP+1
- +36 SET INACTDT=$$FMTE^XLFDT($PIECE(PDATA(ACTDT),U,1),"5Z")
- +37 SET DESC(CODE)=CODE_U_$SELECT(NOLEX=1:$PIECE(PDATA(ACTDT),U,2),1:PDATA(ACTDT,0))
- +38 IF CODESYS="SCT"
- SET DESC(CODE)=DESC(CODE)_" "_$$SCTHIER(CODE,ACTDT)
- +39 IF NP=1
- SET TEXT=CODE_U_$$FMTE^XLFDT(ACTDT,"5Z")_U_INACTDT_U_MAPDT_U_INDXDT
- +40 IF NP>1
- SET TEXT=U_$$FMTE^XLFDT(ACTDT,"5Z")_U_INACTDT
- +41 DO COLFMT^PXRMTEXT(FMTSTR(1),TEXT," ",.NOUT,.TEXTOUT)
- +42 FOR IND=1:1:NOUT
- SET NL=NL+1
- SET OUTPUT(NL)=TEXTOUT(IND)
- End DoDot:3
- End DoDot:2
- +43 ;Display the code descriptions.
- +44 SET CODE=""
- SET NP=0
- +45 FOR
- SET CODE=$ORDER(DESC(CODE))
- if CODE=""
- QUIT
- Begin DoDot:2
- +46 SET NP=NP+1
- +47 IF NP=1
- Begin DoDot:3
- +48 SET NL=NL+1
- SET OUTPUT(NL)=""
- +49 SET NL=NL+1
- SET OUTPUT(NL)=CHDR(3)
- +50 SET NL=NL+1
- SET OUTPUT(NL)=CHDR(4)
- End DoDot:3
- +51 DO COLFMT^PXRMTEXT(FMTSTR(2),DESC(CODE)," ",.NOUT,.TEXTOUT)
- +52 FOR IND=1:1:NOUT
- SET NL=NL+1
- SET OUTPUT(NL)=TEXTOUT(IND)
- End DoDot:2
- End DoDot:1
- +53 QUIT
- +54 ;
- +55 ;==========================================
- SCTHIER(CODE,ACTDT) ;Return the SNOMED hierarchy.
- +1 NEW FSN,HE,HIER,HS
- +2 ;DBIA #5007
- +3 SET FSN=$$GETFSN^LEXTRAN1("SCT",CODE,ACTDT)
- +4 SET HS=$FIND(FSN,"(")
- +5 SET HE=$FIND(FSN,")",HS)
- +6 SET HIER=$EXTRACT(FSN,HS-1,HE-1)
- +7 QUIT HIER
- +8 ;