source: FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0Y.m@ 653

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

initial load of FOIAVistA 6/30/08 version
File size: 8.5 KB
Line 
1OCXOZ0Y ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
4 ;
5 ; ***************************************************************
6 ; ** Warning: This routine is automatically generated by the **
7 ; ** Rule Compiler (^OCXOCMP) and ANY changes to this routine **
8 ; ** will be lost the next time the rule compiler executes. **
9 ; ***************************************************************
10 ;
11 Q
12 ;
13R61R1A ; Verify all Event/Elements of Rule #61 'CREATININE CLEARANCE ESTIMATION' Relation #1 'IF CREAT CLEAR AND ( CREATININE CLEARANCE DATE OR ...'
14 ; Called from EL73+5^OCXOZ0I, and EL96+5^OCXOZ0I, and EL97+5^OCXOZ0I.
15 ;
16 Q:$G(OCXOERR)
17 ;
18 ; Local Extrinsic Functions
19 ; MCE73( -----------> Verify Event/Element: 'CREATININE CLEARANCE ESTIMATE'
20 ; MCE96( -----------> Verify Event/Element: 'CREATININE CLEARANCE DATE/TIME'
21 ; MCE97( -----------> Verify Event/Element: 'RENAL RESULTS'
22 ;
23 Q:$G(^OCXS(860.2,61,"INACT"))
24 ;
25 I $$MCE73 D
26 .I $$MCE96 D R61R1B
27 .I $$MCE97 D R61R1B
28 Q
29 ;
30R61R1B ; Send Order Check, Notication messages and/or Execute code for Rule #61 'CREATININE CLEARANCE ESTIMATION' Relation #1 'IF CREAT CLEAR AND ( CREATININE CLEARANCE DATE OR ...'
31 ; Called from R61R1A+13.
32 ;
33 Q:$G(OCXOERR)
34 ;
35 ; Local Extrinsic Functions
36 ; GETDATA( ---------> GET DATA FROM THE ACTIVE DATA FILE
37 ;
38 Q:$D(OCXRULE("R61R1B"))
39 ;
40 N OCXNMSG,OCXCMSG,OCXPORD,OCXFORD,OCXDATA,OCXNUM,OCXDUZ,OCXQUIT,OCXLOGS,OCXLOGD
41 I ($G(OCXOSRC)="CPRS ORDER PRESCAN") S OCXCMSG=(+OCXPSD)_"^1^^Est. CrCl: "_$$GETDATA(DFN,"73^96^97",76)_" ("_$$GETDATA(DFN,"73^96^97",64)_") [Est. CrCl based on modified Cockcroft-Gault equation using Adjusted Body Weight (if ht > 60 in.)]" I 1
42 E S OCXCMSG="Est. CrCl: "_$$GETDATA(DFN,"73^96^97",76)_" ("_$$GETDATA(DFN,"73^96^97",64)_") [Est. CrCl based on modified Cockcroft-Gault equation using Adjusted Body Weight (if ht > 60 in.)]"
43 S OCXNMSG=""
44 ;
45 Q:$G(OCXOERR)
46 ;
47 ; Send Order Check Message
48 ;
49 S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG
50 Q
51 ;
52CRCL(DFN) ; Compiler Function: CREATININE CLEARANCE (ESTIMATED/CALCULATED)
53 ;
54 N HT,AGE,SEX,SCR,SCRD,CRCL,LRWKLD,RSLT,ORW,ORH,PSCR
55 N HTGT60,ABW,IBW,BWRATIO,BWDIFF,LOWBW,ADJBW
56 S RSLT="0^<Unavailable>"
57 S PSCR="^^^^^^0"
58 D VITAL^ORQQVI("WEIGHT","WT",DFN,.ORW,0,"",$$NOW^XLFDT)
59 Q:'$D(ORW) RSLT
60 S ABW=$P(ORW(1),U,3) Q:+$G(ABW)<1 RSLT
61 S ABW=ABW/2.2 ;ABW (actual body weight) in kg
62 D VITAL^ORQQVI("HEIGHT","HT",DFN,.ORH,0,"",$$NOW^XLFDT)
63 Q:'$D(ORH) RSLT
64 S HT=$P(ORH(1),U,3) Q:+$G(HT)<1 RSLT
65 S AGE=$$AGE^ORQPTQ4(DFN) Q:'AGE RSLT
66 S SEX=$P($$SEX^ORQPTQ4(DFN),U,1) Q:'$L(SEX) RSLT
67 S OCXTL="" Q:'$$TERMLKUP^ORB31(.OCXTL,"SERUM CREATININE") RSLT
68 S OCXTLS="" Q:'$$TERMLKUP^ORB31(.OCXTLS,"SERUM SPECIMEN") RSLT
69 S SCR="",OCXT=0 F S OCXT=$O(OCXTL(OCXT)) Q:'OCXT D
70 .S OCXTS=0 F S OCXTS=$O(OCXTLS(OCXTS)) Q:'OCXTS D
71 ..S SCR=$$LOCL^ORQQLR1(DFN,$P(OCXTL(OCXT),U),$P(OCXTLS(OCXTS),U))
72 ..I $P(SCR,U,7)>$P(PSCR,U,7) S PSCR=SCR
73 S SCR=PSCR,SCRV=$P(SCR,U,3) Q:+$G(SCRV)<.01 RSLT
74 S SCRD=$P(SCR,U,7) Q:'$L(SCRD) RSLT
75 ;
76 S HTGT60=$S(HT>60:(HT-60)*2.3,1:0) ;if ht > 60 inches
77 I HTGT60>0 D
78 .S IBW=$S(SEX="M":50+HTGT60,1:45.5+HTGT60) ;Ideal Body Weight
79 .S BWRATIO=(ABW/IBW) ;body weight ratio
80 .S BWDIFF=$S(ABW>IBW:ABW-IBW,1:0)
81 .S LOWBW=$S(IBW<ABW:IBW,1:ABW)
82 .I BWRATIO>1.3,(BWDIFF>0) S ADJBW=((0.3*BWDIFF)+IBW)
83 .E S ADJBW=LOWBW
84 I +$G(ADJBW)<1 D
85 .S ADJBW=ABW
86 S CRCL=(((140-AGE)*ADJBW)/(SCRV*72))
87 ;
88 S:SEX="M" RSLT=SCRD_U_$J(CRCL,1,1)
89 S:SEX="F" RSLT=SCRD_U_$J((CRCL*.85),1,1)
90 Q RSLT
91 ;
92DT2INT(OCXDT) ; This Local Extrinsic Function converts a date into an integer
93 ; By taking the Years, Months, Days, Hours and Minutes converting
94 ; Them into Seconds and then adding them all together into one big integer
95 ;
96 Q:'$L($G(OCXDT)) ""
97 N OCXDIFF,OCXVAL S (OCXDIFF,OCXVAL)=0
98 ;
99 I $L(OCXDT),'OCXDT,(OCXDT[" at ") D ; EXTERNAL EXPERT SYSTEM FORMAT 1 TO EXTERNAL FORMAT
100 .N OCXHR,OCXMIN,OCXTIME
101 .S OCXTIME=$P($P(OCXDT," at ",2),".",1),OCXHR=$P(OCXTIME,":",1),OCXMIN=$P(OCXTIME,":",2)
102 .S:(OCXDT["Midnight") OCXHR=00
103 .S:(OCXDT["PM") OCXHR=OCXHR+12
104 .S OCXDT=$P(OCXDT," at ")_"@"_$E(OCXHR+100,2,3)_$E(OCXMIN+100,2,3)
105 ;
106 I $L(OCXDT),(OCXDT?1.2N1"/"1.2N.1" ".2N.1":".2N) D ; EXTERNAL EXPERT SYSTEM FORMAT 2 TO EXTERNAL FORMAT
107 .N OCXMON
108 .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1))
109 .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_"@"_$TR($P(OCXDT," ",2),":","")
110 .E S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)
111 ;
112 I $L(OCXDT),(OCXDT?1.2N1"/"1.2N1"/"1.2N.1" ".2N.1":".2N) D ; EXTERNAL EXPERT SYSTEM FORMAT 3 TO EXTERNAL FORMAT
113 .N OCXMON
114 .S OCXMON=$P("January^February^March^April^May^June^July^August^September^October^November^December",U,$P(OCXDT,"/",1))
115 .I $L($P(OCXDT," ",2)) S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_","_$P($P(OCXDT," ",1),"/",3)_"@"_$TR($P(OCXDT," ",2),":","")
116 .E S OCXDT=OCXMON_" "_$P($P(OCXDT," ",1),"/",2)_", "_$P($P(OCXDT," ",1),"/",3)
117 ;
118 I $L(OCXDT),'OCXDT D ; EXTERNAL FORMAT TO INTERNAL FILEMAN FORMAT
119 .I (OCXDT["@0000") S OCXDT=$P(OCXDT,"@",1),OCXDIFF=1
120 .N %DT,X,Y S X=OCXDT,%DT="" S:(OCXDT["@")!(OCXDT="N") %DT="T" D ^%DT S OCXDT=+Y
121 ;
122 I ($L(OCXDT\1)>7) S OCXDT=$$HL7TFM^XLFDT(OCXDT) ; HL7 FORMAT TO INTERNAL FILEMAN FORMAT
123 ;
124 I ($L(OCXDT\1)=7) S OCXDT=$$FMTH^XLFDT(+OCXDT) ; INTERNAL FILEMAN FORMAT TO $H FORMAT
125 ;
126 I (OCXDT?5N1","1.5N) S OCXVAL=(OCXDT*86400)+$P(OCXDT,",",2) ; $H FORMAT TO EXPERT SYSTEM INTERNAL FORMAT
127 ;
128 Q OCXVAL
129 ;
130FLAB(DFN,OCXLIST,OCXSPEC) ; Compiler Function: FORMATTED LAB RESULTS
131 ;
132 Q:'$G(DFN) "<Patient Not Specified>"
133 Q:'$L($G(OCXLIST)) "<Lab Tests Not Specified>"
134 N OCXLAB,OCXOUT,OCXPC,OCXSL,SPEC S OCXOUT="",SPEC=""
135 I $L($G(OCXSPEC)) S OCXSL=$$TERMLKUP(OCXSPEC,.OCXSL)
136 F OCXPC=1:1:$L(OCXLIST,U) S OCXLAB=$P(OCXLIST,U,OCXPC) I $L(OCXLAB) D
137 .N OCXX,OCXY,X,Y,DIC,TEST,SPEC,OCXTL,OCXA,OCXR
138 .S OCXTL="" Q:'$$TERMLKUP(OCXLAB,.OCXTL)
139 .S OCXX="",TEST=0 F S TEST=$O(OCXTL(TEST)) Q:'TEST D
140 ..I $L($G(OCXSL)) D
141 ...S SPEC=0 F S SPEC=$O(OCXSL(SPEC)) Q:'SPEC D
142 ....S OCXX=$$LOCL^ORQQLR1(DFN,TEST,SPEC) I $L(OCXX) D
143 .....S OCXA($P(OCXX,U,7))=OCXX
144 ..I '$L($G(OCXSL)) S OCXX=$$LOCL^ORQQLR1(DFN,TEST,"")
145 ..Q:'$L(OCXX)
146 .I $D(OCXA) S OCXR="",OCXR=$O(OCXA(OCXR),-1),OCXX=OCXA(OCXR)
147 .I $L(OCXX) D
148 ..S OCXY=$P(OCXX,U,2)_": "_$P(OCXX,U,3)_" "_$P(OCXX,U,4)
149 ..S OCXY=OCXY_" "_$S($L($P(OCXX,U,5)):"["_$P(OCXX,U,5)_"]",1:"")
150 ..I $L($P(OCXX,U,7)) S OCXY=OCXY_" "_$$FMTE^XLFDT($P(OCXX,U,7),"2P")
151 .S:$L(OCXOUT) OCXOUT=OCXOUT_" " S OCXOUT=OCXOUT_$G(OCXY)
152 Q:'$L(OCXOUT) "<Results Not Found>" Q OCXOUT
153 ;
154GETDATA(DFN,OCXL,OCXDFI) ; This Local Extrinsic Function returns runtime data
155 ;
156 N OCXE,VAL,PC S VAL=""
157 F PC=1:1:$L(OCXL,U) S OCXE=$P(OCXL,U,PC) I OCXE S VAL=$G(^TMP("OCXCHK",$J,DFN,OCXE,OCXDFI)) Q:$L(VAL)
158 Q VAL
159 ;
160MCE73() ; Verify Event/Element: CREATININE CLEARANCE ESTIMATE
161 ;
162 ; OCXDF(37) -> PATIENT IEN data field
163 ;
164 N OCXRES
165 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(73,37)=OCXDF(37)
166 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),73)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),73))
167 Q 0
168 ;
169MCE96() ; Verify Event/Element: CREATININE CLEARANCE DATE/TIME
170 ;
171 ; OCXDF(76) -> CREATININE CLEARANCE (ESTIM) VALUE data field
172 ; OCXDF(64) -> FORMATTED RENAL LAB RESULTS data field
173 ; OCXDF(77) -> CREATININE CLEARANCE (ESTIM) DATE data field
174 ; OCXDF(37) -> PATIENT IEN data field
175 ;
176 N OCXRES
177 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(96,37)=OCXDF(37)
178 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),96)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),96))
179 S OCXRES(96)=0,OCXDF(77)=$$DT2INT($P($$CRCL(OCXDF(37)),"^",1)) I $L(OCXDF(77)) S OCXRES(96,77)=OCXDF(77) I (OCXDF(77)>$$DT2INT(0))
180 E Q 0
181 S OCXDF(64)=$$FLAB(OCXDF(37),"SERUM CREATININE^SERUM UREA NITROGEN","SERUM SPECIMEN"),OCXDF(76)=$P($$CRCL(OCXDF(37)),"^",2),OCXRES(96)=11 M ^TMP("OCXCHK",$J,OCXDF(37),96)=OCXRES(96)
182 Q +OCXRES(96)
183 ;
184MCE97() ; Verify Event/Element: RENAL RESULTS
185 ;
186 ; OCXDF(76) -> CREATININE CLEARANCE (ESTIM) VALUE data field
187 ; OCXDF(64) -> FORMATTED RENAL LAB RESULTS data field
188 ; OCXDF(37) -> PATIENT IEN data field
189 ;
190 N OCXRES
191 S OCXDF(37)=$G(DFN) I $L(OCXDF(37)) S OCXRES(97,37)=OCXDF(37)
192 Q:'(OCXDF(37)) 0 I $D(^TMP("OCXCHK",$J,OCXDF(37),97)) Q $G(^TMP("OCXCHK",$J,OCXDF(37),97))
193 S OCXRES(97)=0,OCXDF(64)=$$FLAB(OCXDF(37),"SERUM CREATININE^SERUM UREA NITROGEN","SERUM SPECIMEN") I '(OCXDF(64)="<Results Not Found>")
194 E Q 0
195 S OCXDF(76)=$P($$CRCL(OCXDF(37)),"^",2),OCXRES(97)=11 M ^TMP("OCXCHK",$J,OCXDF(37),97)=OCXRES(97)
196 Q +OCXRES(97)
197 ;
198TERMLKUP(OCXTERM,OCXLIST) ;
199 Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST)
200 ;
Note: See TracBrowser for help on using the repository browser.