PXLEX ;SLC/PKR - Routines for PCE Lexicon functionality. ;09/29/2020
;;1.0;PCE PATIENT CARE ENCOUNTER;**211**;Aug 12, 1996;Build 454
;
;Reference to LEXU supported by ICR #5679.
;
;==========================================
CODESYSL(CODESYSL,MAP) ;Return the list of Lexicon coding systems supported
;by PCE.
S CODESYSL("SCT")=""
I 'MAP S CODESYSL(0)=1 Q
;If MAP is true then add the addtional coding systems that can be
;used for mapping.
S CODESYSL("10D")="",CODESYSL("10P")=""
S CODESYSL("CPC")="",CODESYSL("CPT")=""
S CODESYSL("ICD")="",CODESYSL("ICP")=""
S CODESYSL(0)=7
Q
;
;=========================================
CSHELP ;Display help, used as executable help for coding systems fields.
N DIR0,TEXT
;DBIA #5746 covers kill and set of DDS. DDS needs to be set or the
;Browser will kill some ScreenMan variables.
D CSHTEXT(.TEXT)
D BROWSE^DDBR("TEXT","NR","Supported PCE Coding Systems Help")
I $D(DDS) D REFRESH^DDSUTL S DY=IOSL-7,DX=0 X IOXY S $Y=DY,$X=DX
Q
;
;=========================================
CSHTEXT(TEXT) ;Supported coding systems help text.
N CODESYS,CODESYSL,NL,TEMP
S TEXT(1)="The following coding systems are supported in PCE:"
S TEXT(2)=""
D CODESYSL(.CODESYSL,1)
S CODESYS=0,NL=2
F S CODESYS=$O(CODESYSL(CODESYS)) Q:CODESYS="" D
.;DBIA #5679
. S TEMP=$$CSYS^LEXU(CODESYS)
. S NL=NL+1,TEXT(NL)=CODESYS_" = "_$P(TEMP,U,4)_"; "_$P(TEMP,U,5)
Q
;
;==========================================
GETCSYS(MAP) ;Let the user select a coding system.
N CODESYS,CODESYSL,CODESYSN,DIR
;If MAP is true then CODESYSL will contain all the coding systems that
;can be used for mapping.
D CODESYSL^PXLEX(.CODESYSL,MAP)
I CODESYSL(0)=1 D Q CODESYS
. S CODESYS=$O(CODESYSL(0))
. S $P(PXCEAFTR(0),U,5)=CODESYS
. W !,CODESYS," is the only available coding system."
S DIR(0)="S^",DIR("A")="Select a coding system"
S DIR("A",1)="Enter '^' to exit."
S CODESYS=0
F S CODESYS=$O(CODESYSL(CODESYS)) Q:CODESYS="" D
.;DBIA #5679
. S CODESYSN=$P($$CSYS^LEXU(CODESYS),U,4)
. S DIR(0)=DIR(0)_CODESYS_":"_CODESYSN_";"
D ^DIR
I $D(DIRUT) S (X,Y)="" Q ""
S (CODESYS,$P(PXCEAFTR(0),U,5))=$$UP^XLFSTR(X)
Q CODESYS
;
;==========================================
GETST() ;Let the user input a Lexicon search term.
N DIR,DIRUT,X,Y
S DIR(0)="FAO^2:240"
S DIR("A")=""
S DIR("A",1)="Input the Lexicon search term:"
D ^DIR
I $D(DIRUT) Q ""
Q X
;
;==========================================
ISCACT(CODESYS,CODE,DOI) ;Return 1 if the code was active on the date
;of interest DOI, otherwise return 0.
N DATE,HDATA,NEVENTS,SUB
;DBIA #5679
S NEVENTS=$$HIST^LEXU(CODE,CODESYS,.HDATA)
I $P(NEVENTS,U,1)=-1 Q 0
S DOI=$$FMADD^XLFDT(DOI,0,0,0,1)
S DATE=$O(HDATA(DOI),-1)
I DATE=0 Q 0
S SUB=$O(HDATA(DATE,""))
;If the second subscript is 0 then the code is inactive.
Q $S(SUB=0:0,1:1)
;
;==========================================
VCODE(CODESYS,CODE) ;Check that a code in the specified coding system is valid.
N DATA,IEN,RESULT,VALID
S VALID=0
;DBIA #5679
S RESULT=$$HIST^LEXU(CODE,CODESYS,.DATA)
I $P(RESULT,U,1)'=-1 Q 1
I (CODESYS="CPC")!(CODESYS="CPT") D
.;DBIA #1995
. S RESULT=$$CPT^ICPTCOD(CODE)
. S IEN=$P(RESULT,U,1)
. I IEN=-1 S VALID=0 Q
. I IEN=CODE S VALID=0 Q
. I CODESYS="CPC",$P(RESULT,U,5)="H" S VALID=1 Q
. I CODESYS="CPT",$P(RESULT,U,5)="C" S VALID=1 Q
I VALID=1 Q VALID
;DBIA #3990
I CODESYS="ICD" S RESULT=$$ICDDX^ICDCODE(CODE,DT,"",0)
I CODESYS="ICP" S RESULT=$$ICDOP^ICDCODE(CODE,DT,"",0)
S IEN=$P(RESULT,U,1)
I IEN=-1 S VALID=0
I CODE=IEN S VALID=0
Q VALID
;
;==========================================
VCODESYS(CODESYS,MF) ;Make sure the coding system is supported.
N CODESYSL,RESULT
S CODESYS=$$UP^XLFSTR(CODESYS)
;ICR #5679
S RESULT=$$CSYS^LEXU(CODESYS)
I RESULT="-1^Coding System not found" D Q 0
. I 'MF Q
. D EN^DDIOL("The "_CODESYS_" coding system is not supported by the Lexicon.")
. H 3
D CODESYSL^PXLEX(.CODESYSL,1)
I '$D(CODESYSL(CODESYS)) D Q 0
. I 'MF Q
. D EN^DDIOL(CODESYS_" is not a valid coding system for use with PCE.")
. H 3
Q 1
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXLEX 4196 printed Apr 09, 2024@21:32:25 Page 2
PXLEX ;SLC/PKR - Routines for PCE Lexicon functionality. ;09/29/2020
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**211**;Aug 12, 1996;Build 454
+2 ;
+3 ;Reference to LEXU supported by ICR #5679.
+4 ;
+5 ;==========================================
CODESYSL(CODESYSL,MAP) ;Return the list of Lexicon coding systems supported
+1 ;by PCE.
+2 SET CODESYSL("SCT")=""
+3 IF 'MAP
SET CODESYSL(0)=1
QUIT
+4 ;If MAP is true then add the addtional coding systems that can be
+5 ;used for mapping.
+6 SET CODESYSL("10D")=""
SET CODESYSL("10P")=""
+7 SET CODESYSL("CPC")=""
SET CODESYSL("CPT")=""
+8 SET CODESYSL("ICD")=""
SET CODESYSL("ICP")=""
+9 SET CODESYSL(0)=7
+10 QUIT
+11 ;
+12 ;=========================================
CSHELP ;Display help, used as executable help for coding systems fields.
+1 NEW DIR0,TEXT
+2 ;DBIA #5746 covers kill and set of DDS. DDS needs to be set or the
+3 ;Browser will kill some ScreenMan variables.
+4 DO CSHTEXT(.TEXT)
+5 DO BROWSE^DDBR("TEXT","NR","Supported PCE Coding Systems Help")
+6 IF $DATA(DDS)
DO REFRESH^DDSUTL
SET DY=IOSL-7
SET DX=0
XECUTE IOXY
SET $Y=DY
SET $X=DX
+7 QUIT
+8 ;
+9 ;=========================================
CSHTEXT(TEXT) ;Supported coding systems help text.
+1 NEW CODESYS,CODESYSL,NL,TEMP
+2 SET TEXT(1)="The following coding systems are supported in PCE:"
+3 SET TEXT(2)=""
+4 DO CODESYSL(.CODESYSL,1)
+5 SET CODESYS=0
SET NL=2
+6 FOR
SET CODESYS=$ORDER(CODESYSL(CODESYS))
if CODESYS=""
QUIT
Begin DoDot:1
+7 ;DBIA #5679
+8 SET TEMP=$$CSYS^LEXU(CODESYS)
+9 SET NL=NL+1
SET TEXT(NL)=CODESYS_" = "_$PIECE(TEMP,U,4)_"; "_$PIECE(TEMP,U,5)
End DoDot:1
+10 QUIT
+11 ;
+12 ;==========================================
GETCSYS(MAP) ;Let the user select a coding system.
+1 NEW CODESYS,CODESYSL,CODESYSN,DIR
+2 ;If MAP is true then CODESYSL will contain all the coding systems that
+3 ;can be used for mapping.
+4 DO CODESYSL^PXLEX(.CODESYSL,MAP)
+5 IF CODESYSL(0)=1
Begin DoDot:1
+6 SET CODESYS=$ORDER(CODESYSL(0))
+7 SET $PIECE(PXCEAFTR(0),U,5)=CODESYS
+8 WRITE !,CODESYS," is the only available coding system."
End DoDot:1
QUIT CODESYS
+9 SET DIR(0)="S^"
SET DIR("A")="Select a coding system"
+10 SET DIR("A",1)="Enter '^' to exit."
+11 SET CODESYS=0
+12 FOR
SET CODESYS=$ORDER(CODESYSL(CODESYS))
if CODESYS=""
QUIT
Begin DoDot:1
+13 ;DBIA #5679
+14 SET CODESYSN=$PIECE($$CSYS^LEXU(CODESYS),U,4)
+15 SET DIR(0)=DIR(0)_CODESYS_":"_CODESYSN_";"
End DoDot:1
+16 DO ^DIR
+17 IF $DATA(DIRUT)
SET (X,Y)=""
QUIT ""
+18 SET (CODESYS,$PIECE(PXCEAFTR(0),U,5))=$$UP^XLFSTR(X)
+19 QUIT CODESYS
+20 ;
+21 ;==========================================
GETST() ;Let the user input a Lexicon search term.
+1 NEW DIR,DIRUT,X,Y
+2 SET DIR(0)="FAO^2:240"
+3 SET DIR("A")=""
+4 SET DIR("A",1)="Input the Lexicon search term:"
+5 DO ^DIR
+6 IF $DATA(DIRUT)
QUIT ""
+7 QUIT X
+8 ;
+9 ;==========================================
ISCACT(CODESYS,CODE,DOI) ;Return 1 if the code was active on the date
+1 ;of interest DOI, otherwise return 0.
+2 NEW DATE,HDATA,NEVENTS,SUB
+3 ;DBIA #5679
+4 SET NEVENTS=$$HIST^LEXU(CODE,CODESYS,.HDATA)
+5 IF $PIECE(NEVENTS,U,1)=-1
QUIT 0
+6 SET DOI=$$FMADD^XLFDT(DOI,0,0,0,1)
+7 SET DATE=$ORDER(HDATA(DOI),-1)
+8 IF DATE=0
QUIT 0
+9 SET SUB=$ORDER(HDATA(DATE,""))
+10 ;If the second subscript is 0 then the code is inactive.
+11 QUIT $SELECT(SUB=0:0,1:1)
+12 ;
+13 ;==========================================
VCODE(CODESYS,CODE) ;Check that a code in the specified coding system is valid.
+1 NEW DATA,IEN,RESULT,VALID
+2 SET VALID=0
+3 ;DBIA #5679
+4 SET RESULT=$$HIST^LEXU(CODE,CODESYS,.DATA)
+5 IF $PIECE(RESULT,U,1)'=-1
QUIT 1
+6 IF (CODESYS="CPC")!(CODESYS="CPT")
Begin DoDot:1
+7 ;DBIA #1995
+8 SET RESULT=$$CPT^ICPTCOD(CODE)
+9 SET IEN=$PIECE(RESULT,U,1)
+10 IF IEN=-1
SET VALID=0
QUIT
+11 IF IEN=CODE
SET VALID=0
QUIT
+12 IF CODESYS="CPC"
IF $PIECE(RESULT,U,5)="H"
SET VALID=1
QUIT
+13 IF CODESYS="CPT"
IF $PIECE(RESULT,U,5)="C"
SET VALID=1
QUIT
End DoDot:1
+14 IF VALID=1
QUIT VALID
+15 ;DBIA #3990
+16 IF CODESYS="ICD"
SET RESULT=$$ICDDX^ICDCODE(CODE,DT,"",0)
+17 IF CODESYS="ICP"
SET RESULT=$$ICDOP^ICDCODE(CODE,DT,"",0)
+18 SET IEN=$PIECE(RESULT,U,1)
+19 IF IEN=-1
SET VALID=0
+20 IF CODE=IEN
SET VALID=0
+21 QUIT VALID
+22 ;
+23 ;==========================================
VCODESYS(CODESYS,MF) ;Make sure the coding system is supported.
+1 NEW CODESYSL,RESULT
+2 SET CODESYS=$$UP^XLFSTR(CODESYS)
+3 ;ICR #5679
+4 SET RESULT=$$CSYS^LEXU(CODESYS)
+5 IF RESULT="-1^Coding System not found"
Begin DoDot:1
+6 IF 'MF
QUIT
+7 DO EN^DDIOL("The "_CODESYS_" coding system is not supported by the Lexicon.")
+8 HANG 3
End DoDot:1
QUIT 0
+9 DO CODESYSL^PXLEX(.CODESYSL,1)
+10 IF '$DATA(CODESYSL(CODESYS))
Begin DoDot:1
+11 IF 'MF
QUIT
+12 DO EN^DDIOL(CODESYS_" is not a valid coding system for use with PCE.")
+13 HANG 3
End DoDot:1
QUIT 0
+14 QUIT 1
+15 ;
