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

ORAM.m

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