- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0Y.m
r613 r623 1 OCXOZ0Y ;SLC/RJS,CLA - Order Check Scan ;NOV 8,2009 at 18:442 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221,243**;Dec 17,1997;Build 242 3 4 5 6 7 8 9 10 11 12 13 R61R1A 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 R61R1B 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 CRCL(DFN) 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 DT2INT(OCXDT) 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 FLAB(DFN,OCXLIST,OCXSPEC) 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 GETDATA(DFN,OCXL,OCXDFI) 155 156 157 158 159 160 MCE73() 161 162 163 164 165 166 167 168 169 MCE96() 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 MCE97() 185 186 187 188 189 190 191 192 193 194 195 196 197 198 TERMLKUP(OCXTERM,OCXLIST) 199 200 1 OCXOZ0Y ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00 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 ; 13 R61R1A ; 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 ; 30 R61R1B ; 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 ; 52 CRCL(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 ; 92 DT2INT(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 ; 130 FLAB(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 ; 154 GETDATA(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 ; 160 MCE73() ; 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 ; 169 MCE96() ; 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 ; 184 MCE97() ; 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 ; 198 TERMLKUP(OCXTERM,OCXLIST) ; 199 Q $$TERM^OCXOZ01(OCXTERM,.OCXLIST) 200 ;
Note:
See TracChangeset
for help on using the changeset viewer.
