source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGENA5.m@ 1259

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

initial load of WorldVistAEHR

File size: 7.0 KB
Line 
1DGENA5 ;ISA/Zoltan - Enrollment API - CD Processing; 05/11/99
2 ;;5.3;Registration;**232**;Aug 13, 1993
3 ;Phase II API's Related to Catastrophic Disability.
4 ;
5 ; The following variable names are used consistently in this routine:
6 ; DFN = IEN in PATIENT file (#2).
7 ; REASON = IEN in CATASTROPHIC DISABILITY REASONS file (#2).
8 ; COND = Sub-ien PATIENT(#2) CD STATUS CONDITIONS field (#.398).
9 ; SCORE = Score achieved by veteran on a test (#2, #.398, #1).
10 ; PERM = Permanent Indicator (#2, #.398, #2).
11 ; D2 = Secondary delimiter (optional.)
12 ;
13 ; Processing related to a patient (#2).
14VCD(DFN) ; Veteran Catastrophically Disabled? (#.39)
15 Q $P($G(^DPT(DFN,.39)),"^",6)
16CONDHELP(DFN,COND) ; Display help text for a condition.
17 ; Applies to the PATIENT file (#2) CD STATUS CONDITIONS field (#.398)
18 ; Note - Help text stored in 27.17 CD REASONS.
19 N REASON
20 S REASON=$$REASON(DFN,COND)
21 D HELP(REASON)
22 Q
23CONDINP(DFN,COND,SCORE) ; Validate a score entered by the user for a PATIENT.
24 N REASON
25 S REASON=$$REASON(DFN,COND)
26 Q $$VALID(REASON,SCORE)
27CONDMET(DFN,COND) ; Determine whether a condition meets the criteria.
28 N SCORE,PERM
29 S REASON=$$REASON(DFN,COND)
30 S SCORE=$$PATSCORE(DFN,COND)
31 S PERM=$$PATPERM(DFN,COND)
32 Q $$RANGEMET(REASON,SCORE,PERM)
33 ; Patient Field Lookup.
34REASON(DFN,COND) ; Get the CD REASON for this patient, for this condition.
35 N REASON
36 I DFN=""!(COND="") D
37 . S REASON=$G(DGCDREAS)
38 . I REASON="",$G(ITEM)'="" S REASON=$G(DGCDIS("COND",ITEM))
39 E S REASON=$P($G(^DPT(DFN,.398,COND,0)),"^",1)
40 Q REASON
41PATSCORE(DFN,COND) ; Get the TEST SCORE for this patient, for this condition.
42 N REASON
43 I DFN=""!(COND="") Q ""
44 S REASON=$P($G(^DPT(DFN,.398,COND,0)),"^",2)
45 Q REASON
46PATPERM(DFN,COND) ; Get the PERMANENT INDICATOR for this patient+condition.
47 N REASON
48 I DFN=""!(COND="") Q ""
49 S REASON=$P($G(^DPT(DFN,.398,COND,0)),"^",3)
50 Q REASON
51 ; Processing related to catastrophic disability reasons (#27.17)
52HELP(REASON) ; Display help text from 27.17 CD REASONS.
53 N LINE
54 Q:$$TYPE(REASON)'="C"
55 S LINE=0
56 W !,"HELP TEXT FOR ",$$NAME(REASON),!
57 F S LINE=$O(^DGEN(27.17,REASON,3,LINE)) Q:'LINE D
58 . W ?3,^DGEN(27.17,REASON,3,LINE,0),!
59 Q
60VALID(REASON,SCORE) ; Validate a proposed score for a test.
61 N TEST,X
62 S TEST=$$VALSCORE(REASON)
63 S X=SCORE
64 I @TEST Q 1
65 Q 0
66RANGEMET(REASON,SCORE,PERM) ; Determine whether this reason is satisfied.
67 N TEST
68 S TEST=$$RANGE(REASON)
69 I @TEST Q 1
70 Q 0
71 ; APIs to access CD REASONS file.
72NAME(REASON) ; Return NAME (.01) for this CD REASON.
73 Q:'REASON ""
74 Q $P($G(^DGEN(27.17,REASON,0)),"^",1)
75TYPE(REASON) ; Return TYPE (#1) for this CD REASON.
76 Q:'REASON ""
77 Q $P($G(^DGEN(27.17,REASON,0)),"^",2)
78VALSCORE(REASON) ; Return VALIDATION (#7) for this CD REASON.
79 ; This determines whether a score is valid at all.
80 Q $G(^DGEN(27.17,REASON,4))
81RANGE(REASON) ; Return TEST SCORE RANGE (#5) for this CD REASON.
82 ; This determines whether the score qualifies for CD.
83 Q $G(^DGEN(27.17,REASON,2))
84FILENAME(REASON) ; Return the file name to which this CD Reason points.
85 N CODEPTR,DIC,DO
86 S U=$G(U,"^")
87 S CODEPTR=$$CODEPTR(REASON)
88 I CODEPTR="" Q ""
89 S DIC="^"_$P(CODEPTR,";",2)
90 S DIC(0)=""
91 D DO^DIC1
92 Q $P(DO,"^",1)
93CODE(REASON) ; Return the HL7 Transmission Code for this CD Reason.
94 Q:'REASON ""
95 Q $P($G(^DGEN(27.17,REASON,0)),"^",4)
96CODENAME(REASON) ; Return name of code associated with this CD Reason.
97 N CODEPTR,CODEIEN,CODEGLO,CODEPC,CODENAME,CODE
98 S CODEPTR=$$CODEPTR(REASON)
99 I CODEPTR="" Q ""
100 S CODEIEN=$P(CODEPTR,";",1)
101 S CODEGLO=$P(CODEPTR,";",2)
102 S CODEPC=$S(CODEGLO="ICD9(":3,CODEGLO="ICD0(":4,CODEGLO="ICPT(":2)
103 S CODEGLO="^"_CODEGLO_CODEIEN_",0)"
104 S CODE=$P(@CODEGLO,"^",1)
105 S CODENAME=$P(@CODEGLO,"^",CODEPC)
106 Q CODENAME
107CODEPTR(REASON) ; Internal label--get pointer to CODE.
108 Q $P($G(^DGEN(27.17,REASON,0)),"^",3)
109LSCREEN(LIMBCODE) ; Used to validate LIMB in screen.
110 N REASON
111 S REASON=""
112 I $G(D0)=""!($G(D1)="") D
113 . S REASON=$G(DGCDREAS)
114 . I REASON="",$G(ITEM)'="" S REASON=$G(DGCDIS("PROC",ITEM))
115 E S REASON=$P($G(^DPT(D0,.397,D1,0)),"^",1)
116 I REASON="" Q ".RUE.LUE.RLE.LLE."[("."_LIMBCODE_".")
117 Q $$LIMBOK(REASON,LIMBCODE)
118LIMBOK(REASON,LIMBCODE) ; Return 1/0 Affected Extremity OK for this REASON.
119 N LIMBIEN,VALID
120 S VALID=0
121 S LIMBIEN=0
122 F S LIMBIEN=$$NEXTLIMB(REASON,LIMBIEN) Q:'LIMBIEN D Q:VALID
123 . I $$LIMBCODE(REASON,LIMBIEN)=LIMBCODE S VALID=1
124 Q VALID
125NEXTLIMB(REASON,LIMBIEN) ; Get next possible limb for this REASON.
126 I 'LIMBIEN S LIMBIEN=0
127 S LIMBIEN=$O(^DGEN(27.17,REASON,1,LIMBIEN))
128 I 'LIMBIEN S LIMBIEN=""
129 Q LIMBIEN
130LIMBCODE(REASON,LIMBIEN) ; Return limb code for an affected limb.
131 Q $P($G(^DGEN(27.17,REASON,1,LIMBIEN,0)),"^",1)
132 ; HL7-related changes.
133HL7TORSN(HL7VAL,D2) ; Return REASON IEN for a HL7 Transmission Value.
134 ; This function returns the IEN or 0 if there is none.
135 S D2=$S(11[$D(D2):D2,11[$D(HLECH):$E(HLECH),1:"~")
136 I $P("KATZ^FOLS^FIM^GAF","^",$P(HL7VAL,D2,1))=$P(HL7VAL,D2,2) D
137 . S HL7VAL=$P("KATZ^FOLS^FIM^GAF","^",+HL7VAL)
138 E S HL7VAL=$P(HL7VAL,D2)
139 Q:HL7VAL="" 0
140 Q +$O(^DGEN(27.17,"C",HL7VAL,""))
141RSNTOHL7(REASON,D2) ; Return HL7 Segment Value for this Reason.
142 Q:REASON="" 0
143 S D2=$S(11[$D(D2):D2,11[$D(HLECH):$E(HLECH),1:"~")
144 N NAME,NUMBER,TABLE,FILE,CODE,HL7VAL
145 I $$TYPE(REASON)="C" D
146 . S CODE=$$CODE(REASON)
147 . Q:CODE=""
148 . S NUMBER=$L($P("KATZ^FOLS^FIM^GAF^",CODE),"^")
149 . Q:NUMBER>4
150 . S TABLE="VA0043"
151 . S HL7VAL=NUMBER_D2_CODE_D2_TABLE
152 E D
153 . S NAME=$$NAME(REASON)
154 . Q:NAME=""
155 . S CODE=$$CODE(REASON)
156 . Q:CODE=""
157 . S FILE=$$FILENAME(REASON)
158 . Q:FILE=""
159 . S HL7VAL=CODE_D2_NAME_D2_FILE
160 ; NOTE: an undefined variable error on the following line may
161 ; result, if someone has tampered with the CATASTROPHIC
162 ; DISABILITY REASONS file (#27.17).
163 Q HL7VAL
164HLTOLIMB(HLVAL,D2) ; Convert HL7 transmission value to Limb code.
165 ; HLVAL = HL7 text of "Affected Extremity" code.
166 ; D2 = Secondary delimiter (for future expansion.)
167 ; NOTE: D2 Parameter is ignored at present, but may be
168 ; required in future if the sequence structure changes.
169 Q $P("RUE-RLE-LUE-LLE","-",+HLVAL)
170LIMBTOHL(LIMB,D2) ; Convert Limb code to HL7 transmission value.
171 ; LIMB = Affected Extremity code: RUE = Right Upper Extremity;
172 ; LLE = Left Lower Extremity; also RLE and LUE.
173 ; D2 = Secondary Delimiter to use in this HL7 sequence.
174 S D2=$S(11[$D(D2):D2,11[$D(HLECH):$E(HLECH),1:"~")
175 N NUMBER,HLVAL
176 I "-RUE-RLE-LUE-LLE-"'[("-"_LIMB_"-")!(LIMB["-") Q ""
177 S NUMBER=$L($P("-RUE-RLE-LUE-LLE-","-"_LIMB_"-"),"-")
178 S HLVAL=NUMBER_D2_LIMB_D2_"VA0042"
179 Q HLVAL
180PERMTOHL(NUMBER,D2) ; Convert Permanent Status Indicator to HL7 sequence.
181 ; NUMBER = 1 for Permanent, 2 for Not Permanent, 3 for Unknown.
182 ; D2 = Secondary Delimiter to use in this HL7 sequence.
183 S D2=$S(11[$D(D2):D2,11[$D(HLECH):$E(HLECH),1:"~")
184 N PERM,HLVAL
185 S PERM=$P("PERMANENT-NOT PERMANENT-UNKNOWN","-",NUMBER)
186 I PERM="" Q ""
187 S HLVAL=NUMBER_D2_PERM_D2_"VA0045"
188 Q HLVAL
189METH2HL7(METHOD,D2) ; Comvert Method of Determination to HL7 Transmission Value.
190 S D2=$S(11[$D(D2):D2,11[$D(HLECH):$E(HLECH),1:"~")
191 N METHS
192 S METHS="AUTOMATED RECORD REVIEW^MEDICAL RECORD REVIEW^PHYSICAL EXAMINATION"
193 I ".1.2.3."'[("."_METHOD_".") Q ""
194 Q METHOD_D2_$P(METHS,"^",METHOD)_D2_"VA0041"
Note: See TracBrowser for help on using the repository browser.