GMPLPXRM ; SLC/PKR - Build Clinical Reminder Index for AUPNPROB. ;04-Aug-2015 10:42;DU
;;2.0;Problem List;**27,1002,43,44,100,1004**;Aug 25, 1994;Build 10
;DBIA #4113 supports PXRMSXRM entry points.
;DBIA #4114 supports setting and killing ^PXRMINDX(9000011)
;DBIA #5747 covers references to ^ICDEX entry point.
;1004 added $G if problem has no 1 node
;===================================
INDEX ;Build the indexes for PROBLEM LIST.
N CODE,CODEP,CODESYS,COND,DAS,DAS803,DFN,DIFF,DLM,DONE,NUMBR
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)
. S NUMBR=$P(TEMP,U,7) ;Patch 1002
. Q:CODEP="" ;Patch 1004
. ;I CODEP="" D Q
..;S ETEXT=DAS_" missing problem"
..;D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
. S DFN=$P(TEMP,U,2)
. Q:DFN="" ;Patch 1002
. ;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
..I +NUMBR D
...S STATUS="I"
...N FDA
...S FN=9000011
...S FDA(FN,DAS_",",.12)=STATUS
...D FILE^DIE("K","FDA")
...;S ETEXT=DAS_" missing status"
...;D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) Q
...;End Patch 1002
. 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
;
;===================================
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=$G(^AUPNPROB(IEN,1))
S DATA("PROBLEM")=$P(TEMP,U,1)
S DATA("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
;
;===================================
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
;
GMPLPXRM ; SLC/PKR - Build Clinical Reminder Index for AUPNPROB. ;04-Aug-2015 10:42;DU
+1 ;;2.0;Problem List;**27,1002,43,44,100,1004**;Aug 25, 1994;Build 10
+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 ;1004 added $G if problem has no 1 node
+6 ;===================================
INDEX ;Build the indexes for PROBLEM LIST.
+1 NEW CODE,CODEP,CODESYS,COND,DAS,DAS803,DFN,DIFF,DLM,DONE,NUMBR
+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 ;Patch 1002
SET NUMBR=$PIECE(TEMP,U,7)
+38 ;Patch 1004
IF CODEP=""
QUIT
+39 ;I CODEP="" D Q
+40 ;S ETEXT=DAS_" missing problem"
+41 ;D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
+42 SET DFN=$PIECE(TEMP,U,2)
+43 ;Patch 1002
IF DFN=""
QUIT
+44 ;I DFN="" D Q
+45 ;S ETEXT=DAS_" missing DFN"
+46 ;D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
+47 SET DLM=$PIECE(TEMP,U,3)
+48 IF DLM=""
Begin DoDot:2
+49 SET ETEXT=DAS_" missing date last modified"
+50 DO ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
End DoDot:2
QUIT
+51 SET STATUS=$PIECE(TEMP,U,12)
+52 IF STATUS=""
Begin DoDot:2
+53 IF +NUMBR
Begin DoDot:3
+54 SET STATUS="I"
+55 NEW FDA
+56 SET FN=9000011
+57 SET FDA(FN,DAS_",",.12)=STATUS
+58 DO FILE^DIE("K","FDA")
+59 ;S ETEXT=DAS_" missing status"
+60 ;D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) Q
+61 ;End Patch 1002
End DoDot:3
End DoDot:2
QUIT
+62 SET CODESYS=$PIECE($GET(^AUPNPROB(DAS,802)),U,2)
+63 IF CODESYS=""
SET CODESYS=$PIECE($$SINFO^ICDEX($$CSI^ICDEX(80,CODEP)),U,3)
+64 SET CODE=$$CODEC^ICDEX(80,CODEP)
+65 IF +CODE=-1
Begin DoDot:2
+66 SET ETEXT=DAS_" has the invalid code "_CODE
+67 DO ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
End DoDot:2
QUIT
+68 SET NE=NE+1
+69 SET ^PXRMINDX(9000011,CODESYS,"ISPP",CODE,STATUS,PRIO,DFN,DLM,DAS)=""
+70 SET ^PXRMINDX(9000011,CODESYS,"PSPI",DFN,STATUS,PRIO,CODE,DLM,DAS)=""
+71 ;Check for a SNOMED CT code.
+72 SET CODE=$PIECE($GET(^AUPNPROB(DAS,800)),U,1)
+73 IF CODE=""
QUIT
+74 SET ^PXRMINDX(9000011,"SCT","ISPP",CODE,STATUS,PRIO,DFN,DLM,DAS)=""
+75 SET ^PXRMINDX(9000011,"SCT","PSPI",DFN,STATUS,PRIO,CODE,DLM,DAS)=""
+76 ;Check for entries in the Mapping Targets multiple.
+77 SET JND=0
+78 FOR
SET JND=+$ORDER(^AUPNPROB(DAS,803,JND))
IF JND=0
QUIT
Begin DoDot:2
+79 SET TEMP=^AUPNPROB(DAS,803,JND,0)
+80 SET CODE=$PIECE(TEMP,U,1)
+81 SET CODESYS=$PIECE(TEMP,U,2)
+82 SET DAS803=DAS_";803;"_JND
+83 SET ^PXRMINDX(9000011,CODESYS,"ISPP",CODE,STATUS,PRIO,DFN,DLM,DAS803)=""
+84 SET ^PXRMINDX(9000011,CODESYS,"PSPI",DFN,STATUS,PRIO,CODE,DLM,DAS803)=""
End DoDot:2
End DoDot:1
+85 SET END=$HOROLOG
+86 SET TEXT=NE_" PROBLEM LIST results indexed."
+87 DO MES^XPDUTL(TEXT)
+88 DO DETIME^PXRMSXRM(START,END)
+89 ;If there were errors send a message.
+90 IF NERROR>0
DO ERRMSG^PXRMSXRM(NERROR,GLOBAL)
+91 ;Send a MailMan message with the results.
+92 DO COMMSG^PXRMSXRM(GLOBAL,START,END,NE,NERROR)
+93 SET ^PXRMINDX(9000011,"GLOBAL NAME")=GLOBAL
+94 SET ^PXRMINDX(9000011,"BUILT BY")=DUZ
+95 SET ^PXRMINDX(9000011,"DATE BUILT")=$$NOW^XLFDT
+96 QUIT
+97 ;
+98 ;===================================
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 ;===================================
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=$GET(^AUPNPROB(IEN,1))
+12 SET DATA("PROBLEM")=$PIECE(TEMP,U,1)
+13 SET DATA("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 ;===================================
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 ;
