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 Apr 09, 2024@20:55: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 ;
