- 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 Jan 18, 2025@03:28:08 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