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