Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: OCXDI02G

OCXDI02G.m

Go to the documentation of this file. 
  1. OCXDI02G ;SLC/RJS,CLA - OCX PACKAGE DIAGNOSTIC ROUTINES ;SEP 7,1999 at 10:30
  1.  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32**;Dec 17,1997
  1.  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
  1.  ;
  1. S ;
  1.  ;
  1.  D DOT^OCXDIAG
  1.  ;
  1.  ;
  1.  K REMOTE,LOCAL,OPCODE,REF
  1.  F LINE=1:1:500 S TEXT=$P($T(DATA+LINE),";",2,999) Q:TEXT  I $L(TEXT) D  Q:QUIT
  1.  .S ^TMP("OCXDIAG",$J,$O(^TMP("OCXDIAG",$J,"A"),-1)+1)=TEXT
  1.  ;
  1.  G ^OCXDI02H
  1.  ;
  1.  Q
  1.  ;
  1. DATA ;
  1.  ;
  1.  ;;R^"860.8:",100,3
  1.  ;;D^T+; I $G(OCXTRACE) W !,"%%%%",?20," Execution trace  OILIST: ",$G(OILIST)
  1.  ;;R^"860.8:",100,4
  1.  ;;D^  ; N OCXPC,OCXOI,OCXOUT S OCXOUT=""
  1.  ;;R^"860.8:",100,5
  1.  ;;D^  ; F OCXPC=1:1:$L(OILIST,",") S OCXOI=$P(OILIST,",",OCXPC) I $L(OCXOI) D
  1.  ;;R^"860.8:",100,6
  1.  ;;D^  ; .N OCXL,OCXF,OCXD0
  1.  ;;R^"860.8:",100,7
  1.  ;;D^  ; .S OCXL="",OCXF=$$TERMLKUP(OCXOI,.OCXL)
  1.  ;;R^"860.8:",100,8
  1.  ;;D^  ; .S OCXD0=0 F  S OCXD0=$O(OCXL(OCXD0)) Q:'OCXD0  Q:$$OISESS^ORKCHK2(+OCXD0)
  1.  ;;R^"860.8:",100,9
  1.  ;;D^  ; .Q:OCXD0
  1.  ;;R^"860.8:",100,10
  1.  ;;D^  ; .S:$L(OCXOUT) OCXOUT=OCXOUT_", " S OCXOUT=OCXOUT_OCXOI
  1.  ;;R^"860.8:",100,11
  1.  ;;D^  ; Q OCXOUT
  1.  ;;R^"860.8:",100,12
  1.  ;;D^  ; ;
  1.  ;;EOR^
  1.  ;;KEY^860.8:^RECENT BARIUM STUDY
  1.  ;;R^"860.8:",.01,"E"
  1.  ;;D^RECENT BARIUM STUDY
  1.  ;;R^"860.8:",.02,"E"
  1.  ;;D^RECBAR
  1.  ;;R^"860.8:",100,1
  1.  ;;D^  ;RECBAR(DFN,HOURS) ;
  1.  ;;R^"860.8:",100,2
  1.  ;;D^  ; ;
  1.  ;;R^"860.8:",100,3
  1.  ;;D^  ; Q:'$G(DFN) 0 Q:'$G(HOURS) 0 N OUT S OUT=$$RECENTBA^ORKRA(DFN,HOURS) Q:'$L(OUT) 0 Q 1_U_OUT
  1.  ;;R^"860.8:",100,4
  1.  ;;D^  ; ;  
  1.  ;;EOR^
  1.  ;;KEY^860.8:^RECENT WBC LAB PROCEDURE
  1.  ;;R^"860.8:",.01,"E"
  1.  ;;D^RECENT WBC LAB PROCEDURE
  1.  ;;R^"860.8:",.02,"E"
  1.  ;;D^RECWBC
  1.  ;;R^"860.8:",100,1
  1.  ;;D^  ;RECWBC(DFN,DAYS) ;
  1.  ;;R^"860.8:",100,2
  1.  ;;D^  ; ;
  1.  ;;R^"860.8:",100,3
  1.  ;;D^  ; Q:'$G(DFN) 0
  1.  ;;R^"860.8:",100,4
  1.  ;;D^  ; N OUT S OUT=$$RECNTWBC^ORKLR(DFN,DAYS) Q:'OUT 0 Q OUT
  1.  ;;R^"860.8:",100,5
  1.  ;;D^  ; ;  
  1.  ;;EOR^
  1.  ;;KEY^860.8:^CREATININE CLEARANCE (ESTIMATED/CALCULATED)
  1.  ;;R^"860.8:",.01,"E"
  1.  ;;D^CREATININE CLEARANCE (ESTIMATED/CALCULATED)
  1.  ;;R^"860.8:",.02,"E"
  1.  ;;D^CRCL
  1.  ;;R^"860.8:",100,1
  1.  ;;D^  ;CRCL(DFN) ;
  1.  ;;R^"860.8:",100,2
  1.  ;;D^  ; ;
  1.  ;;R^"860.8:",100,3
  1.  ;;D^  ; N WT,AGE,SEX,SCR,SCRD,CRCL,UNAV,OCXTL,OCXTLS,OCXT,OCXTS
  1.  ;;R^"860.8:",100,4
  1.  ;;D^  ; S UNAV="0^<Unavailable>"
  1.  ;;R^"860.8:",100,5
  1.  ;;D^  ; S WT=$P($$WT^ORQPTQ4(DFN),U,2)*.454 Q:'WT UNAV
  1.  ;;R^"860.8:",100,6
  1.  ;;D^  ; S AGE=$$AGE^ORQPTQ4(DFN) Q:'AGE UNAV
  1.  ;;R^"860.8:",100,7
  1.  ;;D^  ; S SEX=$P($$SEX^ORQPTQ4(DFN),U,1) Q:'$L(SEX) UNAV
  1.  ;;R^"860.8:",100,8
  1.  ;;D^  ; S OCXTL="" Q:'$$TERMLKUP("SERUM CREATININE",.OCXTL) UNAV
  1.  ;;R^"860.8:",100,9
  1.  ;;D^  ; S OCXTLS="" Q:'$$TERMLKUP("SERUM SPECIMEN",.OCXTLS) UNAV
  1.  ;;R^"860.8:",100,10
  1.  ;;D^  ; S SCR="",OCXT=0 F  S OCXT=$O(OCXTL(OCXT)) Q:'OCXT  D  Q:$L(SCR)
  1.  ;;R^"860.8:",100,11
  1.  ;;D^  ; .S OCXTS=0 F  S OCXTS=$O(OCXTLS(OCXTS)) Q:'OCXTS  D  Q:$L(SCR)
  1.  ;;R^"860.8:",100,12
  1.  ;;D^  ; ..S SCR=$$LOCL^ORQQLR1(DFN,OCXT,OCXTS)
  1.  ;;R^"860.8:",100,13
  1.  ;;D^  ; Q:'$L(SCR) UNAV  S SCRV=$P(SCR,U,3) Q:'SCRV UNAV
  1.  ;;R^"860.8:",100,14
  1.  ;;D^  ; S SCRD=$P(SCR,U,7) Q:'$L(SCRD) UNAV
  1.  ;;R^"860.8:",100,15
  1.  ;;D^  ; ;
  1.  ;;R^"860.8:",100,16
  1.  ;;D^  ; S CRCL=(((140-AGE)*WT)/(SCRV*72))
  1.  ;;R^"860.8:",100,17
  1.  ;;D^  ; ;
  1.  ;;R^"860.8:",100,18
  1.  ;;D^  ; I (SEX="M") Q SCRD_U_$J(CRCL,1,2)
  1.  ;;R^"860.8:",100,19
  1.  ;;D^  ; I (SEX="F") Q SCRD_U_$J((CRCL*.85),1,2)
  1.  ;;R^"860.8:",100,20
  1.  ;;D^  ; Q UNAV
  1.  ;;R^"860.8:",100,21
  1.  ;;D^  ; ;
  1.  ;;EOR^
  1.  ;;KEY^860.8:^CT MRI PHYSICAL LIMITS
  1.  ;;R^"860.8:",.01,"E"
  1.  ;;D^CT MRI PHYSICAL LIMITS
  1.  ;;R^"860.8:",.02,"E"
  1.  ;;D^CTMRI
  1.  ;;R^"860.8:",100,1
  1.  ;;D^  ;CTMRI(DFN,OCXOI) ;
  1.  ;;R^"860.8:",100,2
  1.  ;;D^  ; ;
  1.  ;;R^"860.8:",100,3
  1.  ;;D^  ; N OCXDEV,OCXWTP,OCXHTP,OCXWTL,OCXHTL
  1.  ;;R^"860.8:",100,4
  1.  ;;D^  ; S OCXDEV=$$TYPE^ORKRA(OCXOI)
  1.  ;;R^"860.8:",100,5
  1.  ;;D^  ; Q:'((OCXDEV="MRI")!(OCXDEV="CT")) 0_U
  1.  ;;R^"860.8:",100,6
  1.  ;;D^  ; S OCXWTP=$P($$WT^ORQPTQ4(DFN),U,2),OCXHTP=$P($$HT^ORQPTQ4(DFN),U,2)
  1.  ;;R^"860.8:",100,7
  1.  ;;D^  ; I (OCXDEV="CT") S OCXWTL=$$GET^XPAR("ALL","ORK CT LIMIT WT",1,"Q"),OCXHTL=$$GET^XPAR("ALL","ORK CT LIMIT HT",1,"Q")
  1.  ;;R^"860.8:",100,8
  1.  ;;D^  ; I (OCXDEV="CT"),(OCXWTL),(OCXWTP>OCXWTL) Q 1_U_"too heavy"_U_"CT scanner"
  1.  ;;R^"860.8:",100,9
  1.  ;;D^  ; I (OCXDEV="CT"),(OCXHTL),(OCXHTP>OCXHTL) Q 1_U_"too tall"_U_"CT scanner"
  1.  ;;R^"860.8:",100,10
  1.  ;;D^  ; I (OCXDEV="MRI") S OCXWTL=$$GET^XPAR("ALL","ORK MRI LIMIT WT",1,"Q"),OCXHTL=$$GET^XPAR("ALL","ORK MRI LIMIT HT",1,"Q")
  1.  ;;R^"860.8:",100,11
  1.  ;;D^  ; I (OCXDEV="MRI"),(OCXWTL),(OCXWTP>OCXWTL) Q 1_U_"too heavy"_U_"MRI scanner"
  1.  ;;R^"860.8:",100,12
  1.  ;;D^  ; I (OCXDEV="MRI"),(OCXHTL),(OCXHTP>OCXHTL) Q 1_U_"too tall"_U_"MRI scanner"
  1.  ;;R^"860.8:",100,13
  1.  ;;D^  ; Q 0_U
  1.  ;;R^"860.8:",100,14
  1.  ;;D^  ; ;
  1.  ;;EOR^
  1.  ;;KEY^860.8:^GET ORDERABLE ITEM INTERNAL ENTRY NUMBER
  1.  ;;R^"860.8:",.01,"E"
  1.  ;;D^GET ORDERABLE ITEM INTERNAL ENTRY NUMBER
  1.  ;;R^"860.8:",.02,"E"
  1.  ;;D^GETOIIEN
  1.  ;;R^"860.8:",100,1
  1.  ;;D^ ;GETOIIEN(OCXPKG,OCXNAME) ;
  1.  ;;R^"860.8:",100,2
  1.  ;;D^ ; ;
  1.  ;;R^"860.8:",100,3
  1.  ;;D^ ; Q:'$L($G(OCXNAME)) 0 Q:'$L($G(OCXPKG)) 0 Q:'$D(^ORD(101.43,"S."_OCXPKG)) 0
  1.  ;;R^"860.8:",100,4
  1.  ;;D^ ; N OCXD0,OCXLIST,OCXOI
  1.  ;;R^"860.8:",100,5
  1.  ;1;
  1.  ;