source: FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMCSTX.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: 5.7 KB
Line 
1PXRMCSTX ; SLC/PKR - Routines for taxonomy code set update. ; 02/22/2007
2 ;;2.0;CLINICAL REMINDERS;**9**;Feb 04, 2005;Build 4
3 ;
4 ;=====================================================
5ADDTMSG(LC,MSG) ;Add a set of messages to the global message.
6 N IND
7 S IND=0
8 F S IND=$O(MSG(IND)) Q:IND="" S LC=LC+1,^TMP("PXRMXMZ",$J,LC,0)=MSG(IND)
9 Q
10 ;
11 ;=====================================================
12ADJMSG(FILENUM,LOW,HIGH,ALOW,ALOWC,ALOWO,AHIGH,AHIGHC,AHIGHO,ADJMSG) ;
13 ;Create the message for adjacent codes that have changed.
14 N LC,TYPE
15 K ADJMSG
16 S TYPE=$S(FILENUM=80:"ICD9",FILENUM=80.1:"ICD0",FILENUM=81:"CPT")
17 S ADJMSG(1)="Adjacent "_TYPE_" codes have changed for the range defined by:"
18 S ADJMSG(2)=" Low code "_$$GETCTEXT(FILENUM,LOW)
19 S ADJMSG(3)=" High code "_$$GETCTEXT(FILENUM,HIGH)
20 S LC=3
21 I ALOWC D
22 . S LC=LC+1,ADJMSG(LC)=" Old adjacent lower code "_$$GETCTEXT(FILENUM,ALOWO)
23 . S LC=LC+1,ADJMSG(LC)=" New adjacent lower code "_$$GETCTEXT(FILENUM,ALOW)
24 E S LC=LC+1,ADJMSG(LC)=" No change in adjacent lower code"
25 I AHIGHC D
26 . S LC=LC+1,ADJMSG(LC)=" Old adjacent higher code "_$$GETCTEXT(FILENUM,AHIGHO)
27 . S LC=LC+1,ADJMSG(LC)=" New adjacent higher code "_$$GETCTEXT(FILENUM,AHIGH)
28 E S LC=LC+1,ADJMSG(LC)=" No change in adjacent higher code"
29 S LC=LC+1,ADJMSG(LC)=" "
30 Q
31 ;
32 ;=====================================================
33CMSGHDR(TYPE) ;Create the message header.
34 N PTYPE
35 S PTYPE=$S(TYPE="CPT":"a CPT",TYPE="ICD":"an ICD")
36 S ^TMP("PXRMXMZ",$J,1,0)="There was "_PTYPE_" code set update on "_$$FMTE^XLFDT(DT,"5Z")_"."
37 S ^TMP("PXRMXMZ",$J,2,0)="This could affect adjacent codes and/or taxonomy expansions."
38 S ^TMP("PXRMXMZ",$J,3,0)="Please review the affected taxonomies and take appropriate action."
39 S ^TMP("PXRMXMZ",$J,4,0)="You can get the full details of a taxonomy using the taxonomy inquiry option."
40 S ^TMP("PXRMXMZ",$J,5,0)=" "
41 Q
42 ;
43 ;=====================================================
44CSU(TYPE) ;Entry point for code set update.
45 I TYPE'="CPT",TYPE'="ICD" Q
46 N ADJMSG,ALOW,ALOWC,ALOWO,AHIGH,AHIGHC,AHIGHO,CODEIEN,CODEMSG
47 N FI,FILELIST,FILENUM,IEN,IND,HIGH,LC,LOW,NFILES,NNEW,NEWCODES,SENDMSG
48 N TAXHDRE,TAXHDRL,TAXHDRS,TAXMSG,TEMP,XMSUB
49 I TYPE="CPT" S NFILES=1,FILELIST(1)=81
50 I TYPE="ICD" S NFILES=2,FILELIST(1)=80,FILELIST(2)=80.1
51 K ^TMP("PXRMXMZ",$J)
52 ;Set the line count to the end of the taxonomy header.
53 S TAXHDRS=6,TAXHDRL=1,TAXHDRE=TAXHDRS+TAXHDRL,LC=TAXHDRE
54 S (IEN,SENDMSG)=0
55 F S IEN=+$O(^PXD(811.2,IEN)) Q:IEN=0 D
56 . F FI=1:1:NFILES D
57 .. S FILENUM=FILELIST(FI)
58 .. I '$D(^PXD(811.2,IEN,FILENUM,"B")) Q
59 .. S (IND,TAXMSG)=0
60 .. F S IND=+$O(^PXD(811.2,IEN,FILENUM,IND)) Q:IND=0 D
61 ... S TEMP=^PXD(811.2,IEN,FILENUM,IND,0)
62 ... S LOW=$P(TEMP,U,1),HIGH=$P(TEMP,U,2)
63 ... S ALOWO=$P(TEMP,U,3),AHIGHO=$P(TEMP,U,4)
64 ... S ALOW=$S(FILENUM=80:$$PREV^ICDAPIU(LOW),FILENUM=80.1:$$PREV^ICDAPIU(LOW),FILENUM=81:$$PREV^ICPTAPIU(LOW))
65 ... S AHIGH=$S(FILENUM=80:$$NEXT^ICDAPIU(HIGH),FILENUM=80.1:$$NEXT^ICDAPIU(HIGH),FILENUM=81:$$NEXT^ICPTAPIU(HIGH))
66 ... I ALOW'=ALOWO S ALOWC=1,$P(^PXD(811.2,IEN,FILENUM,IND,0),U,3)=ALOW
67 ... E S ALOWC=0
68 ... I AHIGH'=AHIGHO S AHIGHC=1,$P(^PXD(811.2,IEN,FILENUM,IND,0),U,4)=AHIGH
69 ... E S AHIGHC=0
70 ... I ALOWC!AHIGHC D
71 .... D ADJMSG(FILENUM,LOW,HIGH,ALOW,ALOWC,ALOWO,AHIGH,AHIGHC,AHIGHO,.ADJMSG)
72 .... D ADDTMSG(.LC,.ADJMSG)
73 .... S TAXMSG=1
74 ..;Save the old expansion and compare with the old one.
75 .. K ^TMP($J,"OLDEXP")
76 .. S IND=0
77 .. F S IND=+$O(^PXD(811.3,IEN,FILENUM,IND)) Q:IND=0 D
78 ... S CODEIEN=^PXD(811.3,IEN,FILENUM,IND,0)
79 ... S ^TMP($J,"OLDEXP",CODEIEN)=""
80 ..;Rexpand and compare with the old.
81 .. D DELEXTL^PXRMBXTL(IEN)
82 .. D EXPAND^PXRMBXTL(IEN,"")
83 ..;Old codes are never deleted from the ICD or CPT globals so just
84 ..;check for new entries in the expansion.
85 .. S (IND,NNEW)=0
86 .. F S IND=+$O(^PXD(811.3,IEN,FILENUM,IND)) Q:IND=0 D
87 ... S CODEIEN=^PXD(811.3,IEN,FILENUM,IND,0)
88 ... I '$D(^TMP($J,"OLDEXP",CODEIEN)) S NNEW=NNEW+1,NEWCODES(NNEW)=CODEIEN
89 ..;If there are any new codes add them to the message.
90 .. I NNEW>0 D
91 ... D NEWCMSG(FILENUM,NNEW,.NEWCODES,.CODEMSG)
92 ... D ADDTMSG(.LC,.CODEMSG)
93 ... S TAXMSG=1
94 ..;Check the selectable codes.
95 .. D SELCODE^PXRMCSSC(FILENUM,IEN,.LC,.TAXMSG)
96 .. I TAXMSG D
97 ... D TAXHDR(IEN,TAXHDRS)
98 ... S TAXHDRS=LC+1,TAXHDRE=TAXHDRS+TAXHDRL,LC=TAXHDRE
99 ... S SENDMSG=1
100 S XMSUB="Clinical Reminder taxonomy updates, new "_TYPE_" global installation."
101 I SENDMSG D CMSGHDR(TYPE)
102 I 'SENDMSG D
103 . S ^TMP("PXRMXMZ",$J,1,0)="No changes in adjacent high and low codes were found."
104 . S ^TMP("PXRMXMZ",$J,2,0)="No inactive selectable codes were found."
105 . S ^TMP("PXRMXMZ",$J,3,0)="No action is necessary."
106 D SEND^PXRMMSG(XMSUB)
107 K ^TMP("PXRMXMZ",$J),^TMP($J,"OLDEXP")
108 Q
109 ;
110 ;=====================================================
111GETCTEXT(FILENUM,CODE) ;Return the code and text associated with the code.
112 N TEMP,TEXT
113 I FILENUM=80 D Q TEXT
114 . S TEMP=$$ICDDX^ICDCODE(CODE,DT)
115 . S TEXT=$P(TEMP,U,2)_"-"_$P(TEMP,U,4)
116 I FILENUM=80.1 D Q TEXT
117 . S TEMP=$$ICDOP^ICDCODE(CODE,DT)
118 . S TEXT=$P(TEMP,U,2)_"-"_$P(TEMP,U,5)
119 I FILENUM=81 D
120 . S TEMP=$$CPT^ICPTCOD(CODE,DT)
121 . S TEXT=$P(TEMP,U,2)_"-"_$P(TEMP,U,3)
122 Q TEXT
123 ;
124 ;=====================================================
125NEWCMSG(FILENUM,NNEW,NEWCODES,CODEMSG) ;Create the message for new codes
126 ;appearing in the expansion.
127 I NNEW=0 Q
128 N LC,IND,TYPE
129 K CODEMSG
130 S TYPE=$S(FILENUM=80:"ICD9",FILENUM=80.1:"ICD0",FILENUM=81:"CPT")
131 S CODEMSG(1)="The following are new "_TYPE_" codes in the expansion for this taxonomy:"
132 S LC=1
133 F IND=1:1:NNEW D
134 . S CODE=NEWCODES(IND)
135 . S LC=LC+1,CODEMSG(LC)=" "_$$GETCTEXT(FILENUM,CODE)
136 S LC=LC+1,CODEMSG(LC)=" "
137 Q
138 ;
139 ;=====================================================
140TAXHDR(IEN,LC) ;Create message header for a specific taxonomy.
141 S ^TMP("PXRMXMZ",$J,LC,0)="Taxonomy: "_$P(^PXD(811.2,IEN,0),U,1)_" = TX("_IEN_")"
142 Q
143 ;
Note: See TracBrowser for help on using the repository browser.