source: FOIAVistA/trunk/r/PROBLEM_LIST-GMPL/GMPLPXRM.m@ 1801

Last change on this file since 1801 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 3.1 KB
Line 
1GMPLPXRM ; SLC/PKR - Build Clinical Reminder indexes for AUPNPROB. ;02/27/2004
2 ;;2.0;Problem List;**27**;Aug 25, 1994
3 ;DBIA 4113 supports PXRMSXRM entry points.
4 ;DBIA 4114 supports setting and killing ^PXRMINDX(9000011)
5 ;===============================================================
6INDEX ;Build the indexes for PROBLEM LIST.
7 N COND,DAS,DFN,DIFF,DLM,DONE,END,ENTRIES,ETEXT,GLOBAL,IND,NE,NERROR
8 N PRIO,PROB,START,STATUS,TEMP,TENP,TEXT
9 ;Don't leave any old stuff around.
10 ;DBIA 4114
11 K ^PXRMINDX(9000011)
12 S GLOBAL=$$GET1^DID(9000011,"","","GLOBAL NAME")
13 S ENTRIES=$P(^AUPNPROB(0),U,4)
14 S TENP=ENTRIES/10
15 S TENP=+$P(TENP,".",1)
16 I TENP<1 S TENP=1
17 D BMES^XPDUTL("Building indexes PROBLEM LIST")
18 S TEXT="There are "_ENTRIES_" entries to process."
19 D MES^XPDUTL(TEXT)
20 S START=$H
21 S (DAS,DONE,IND,NE,NERROR)=0
22 F S DAS=$O(^AUPNPROB(DAS)) Q:DONE D
23 . I +DAS=0 S DONE=1 Q
24 . I +DAS'=DAS D Q
25 .. S DONE=1
26 .. S ETEXT="Bad ien: "_DAS_", cannot continue."
27 .. D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
28 . S IND=IND+1
29 . I IND#TENP=0 D
30 .. S TEXT="Processing entry "_IND
31 .. D MES^XPDUTL(TEXT)
32 . I IND#10000=0 W "."
33 . S TEMP=$G(^AUPNPROB(DAS,1))
34 . S COND=$P(TEMP,U,2)
35 .;Don't index Hidden problems.
36 . I COND="H" Q
37 . S PRIO=$P(TEMP,U,14)
38 .;If there is no priority set it to "U" for undefined.
39 . I PRIO="" S PRIO="U"
40 . S TEMP=^AUPNPROB(DAS,0)
41 . S PROB=$P(TEMP,U,1)
42 . I PROB="" D Q
43 .. S ETEXT=DAS_" missing problem"
44 .. D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
45 . I '$D(^ICD9(PROB)) D Q
46 .. S ETEXT=DAS_" invalid ICD9"
47 .. D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
48 . S DFN=$P(TEMP,U,2)
49 . I DFN="" D Q
50 .. S ETEXT=DAS_" missing DFN"
51 .. D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
52 . S DLM=$P(TEMP,U,3)
53 . I DLM="" D Q
54 .. S ETEXT=DAS_" missing date laste modified"
55 .. D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)
56 . S STATUS=$P(TEMP,U,12)
57 . I STATUS="" D Q
58 .. S ETEXT=DAS_" missing status"
59 .. D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR) Q
60 . S NE=NE+1
61 . S ^PXRMINDX(9000011,"ISPP",PROB,STATUS,PRIO,DFN,DLM,DAS)=""
62 . S ^PXRMINDX(9000011,"PSPI",DFN,STATUS,PRIO,PROB,DLM,DAS)=""
63 S END=$H
64 S TEXT=NE_" PROBLEM LIST results indexed."
65 D MES^XPDUTL(TEXT)
66 D DETIME^PXRMSXRM(START,END)
67 ;If there were errors send a message.
68 I NERROR>0 D ERRMSG^PXRMSXRM(NERROR,GLOBAL)
69 ;Send a MailMan message with the results.
70 D COMMSG^PXRMSXRM(GLOBAL,START,END,NE,NERROR)
71 S ^PXRMINDX(9000011,"GLOBAL NAME")=GLOBAL
72 S ^PXRMINDX(9000011,"BUILT BY")=DUZ
73 S ^PXRMINDX(9000011,"DATE BUILT")=$$NOW^XLFDT
74 Q
75 ;
76 ;===============================================================
77KPROB(X,DA) ;Delete index for Problem List.
78 N PRIO
79 S PRIO=$S(X(5)="":"U",1:X(5))
80 ;DBIA 4114
81 K ^PXRMINDX(9000011,"ISPP",X(1),X(4),PRIO,X(2),X(3),DA)
82 K ^PXRMINDX(9000011,"PSPI",X(2),X(4),PRIO,X(1),X(3),DA)
83 Q
84 ;
85 ;===============================================================
86SPROB(X,DA) ;Set index for Problem List.
87 ;X(1)=DIAGNOSIS, X(2)=DFN, X(3)=DATE LAST MODIFIED, X(4)=STATUS
88 ;X(5)=PRIORITY, X(6)=CONDITION
89 ;Don't index Hidden problems.
90 I X(6)="H" Q
91 N PRIO
92 S PRIO=$S(X(5)="":"U",1:X(5))
93 ;DBIA 4114
94 S ^PXRMINDX(9000011,"ISPP",X(1),X(4),PRIO,X(2),X(3),DA)=""
95 S ^PXRMINDX(9000011,"PSPI",X(2),X(4),PRIO,X(1),X(3),DA)=""
96 Q
97 ;
Note: See TracBrowser for help on using the repository browser.