GMPLPXRM ; SLC/PKR - Build Clinical Reminder Index for AUPNPROB. ;10/22/2014
;;2.0;Problem List;**27,43,44,47**;Aug 25, 1994;Build 58
;DBIA #4113 supports PXRMSXRM entry points.
;DBIA #4114 supports setting and killing ^PXRMINDX(9000011)
;DBIA #5747 covers references to ^ICDEX entry point.
;===================================
INDEX ;Build the indexes for PROBLEM LIST.
N CODE,CODEP,CODESYS,COND,DAS,DAS803,DFN,DIFF,DLM,DONE
N END,ENTRIES,ETEXT,GLOBAL,IND,JND,NE,NERROR,PRIO,PROB
N START,STATUS,TEMP,TENP,TEXT
;Don't leave any old stuff around.
K ^PXRMINDX(9000011)
S GLOBAL=$$GET1^DID(9000011,"","","GLOBAL NAME")
S ENTRIES=$P(^AUPNPROB(0),U,4)
S TENP=ENTRIES/10
S TENP=+$P(TENP,".",1)
I TENP<1 S TENP=1
D BMES^XPDUTL("Building indexes PROBLEM LIST")
S TEXT="There are "_ENTRIES_" entries to process."
D MES^XPDUTL(TEXT)
S START=$H
S (DAS,DONE,IND,NE,NERROR)=0
F S DAS=$O(^AUPNPROB(DAS)) Q:DONE D
. N GMPDT,GMPCSYS
. I +DAS=0 S DONE=1 Q
. I +DAS'=DAS D Q
.. S DONE=1
.. S ETEXT="Bad ien: "_DAS_", cannot continue."
.. D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
. S IND=IND+1
. I IND#TENP=0 D
.. S TEXT="Processing entry "_IND
.. D MES^XPDUTL(TEXT)
. I IND#10000=0 W "."
. S TEMP=$G(^AUPNPROB(DAS,1))
. S COND=$P(TEMP,U,2)
.;Don't index Hidden problems.
. I COND="H" Q
. S PRIO=$P(TEMP,U,14)
.;If there is no priority set it to "U" for undefined.
. I PRIO="" S PRIO="U"
. S TEMP=^AUPNPROB(DAS,0)
. S CODEP=$P(TEMP,U,1)
. I CODEP="" D Q
.. S ETEXT=DAS_" missing problem"
.. D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
. S DFN=$P(TEMP,U,2)
. I DFN="" D Q
.. S ETEXT=DAS_" missing DFN"
.. D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
. S DLM=$P(TEMP,U,3)
. I DLM="" D Q
.. S ETEXT=DAS_" missing date last modified"
.. D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
. S STATUS=$P(TEMP,U,12)
. I STATUS="" D Q
.. S ETEXT=DAS_" missing status"
.. D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) Q
. S CODESYS=$P($G(^AUPNPROB(DAS,802)),U,2)
. I CODESYS="" S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80,CODEP)),U,3)
. S CODE=$$CODEC^ICDEX(80,CODEP)
. I +CODE=-1 D Q
.. S ETEXT=DAS_" has the invalid code "_CODE
.. D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
. S NE=NE+1
. S ^PXRMINDX(9000011,CODESYS,"ISPP",CODE,STATUS,PRIO,DFN,DLM,DAS)=""
. S ^PXRMINDX(9000011,CODESYS,"PSPI",DFN,STATUS,PRIO,CODE,DLM,DAS)=""
.;Check for a SNOMED CT code.
. S CODE=$P($G(^AUPNPROB(DAS,800)),U,1)
. I CODE="" Q
. S ^PXRMINDX(9000011,"SCT","ISPP",CODE,STATUS,PRIO,DFN,DLM,DAS)=""
. S ^PXRMINDX(9000011,"SCT","PSPI",DFN,STATUS,PRIO,CODE,DLM,DAS)=""
.;Check for entries in the Mapping Targets multiple.
. S JND=0
. F S JND=+$O(^AUPNPROB(DAS,803,JND)) Q:JND=0 D
.. S TEMP=^AUPNPROB(DAS,803,JND,0)
.. S CODE=$P(TEMP,U,1)
.. S CODESYS=$P(TEMP,U,2)
.. S DAS803=DAS_";803;"_JND
.. S ^PXRMINDX(9000011,CODESYS,"ISPP",CODE,STATUS,PRIO,DFN,DLM,DAS803)=""
.. S ^PXRMINDX(9000011,CODESYS,"PSPI",DFN,STATUS,PRIO,CODE,DLM,DAS803)=""
S END=$H
S TEXT=NE_" PROBLEM LIST results indexed."
D MES^XPDUTL(TEXT)
D DETIME^PXRMSXRM(START,END)
;If there were errors send a message.
I NERROR>0 D ERRMSG^PXRMSXRM(NERROR,GLOBAL)
;Send a MailMan message with the results.
D COMMSG^PXRMSXRM(GLOBAL,START,END,NE,NERROR)
S ^PXRMINDX(9000011,"GLOBAL NAME")=GLOBAL
S ^PXRMINDX(9000011,"BUILT BY")=DUZ
S ^PXRMINDX(9000011,"DATE BUILT")=$$NOW^XLFDT
Q
;
;===================================
KPROB01(X,DA) ;Delete Index entry for Problem List .01.
;X(1)=DIAGNOSIS, X(2)=DFN, X(3)=DATE LAST MODIFIED, X(4)=STATUS
;X(5)=PRIORITY, X(6)=CONDITION, X(7)=CODING SYSTEM
N CODE,CODESYS,PRIO
S CODE=$$CODEC^ICDEX(80,X(1))
I +CODE=-1 Q
S CODESYS=$G(X(7))
I CODESYS="" S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80,X(1))),U,3)
S PRIO=$S(X(5)="":"U",1:X(5))
K ^PXRMINDX(9000011,CODESYS,"ISPP",CODE,X(4),PRIO,X(2),X(3),DA)
K ^PXRMINDX(9000011,CODESYS,"PSPI",X(2),X(4),PRIO,CODE,X(3),DA)
Q
;
;===================================
KPROBMT(X,DA) ;Kill Index entry for Problem List Mapping Targets.
;X(1)=CODE, X(2)=CODING SYSTEM
N DAS,DFN,DLM,PRIO,STATUS,TEMP
I X(2)="" Q
S TEMP=^AUPNPROB(DA(1),1)
S PRIO=$P(TEMP,U,14)
I PRIO="" S PRIO="U"
S TEMP=^AUPNPROB(DA(1),0)
S DFN=$P(TEMP,U,2),DLM=$P(TEMP,U,3),STATUS=$P(TEMP,U,12)
S DAS=DA(1)_";"_803_";"_DA
K ^PXRMINDX(9000011,X(2),"ISPP",X(1),STATUS,PRIO,DFN,DLM,DAS)
K ^PXRMINDX(9000011,X(2),"PSPI",DFN,STATUS,PRIO,X(1),DLM,DAS)
Q
;
;===================================
KPROBMTA(X,DA) ;Whenever any of the fields in the 803 node index are changed
;kill the old index entry.
;X(1)=DATE LAST MODIFIED, X(2)=STATUS, X(3)=PRIORITY, X(4)=CONDITION
N CODE,CODESYS,DAS,DFN,IND,PRIO,TEMP
S PRIO=X(3)
I PRIO="" S PRIO="U"
S DFN=$P(^AUPNPROB(DA,0),U,2)
S IND=0
F S IND=+$O(^AUPNPROB(DA,803,IND)) Q:IND=0 D
. S TEMP=^AUPNPROB(DA,803,IND,0)
. S CODE=$P(TEMP,U,1),CODESYS=$P(TEMP,U,2)
. S DAS=DA_";"_803_";"_IND
. K ^PXRMINDX(9000011,CODESYS,"ISPP",CODE,X(2),PRIO,DFN,X(1),DAS)
. K ^PXRMINDX(9000011,CODESYS,"PSPI",DFN,X(2),PRIO,CODE,X(1),DAS)
Q
;
;===================================
KPROBSCT(X,DA) ;Delete Index entry for Problem List SNOMED CT.
;X(1)=SNOMED CT CONCEPT CODE, X(2)=DFN, X(3)=DATE LAST MODIFIED,
;X(4)=STATUS, X(5)=PRIORITY, X(6)=CONDITION
S PRIO=$S(X(5)="":"U",1:X(5))
K ^PXRMINDX(9000011,"SCT","ISPP",X(1),X(4),PRIO,X(2),X(3),DA)
K ^PXRMINDX(9000011,"SCT","PSPI",X(2),X(4),PRIO,X(1),X(3),DA)
Q
;
;===================================
PROBDATA(DAS,DATA) ;Return data for a Problem List entry.
;DBIA #5881
N EM,IEN,IND,TEMP
S IEN=$P(DAS,";",1)
S TEMP=^AUPNPROB(IEN,0)
S DATA("ICD DIAGNOSIS")=$P(TEMP,U,1)
S DATA("DATE LAST MODIFIED")=$P(TEMP,U,3)
S DATA("PROVIDER NARRATIVE")=$P(TEMP,U,5)
S DATA("DATE ENTERED")=$P(TEMP,U,8)
S DATA("STATUS")=$P(TEMP,U,12)
S DATA("DATE OF ONSET")=$P(TEMP,U,13)
S TEMP=^AUPNPROB(IEN,1)
S DATA("PROBLEM")=$P(TEMP,U,1)
S DATA("PROBLEM CONDITION")=$P(TEMP,U,2)
S DATA("RECORDING PROVIDER")=$P(TEMP,U,4)
S DATA("RESPONSIBLE PROVIDER")=$P(TEMP,U,5)
S DATA("DATE RESOLVED")=$P(TEMP,U,7)
S DATA("CLINIC")=$P(TEMP,U,8)
S DATA("PRIORITY")=$P(TEMP,U,14)
S DATA("DATE OF INTEREST")=$P($G(^AUPNPROB(IEN,802)),U,1)
I DAS'[";803;" Q
S IND=$P(DAS,";",3)
S TEMP=^AUPNPROB(IEN,803,IND,0)
S DATA("MT CODE")=$P(TEMP,U,1)
S DATA("MT CODING SYSTEM")=$P(TEMP,U,2)
S DATA("MT CODE DATE")=$P(TEMP,U,3)
Q
;
;===================================
SPROB01(X,DA) ;Set Index entry for Problem List .01.
;X(1)=DIAGNOSIS, X(2)=DFN, X(3)=DATE LAST MODIFIED, X(4)=STATUS
;X(5)=PRIORITY, X(6)=CONDITION, X(7)=CODING SYSTEM
;Don't index Hidden problems.
I X(6)="H" Q
N CODE,CODESYS,PRIO
S CODE=$$CODEC^ICDEX(80,X(1))
I +CODE=-1 Q
S CODESYS=$G(X(7))
I CODESYS="" S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80,X(1))),U,3)
S PRIO=$S(X(5)="":"U",1:X(5))
S ^PXRMINDX(9000011,CODESYS,"ISPP",CODE,X(4),PRIO,X(2),X(3),DA)=""
S ^PXRMINDX(9000011,CODESYS,"PSPI",X(2),X(4),PRIO,CODE,X(3),DA)=""
Q
;
;===================================
SPROBMT(X,DA) ;Set Index entry for Problem List Mapping Targets.
;X(1)=CODE, X(2)=CODING SYSTEM
N DAS,DFN,DLM,PRIO,STATUS,TEMP
S TEMP=^AUPNPROB(DA(1),1)
;Don't index Hidden problems.
I $P(TEMP,U,2)="H" Q
S PRIO=$P(TEMP,U,14)
I PRIO="" S PRIO="U"
S TEMP=^AUPNPROB(DA(1),0)
S DFN=$P(TEMP,U,2),DLM=$P(TEMP,U,3),STATUS=$P(TEMP,U,12)
S DAS=DA(1)_";"_803_";"_DA
S ^PXRMINDX(9000011,X(2),"ISPP",X(1),STATUS,PRIO,DFN,DLM,DAS)=""
S ^PXRMINDX(9000011,X(2),"PSPI",DFN,STATUS,PRIO,X(1),DLM,DAS)=""
Q
;
;===================================
SPROBMTA(X,DA) ;Whenever any of the fields in the 803 node index are changed
;set the index.
;X(1)=DATE LAST MODIFIED, X(2)=STATUS, X(3)=PRIORITY, X(4)=CONDITION
N CODE,CODESYS,DAS,DFN,IND,PRIO,TEMP
S TEMP=^AUPNPROB(DA,1)
;Don't index Hidden problems.
I X(4)="H" Q
S PRIO=X(3)
I PRIO="" S PRIO="U"
S DFN=$P(^AUPNPROB(DA,0),U,2)
S IND=0
F S IND=+$O(^AUPNPROB(DA,803,IND)) Q:IND=0 D
. S TEMP=^AUPNPROB(DA,803,IND,0)
. S CODE=$P(TEMP,U,1),CODESYS=$P(TEMP,U,2)
. S DAS=DA_";"_803_";"_IND
. S ^PXRMINDX(9000011,CODESYS,"ISPP",CODE,X(2),PRIO,DFN,X(1),DAS)=""
. S ^PXRMINDX(9000011,CODESYS,"PSPI",DFN,X(2),PRIO,CODE,X(1),DAS)=""
Q
;
;===================================
SPROBSCT(X,DA) ;Set Index entry for Problem List SNOMED CT.
;X(1)=SNOMED CT CONCEPT CODE, X(2)=DFN, X(3)=DATE LAST MODIFIED,
;X(4)=STATUS, X(5)=PRIORITY, X(6)=CONDITION
;Don't index Hidden problems.
I X(6)="H" Q
S PRIO=$S(X(5)="":"U",1:X(5))
S ^PXRMINDX(9000011,"SCT","ISPP",X(1),X(4),PRIO,X(2),X(3),DA)=""
S ^PXRMINDX(9000011,"SCT","PSPI",X(2),X(4),PRIO,X(1),X(3),DA)=""
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMPLPXRM 8808 printed Sep 02, 2024@19:15:40 Page 2
GMPLPXRM ; SLC/PKR - Build Clinical Reminder Index for AUPNPROB. ;10/22/2014
+1 ;;2.0;Problem List;**27,43,44,47**;Aug 25, 1994;Build 58
+2 ;DBIA #4113 supports PXRMSXRM entry points.
+3 ;DBIA #4114 supports setting and killing ^PXRMINDX(9000011)
+4 ;DBIA #5747 covers references to ^ICDEX entry point.
+5 ;===================================
INDEX ;Build the indexes for PROBLEM LIST.
+1 NEW CODE,CODEP,CODESYS,COND,DAS,DAS803,DFN,DIFF,DLM,DONE
+2 NEW END,ENTRIES,ETEXT,GLOBAL,IND,JND,NE,NERROR,PRIO,PROB
+3 NEW START,STATUS,TEMP,TENP,TEXT
+4 ;Don't leave any old stuff around.
+5 KILL ^PXRMINDX(9000011)
+6 SET GLOBAL=$$GET1^DID(9000011,"","","GLOBAL NAME")
+7 SET ENTRIES=$PIECE(^AUPNPROB(0),U,4)
+8 SET TENP=ENTRIES/10
+9 SET TENP=+$PIECE(TENP,".",1)
+10 IF TENP<1
SET TENP=1
+11 DO BMES^XPDUTL("Building indexes PROBLEM LIST")
+12 SET TEXT="There are "_ENTRIES_" entries to process."
+13 DO MES^XPDUTL(TEXT)
+14 SET START=$HOROLOG
+15 SET (DAS,DONE,IND,NE,NERROR)=0
+16 FOR
SET DAS=$ORDER(^AUPNPROB(DAS))
if DONE
QUIT
Begin DoDot:1
+17 NEW GMPDT,GMPCSYS
+18 IF +DAS=0
SET DONE=1
QUIT
+19 IF +DAS'=DAS
Begin DoDot:2
+20 SET DONE=1
+21 SET ETEXT="Bad ien: "_DAS_", cannot continue."
+22 DO ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
End DoDot:2
QUIT
+23 SET IND=IND+1
+24 IF IND#TENP=0
Begin DoDot:2
+25 SET TEXT="Processing entry "_IND
+26 DO MES^XPDUTL(TEXT)
End DoDot:2
+27 IF IND#10000=0
WRITE "."
+28 SET TEMP=$GET(^AUPNPROB(DAS,1))
+29 SET COND=$PIECE(TEMP,U,2)
+30 ;Don't index Hidden problems.
+31 IF COND="H"
QUIT
+32 SET PRIO=$PIECE(TEMP,U,14)
+33 ;If there is no priority set it to "U" for undefined.
+34 IF PRIO=""
SET PRIO="U"
+35 SET TEMP=^AUPNPROB(DAS,0)
+36 SET CODEP=$PIECE(TEMP,U,1)
+37 IF CODEP=""
Begin DoDot:2
+38 SET ETEXT=DAS_" missing problem"
+39 DO ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
End DoDot:2
QUIT
+40 SET DFN=$PIECE(TEMP,U,2)
+41 IF DFN=""
Begin DoDot:2
+42 SET ETEXT=DAS_" missing DFN"
+43 DO ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
End DoDot:2
QUIT
+44 SET DLM=$PIECE(TEMP,U,3)
+45 IF DLM=""
Begin DoDot:2
+46 SET ETEXT=DAS_" missing date last modified"
+47 DO ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
End DoDot:2
QUIT
+48 SET STATUS=$PIECE(TEMP,U,12)
+49 IF STATUS=""
Begin DoDot:2
+50 SET ETEXT=DAS_" missing status"
+51 DO ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
QUIT
End DoDot:2
QUIT
+52 SET CODESYS=$PIECE($GET(^AUPNPROB(DAS,802)),U,2)
+53 IF CODESYS=""
SET CODESYS=$PIECE($$SINFO^ICDEX($$CSI^ICDEX(80,CODEP)),U,3)
+54 SET CODE=$$CODEC^ICDEX(80,CODEP)
+55 IF +CODE=-1
Begin DoDot:2
+56 SET ETEXT=DAS_" has the invalid code "_CODE
+57 DO ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
End DoDot:2
QUIT
+58 SET NE=NE+1
+59 SET ^PXRMINDX(9000011,CODESYS,"ISPP",CODE,STATUS,PRIO,DFN,DLM,DAS)=""
+60 SET ^PXRMINDX(9000011,CODESYS,"PSPI",DFN,STATUS,PRIO,CODE,DLM,DAS)=""
+61 ;Check for a SNOMED CT code.
+62 SET CODE=$PIECE($GET(^AUPNPROB(DAS,800)),U,1)
+63 IF CODE=""
QUIT
+64 SET ^PXRMINDX(9000011,"SCT","ISPP",CODE,STATUS,PRIO,DFN,DLM,DAS)=""
+65 SET ^PXRMINDX(9000011,"SCT","PSPI",DFN,STATUS,PRIO,CODE,DLM,DAS)=""
+66 ;Check for entries in the Mapping Targets multiple.
+67 SET JND=0
+68 FOR
SET JND=+$ORDER(^AUPNPROB(DAS,803,JND))
if JND=0
QUIT
Begin DoDot:2
+69 SET TEMP=^AUPNPROB(DAS,803,JND,0)
+70 SET CODE=$PIECE(TEMP,U,1)
+71 SET CODESYS=$PIECE(TEMP,U,2)
+72 SET DAS803=DAS_";803;"_JND
+73 SET ^PXRMINDX(9000011,CODESYS,"ISPP",CODE,STATUS,PRIO,DFN,DLM,DAS803)=""
+74 SET ^PXRMINDX(9000011,CODESYS,"PSPI",DFN,STATUS,PRIO,CODE,DLM,DAS803)=""
End DoDot:2
End DoDot:1
+75 SET END=$HOROLOG
+76 SET TEXT=NE_" PROBLEM LIST results indexed."
+77 DO MES^XPDUTL(TEXT)
+78 DO DETIME^PXRMSXRM(START,END)
+79 ;If there were errors send a message.
+80 IF NERROR>0
DO ERRMSG^PXRMSXRM(NERROR,GLOBAL)
+81 ;Send a MailMan message with the results.
+82 DO COMMSG^PXRMSXRM(GLOBAL,START,END,NE,NERROR)
+83 SET ^PXRMINDX(9000011,"GLOBAL NAME")=GLOBAL
+84 SET ^PXRMINDX(9000011,"BUILT BY")=DUZ
+85 SET ^PXRMINDX(9000011,"DATE BUILT")=$$NOW^XLFDT
+86 QUIT
+87 ;
+88 ;===================================
KPROB01(X,DA) ;Delete Index entry for Problem List .01.
+1 ;X(1)=DIAGNOSIS, X(2)=DFN, X(3)=DATE LAST MODIFIED, X(4)=STATUS
+2 ;X(5)=PRIORITY, X(6)=CONDITION, X(7)=CODING SYSTEM
+3 NEW CODE,CODESYS,PRIO
+4 SET CODE=$$CODEC^ICDEX(80,X(1))
+5 IF +CODE=-1
QUIT
+6 SET CODESYS=$GET(X(7))
+7 IF CODESYS=""
SET CODESYS=$PIECE($$SINFO^ICDEX($$CSI^ICDEX(80,X(1))),U,3)
+8 SET PRIO=$SELECT(X(5)="":"U",1:X(5))
+9 KILL ^PXRMINDX(9000011,CODESYS,"ISPP",CODE,X(4),PRIO,X(2),X(3),DA)
+10 KILL ^PXRMINDX(9000011,CODESYS,"PSPI",X(2),X(4),PRIO,CODE,X(3),DA)
+11 QUIT
+12 ;
+13 ;===================================
KPROBMT(X,DA) ;Kill Index entry for Problem List Mapping Targets.
+1 ;X(1)=CODE, X(2)=CODING SYSTEM
+2 NEW DAS,DFN,DLM,PRIO,STATUS,TEMP
+3 IF X(2)=""
QUIT
+4 SET TEMP=^AUPNPROB(DA(1),1)
+5 SET PRIO=$PIECE(TEMP,U,14)
+6 IF PRIO=""
SET PRIO="U"
+7 SET TEMP=^AUPNPROB(DA(1),0)
+8 SET DFN=$PIECE(TEMP,U,2)
SET DLM=$PIECE(TEMP,U,3)
SET STATUS=$PIECE(TEMP,U,12)
+9 SET DAS=DA(1)_";"_803_";"_DA
+10 KILL ^PXRMINDX(9000011,X(2),"ISPP",X(1),STATUS,PRIO,DFN,DLM,DAS)
+11 KILL ^PXRMINDX(9000011,X(2),"PSPI",DFN,STATUS,PRIO,X(1),DLM,DAS)
+12 QUIT
+13 ;
+14 ;===================================
KPROBMTA(X,DA) ;Whenever any of the fields in the 803 node index are changed
+1 ;kill the old index entry.
+2 ;X(1)=DATE LAST MODIFIED, X(2)=STATUS, X(3)=PRIORITY, X(4)=CONDITION
+3 NEW CODE,CODESYS,DAS,DFN,IND,PRIO,TEMP
+4 SET PRIO=X(3)
+5 IF PRIO=""
SET PRIO="U"
+6 SET DFN=$PIECE(^AUPNPROB(DA,0),U,2)
+7 SET IND=0
+8 FOR
SET IND=+$ORDER(^AUPNPROB(DA,803,IND))
if IND=0
QUIT
Begin DoDot:1
+9 SET TEMP=^AUPNPROB(DA,803,IND,0)
+10 SET CODE=$PIECE(TEMP,U,1)
SET CODESYS=$PIECE(TEMP,U,2)
+11 SET DAS=DA_";"_803_";"_IND
+12 KILL ^PXRMINDX(9000011,CODESYS,"ISPP",CODE,X(2),PRIO,DFN,X(1),DAS)
+13 KILL ^PXRMINDX(9000011,CODESYS,"PSPI",DFN,X(2),PRIO,CODE,X(1),DAS)
End DoDot:1
+14 QUIT
+15 ;
+16 ;===================================
KPROBSCT(X,DA) ;Delete Index entry for Problem List SNOMED CT.
+1 ;X(1)=SNOMED CT CONCEPT CODE, X(2)=DFN, X(3)=DATE LAST MODIFIED,
+2 ;X(4)=STATUS, X(5)=PRIORITY, X(6)=CONDITION
+3 SET PRIO=$SELECT(X(5)="":"U",1:X(5))
+4 KILL ^PXRMINDX(9000011,"SCT","ISPP",X(1),X(4),PRIO,X(2),X(3),DA)
+5 KILL ^PXRMINDX(9000011,"SCT","PSPI",X(2),X(4),PRIO,X(1),X(3),DA)
+6 QUIT
+7 ;
+8 ;===================================
PROBDATA(DAS,DATA) ;Return data for a Problem List entry.
+1 ;DBIA #5881
+2 NEW EM,IEN,IND,TEMP
+3 SET IEN=$PIECE(DAS,";",1)
+4 SET TEMP=^AUPNPROB(IEN,0)
+5 SET DATA("ICD DIAGNOSIS")=$PIECE(TEMP,U,1)
+6 SET DATA("DATE LAST MODIFIED")=$PIECE(TEMP,U,3)
+7 SET DATA("PROVIDER NARRATIVE")=$PIECE(TEMP,U,5)
+8 SET DATA("DATE ENTERED")=$PIECE(TEMP,U,8)
+9 SET DATA("STATUS")=$PIECE(TEMP,U,12)
+10 SET DATA("DATE OF ONSET")=$PIECE(TEMP,U,13)
+11 SET TEMP=^AUPNPROB(IEN,1)
+12 SET DATA("PROBLEM")=$PIECE(TEMP,U,1)
+13 SET DATA("PROBLEM CONDITION")=$PIECE(TEMP,U,2)
+14 SET DATA("RECORDING PROVIDER")=$PIECE(TEMP,U,4)
+15 SET DATA("RESPONSIBLE PROVIDER")=$PIECE(TEMP,U,5)
+16 SET DATA("DATE RESOLVED")=$PIECE(TEMP,U,7)
+17 SET DATA("CLINIC")=$PIECE(TEMP,U,8)
+18 SET DATA("PRIORITY")=$PIECE(TEMP,U,14)
+19 SET DATA("DATE OF INTEREST")=$PIECE($GET(^AUPNPROB(IEN,802)),U,1)
+20 IF DAS'[";803;"
QUIT
+21 SET IND=$PIECE(DAS,";",3)
+22 SET TEMP=^AUPNPROB(IEN,803,IND,0)
+23 SET DATA("MT CODE")=$PIECE(TEMP,U,1)
+24 SET DATA("MT CODING SYSTEM")=$PIECE(TEMP,U,2)
+25 SET DATA("MT CODE DATE")=$PIECE(TEMP,U,3)
+26 QUIT
+27 ;
+28 ;===================================
SPROB01(X,DA) ;Set Index entry for Problem List .01.
+1 ;X(1)=DIAGNOSIS, X(2)=DFN, X(3)=DATE LAST MODIFIED, X(4)=STATUS
+2 ;X(5)=PRIORITY, X(6)=CONDITION, X(7)=CODING SYSTEM
+3 ;Don't index Hidden problems.
+4 IF X(6)="H"
QUIT
+5 NEW CODE,CODESYS,PRIO
+6 SET CODE=$$CODEC^ICDEX(80,X(1))
+7 IF +CODE=-1
QUIT
+8 SET CODESYS=$GET(X(7))
+9 IF CODESYS=""
SET CODESYS=$PIECE($$SINFO^ICDEX($$CSI^ICDEX(80,X(1))),U,3)
+10 SET PRIO=$SELECT(X(5)="":"U",1:X(5))
+11 SET ^PXRMINDX(9000011,CODESYS,"ISPP",CODE,X(4),PRIO,X(2),X(3),DA)=""
+12 SET ^PXRMINDX(9000011,CODESYS,"PSPI",X(2),X(4),PRIO,CODE,X(3),DA)=""
+13 QUIT
+14 ;
+15 ;===================================
SPROBMT(X,DA) ;Set Index entry for Problem List Mapping Targets.
+1 ;X(1)=CODE, X(2)=CODING SYSTEM
+2 NEW DAS,DFN,DLM,PRIO,STATUS,TEMP
+3 SET TEMP=^AUPNPROB(DA(1),1)
+4 ;Don't index Hidden problems.
+5 IF $PIECE(TEMP,U,2)="H"
QUIT
+6 SET PRIO=$PIECE(TEMP,U,14)
+7 IF PRIO=""
SET PRIO="U"
+8 SET TEMP=^AUPNPROB(DA(1),0)
+9 SET DFN=$PIECE(TEMP,U,2)
SET DLM=$PIECE(TEMP,U,3)
SET STATUS=$PIECE(TEMP,U,12)
+10 SET DAS=DA(1)_";"_803_";"_DA
+11 SET ^PXRMINDX(9000011,X(2),"ISPP",X(1),STATUS,PRIO,DFN,DLM,DAS)=""
+12 SET ^PXRMINDX(9000011,X(2),"PSPI",DFN,STATUS,PRIO,X(1),DLM,DAS)=""
+13 QUIT
+14 ;
+15 ;===================================
SPROBMTA(X,DA) ;Whenever any of the fields in the 803 node index are changed
+1 ;set the index.
+2 ;X(1)=DATE LAST MODIFIED, X(2)=STATUS, X(3)=PRIORITY, X(4)=CONDITION
+3 NEW CODE,CODESYS,DAS,DFN,IND,PRIO,TEMP
+4 SET TEMP=^AUPNPROB(DA,1)
+5 ;Don't index Hidden problems.
+6 IF X(4)="H"
QUIT
+7 SET PRIO=X(3)
+8 IF PRIO=""
SET PRIO="U"
+9 SET DFN=$PIECE(^AUPNPROB(DA,0),U,2)
+10 SET IND=0
+11 FOR
SET IND=+$ORDER(^AUPNPROB(DA,803,IND))
if IND=0
QUIT
Begin DoDot:1
+12 SET TEMP=^AUPNPROB(DA,803,IND,0)
+13 SET CODE=$PIECE(TEMP,U,1)
SET CODESYS=$PIECE(TEMP,U,2)
+14 SET DAS=DA_";"_803_";"_IND
+15 SET ^PXRMINDX(9000011,CODESYS,"ISPP",CODE,X(2),PRIO,DFN,X(1),DAS)=""
+16 SET ^PXRMINDX(9000011,CODESYS,"PSPI",DFN,X(2),PRIO,CODE,X(1),DAS)=""
End DoDot:1
+17 QUIT
+18 ;
+19 ;===================================
SPROBSCT(X,DA) ;Set Index entry for Problem List SNOMED CT.
+1 ;X(1)=SNOMED CT CONCEPT CODE, X(2)=DFN, X(3)=DATE LAST MODIFIED,
+2 ;X(4)=STATUS, X(5)=PRIORITY, X(6)=CONDITION
+3 ;Don't index Hidden problems.
+4 IF X(6)="H"
QUIT
+5 SET PRIO=$SELECT(X(5)="":"U",1:X(5))
+6 SET ^PXRMINDX(9000011,"SCT","ISPP",X(1),X(4),PRIO,X(2),X(3),DA)=""
+7 SET ^PXRMINDX(9000011,"SCT","PSPI",X(2),X(4),PRIO,X(1),X(3),DA)=""
+8 QUIT
+9 ;
