ORKRA ; slc/CLA - Order checking support procedure for Radiology ;12/15/97
;;3.0;ORDER ENTRY/RESULTS REPORTING;**6,92,105**;Dec 17, 1997
Q
RECENTBA(ORDFN,ORHRS) ; extrinsic function to return the most recent radiology procedure using barium within the past ORHRS in the format:
; order #^order text (first 60 chars) order effective date/time
N BDT,EDT,INBDT,XDT,X,ORDT,HDT,ORN,OROI,ORCM,TOT,ORQ,ORDG
S X="",ORDT="",HDT="",ORN="",TOT=0,ORQ=""
Q:+$G(ORDFN)<1 ORQ
Q:+$G(ORHRS)<1 ORQ
D NOW^%DTC S EDT=% K %
S BDT=$$FMADD^XLFDT(EDT,"","-"_ORHRS,"","")
Q:+$G(BDT)<1 ORQ
S ORDG=$$DG^ORQOR1("GENERAL RADIOLOGY")
Q:+$G(ORDG)<1 ORQ
K ^TMP("ORR",$J)
D EN^ORQ1(ORDFN_";DPT(",ORDG,1,"",BDT,EDT,0,0)
S HDT=$O(^TMP("ORR",$J,HDT)) Q:HDT="" ORQ S TOT=^(HDT,"TOT") I TOT>0 D
.F X=1:1:TOT Q:+$G(ORQ)>0 D ;quit on 1st barium found (most recent)
..S ORN=+^TMP("ORR",$J,HDT,X)
..S OROI=$G(^OR(100,ORN,.1,1,0))
..Q:+$G(OROI)<1
..S ORCM=$$CM^ORQQRA(OROI)
..I $G(ORCM)["B" D
...S ORDT=$G(^OR(100,ORN,0)) S:$L($G(ORDT)) ORDT=$P(ORDT,U,8)
...S ORDT=$$FMTE^XLFDT(ORDT,"2P")
...S ORQ=ORN_U_$P($$TEXT^ORKOR(ORN,60),U,2)_" "_$G(ORDT)
K ^TMP("ORR",$J)
Q ORQ
RECENTCH(ORDFN,ORDAYS) ;extrinsic function to return the most recent cholecystogram procedure within the past ORDAYS in the format:
; order #^order text (first 60 chars) order effective date/time
N BDT,EDT,INBDT,XDT,X,ORDT,HDT,ORN,OROI,ORCM,TOT,ORQ,ORDG
S X="",ORDT="",HDT="",ORN="",TOT=0,ORQ=""
Q:+$G(ORDFN)<1 ORQ
Q:+$G(ORDAYS)<1 ORQ
D NOW^%DTC S EDT=% K %
S BDT=$$FMADD^XLFDT(EDT,"-"_ORDAYS,"","","")
Q:+$G(BDT)<1 ORQ
S ORDG=$$DG^ORQOR1("GENERAL RADIOLOGY")
Q:+$G(ORDG)<1 ORQ
K ^TMP("ORR",$J)
D EN^ORQ1(ORDFN_";DPT(",ORDG,1,"",BDT,EDT,0,0)
S HDT=$O(^TMP("ORR",$J,HDT)) Q:HDT="" ORQ S TOT=^(HDT,"TOT") I TOT>0 D
.F X=1:1:TOT Q:+$G(ORQ)>0 D ;quit on 1st cholecyst found (most recent)
..S ORN=+^TMP("ORR",$J,HDT,X)
..S OROI=$G(^OR(100,ORN,.1,1,0))
..Q:+$G(OROI)<1
..S ORCM=$$CM^ORQQRA(OROI)
..I $G(ORCM)["C" D ;cholecystogram
...S ORDT=$G(^OR(100,ORN,0)) S:$L($G(ORDT)) ORDT=$P(ORDT,U,8)
...S ORDT=$$FMTE^XLFDT(ORDT,"2P")
...S ORQ=ORN_U_$P($$TEXT^ORKOR(ORN,60),U,2)_" "_$G(ORDT)
K ^TMP("ORR",$J)
Q ORQ
TYPE(OI) ;extrinisic function which returns the imaging type for an orderable item
;returned as 'RAD','CT','MRI','ANI','CARD','NM','US', or 'VAS'
N ORTYPE S ORTYPE=""
S ORTYPE=$G(^ORD(101.43,OI,"RA"))
S:$L($G(ORTYPE)) ORTYPE=$P(ORTYPE,U,3)
Q ORTYPE
CMCDAYS(DFN) ;extrinsic function to return number of days to look for
; contrast media serum creatinine result
Q:'$L(DFN) ""
N ORLOC,ORENT,ORDAYS
;get patient's location flag (INPATIENT ONLY - outpt locations cannot be
;reliably determined, and many simultaneous outpt locations can occur):
S VA200="" D OERR^VADPT
S ORLOC=+$G(^DIC(42,+VAIN(4),44))
K VA200,VAIN
S ORENT=+$G(ORLOC)_";SC(^DIV^SYS^PKG"
S ORDAYS=$$GET^XPAR(ORENT,"ORK CONTRAST MEDIA CREATININE",1,"I")
Q:$L(ORDAYS) ORDAYS
Q ""
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORKRA 3011 printed Apr 09, 2024@21:38:18 Page 2
ORKRA ; slc/CLA - Order checking support procedure for Radiology ;12/15/97
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**6,92,105**;Dec 17, 1997
+2 QUIT
RECENTBA(ORDFN,ORHRS) ; extrinsic function to return the most recent radiology procedure using barium within the past ORHRS in the format:
+1 ; order #^order text (first 60 chars) order effective date/time
+2 NEW BDT,EDT,INBDT,XDT,X,ORDT,HDT,ORN,OROI,ORCM,TOT,ORQ,ORDG
+3 SET X=""
SET ORDT=""
SET HDT=""
SET ORN=""
SET TOT=0
SET ORQ=""
+4 if +$GET(ORDFN)<1
QUIT ORQ
+5 if +$GET(ORHRS)<1
QUIT ORQ
+6 DO NOW^%DTC
SET EDT=%
KILL %
+7 SET BDT=$$FMADD^XLFDT(EDT,"","-"_ORHRS,"","")
+8 if +$GET(BDT)<1
QUIT ORQ
+9 SET ORDG=$$DG^ORQOR1("GENERAL RADIOLOGY")
+10 if +$GET(ORDG)<1
QUIT ORQ
+11 KILL ^TMP("ORR",$JOB)
+12 DO EN^ORQ1(ORDFN_";DPT(",ORDG,1,"",BDT,EDT,0,0)
+13 SET HDT=$ORDER(^TMP("ORR",$JOB,HDT))
if HDT=""
QUIT ORQ
SET TOT=^(HDT,"TOT")
IF TOT>0
Begin DoDot:1
+14 ;quit on 1st barium found (most recent)
FOR X=1:1:TOT
if +$GET(ORQ)>0
QUIT
Begin DoDot:2
+15 SET ORN=+^TMP("ORR",$JOB,HDT,X)
+16 SET OROI=$GET(^OR(100,ORN,.1,1,0))
+17 if +$GET(OROI)<1
QUIT
+18 SET ORCM=$$CM^ORQQRA(OROI)
+19 IF $GET(ORCM)["B"
Begin DoDot:3
+20 SET ORDT=$GET(^OR(100,ORN,0))
if $LENGTH($GET(ORDT))
SET ORDT=$PIECE(ORDT,U,8)
+21 SET ORDT=$$FMTE^XLFDT(ORDT,"2P")
+22 SET ORQ=ORN_U_$PIECE($$TEXT^ORKOR(ORN,60),U,2)_" "_$GET(ORDT)
End DoDot:3
End DoDot:2
End DoDot:1
+23 KILL ^TMP("ORR",$JOB)
+24 QUIT ORQ
RECENTCH(ORDFN,ORDAYS) ;extrinsic function to return the most recent cholecystogram procedure within the past ORDAYS in the format:
+1 ; order #^order text (first 60 chars) order effective date/time
+2 NEW BDT,EDT,INBDT,XDT,X,ORDT,HDT,ORN,OROI,ORCM,TOT,ORQ,ORDG
+3 SET X=""
SET ORDT=""
SET HDT=""
SET ORN=""
SET TOT=0
SET ORQ=""
+4 if +$GET(ORDFN)<1
QUIT ORQ
+5 if +$GET(ORDAYS)<1
QUIT ORQ
+6 DO NOW^%DTC
SET EDT=%
KILL %
+7 SET BDT=$$FMADD^XLFDT(EDT,"-"_ORDAYS,"","","")
+8 if +$GET(BDT)<1
QUIT ORQ
+9 SET ORDG=$$DG^ORQOR1("GENERAL RADIOLOGY")
+10 if +$GET(ORDG)<1
QUIT ORQ
+11 KILL ^TMP("ORR",$JOB)
+12 DO EN^ORQ1(ORDFN_";DPT(",ORDG,1,"",BDT,EDT,0,0)
+13 SET HDT=$ORDER(^TMP("ORR",$JOB,HDT))
if HDT=""
QUIT ORQ
SET TOT=^(HDT,"TOT")
IF TOT>0
Begin DoDot:1
+14 ;quit on 1st cholecyst found (most recent)
FOR X=1:1:TOT
if +$GET(ORQ)>0
QUIT
Begin DoDot:2
+15 SET ORN=+^TMP("ORR",$JOB,HDT,X)
+16 SET OROI=$GET(^OR(100,ORN,.1,1,0))
+17 if +$GET(OROI)<1
QUIT
+18 SET ORCM=$$CM^ORQQRA(OROI)
+19 ;cholecystogram
IF $GET(ORCM)["C"
Begin DoDot:3
+20 SET ORDT=$GET(^OR(100,ORN,0))
if $LENGTH($GET(ORDT))
SET ORDT=$PIECE(ORDT,U,8)
+21 SET ORDT=$$FMTE^XLFDT(ORDT,"2P")
+22 SET ORQ=ORN_U_$PIECE($$TEXT^ORKOR(ORN,60),U,2)_" "_$GET(ORDT)
End DoDot:3
End DoDot:2
End DoDot:1
+23 KILL ^TMP("ORR",$JOB)
+24 QUIT ORQ
TYPE(OI) ;extrinisic function which returns the imaging type for an orderable item
+1 ;returned as 'RAD','CT','MRI','ANI','CARD','NM','US', or 'VAS'
+2 NEW ORTYPE
SET ORTYPE=""
+3 SET ORTYPE=$GET(^ORD(101.43,OI,"RA"))
+4 if $LENGTH($GET(ORTYPE))
SET ORTYPE=$PIECE(ORTYPE,U,3)
+5 QUIT ORTYPE
CMCDAYS(DFN) ;extrinsic function to return number of days to look for
+1 ; contrast media serum creatinine result
+2 if '$LENGTH(DFN)
QUIT ""
+3 NEW ORLOC,ORENT,ORDAYS
+4 ;get patient's location flag (INPATIENT ONLY - outpt locations cannot be
+5 ;reliably determined, and many simultaneous outpt locations can occur):
+6 SET VA200=""
DO OERR^VADPT
+7 SET ORLOC=+$GET(^DIC(42,+VAIN(4),44))
+8 KILL VA200,VAIN
+9 SET ORENT=+$GET(ORLOC)_";SC(^DIV^SYS^PKG"
+10 SET ORDAYS=$$GET^XPAR(ORENT,"ORK CONTRAST MEDIA CREATININE",1,"I")
+11 if $LENGTH(ORDAYS)
QUIT ORDAYS
+12 QUIT ""
