source: FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXSRC2.m@ 1783

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

initial load of FOIAVistA 6/30/08 version
File size: 5.5 KB
Line 
1LEXSRC2 ; ISL/KER/FJF Classification Code Source Util ; 01/01/2004
2 ;;2.0;LEXICON UTILITY;**25,28**;Sep 23, 1996
3 ;
4 ; External References
5 ; DBIA 3992 $$STATCHK^ICDAPIU
6 ; DBIA 1997 $$STATCHK^ICPTAPIU
7 ; DBIA 10103 $$DT^XLFDT
8 ;
9 Q
10CPT(LEXC,LEXVDT) ; Return Pointer to Active CPT
11 ;
12 ; Input CPT Code
13 ; Output IEN file 81 of Active Codes only
14 S LEXC=$G(LEXC) Q:'$L(LEXC) "" S LEXVDT=$G(LEXVDT) S:+LEXVDT'>0 LEXVDT=$$DT^XLFDT
15 S LEXC=$$STATCHK^ICPTAPIU(LEXC,LEXVDT) Q:+LEXC'>0 "" S LEXC=$P(LEXC,"^",2) Q:+LEXC'>0 ""
16 Q +LEXC
17 ;
18ICD(LEXC,LEXVDT) ; Return Pointer to Active ICD/ICP
19 ;
20 ; Input ICD9 or ICD0 Code
21 ; Output IEN file 80 or 80.1 of Active Codes only
22 S LEXC=$G(LEXC) Q:'$L(LEXC) "" S LEXVDT=$G(LEXVDT) S:+LEXVDT'>0 LEXVDT=$$DT^XLFDT
23 S LEXC=$$STATCHK^ICDAPIU(LEXC,LEXVDT) Q:+LEXC'>0 "" S LEXC=$P(LEXC,"^",2) Q:+LEXC'>0 ""
24 Q +LEXC
25 ;
26STATCHK(CODE,CDT,LEX) ; Check Status of a Code
27 ;
28 ; Input:
29 ; CODE - Any Code (ICD/CPT/DSM etc)
30 ; CDT - Date to screen against (default = today)
31 ; LEX - Output Array, passed by reference
32 ;
33 ; Output:
34 ;
35 ; 2-Piece String containing the code's status
36 ; and the IEN if the code exists, else -1.
37 ; The following are possible outputs:
38 ; 1 ^ IEN Active Code
39 ; 0 ^ IEN Inactive Code
40 ; 0 ^ -1 Code not Found
41 ;
42 ; ASTM Triplet in array LEX passed by reference (optional)
43 ;
44 ; LEX(0) = <ien 757.02> ^ <code>
45 ; 2-Piece String containing the IEN of
46 ; the code and the code
47 ;
48 ; LEX(1) = <ien 757.01> ^ <expression>
49 ; 2-Piece String containing the IEN of
50 ; the code's expression and the expression
51 ;
52 ; LEX(2) = <ien 757.03> ^ <abbr> ^ <nomen> ^ <name>
53 ; 4-Piece String containing the IEN of
54 ; the code's classification system, the
55 ; source abbreviation, Nomenclature and
56 ; the name of the classification system
57 ;
58 ; This API requires the ACT Cross-Reference
59 ; ^LEX(757.02,"ACT",<code>,<status>,<date>,<ien>)
60 ;
61 ;
62 N LEXC,LEXAIEN,LEXIEN,LEXDT,X,PREVACT,PREVINA,MOSTREC,STATUS
63 S LEXC=$G(CODE) I '$L(LEXC) S (LEX,X)="0^-1" D UPD Q X
64 S LEXDT=$P($G(CDT),".",1),LEXDT=$S(+LEXDT>0:LEXDT,1:$$DT^XLFDT)
65 ;
66 ; Find preceding date for active codes
67 S PREVACT=+$O(^LEX(757.02,"ACT",LEXC_" ",3,LEXDT+.00001),-1)
68 S LEXAIEN=0 S:+PREVACT>0 LEXAIEN=+$O(^LEX(757.02,"ACT",LEXC_" ",3,+PREVACT," "),-1)
69 ;
70 ; Find preceding date for inactive codes
71 S PREVINA=+$O(^LEX(757.02,"ACT",LEXC_" ",2,LEXDT+.00001),-1)
72 S:+LEXAIEN>0&(+$O(^LEX(757.02,"ACT",LEXC_" ",2,PREVINA," "),-1)'=LEXAIEN) PREVINA=0
73 ;
74 ; Check that both are not zero
75 I PREVACT=0,PREVINA=0 S (LEX,X)="0^-1" D UPD Q X
76 ;
77 ; Find the most recent of the two dates and matching status
78 S MOSTREC=$S(PREVACT>PREVINA:PREVACT,1:PREVINA)
79 S STATUS=$S(PREVACT>PREVINA:1,1:0)
80 ;
81 ; Now cope with difficulties arising from boundary conditions
82 I $$BOUND D
83 .S STATUS='STATUS
84 .S MOSTREC=$O(^LEX(757.02,"ACT",LEXC_" ",STATUS+2,LEXDT),-1)
85 ;
86 ; Get code IEN
87 S LEXIEN=$O(^LEX(757.02,"ACT",LEXC_" ",STATUS+2,MOSTREC,""))
88 ;
89 ; Quit with valid status and code IEN
90 S (LEX,X)=STATUS_"^"_LEXIEN D UPD
91 Q X
92 ;
93BOUND() ; Do we have a boundary?
94 ; Check if we have an entry for the next day of the complementary
95 ; status, if so then we need to obtain the status for the
96 ; preceding day
97 I $D(^LEX(757.02,"ACT",LEXC_" ",2+'STATUS,$$DPLUS1(MOSTREC))) Q 1
98 Q 0
99 ;
100DPLUS1(DATE) ; Add a day to the date
101 ;
102 Q $$HTFM^XLFDT($$FMTH^XLFDT(DATE)+1)
103 ;
104UPD ; Update Array
105 N LEXI,LEXC,LEXN,LEXE,LEXS S LEXI=+($P($G(X),"^",2)) Q:+LEXI'>0
106 S LEXN=$G(^LEX(757.02,+LEXI,0)),LEXE=+LEXN,LEXC=$P(LEXN,"^",2)
107 S LEXS=+($P(LEXN,"^",3)),LEX(0)=+LEXI_"^"_LEXC
108 S LEX(1)=LEXE_"^"_$P($G(^LEX(757.01,+LEXE,0)),"^",1)
109 S LEX(2)=LEXS_"^"_$P($G(^LEX(757.03,+LEXS,0)),"^",1,3)
110 Q
111PI(X) ; Preferred IEN for code X
112 N LEXE,LEXLA,LEXA,LEXS,LEXC,LEXP,LEXPF,LEXF,LEXI,LEXC,LEXFL
113 S LEXC=$G(X) Q:'$L(LEXC) "" S (LEXP,LEXF,LEXI)=0,LEXPF(0)=LEXC
114 F S LEXI=$O(^LEX(757.02,"CODE",(LEXC_" "),LEXI)) Q:+LEXI=0!(LEXP>0) D
115 . S:+LEXF'>0 LEXF=LEXI S LEXFL=$S(+($P($G(^LEX(757.02,+LEXI,0)),"^",5))>0:1,1:0)
116 . S LEXE=0,LEXLA="" F S LEXE=$O(^LEX(757.02,+LEXI,4,LEXE)) Q:+LEXE=0 D
117 . . S LEXS=$P($G(^LEX(757.02,+LEXI,4,LEXE,0)),"^",2) Q:+LEXS'>0
118 . . S LEXA=$P($G(^LEX(757.02,+LEXI,4,LEXE,0)),"^",1)
119 . . S:+LEXA>+LEXLA LEXLA=+LEXA
120 . S:+LEXLA>0 LEXPF(LEXFL,LEXLA,LEXI)=""
121 S X="" I $D(LEXPF(1)) S X=$O(LEXPF(1," "),-1),X=$O(LEXPF(1,+X," "),-1)
122 I '$D(LEXPF(1)),$D(LEXPF(0)) S X=$O(LEXPF(0," "),-1),X=$O(LEXPF(0,+X," "),-1)
123 Q X
124 ;
125HIST(CODE,ARY) ; Activation History
126 ;
127 ; Input:
128 ; CODE - Code - REQUIRED
129 ; .ARY - Array, passed by Reference
130 ;
131 ; Output:
132 ; ARY(0) = Number of Activation History Entries
133 ; ARY(<date>) = status where: 1 is Active
134 ; ARY("IEN") = <ien>
135 ;
136 N LEXC,LEXI,LEXN,LEXD,LEXF,LEXO S LEXC=$G(CODE) Q:'$L(LEXC) -1
137 S LEXI=$$PI(LEXC),ARY("IEN")=LEXI,LEXO=""
138 M LEXO=^LEX(757.02,+LEXI,4) K LEXO("B")
139 S ARY(0)=+($P($G(LEXO(0)),U,4))
140 S:+ARY(0)=0 ARY(0)=-1 K:ARY(0)=-1 ARY("IEN")
141 S (LEXI,LEXC)=0 F S LEXI=$O(LEXO(LEXI)) Q:+LEXI=0 D
142 . S LEXD=$P($G(LEXO(LEXI,0)),U,1) Q:+LEXD=0
143 . S LEXF=$P($G(LEXO(LEXI,0)),U,2) Q:'$L(LEXF)
144 . S LEXC=LEXC+1,ARY(0)=LEXC,ARY(LEXD)=LEXF
145 Q ARY(0)
Note: See TracBrowser for help on using the repository browser.