- PXRMPDX ; SLC/PKR - API for previous encounter diagnosis ;10/26/2020
- ;;2.0;CLINICAL REMINDERS;**44**;Feb 04, 2005;Build 11
- ;
- ;====================
- PRENDIAG(DFN,BDT,ENCDATE,DIAGLIST) ;
- ;Reference to ICDEX supported by ICR #5747
- ;Reference to LEXSRC2 supported by ICR #4083
- N CODE,CODELIST,DONE,DS,LD,LEXDATA,NL,PS
- N STATUS,SD,TEMP,VPOVIEN
- I $G(^PXRMINDX(9000010.07,"DATE BUILT"))="" Q -1
- S DS=$$CTFMD^PXRMDATE(BDT)-.000001
- F PS="P","S" D
- . S CODE="",DONE=0
- . F S CODE=$O(^PXRMINDX(9000010.07,"10D","PPI",DFN,PS,CODE)) Q:CODE="" D
- .. K LEXDATA
- .. S STATUS=$$STATCHK^LEXSRC2(CODE,ENCDATE,.LEXDATA,30)
- ..;If the code is not active on the encounter date skip it.
- .. I $P(STATUS,U,1)=0 Q
- .. S DATE=DS
- .. F S DATE=$O(^PXRMINDX(9000010.07,"10D","PPI",DFN,PS,CODE,DATE)) Q:DATE="" D
- ... S VPOVIEN=""
- ... F S VPOVIEN=$O(^PXRMINDX(9000010.07,"10D","PPI",DFN,PS,CODE,DATE,VPOVIEN)) Q:VPOVIEN="" D
- ....;Filters
- .... S TEMP=^AUPNVPOV(VPOVIEN,0)
- .... S VISITIEN=$P(TEMP,U,3)
- ....;The encounter status must be CHECKED OUT.
- ....;ICR #4850
- .... S STATUS=$$STATUS^SDPCE(VISITIEN)
- .... I $P(STATUS,U,2)'="CHECKED OUT" Q
- .... S CODEIEN=$P($$CODEN^ICDEX(CODE,80),"~",1)
- .... S TEMP=$$SD^ICDEX(80,CODEIEN)
- .... I $D(LD(CODE)) Q
- .... S SD(TEMP,CODE)=$P(LEXDATA(1),U,1)
- .... S LD(CODE)=$P(LEXDATA(1),U,2)
- S DIAGLIST(1)="^Prior Encounter Diagnoses"
- I '$D(SD) Q 0
- S TEMP="",NL=1
- F S TEMP=$O(SD(TEMP)) Q:TEMP="" D
- . S CODE=$O(SD(TEMP,""))
- . S NL=NL+1
- . S DIAGLIST(NL)=CODE_U_TEMP_"^^^^^^^"_SD(TEMP,CODE)_U_LD(CODE)
- Q NL
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMPDX 1586 printed Mar 13, 2025@20:53:10 Page 2
- PXRMPDX ; SLC/PKR - API for previous encounter diagnosis ;10/26/2020
- +1 ;;2.0;CLINICAL REMINDERS;**44**;Feb 04, 2005;Build 11
- +2 ;
- +3 ;====================
- PRENDIAG(DFN,BDT,ENCDATE,DIAGLIST) ;
- +1 ;Reference to ICDEX supported by ICR #5747
- +2 ;Reference to LEXSRC2 supported by ICR #4083
- +3 NEW CODE,CODELIST,DONE,DS,LD,LEXDATA,NL,PS
- +4 NEW STATUS,SD,TEMP,VPOVIEN
- +5 IF $GET(^PXRMINDX(9000010.07,"DATE BUILT"))=""
- QUIT -1
- +6 SET DS=$$CTFMD^PXRMDATE(BDT)-.000001
- +7 FOR PS="P","S"
- Begin DoDot:1
- +8 SET CODE=""
- SET DONE=0
- +9 FOR
- SET CODE=$ORDER(^PXRMINDX(9000010.07,"10D","PPI",DFN,PS,CODE))
- if CODE=""
- QUIT
- Begin DoDot:2
- +10 KILL LEXDATA
- +11 SET STATUS=$$STATCHK^LEXSRC2(CODE,ENCDATE,.LEXDATA,30)
- +12 ;If the code is not active on the encounter date skip it.
- +13 IF $PIECE(STATUS,U,1)=0
- QUIT
- +14 SET DATE=DS
- +15 FOR
- SET DATE=$ORDER(^PXRMINDX(9000010.07,"10D","PPI",DFN,PS,CODE,DATE))
- if DATE=""
- QUIT
- Begin DoDot:3
- +16 SET VPOVIEN=""
- +17 FOR
- SET VPOVIEN=$ORDER(^PXRMINDX(9000010.07,"10D","PPI",DFN,PS,CODE,DATE,VPOVIEN))
- if VPOVIEN=""
- QUIT
- Begin DoDot:4
- +18 ;Filters
- +19 SET TEMP=^AUPNVPOV(VPOVIEN,0)
- +20 SET VISITIEN=$PIECE(TEMP,U,3)
- +21 ;The encounter status must be CHECKED OUT.
- +22 ;ICR #4850
- +23 SET STATUS=$$STATUS^SDPCE(VISITIEN)
- +24 IF $PIECE(STATUS,U,2)'="CHECKED OUT"
- QUIT
- +25 SET CODEIEN=$PIECE($$CODEN^ICDEX(CODE,80),"~",1)
- +26 SET TEMP=$$SD^ICDEX(80,CODEIEN)
- +27 IF $DATA(LD(CODE))
- QUIT
- +28 SET SD(TEMP,CODE)=$PIECE(LEXDATA(1),U,1)
- +29 SET LD(CODE)=$PIECE(LEXDATA(1),U,2)
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +30 SET DIAGLIST(1)="^Prior Encounter Diagnoses"
- +31 IF '$DATA(SD)
- QUIT 0
- +32 SET TEMP=""
- SET NL=1
- +33 FOR
- SET TEMP=$ORDER(SD(TEMP))
- if TEMP=""
- QUIT
- Begin DoDot:1
- +34 SET CODE=$ORDER(SD(TEMP,""))
- +35 SET NL=NL+1
- +36 SET DIAGLIST(NL)=CODE_U_TEMP_"^^^^^^^"_SD(TEMP,CODE)_U_LD(CODE)
- End DoDot:1
- +37 QUIT NL
- +38 ;
