Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PXLEX

PXLEX.m

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