ORAM ;POR/RSF - ANTICOAGULATION MANAGEMENT RPCS (1 of 4) ;11/26/14 12:08
;;3.0;ORDER ENTRY/RESULTS REPORTING;**307,330,391**;Dec 17, 1997;Build 11
;;Per VHA Directive 2004-038, this routine should not be modified
Q
;
PATIENT(RESULT,ORAMDFN) ;Returns current Patient info as:
;DFN^NAME^GENDER^ADMISSION^CURRENT DT/TIME (internal)^SSN^CURRENT DT/TIME (external)^CLINIC LOCATION^DTIME
;RPC=ORAM PATIENT
N CURADM,PTNAME,GENDER,ORAMNOW,ORAMRD,ORAMSSN,ORAMPLOC,ORAMVDT,ORAMLOCS
I '$G(ORAMDFN) D
. N DIC,X,Y
. S DIC="^DPT(",DIC(0)="Z",X=" "
. D ^DIC
. S ORAMDFN=+$G(Y)
I ORAMDFN<1 S ORAMDFN=0 G PATIENTQ
S CURADM=$G(^DPT(ORAMDFN,.105)) ;CHECKS IF PATIENT IS ADMITTED
S PTNAME=$P(^DPT(ORAMDFN,0),U)
I $L(PTNAME)>19 D
. N ORFMT
. F ORFMT="LAST,FIRST MI","LAST,FI MI" S PTNAME=$$NAME^ORAMX(PTNAME,ORFMT) Q:$L(PTNAME)'>19
S GENDER=$P(^DPT(ORAMDFN,0),U,2)
S ORAMSSN=$P(^DPT(ORAMDFN,0),U,9)
S ORAMNOW=$$NOW^XLFDT S ORAMRD=$$FMTE^XLFDT($E(ORAMNOW,1,12),2)
S ORAMPLOC=$P($G(^ORAM(103,ORAMDFN,6)),U,2)
; if pt enrolled in a clinic, use that location and look for an appt in look-up range
I +ORAMPLOC>0 D I 1
. S ORAMPLOC=ORAMPLOC_";SC("
. S ORAMVDT=$$GETAPPT(ORAMDFN,+ORAMPLOC)
E D ; otherwise check whether pt has appt at any anticoag clinic in look-up range
. N ORAMLOCS,ORI S ORI=0
. D GETCLINS^ORAMSET(.ORAMLOCS) Q:+$G(ORAMLOCS(0))'>0
. F S ORI=$O(ORAMLOCS(ORI)) D Q:+ORI'>0!+ORAMVDT
. . S ORAMPLOC=$P($G(ORAMLOCS(ORI)),U,2)
. . S ORAMVDT=$$GETAPPT(ORAMDFN,+ORAMPLOC)
S:+$G(ORAMVDT)'>0 ORAMVDT=ORAMNOW
S:$L($P(ORAMRD,"/",1))=1 $P(ORAMRD,"/",1)="0"_$P(ORAMRD,"/",1)
S:$L($P(ORAMRD,"/",2))=1 $P(ORAMRD,"/",2)="0"_$P(ORAMRD,"/",2)
S RESULT=$G(ORAMDFN)_U_$G(PTNAME)_U_$G(GENDER)_U_$G(CURADM)_U_ORAMNOW_U_$G(ORAMSSN)_U_$G(ORAMRD)_U_ORAMPLOC_U_$G(DTIME)_U_ORAMVDT
PATIENTQ Q
;
APPTMTCH(RESULT,ORAMDFN,ORAMCL) ; Find appt match on clinic change
S RESULT=$$GETAPPT(ORAMDFN,+ORAMCL)
Q
;
GETAPPT(ORAMDFN,ORAMCL) ; Find most recent appointment to Clinic from t-1 to t+1 days
N ORAMC,ORAMEDT,ORAMLDT,ORAMOK,ORAMY,ORAMDIFF,ORAMTCL,ORAMVCL,ORAMLAD,ORAMLBD,ORAMFLTR,ORAMAPPT
S ORAMOK=0
S ORAMY=$$NOW^XLFDT
I +ORAMCL'>0 G GETAPPX
S ORAMLBD=$$GET^XPAR(ORAMCL_";SC(^ALL","ORAM APPT MATCH LOOK-BACK",1,"I")
S ORAMDIFF=$S(ORAMLBD]"":-ORAMLBD,1:-1)
S ORAMEDT=$$FMADD^XLFDT(DT,ORAMDIFF)
S ORAMLAD=$$GET^XPAR(ORAMCL_";SC(^ALL","ORAM APPT MATCH LOOK-AHEAD",1,"I")
S ORAMDIFF=$S(ORAMLAD]"":ORAMLAD,1:1)
S ORAMLDT=$$FMADD^XLFDT(DT,ORAMDIFF)_".2359"
S ORAMVCL=$$GET^XPAR(ORAMCL_";SC(","ORAM VISIT LOCATION",1,"I")
S ORAMTCL=$$GET^XPAR(ORAMCL_";SC(","ORAM PHONE CLINIC",1,"I")
F ORAMC=ORAMVCL,ORAMTCL D
. N ORAMOK
. S ORAMFLTR(1)=ORAMEDT_";"_ORAMLDT
. S ORAMFLTR(2)=ORAMC
. S ORAMFLTR(3)="R;I;NT"
. S ORAMFLTR(4)=ORAMDFN
. S ORAMFLTR("MAX")=-3
. S ORAMFLTR("FLDS")="1;2;4"
. S ORAMOK=$$SDAPI^SDAMA301(.ORAMFLTR)
. I +ORAMOK>0 M ORAMAPPT=^TMP($J,"SDAMA301")
I +$D(ORAMAPPT)>9 S ORAMY=$$NEAREST($NA(ORAMAPPT(ORAMDFN)))
K ^TMP($J,"SDAMA301")
GETAPPX Q ORAMY
;
NEAREST(APPTS) ; Find the nearest appointment to NOW
N ORC,ORI,ORY,ORNOW,ORDIFFS S (ORC,ORY)=0,ORNOW=$$NOW^XLFDT
F S ORC=$O(@APPTS@(ORC)) Q:+ORC'>0 D
. N ORDT S ORDT=0
. F S ORDT=$O(@APPTS@(ORC,ORDT)) Q:+ORDT'>0 S ORDIFFS($$ABS^XLFMTH($$FMDIFF^XLFDT(ORNOW,ORDT,2)))=ORDT
S ORI=$O(ORDIFFS(0))
S:+ORI>0 ORY=ORDIFFS(ORI)
Q ORY
;
PROVIDER(RESULT) ;GETS DUZ/NAME OF PROVIDER WHO IS SIGNED IN
;;RPC=ORAM PROVIDER
N PN,INIT
S DUZ=$G(DUZ)
S PN=$P(^VA(200,DUZ,0),U)
S INIT=$P(^VA(200,DUZ,0),U,2)
S RESULT=$G(DUZ)_U_PN_U_$G(INIT)
Q
;
INRCHK(ORAMQO) ; Resolve Lab Test id from Quick Order
N TST,N,ORAM60,ORAMT2,ORAMTT,ORAMPP,ORAMTST,ORAMTSTN,ORAMNEW,ORAML,ORAMT60,ORAMORD,ORY
S ORAMORD=$$QOORD(ORAMQO),ORY=""
I +$G(ORAMQO) D
. N ORAMC
. S ORAM60=+$P(^ORD(101.43,ORAMORD,0),U,2) Q:'+$G(ORAM60)
. S ORAMT60=$P($P($G(^LAB(60,ORAM60,0)),U,5),";",2) I +$G(ORAMT60) S ORY=ORAMT60 Q
. I '$G(ORAMT60),$D(^LAB(60,ORAM60,2,0)) S ORAMC=0 F S ORAMC=$O(^LAB(60,ORAM60,2,ORAMC)) Q:'+$G(ORAMC)!(+$G(ORY)) D
.. S ORAMNEW=^LAB(60,ORAM60,2,ORAMC,0) I +ORAMNEW>0,$$ISINR(ORAMNEW) S ORY=$P($P($G(^LAB(60,ORAMNEW,0)),U,5),";",2) Q
Q ORY
;
ISINR(ORTEST) ; Is the lab test an INR?
N ORY,ORNM S ORY=0
S ORNM=$P($G(^LAB(60,ORTEST,0)),U)
S ORY=$S(ORNM["INR":1,(ORNM["INT")&(ORNM["NORM")&(ORNM["RAT"):1,1:0)
Q ORY
;
LABCHK(RESULT) ;
;;RPC=ORAM ORDERABLES
N ORAMINR,ORAMCBC,C,Y S (C,Y)=0,RESULT="0|0"
S ORAMINR=0 F S ORAMINR=$O(^ORD(101.43,"B","INR",ORAMINR)) Q:'+$G(ORAMINR)!(+$G(C)) I +$G(ORAMINR) S $P(RESULT,"|")=ORAMINR,C=1
I $G(ORAMINR)="" S ORAMINR=0 F S ORAMINR=$O(^ORD(101.43,"B","INR ",ORAMINR)) Q:'+$G(ORAMINR)!(+$G(C)) I +$G(ORAMINR) S $P(RESULT,"|")=ORAMINR,C=1
I $G(ORAMINR)="" S ORAMINR=0 F S ORAMINR=$O(^ORD(101.43,"B","INR/PT",ORAMINR)) Q:'+$G(ORAMINR)!(+$G(C)) I +$G(ORAMINR) S $P(RESULT,"|")=ORAMINR,C=1
I $G(ORAMINR)="" S ORAMINR=0 F S ORAMINR=$O(^ORD(101.43,"B","PT",ORAMINR)) Q:'+$G(ORAMINR)!(+$G(C)) I +$G(ORAMINR) S $P(RESULT,"|")=ORAMINR,C=1
S ORAMCBC=0 F S ORAMCBC=$O(^ORD(101.43,"B","CBC",ORAMCBC)) Q:'+$G(ORAMCBC)!(+$G(Y)) I +$G(ORAMCBC) S $P(RESULT,"|",2)=ORAMCBC,Y=1
I $G(ORAMCBC)="" S ORAMCBC=$O(^ORD(101.43,"B","CBC ",ORAMCBC)) Q:'+$G(ORAMCBC)!(+$G(Y)) I +$G(ORAMCBC) S $P(RESULT,"|",2)=ORAMCBC,Y=1
Q
;
SIGCHECK(RESULT,ESCODE) ;
;;CHECKS SIG CODE
;;RPC=ORAM SIGCHECK
N SUCCESS,X
S SUCCESS=0
Q:ESCODE=""
S X=ESCODE D HASH^XUSHSHP
I $P($G(^VA(200,DUZ,20)),U,4)=X S SUCCESS=1 ;SIG CODE CORRECT
S RESULT=$G(SUCCESS)
SIGQ Q
;
HCT(RESULT,ORAMDFN) ;GET HCT
;;GETS MOST RECENT HCT
;;RPC=ORAM HCT
N HCT,LDATE,HCTDATE,LOOPCNT,HCTDIFF,LRDFN,ORAMS,ORAMHCT,ORAMDNM,OHCT,OHCTD,ORAMFM,ORAMHCTN
I '$G(ORAMDFN) S RESULT="" Q ;IF DFN IS NOT PASSED, EXIT
S LRDFN=$$LAB($G(ORAMDFN)) I +LRDFN'>0 S RESULT="Patient has no VistA Lab Data." Q
S ORAMHCT=$$GET^XPAR("ALL","ORAM HCT/HGB REFERENCE",1,"B")
I +$G(ORAMHCT)'>0 S RESULT="HCT Param not set." Q
S ORAMHCTN=$P(ORAMHCT,U,2),ORAMHCT=$P(ORAMHCT,U)
; Get Lab Data Name based on IEN in ^LAB(60,
S ORAMDNM=$P($P(^LAB(60,+ORAMHCT,0),U,5),";",2) I ORAMDNM']"" S RESULT="Data Name not defined for "_ORAMHCTN_" in Lab Test File." Q
S LDATE=0 F SET LDATE=$O(^LR(LRDFN,"CH",LDATE)) S LOOPCNT=0 Q:LDATE=""!(+$G(HCT)) D Q:LOOPCNT
. S RESULT=$G(^LR(LRDFN,"CH",LDATE,ORAMDNM))
. Q:RESULT=""
. Q:$P(RESULT,U,1)="" ;QUIT IF NO HCT DATA
. S HCT=$P(RESULT,U,1) ;HCT
. S HCTDATE=9999999-LDATE
. S LOOPCNT=1
. Q:+HCT
I LDATE="" S RESULT="NONE"
I $D(^ORAM(103,ORAMDFN,6)),($L($P(^ORAM(103,ORAMDFN,6),U,4),"|")=3) D
. S OHCT=$P($P(^ORAM(103,ORAMDFN,6),U,4),"|"),OHCTD=$P($P(^ORAM(103,ORAMDFN,6),U,4),"|",2)
. I +$G(OHCT) D DT^DILF(,OHCTD,.ORAMFM)
I +$G(HCTDATE),$G(ORAMFM)>HCTDATE S HCT=OHCT_" (Outside Lab)",HCTDATE=ORAMFM,ORAMHCTN="HCT"
I '+$G(HCTDATE) S:+$G(OHCT) HCT=OHCT_" (Outside Lab)",ORAMHCTN="HCT" S:$G(ORAMFM)'="" HCTDATE=ORAMFM
I +$G(HCTDATE) S HCTDATE=$$FMTE^XLFDT($E(HCTDATE,1,7),2)
S RESULT=$G(HCT)_U_$G(HCTDATE)_U_ORAMHCTN
Q
;
INR(RESULT,ORAMDFN) ; Gets most recent INR
;;RPC=ORAM INR
N LDATE,INR,INRFD,LRDFN,HDATE,TDIFF,SIXMON,COUNT,SCORE,ORAMITST,INRHD,INRRD
N ORAMQO
S RESULT=""
I '$G(ORAMDFN) Q ;IF DFN IS NOT PASSED, EXIT
S LRDFN=$$LAB($G(ORAMDFN)) I +LRDFN'>0 S RESULT="Patient has no Lab Data." Q
S ORAMQO=$$GET^XPAR("ALL","ORAM INR QUICK ORDER",1,"I") S ORAMITST=$$INRCHK(ORAMQO)
I +ORAMITST'>0 Q
S (LDATE,COUNT)=0,SIXMON=$$FMADD^XLFDT(DT,-180)
F S LDATE=$O(^LR(LRDFN,"CH",LDATE)) Q:+LDATE'>0!(LDATE>(9999999-SIXMON)) D
. N SCORE,INR,INRFD,INRHD,INRRD,XDT
. S SCORE=$G(^LR(LRDFN,"CH",LDATE,ORAMITST))
. Q:SCORE="" ;QUIT IF NO INR TEST
. S INR=$P(SCORE,U) ;INR
. Q:INR="" ;QUIT IF NO INR DATA
. S INRFD=9999999-LDATE
. S XDT=$P(INRFD,".") S INRHD=$$FMTH^XLFDT(XDT,1),INRRD=$$FMTE^XLFDT(XDT,"2P")
. S RESULT(COUNT)=$G(INR)_"^^"_$G(INRRD)_U_$G(INRHD)
. Q:INRFD<SIXMON ;Q WHEN SEARCHED LAST 6 MONTHS
. S COUNT=COUNT+1
Q
;
CONCOMP(RESULT,ORAMCNUM,ORAMNNUM,ORAMDUZ) ;
;;BRINGS IN CONSULT NUMBER(ORAMCNUM)
;;BRINGS IN NOTE NUMBER(ORAMNNUM), COMPLETES CONSULT
;;RPC=ORAM CONCOMP
N ORAMCST
S RESULT=0
S ORAMCST=$S($$STATUS^TIULC(ORAMNNUM)="completed":"COMPLETE",1:"INCOMPLETE")
D GET^GMRCTIU(ORAMCNUM,ORAMNNUM,ORAMCST,ORAMDUZ)
S RESULT=1
Q
;
LAB(DFN) ;GET LAB NUMBER
N LRDFN
IF 'DFN S LRDFN="" G LABQ ;IF DFN IS NOT PASSED, EXIT
S LRDFN=$G(^DPT(DFN,"LR"))
LABQ Q LRDFN
;
ORDER(ORESULT,DFN,ORNP,ORLOC,ORQO,ORCDT) ; Place Quick Order for INR or CBC
; RPC ORAM ORDER
; in: DFN - pt id file 2
; ORNP - ordering provider id file 200
; ORLOC - location id file 42
; ORQO - quick order id file 101.41
; ORCDT - collection date/time
N ORANS,ORDIALOG,ORDG,ORDLG
I +$G(DFN)'>0 S ORESULT="0^invalid Patient id" Q
I +$G(ORNP)'>0 S ORESULT="0^invalid Provider id" Q
I +$G(ORLOC)'>0 S ORESULT="0^invalid Location id" Q
I +$G(ORQO)'>0 S ORESULT="0^invalid Quick Order id" Q
I $G(ORCDT)']"" S ORESULT="0^invalid Collection Date/Time" Q
D GETQDLG^ORCD(ORQO)
I '$D(ORDIALOG) S ORESULT="0^invalid Quick Order id" Q
S ORDLG=$$GET1^DIQ(101.41,+ORDIALOG_",",.01)
I ORDLG']"" S ORESULT="0^invalid Quick Order id" Q
S ORDG=$$GET1^DIQ(101.41,ORQO_",",5,"I")
I +ORDG'>0 S ORESULT="0^invalid Quick Order id - no Display Group" Q
S ORDIALOG(6,1)=$$IDATE(ORCDT)
D SAVE^ORWDX(.ORESULT,DFN,ORNP,ORLOC,ORDLG,ORDG,ORQO,"",.ORDIALOG) ; Place the order
; if the order is placed, call UNOTIF^ORCSIGN to avoid duplicate alerts,
; then call NOTIF^ORCSIGN to generate an unsigned order notification
I +ORESULT D
. N ORVP,ORIFN,Y
. S ORVP=DFN_";DPT(",ORIFN=$P($P($G(ORESULT(1)),"~",2),";")
. D UNOTIF^ORCSIGN
. D NOTIF^ORCSIGN
Q
IDATE(ORX) ; Convert External Date/time to FM Internal format
N ORY S ORY=""
D DT^DILF("T",ORX,.ORY) S:+ORY'>0 ORY=""
Q ORY
QOORD(ORQO) ; Given Quick Order, find the IEN of the Orderable Item
N ORI,ORDIALOG,ORY S ORY=0
D GETQDLG^ORCD(+$G(ORQO))
I '$D(ORDIALOG) G QOORDX
S ORI=0
F S ORI=$O(ORDIALOG(ORI)) Q:ORI'>0!+ORY>0 D
. I $G(ORDIALOG(ORI))["ORDERABLE" S ORY=$G(ORDIALOG(ORI,1))
QOORDX Q ORY
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORAM 10237 printed Sep 23, 2025@20:03:15 Page 2
ORAM ;POR/RSF - ANTICOAGULATION MANAGEMENT RPCS (1 of 4) ;11/26/14 12:08
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**307,330,391**;Dec 17, 1997;Build 11
+2 ;;Per VHA Directive 2004-038, this routine should not be modified
+3 QUIT
+4 ;
PATIENT(RESULT,ORAMDFN) ;Returns current Patient info as:
+1 ;DFN^NAME^GENDER^ADMISSION^CURRENT DT/TIME (internal)^SSN^CURRENT DT/TIME (external)^CLINIC LOCATION^DTIME
+2 ;RPC=ORAM PATIENT
+3 NEW CURADM,PTNAME,GENDER,ORAMNOW,ORAMRD,ORAMSSN,ORAMPLOC,ORAMVDT,ORAMLOCS
+4 IF '$GET(ORAMDFN)
Begin DoDot:1
+5 NEW DIC,X,Y
+6 SET DIC="^DPT("
SET DIC(0)="Z"
SET X=" "
+7 DO ^DIC
+8 SET ORAMDFN=+$GET(Y)
End DoDot:1
+9 IF ORAMDFN<1
SET ORAMDFN=0
GOTO PATIENTQ
+10 ;CHECKS IF PATIENT IS ADMITTED
SET CURADM=$GET(^DPT(ORAMDFN,.105))
+11 SET PTNAME=$PIECE(^DPT(ORAMDFN,0),U)
+12 IF $LENGTH(PTNAME)>19
Begin DoDot:1
+13 NEW ORFMT
+14 FOR ORFMT="LAST,FIRST MI","LAST,FI MI"
SET PTNAME=$$NAME^ORAMX(PTNAME,ORFMT)
if $LENGTH(PTNAME)'>19
QUIT
End DoDot:1
+15 SET GENDER=$PIECE(^DPT(ORAMDFN,0),U,2)
+16 SET ORAMSSN=$PIECE(^DPT(ORAMDFN,0),U,9)
+17 SET ORAMNOW=$$NOW^XLFDT
SET ORAMRD=$$FMTE^XLFDT($EXTRACT(ORAMNOW,1,12),2)
+18 SET ORAMPLOC=$PIECE($GET(^ORAM(103,ORAMDFN,6)),U,2)
+19 ; if pt enrolled in a clinic, use that location and look for an appt in look-up range
+20 IF +ORAMPLOC>0
Begin DoDot:1
+21 SET ORAMPLOC=ORAMPLOC_";SC("
+22 SET ORAMVDT=$$GETAPPT(ORAMDFN,+ORAMPLOC)
End DoDot:1
IF 1
+23 ; otherwise check whether pt has appt at any anticoag clinic in look-up range
IF '$TEST
Begin DoDot:1
+24 NEW ORAMLOCS,ORI
SET ORI=0
+25 DO GETCLINS^ORAMSET(.ORAMLOCS)
if +$GET(ORAMLOCS(0))'>0
QUIT
+26 FOR
SET ORI=$ORDER(ORAMLOCS(ORI))
Begin DoDot:2
+27 SET ORAMPLOC=$PIECE($GET(ORAMLOCS(ORI)),U,2)
+28 SET ORAMVDT=$$GETAPPT(ORAMDFN,+ORAMPLOC)
End DoDot:2
if +ORI'>0!+ORAMVDT
QUIT
End DoDot:1
+29 if +$GET(ORAMVDT)'>0
SET ORAMVDT=ORAMNOW
+30 if $LENGTH($PIECE(ORAMRD,"/",1))=1
SET $PIECE(ORAMRD,"/",1)="0"_$PIECE(ORAMRD,"/",1)
+31 if $LENGTH($PIECE(ORAMRD,"/",2))=1
SET $PIECE(ORAMRD,"/",2)="0"_$PIECE(ORAMRD,"/",2)
+32 SET RESULT=$GET(ORAMDFN)_U_$GET(PTNAME)_U_$GET(GENDER)_U_$GET(CURADM)_U_ORAMNOW_U_$GET(ORAMSSN)_U_$GET(ORAMRD)_U_ORAMPLOC_U_$GET(DTIME)_U_ORAMVDT
PATIENTQ QUIT
+1 ;
APPTMTCH(RESULT,ORAMDFN,ORAMCL) ; Find appt match on clinic change
+1 SET RESULT=$$GETAPPT(ORAMDFN,+ORAMCL)
+2 QUIT
+3 ;
GETAPPT(ORAMDFN,ORAMCL) ; Find most recent appointment to Clinic from t-1 to t+1 days
+1 NEW ORAMC,ORAMEDT,ORAMLDT,ORAMOK,ORAMY,ORAMDIFF,ORAMTCL,ORAMVCL,ORAMLAD,ORAMLBD,ORAMFLTR,ORAMAPPT
+2 SET ORAMOK=0
+3 SET ORAMY=$$NOW^XLFDT
+4 IF +ORAMCL'>0
GOTO GETAPPX
+5 SET ORAMLBD=$$GET^XPAR(ORAMCL_";SC(^ALL","ORAM APPT MATCH LOOK-BACK",1,"I")
+6 SET ORAMDIFF=$SELECT(ORAMLBD]"":-ORAMLBD,1:-1)
+7 SET ORAMEDT=$$FMADD^XLFDT(DT,ORAMDIFF)
+8 SET ORAMLAD=$$GET^XPAR(ORAMCL_";SC(^ALL","ORAM APPT MATCH LOOK-AHEAD",1,"I")
+9 SET ORAMDIFF=$SELECT(ORAMLAD]"":ORAMLAD,1:1)
+10 SET ORAMLDT=$$FMADD^XLFDT(DT,ORAMDIFF)_".2359"
+11 SET ORAMVCL=$$GET^XPAR(ORAMCL_";SC(","ORAM VISIT LOCATION",1,"I")
+12 SET ORAMTCL=$$GET^XPAR(ORAMCL_";SC(","ORAM PHONE CLINIC",1,"I")
+13 FOR ORAMC=ORAMVCL,ORAMTCL
Begin DoDot:1
+14 NEW ORAMOK
+15 SET ORAMFLTR(1)=ORAMEDT_";"_ORAMLDT
+16 SET ORAMFLTR(2)=ORAMC
+17 SET ORAMFLTR(3)="R;I;NT"
+18 SET ORAMFLTR(4)=ORAMDFN
+19 SET ORAMFLTR("MAX")=-3
+20 SET ORAMFLTR("FLDS")="1;2;4"
+21 SET ORAMOK=$$SDAPI^SDAMA301(.ORAMFLTR)
+22 IF +ORAMOK>0
MERGE ORAMAPPT=^TMP($JOB,"SDAMA301")
End DoDot:1
+23 IF +$DATA(ORAMAPPT)>9
SET ORAMY=$$NEAREST($NAME(ORAMAPPT(ORAMDFN)))
+24 KILL ^TMP($JOB,"SDAMA301")
GETAPPX QUIT ORAMY
+1 ;
NEAREST(APPTS) ; Find the nearest appointment to NOW
+1 NEW ORC,ORI,ORY,ORNOW,ORDIFFS
SET (ORC,ORY)=0
SET ORNOW=$$NOW^XLFDT
+2 FOR
SET ORC=$ORDER(@APPTS@(ORC))
if +ORC'>0
QUIT
Begin DoDot:1
+3 NEW ORDT
SET ORDT=0
+4 FOR
SET ORDT=$ORDER(@APPTS@(ORC,ORDT))
if +ORDT'>0
QUIT
SET ORDIFFS($$ABS^XLFMTH($$FMDIFF^XLFDT(ORNOW,ORDT,2)))=ORDT
End DoDot:1
+5 SET ORI=$ORDER(ORDIFFS(0))
+6 if +ORI>0
SET ORY=ORDIFFS(ORI)
+7 QUIT ORY
+8 ;
PROVIDER(RESULT) ;GETS DUZ/NAME OF PROVIDER WHO IS SIGNED IN
+1 ;;RPC=ORAM PROVIDER
+2 NEW PN,INIT
+3 SET DUZ=$GET(DUZ)
+4 SET PN=$PIECE(^VA(200,DUZ,0),U)
+5 SET INIT=$PIECE(^VA(200,DUZ,0),U,2)
+6 SET RESULT=$GET(DUZ)_U_PN_U_$GET(INIT)
+7 QUIT
+8 ;
INRCHK(ORAMQO) ; Resolve Lab Test id from Quick Order
+1 NEW TST,N,ORAM60,ORAMT2,ORAMTT,ORAMPP,ORAMTST,ORAMTSTN,ORAMNEW,ORAML,ORAMT60,ORAMORD,ORY
+2 SET ORAMORD=$$QOORD(ORAMQO)
SET ORY=""
+3 IF +$GET(ORAMQO)
Begin DoDot:1
+4 NEW ORAMC
+5 SET ORAM60=+$PIECE(^ORD(101.43,ORAMORD,0),U,2)
if '+$GET(ORAM60)
QUIT
+6 SET ORAMT60=$PIECE($PIECE($GET(^LAB(60,ORAM60,0)),U,5),";",2)
IF +$GET(ORAMT60)
SET ORY=ORAMT60
QUIT
+7 IF '$GET(ORAMT60)
IF $DATA(^LAB(60,ORAM60,2,0))
SET ORAMC=0
FOR
SET ORAMC=$ORDER(^LAB(60,ORAM60,2,ORAMC))
if '+$GET(ORAMC)!(+$GET(ORY))
QUIT
Begin DoDot:2
+8 SET ORAMNEW=^LAB(60,ORAM60,2,ORAMC,0)
IF +ORAMNEW>0
IF $$ISINR(ORAMNEW)
SET ORY=$PIECE($PIECE($GET(^LAB(60,ORAMNEW,0)),U,5),";",2)
QUIT
End DoDot:2
End DoDot:1
+9 QUIT ORY
+10 ;
ISINR(ORTEST) ; Is the lab test an INR?
+1 NEW ORY,ORNM
SET ORY=0
+2 SET ORNM=$PIECE($GET(^LAB(60,ORTEST,0)),U)
+3 SET ORY=$SELECT(ORNM["INR":1,(ORNM["INT")&(ORNM["NORM")&(ORNM["RAT"):1,1:0)
+4 QUIT ORY
+5 ;
LABCHK(RESULT) ;
+1 ;;RPC=ORAM ORDERABLES
+2 NEW ORAMINR,ORAMCBC,C,Y
SET (C,Y)=0
SET RESULT="0|0"
+3 SET ORAMINR=0
FOR
SET ORAMINR=$ORDER(^ORD(101.43,"B","INR",ORAMINR))
if '+$GET(ORAMINR)!(+$GET(C))
QUIT
IF +$GET(ORAMINR)
SET $PIECE(RESULT,"|")=ORAMINR
SET C=1
+4 IF $GET(ORAMINR)=""
SET ORAMINR=0
FOR
SET ORAMINR=$ORDER(^ORD(101.43,"B","INR ",ORAMINR))
if '+$GET(ORAMINR)!(+$GET(C))
QUIT
IF +$GET(ORAMINR)
SET $PIECE(RESULT,"|")=ORAMINR
SET C=1
+5 IF $GET(ORAMINR)=""
SET ORAMINR=0
FOR
SET ORAMINR=$ORDER(^ORD(101.43,"B","INR/PT",ORAMINR))
if '+$GET(ORAMINR)!(+$GET(C))
QUIT
IF +$GET(ORAMINR)
SET $PIECE(RESULT,"|")=ORAMINR
SET C=1
+6 IF $GET(ORAMINR)=""
SET ORAMINR=0
FOR
SET ORAMINR=$ORDER(^ORD(101.43,"B","PT",ORAMINR))
if '+$GET(ORAMINR)!(+$GET(C))
QUIT
IF +$GET(ORAMINR)
SET $PIECE(RESULT,"|")=ORAMINR
SET C=1
+7 SET ORAMCBC=0
FOR
SET ORAMCBC=$ORDER(^ORD(101.43,"B","CBC",ORAMCBC))
if '+$GET(ORAMCBC)!(+$GET(Y))
QUIT
IF +$GET(ORAMCBC)
SET $PIECE(RESULT,"|",2)=ORAMCBC
SET Y=1
+8 IF $GET(ORAMCBC)=""
SET ORAMCBC=$ORDER(^ORD(101.43,"B","CBC ",ORAMCBC))
if '+$GET(ORAMCBC)!(+$GET(Y))
QUIT
IF +$GET(ORAMCBC)
SET $PIECE(RESULT,"|",2)=ORAMCBC
SET Y=1
+9 QUIT
+10 ;
SIGCHECK(RESULT,ESCODE) ;
+1 ;;CHECKS SIG CODE
+2 ;;RPC=ORAM SIGCHECK
+3 NEW SUCCESS,X
+4 SET SUCCESS=0
+5 if ESCODE=""
QUIT
+6 SET X=ESCODE
DO HASH^XUSHSHP
+7 ;SIG CODE CORRECT
IF $PIECE($GET(^VA(200,DUZ,20)),U,4)=X
SET SUCCESS=1
+8 SET RESULT=$GET(SUCCESS)
SIGQ QUIT
+1 ;
HCT(RESULT,ORAMDFN) ;GET HCT
+1 ;;GETS MOST RECENT HCT
+2 ;;RPC=ORAM HCT
+3 NEW HCT,LDATE,HCTDATE,LOOPCNT,HCTDIFF,LRDFN,ORAMS,ORAMHCT,ORAMDNM,OHCT,OHCTD,ORAMFM,ORAMHCTN
+4 ;IF DFN IS NOT PASSED, EXIT
IF '$GET(ORAMDFN)
SET RESULT=""
QUIT
+5 SET LRDFN=$$LAB($GET(ORAMDFN))
IF +LRDFN'>0
SET RESULT="Patient has no VistA Lab Data."
QUIT
+6 SET ORAMHCT=$$GET^XPAR("ALL","ORAM HCT/HGB REFERENCE",1,"B")
+7 IF +$GET(ORAMHCT)'>0
SET RESULT="HCT Param not set."
QUIT
+8 SET ORAMHCTN=$PIECE(ORAMHCT,U,2)
SET ORAMHCT=$PIECE(ORAMHCT,U)
+9 ; Get Lab Data Name based on IEN in ^LAB(60,
+10 SET ORAMDNM=$PIECE($PIECE(^LAB(60,+ORAMHCT,0),U,5),";",2)
IF ORAMDNM']""
SET RESULT="Data Name not defined for "_ORAMHCTN_" in Lab Test File."
QUIT
+11 SET LDATE=0
FOR
SET LDATE=$ORDER(^LR(LRDFN,"CH",LDATE))
SET LOOPCNT=0
if LDATE=""!(+$GET(HCT))
QUIT
Begin DoDot:1
+12 SET RESULT=$GET(^LR(LRDFN,"CH",LDATE,ORAMDNM))
+13 if RESULT=""
QUIT
+14 ;QUIT IF NO HCT DATA
if $PIECE(RESULT,U,1)=""
QUIT
+15 ;HCT
SET HCT=$PIECE(RESULT,U,1)
+16 SET HCTDATE=9999999-LDATE
+17 SET LOOPCNT=1
+18 if +HCT
QUIT
End DoDot:1
if LOOPCNT
QUIT
+19 IF LDATE=""
SET RESULT="NONE"
+20 IF $DATA(^ORAM(103,ORAMDFN,6))
IF ($LENGTH($PIECE(^ORAM(103,ORAMDFN,6),U,4),"|")=3)
Begin DoDot:1
+21 SET OHCT=$PIECE($PIECE(^ORAM(103,ORAMDFN,6),U,4),"|")
SET OHCTD=$PIECE($PIECE(^ORAM(103,ORAMDFN,6),U,4),"|",2)
+22 IF +$GET(OHCT)
DO DT^DILF(,OHCTD,.ORAMFM)
End DoDot:1
+23 IF +$GET(HCTDATE)
IF $GET(ORAMFM)>HCTDATE
SET HCT=OHCT_" (Outside Lab)"
SET HCTDATE=ORAMFM
SET ORAMHCTN="HCT"
+24 IF '+$GET(HCTDATE)
if +$GET(OHCT)
SET HCT=OHCT_" (Outside Lab)"
SET ORAMHCTN="HCT"
if $GET(ORAMFM)'=""
SET HCTDATE=ORAMFM
+25 IF +$GET(HCTDATE)
SET HCTDATE=$$FMTE^XLFDT($EXTRACT(HCTDATE,1,7),2)
+26 SET RESULT=$GET(HCT)_U_$GET(HCTDATE)_U_ORAMHCTN
+27 QUIT
+28 ;
INR(RESULT,ORAMDFN) ; Gets most recent INR
+1 ;;RPC=ORAM INR
+2 NEW LDATE,INR,INRFD,LRDFN,HDATE,TDIFF,SIXMON,COUNT,SCORE,ORAMITST,INRHD,INRRD
+3 NEW ORAMQO
+4 SET RESULT=""
+5 ;IF DFN IS NOT PASSED, EXIT
IF '$GET(ORAMDFN)
QUIT
+6 SET LRDFN=$$LAB($GET(ORAMDFN))
IF +LRDFN'>0
SET RESULT="Patient has no Lab Data."
QUIT
+7 SET ORAMQO=$$GET^XPAR("ALL","ORAM INR QUICK ORDER",1,"I")
SET ORAMITST=$$INRCHK(ORAMQO)
+8 IF +ORAMITST'>0
QUIT
+9 SET (LDATE,COUNT)=0
SET SIXMON=$$FMADD^XLFDT(DT,-180)
+10 FOR
SET LDATE=$ORDER(^LR(LRDFN,"CH",LDATE))
if +LDATE'>0!(LDATE>(9999999-SIXMON))
QUIT
Begin DoDot:1
+11 NEW SCORE,INR,INRFD,INRHD,INRRD,XDT
+12 SET SCORE=$GET(^LR(LRDFN,"CH",LDATE,ORAMITST))
+13 ;QUIT IF NO INR TEST
if SCORE=""
QUIT
+14 ;INR
SET INR=$PIECE(SCORE,U)
+15 ;QUIT IF NO INR DATA
if INR=""
QUIT
+16 SET INRFD=9999999-LDATE
+17 SET XDT=$PIECE(INRFD,".")
SET INRHD=$$FMTH^XLFDT(XDT,1)
SET INRRD=$$FMTE^XLFDT(XDT,"2P")
+18 SET RESULT(COUNT)=$GET(INR)_"^^"_$GET(INRRD)_U_$GET(INRHD)
+19 ;Q WHEN SEARCHED LAST 6 MONTHS
if INRFD<SIXMON
QUIT
+20 SET COUNT=COUNT+1
End DoDot:1
+21 QUIT
+22 ;
CONCOMP(RESULT,ORAMCNUM,ORAMNNUM,ORAMDUZ) ;
+1 ;;BRINGS IN CONSULT NUMBER(ORAMCNUM)
+2 ;;BRINGS IN NOTE NUMBER(ORAMNNUM), COMPLETES CONSULT
+3 ;;RPC=ORAM CONCOMP
+4 NEW ORAMCST
+5 SET RESULT=0
+6 SET ORAMCST=$SELECT($$STATUS^TIULC(ORAMNNUM)="completed":"COMPLETE",1:"INCOMPLETE")
+7 DO GET^GMRCTIU(ORAMCNUM,ORAMNNUM,ORAMCST,ORAMDUZ)
+8 SET RESULT=1
+9 QUIT
+10 ;
LAB(DFN) ;GET LAB NUMBER
+1 NEW LRDFN
+2 ;IF DFN IS NOT PASSED, EXIT
IF 'DFN
SET LRDFN=""
GOTO LABQ
+3 SET LRDFN=$GET(^DPT(DFN,"LR"))
LABQ QUIT LRDFN
+1 ;
ORDER(ORESULT,DFN,ORNP,ORLOC,ORQO,ORCDT) ; Place Quick Order for INR or CBC
+1 ; RPC ORAM ORDER
+2 ; in: DFN - pt id file 2
+3 ; ORNP - ordering provider id file 200
+4 ; ORLOC - location id file 42
+5 ; ORQO - quick order id file 101.41
+6 ; ORCDT - collection date/time
+7 NEW ORANS,ORDIALOG,ORDG,ORDLG
+8 IF +$GET(DFN)'>0
SET ORESULT="0^invalid Patient id"
QUIT
+9 IF +$GET(ORNP)'>0
SET ORESULT="0^invalid Provider id"
QUIT
+10 IF +$GET(ORLOC)'>0
SET ORESULT="0^invalid Location id"
QUIT
+11 IF +$GET(ORQO)'>0
SET ORESULT="0^invalid Quick Order id"
QUIT
+12 IF $GET(ORCDT)']""
SET ORESULT="0^invalid Collection Date/Time"
QUIT
+13 DO GETQDLG^ORCD(ORQO)
+14 IF '$DATA(ORDIALOG)
SET ORESULT="0^invalid Quick Order id"
QUIT
+15 SET ORDLG=$$GET1^DIQ(101.41,+ORDIALOG_",",.01)
+16 IF ORDLG']""
SET ORESULT="0^invalid Quick Order id"
QUIT
+17 SET ORDG=$$GET1^DIQ(101.41,ORQO_",",5,"I")
+18 IF +ORDG'>0
SET ORESULT="0^invalid Quick Order id - no Display Group"
QUIT
+19 SET ORDIALOG(6,1)=$$IDATE(ORCDT)
+20 ; Place the order
DO SAVE^ORWDX(.ORESULT,DFN,ORNP,ORLOC,ORDLG,ORDG,ORQO,"",.ORDIALOG)
+21 ; if the order is placed, call UNOTIF^ORCSIGN to avoid duplicate alerts,
+22 ; then call NOTIF^ORCSIGN to generate an unsigned order notification
+23 IF +ORESULT
Begin DoDot:1
+24 NEW ORVP,ORIFN,Y
+25 SET ORVP=DFN_";DPT("
SET ORIFN=$PIECE($PIECE($GET(ORESULT(1)),"~",2),";")
+26 DO UNOTIF^ORCSIGN
+27 DO NOTIF^ORCSIGN
End DoDot:1
+28 QUIT
IDATE(ORX) ; Convert External Date/time to FM Internal format
+1 NEW ORY
SET ORY=""
+2 DO DT^DILF("T",ORX,.ORY)
if +ORY'>0
SET ORY=""
+3 QUIT ORY
QOORD(ORQO) ; Given Quick Order, find the IEN of the Orderable Item
+1 NEW ORI,ORDIALOG,ORY
SET ORY=0
+2 DO GETQDLG^ORCD(+$GET(ORQO))
+3 IF '$DATA(ORDIALOG)
GOTO QOORDX
+4 SET ORI=0
+5 FOR
SET ORI=$ORDER(ORDIALOG(ORI))
if ORI'>0!+ORY>0
QUIT
Begin DoDot:1
+6 IF $GET(ORDIALOG(ORI))["ORDERABLE"
SET ORY=$GET(ORDIALOG(ORI,1))
End DoDot:1
QOORDX QUIT ORY
