Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: GMPLPXRM

GMPLPXRM.m

Go to the documentation of this file. 
  1. 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
  1.  ;DBIA #4113 supports PXRMSXRM entry points.
  1.  ;DBIA #4114 supports setting and killing ^PXRMINDX(9000011)
  1.  ;DBIA #5747 covers references to ^ICDEX entry point.
  1.  ;===================================
  1. INDEX ;Build the indexes for PROBLEM LIST.
  1.  N CODE,CODEP,CODESYS,COND,DAS,DAS803,DFN,DIFF,DLM,DONE
  1.  N END,ENTRIES,ETEXT,GLOBAL,IND,JND,NE,NERROR,PRIO,PROB
  1.  N START,STATUS,TEMP,TENP,TEXT
  1.  ;Don't leave any old stuff around.
  1.  K ^PXRMINDX(9000011)
  1.  S GLOBAL=$$GET1^DID(9000011,"","","GLOBAL NAME")
  1.  S ENTRIES=$P(^AUPNPROB(0),U,4)
  1.  S TENP=ENTRIES/10
  1.  S TENP=+$P(TENP,".",1)
  1.  I TENP<1 S TENP=1
  1.  D BMES^XPDUTL("Building indexes PROBLEM LIST")
  1.  S TEXT="There are "_ENTRIES_" entries to process."
  1.  D MES^XPDUTL(TEXT)
  1.  S START=$H
  1.  S (DAS,DONE,IND,NE,NERROR)=0
  1.  F  S DAS=$O(^AUPNPROB(DAS)) Q:DONE  D
  1.  . N GMPDT,GMPCSYS
  1.  . I +DAS=0 S DONE=1 Q
  1.  . I +DAS'=DAS D  Q
  1.  .. S DONE=1
  1.  .. S ETEXT="Bad ien: "_DAS_", cannot continue."
  1.  .. D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
  1.  . S IND=IND+1
  1.  . I IND#TENP=0 D
  1.  .. S TEXT="Processing entry "_IND
  1.  .. D MES^XPDUTL(TEXT)
  1.  . I IND#10000=0 W "."
  1.  . S TEMP=$G(^AUPNPROB(DAS,1))
  1.  . S COND=$P(TEMP,U,2)
  1.  .;Don't index Hidden problems.
  1.  . I COND="H" Q
  1.  . S PRIO=$P(TEMP,U,14)
  1.  .;If there is no priority set it to "U" for undefined.
  1.  . I PRIO="" S PRIO="U"
  1.  . S TEMP=^AUPNPROB(DAS,0)
  1.  . S CODEP=$P(TEMP,U,1)
  1.  . I CODEP="" D  Q
  1.  .. S ETEXT=DAS_" missing problem"
  1.  .. D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
  1.  . S DFN=$P(TEMP,U,2)
  1.  . I DFN="" D  Q
  1.  .. S ETEXT=DAS_" missing DFN"
  1.  .. D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
  1.  . S DLM=$P(TEMP,U,3)
  1.  . I DLM="" D  Q
  1.  .. S ETEXT=DAS_" missing date last modified"
  1.  .. D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
  1.  . S STATUS=$P(TEMP,U,12)
  1.  . I STATUS="" D  Q
  1.  .. S ETEXT=DAS_" missing status"
  1.  .. D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) Q
  1.  . S CODESYS=$P($G(^AUPNPROB(DAS,802)),U,2)
  1.  . I CODESYS="" S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80,CODEP)),U,3)
  1.  . S CODE=$$CODEC^ICDEX(80,CODEP)
  1.  . I +CODE=-1 D  Q
  1.  .. S ETEXT=DAS_" has the invalid code "_CODE
  1.  .. D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
  1.  . S NE=NE+1
  1.  . S ^PXRMINDX(9000011,CODESYS,"ISPP",CODE,STATUS,PRIO,DFN,DLM,DAS)=""
  1.  . S ^PXRMINDX(9000011,CODESYS,"PSPI",DFN,STATUS,PRIO,CODE,DLM,DAS)=""
  1.  .;Check for a SNOMED CT code.
  1.  . S CODE=$P($G(^AUPNPROB(DAS,800)),U,1)
  1.  . I CODE="" Q
  1.  . S ^PXRMINDX(9000011,"SCT","ISPP",CODE,STATUS,PRIO,DFN,DLM,DAS)=""
  1.  . S ^PXRMINDX(9000011,"SCT","PSPI",DFN,STATUS,PRIO,CODE,DLM,DAS)=""
  1.  .;Check for entries in the Mapping Targets multiple.
  1.  . S JND=0
  1.  . F  S JND=+$O(^AUPNPROB(DAS,803,JND)) Q:JND=0  D
  1.  .. S TEMP=^AUPNPROB(DAS,803,JND,0)
  1.  .. S CODE=$P(TEMP,U,1)
  1.  .. S CODESYS=$P(TEMP,U,2)
  1.  .. S DAS803=DAS_";803;"_JND
  1.  .. S ^PXRMINDX(9000011,CODESYS,"ISPP",CODE,STATUS,PRIO,DFN,DLM,DAS803)=""
  1.  .. S ^PXRMINDX(9000011,CODESYS,"PSPI",DFN,STATUS,PRIO,CODE,DLM,DAS803)=""
  1.  S END=$H
  1.  S TEXT=NE_" PROBLEM LIST results indexed."
  1.  D MES^XPDUTL(TEXT)
  1.  D DETIME^PXRMSXRM(START,END)
  1.  ;If there were errors send a message.
  1.  I NERROR>0 D ERRMSG^PXRMSXRM(NERROR,GLOBAL)
  1.  ;Send a MailMan message with the results.
  1.  D COMMSG^PXRMSXRM(GLOBAL,START,END,NE,NERROR)
  1.  S ^PXRMINDX(9000011,"GLOBAL NAME")=GLOBAL
  1.  S ^PXRMINDX(9000011,"BUILT BY")=DUZ
  1.  S ^PXRMINDX(9000011,"DATE BUILT")=$$NOW^XLFDT
  1.  Q
  1.  ;
  1.  ;===================================
  1. 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
  1.  ;X(5)=PRIORITY, X(6)=CONDITION, X(7)=CODING SYSTEM
  1.  N CODE,CODESYS,PRIO
  1.  S CODE=$$CODEC^ICDEX(80,X(1))
  1.  I +CODE=-1 Q
  1.  S CODESYS=$G(X(7))
  1.  I CODESYS="" S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80,X(1))),U,3)
  1.  S PRIO=$S(X(5)="":"U",1:X(5))
  1.  K ^PXRMINDX(9000011,CODESYS,"ISPP",CODE,X(4),PRIO,X(2),X(3),DA)
  1.  K ^PXRMINDX(9000011,CODESYS,"PSPI",X(2),X(4),PRIO,CODE,X(3),DA)
  1.  Q
  1.  ;
  1.  ;===================================
  1. KPROBMT(X,DA) ;Kill Index entry for Problem List Mapping Targets.
  1.  ;X(1)=CODE, X(2)=CODING SYSTEM
  1.  N DAS,DFN,DLM,PRIO,STATUS,TEMP
  1.  I X(2)="" Q
  1.  S TEMP=^AUPNPROB(DA(1),1)
  1.  S PRIO=$P(TEMP,U,14)
  1.  I PRIO="" S PRIO="U"
  1.  S TEMP=^AUPNPROB(DA(1),0)
  1.  S DFN=$P(TEMP,U,2),DLM=$P(TEMP,U,3),STATUS=$P(TEMP,U,12)
  1.  S DAS=DA(1)_";"_803_";"_DA
  1.  K ^PXRMINDX(9000011,X(2),"ISPP",X(1),STATUS,PRIO,DFN,DLM,DAS)
  1.  K ^PXRMINDX(9000011,X(2),"PSPI",DFN,STATUS,PRIO,X(1),DLM,DAS)
  1.  Q
  1.  ;
  1.  ;===================================
  1. KPROBMTA(X,DA) ;Whenever any of the fields in the 803 node index are changed
  1.  ;kill the old index entry.
  1.  ;X(1)=DATE LAST MODIFIED, X(2)=STATUS, X(3)=PRIORITY, X(4)=CONDITION
  1.  N CODE,CODESYS,DAS,DFN,IND,PRIO,TEMP
  1.  S PRIO=X(3)
  1.  I PRIO="" S PRIO="U"
  1.  S DFN=$P(^AUPNPROB(DA,0),U,2)
  1.  S IND=0
  1.  F  S IND=+$O(^AUPNPROB(DA,803,IND)) Q:IND=0  D
  1.  . S TEMP=^AUPNPROB(DA,803,IND,0)
  1.  . S CODE=$P(TEMP,U,1),CODESYS=$P(TEMP,U,2)
  1.  . S DAS=DA_";"_803_";"_IND
  1.  . K ^PXRMINDX(9000011,CODESYS,"ISPP",CODE,X(2),PRIO,DFN,X(1),DAS)
  1.  . K ^PXRMINDX(9000011,CODESYS,"PSPI",DFN,X(2),PRIO,CODE,X(1),DAS)
  1.  Q
  1.  ;
  1.  ;===================================
  1. 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,
  1.  ;X(4)=STATUS, X(5)=PRIORITY, X(6)=CONDITION
  1.  S PRIO=$S(X(5)="":"U",1:X(5))
  1.  K ^PXRMINDX(9000011,"SCT","ISPP",X(1),X(4),PRIO,X(2),X(3),DA)
  1.  K ^PXRMINDX(9000011,"SCT","PSPI",X(2),X(4),PRIO,X(1),X(3),DA)
  1.  Q
  1.  ;
  1.  ;===================================
  1. PROBDATA(DAS,DATA) ;Return data for a Problem List entry.
  1.  ;DBIA #5881
  1.  N EM,IEN,IND,TEMP
  1.  S IEN=$P(DAS,";",1)
  1.  S TEMP=^AUPNPROB(IEN,0)
  1.  S DATA("ICD DIAGNOSIS")=$P(TEMP,U,1)
  1.  S DATA("DATE LAST MODIFIED")=$P(TEMP,U,3)
  1.  S DATA("PROVIDER NARRATIVE")=$P(TEMP,U,5)
  1.  S DATA("DATE ENTERED")=$P(TEMP,U,8)
  1.  S DATA("STATUS")=$P(TEMP,U,12)
  1.  S DATA("DATE OF ONSET")=$P(TEMP,U,13)
  1.  S TEMP=^AUPNPROB(IEN,1)
  1.  S DATA("PROBLEM")=$P(TEMP,U,1)
  1.  S DATA("PROBLEM CONDITION")=$P(TEMP,U,2)
  1.  S DATA("RECORDING PROVIDER")=$P(TEMP,U,4)
  1.  S DATA("RESPONSIBLE PROVIDER")=$P(TEMP,U,5)
  1.  S DATA("DATE RESOLVED")=$P(TEMP,U,7)
  1.  S DATA("CLINIC")=$P(TEMP,U,8)
  1.  S DATA("PRIORITY")=$P(TEMP,U,14)
  1.  S DATA("DATE OF INTEREST")=$P($G(^AUPNPROB(IEN,802)),U,1)
  1.  I DAS'[";803;" Q
  1.  S IND=$P(DAS,";",3)
  1.  S TEMP=^AUPNPROB(IEN,803,IND,0)
  1.  S DATA("MT CODE")=$P(TEMP,U,1)
  1.  S DATA("MT CODING SYSTEM")=$P(TEMP,U,2)
  1.  S DATA("MT CODE DATE")=$P(TEMP,U,3)
  1.  Q
  1.  ;
  1.  ;===================================
  1. 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
  1.  ;X(5)=PRIORITY, X(6)=CONDITION, X(7)=CODING SYSTEM
  1.  ;Don't index Hidden problems.
  1.  I X(6)="H" Q
  1.  N CODE,CODESYS,PRIO
  1.  S CODE=$$CODEC^ICDEX(80,X(1))
  1.  I +CODE=-1 Q
  1.  S CODESYS=$G(X(7))
  1.  I CODESYS="" S CODESYS=$P($$SINFO^ICDEX($$CSI^ICDEX(80,X(1))),U,3)
  1.  S PRIO=$S(X(5)="":"U",1:X(5))
  1.  S ^PXRMINDX(9000011,CODESYS,"ISPP",CODE,X(4),PRIO,X(2),X(3),DA)=""
  1.  S ^PXRMINDX(9000011,CODESYS,"PSPI",X(2),X(4),PRIO,CODE,X(3),DA)=""
  1.  Q
  1.  ;
  1.  ;===================================
  1. SPROBMT(X,DA) ;Set Index entry for Problem List Mapping Targets.
  1.  ;X(1)=CODE, X(2)=CODING SYSTEM
  1.  N DAS,DFN,DLM,PRIO,STATUS,TEMP
  1.  S TEMP=^AUPNPROB(DA(1),1)
  1.  ;Don't index Hidden problems.
  1.  I $P(TEMP,U,2)="H" Q
  1.  S PRIO=$P(TEMP,U,14)
  1.  I PRIO="" S PRIO="U"
  1.  S TEMP=^AUPNPROB(DA(1),0)
  1.  S DFN=$P(TEMP,U,2),DLM=$P(TEMP,U,3),STATUS=$P(TEMP,U,12)
  1.  S DAS=DA(1)_";"_803_";"_DA
  1.  S ^PXRMINDX(9000011,X(2),"ISPP",X(1),STATUS,PRIO,DFN,DLM,DAS)=""
  1.  S ^PXRMINDX(9000011,X(2),"PSPI",DFN,STATUS,PRIO,X(1),DLM,DAS)=""
  1.  Q
  1.  ;
  1.  ;===================================
  1. SPROBMTA(X,DA) ;Whenever any of the fields in the 803 node index are changed
  1.  ;set the index.
  1.  ;X(1)=DATE LAST MODIFIED, X(2)=STATUS, X(3)=PRIORITY, X(4)=CONDITION
  1.  N CODE,CODESYS,DAS,DFN,IND,PRIO,TEMP
  1.  S TEMP=^AUPNPROB(DA,1)
  1.  ;Don't index Hidden problems.
  1.  I X(4)="H" Q
  1.  S PRIO=X(3)
  1.  I PRIO="" S PRIO="U"
  1.  S DFN=$P(^AUPNPROB(DA,0),U,2)
  1.  S IND=0
  1.  F  S IND=+$O(^AUPNPROB(DA,803,IND)) Q:IND=0  D
  1.  . S TEMP=^AUPNPROB(DA,803,IND,0)
  1.  . S CODE=$P(TEMP,U,1),CODESYS=$P(TEMP,U,2)
  1.  . S DAS=DA_";"_803_";"_IND
  1.  . S ^PXRMINDX(9000011,CODESYS,"ISPP",CODE,X(2),PRIO,DFN,X(1),DAS)=""
  1.  . S ^PXRMINDX(9000011,CODESYS,"PSPI",DFN,X(2),PRIO,CODE,X(1),DAS)=""
  1.  Q
  1.  ;
  1.  ;===================================
  1. 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,
  1.  ;X(4)=STATUS, X(5)=PRIORITY, X(6)=CONDITION
  1.  ;Don't index Hidden problems.
  1.  I X(6)="H" Q
  1.  S PRIO=$S(X(5)="":"U",1:X(5))
  1.  S ^PXRMINDX(9000011,"SCT","ISPP",X(1),X(4),PRIO,X(2),X(3),DA)=""
  1.  S ^PXRMINDX(9000011,"SCT","PSPI",X(2),X(4),PRIO,X(1),X(3),DA)=""
  1.  Q
  1.  ;