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 Sep 23, 2025@20:05: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 ;
