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

ORWPT.m

Go to the documentation of this file.
  1. ORWPT ;SLC/KCM/REV - Patient Lookup Functions ; Apr 2, 2024@08:12:00
  1. ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,132,149,206,187,190,215,243,280,306,311,441,528,519,544,405,608**;Dec 17, 1997;Build 15
  1. ;
  1. ; Reference to ^UTILITY( in ICR #10061
  1. ; Reference to ^%ZOSF() in ICR #10096
  1. ; Reference to ^DG(391 in ICR #2966
  1. ; Reference to ^DG(405.1 in ICR #2965
  1. ; Reference to ^DGPM( in ICR #1865
  1. ; Reference to ^DGACT in ICR #2248
  1. ; Reference to ^DIC in ICR #10006
  1. ; Reference to ^DIC(31 in ICR #2967
  1. ; Reference to ^DIC(42 in ICR #10039 and ICR #3790
  1. ; Reference to ^DISV( in ICR #510
  1. ; Reference to ^SC( in ICR #10040
  1. ; Reference to DOB^DPTLK1 in ICR #3266
  1. ; Reference to SSN^DPTLK1 in ICR #3267
  1. ; Reference to ^MPIF001 in ICR #2701
  1. ; Reference to ^TIULX in ICR #2960
  1. ; Reference to ^A7RDPAGU in ICR #3132
  1. ; Reference to ^XLFDT in ICR #10103
  1. ; Reference to ^XPAR in ICR #2263
  1. ; Reference to ^VA(200 in ICR #10060
  1. ; Reference to ^DPT( in ICR #10035
  1. ; Reference to ^DPT(IEN,-9 in ICR #2762
  1. ; Reference to ELIG^VADPT in ICR #10061
  1. ; Reference to DEM^VADPT in ICR #10061
  1. ; Reference to DEMUPD^VADPT in ICR #7109
  1. ; Reference to GET1^DIQ in ICR #2056
  1. ; Reference to ^DPT(DFN,.372 in 1476
  1. ;
  1. IDINFO(REC,DFN) ; Return identifying information for a patient
  1. ; PID^DOB^SEX^VET^SC%^WARD^RM-BED^NAME
  1. N X0,X1,X101,X3,XV,X24,VAEL,ATT ; name/dob/sex/ssn, ward, room-bed, sc%, vet, SIGI, Attending Physician
  1. D ELIG^VADPT S XV=$S(VAEL(4):"Y",1:"N"),X3=$P(VAEL(3),"^",2)
  1. D DEM^VADPT S X24=$P($G(VADM(14,5)),"^")
  1. S ATT=$P($G(^DPT(DFN,.1041)),"^") I ATT]"" S ATT=$$GET1^DIQ(200,ATT,.01)
  1. S X0=$G(^DPT(DFN,0)),X1=$G(^(.1)),X101=$G(^(.101))
  1. S REC=$$SSN^DPTLK1(DFN)_U_$$DOB^DPTLK1(DFN,2)_U_$P(X0,U,2)_U_XV_U_X3_U_$P(X1,U)_U_$P(X101,U)_U_$P(X0,U)_U_X24_U_ATT ;DG249
  1. Q
  1. PTINQ(REF,DFN) ; Return formatted pt inquiry report
  1. K ^TMP("ORDATA",$J,1)
  1. D DGINQ^ORCXPND1(DFN)
  1. S REF=$NA(^TMP("ORDATA",$J,1))
  1. Q
  1. SCDIS(LST,DFN) ; Return service connected % and rated disabilities
  1. N VAEL,VAERR,I,ILST,DIS,SC,X
  1. D ELIG^VADPT
  1. S LST(1)="Service Connected: "_$S(+VAEL(3):$P(VAEL(3),U,2)_"%",1:"NO")
  1. I 'VAEL(4),'$P($G(^DG(391,+VAEL(6),0)),U,2) S LST(2)="NOT A VETERAN." Q
  1. S I=0,ILST=1 F S I=$O(^DPT(DFN,.372,I)) Q:'I S X=^(I,0) D
  1. . S DIS=$P($G(^DIC(31,+X,0)),U) Q:DIS=""
  1. . S SC=$S($P(X,U,3):"SC",$P(X,U,3)']"":"not specified",1:"NSC")
  1. . S ILST=ILST+1,LST(ILST)=DIS_" ("_$P(X,U,2)_"% "_SC_")"
  1. I ILST=1 S LST(2)="Rated Disabilities: NONE STATED"
  1. Q
  1. SHOW ; temporary - show patient inquiry screen
  1. N I,Y,DIC S DIC=2,DIC(0)="AEMQ" D ^DIC Q:'Y
  1. K ^TMP("ORDATA",$J,1)
  1. D DGINQ^ORCXPND1(+Y)
  1. S I=0 F S I=$O(^TMP("ORDATA",$J,1,I)) Q:'I W !,^(I)
  1. K ^TMP("ORDATA",$J,1)
  1. Q
  1. SELCHK(REC,DFN) ; Check for sensitive pt
  1. ; SENSITIVE
  1. S REC=$$EN1^ORQPT2(DFN)
  1. Q
  1. DIEDON(VAL,DFN) ; Check for a date of death
  1. S VAL=+$G(^DPT(DFN,.35))
  1. Q
  1. SELECT(REC,DFN) ; Selects patient & returns key information
  1. ; 1 2 3 4 5 6 7 8 9 10 11 12
  1. ; NAME^SEX^DOB^SSN^LOCIEN^LOCNM^RMBD^CWAD^SENSITIVE^ADMITTED^CONV^SC^
  1. ; 13 14 15 16 17 18 19
  1. ; SC%^ICN^AGE^TS^TSSVC^SIGI^PRONOUN(S)
  1. ;
  1. ; for CCOW (RV - 2/27/03) name="-1", location=error message
  1. I '$D(^DPT(+DFN,0)) S REC="-1^^^^^Patient is unknown to CPRS." Q
  1. ;
  1. N X,ORPREF,VADEMO,X24,ORPRON
  1. I $G(XWB("2","RPC"))="ORWPT SELECT" K ^TMP($J,"OC-OPOS") ; delete once per order session order checks
  1. K ^TMP("ORWPCE",$J) ; delete PCE 'cache' when switching patients
  1. K ^TMP("ORALLERGYCHK",$J) ; delete all temp allergy data for current session
  1. D DEMUPD^VADPT S ORPREF=$P(VADEMO(1,1),"^")
  1. S X=^DPT(DFN,0),REC=$P(X,U,1)_$S(ORPREF="":"",1:" ("_ORPREF_")")_"^"_$P(X,U,2,3)_U_$P(X,U,9)_U_U_$G(^(.1))_U_$G(^(.101))
  1. S X=$P(REC,U,6) I $L(X) S $P(REC,U,5)=+$G(^DIC(42,+$O(^DIC(42,"B",X,0)),44))
  1. S $P(REC,U,8)=$$CWAD^ORQPT2(DFN)_U_$$EN1^ORQPT2(DFN)
  1. ; I $P(REC,U,9) D EN2^ORQPT2(DFN) ;update DG security log ; DG249
  1. S X=$G(^DPT(DFN,.105)) I X S $P(REC,U,10)=$P($G(^DGPM(X,0)),U)
  1. S:'$D(IOST) IOST="P-OTHER"
  1. S $P(REC,U,11)=0
  1. D ELIG^VADPT S $P(REC,U,12)=$G(VAEL(3)) ;two pieces: SC^SC%
  1. I $L($T(GETICN^MPIF001)) S X=+$$GETICN^MPIF001(DFN) S:X>0 $P(REC,U,14)=X
  1. S $P(REC,U,15)=$$AGE(DFN,$P(REC,U,3))
  1. S $P(REC,U,16)=+$G(^DPT(DFN,.103)) ; treating specialty
  1. I +$P(REC,U,16)>0 D
  1. . N X,Y,Z
  1. . S (X,Y)=""
  1. . S X=$$TSDATA^DGACT(45.7,+$P(REC,U,16),.Y,"")
  1. . I +X,+$P($G(Y(2)),U,1)>0 S (X,Z)="" S X=$$TSDATA^DGACT(42.4,+$P($G(Y(2)),U,1),.Z,"")
  1. . I +X S $P(REC,U,17)=$P($G(Z(3)),U,1) ; treating specialty service
  1. ;SIGI
  1. S X24=$$GET1^DIQ(2,DFN,.024,"E") I X24'="" S $P(REC,U,18)=X24
  1. ;PRONOUN(S)
  1. S ORPRON=""
  1. I $G(VADEMO(14,3))>0 D
  1. . N S1
  1. . S S1=0,ORPRON="("
  1. . F S S1=$O(VADEMO(14,3,S1)) Q:'S1 S ORPRON=ORPRON_$P($P(VADEMO(14,3,S1),"^"),"/",1,2)_", "
  1. . S ORPRON=$E(ORPRON,1,$L(ORPRON)-2)_")"
  1. S $P(REC,U,19)=ORPRON
  1. K VAEL,VAERR ;VADPT call to kill?
  1. S ^DISV(DUZ,"^DPT(")=DFN
  1. Q
  1. SHARE(VAL,IP,HWND,DFN) ; Set global to share DFN with other applications
  1. K ^TMP("ORWCHART",$J),^TMP("ORECALL",$J),^TMP("ORWORD",$J)
  1. K ^TMP("ORWDXMQ",$J)
  1. S ^TMP("ORWCHART",$J,IP,HWND)=DFN
  1. Q
  1. BYWARD(LST,WARD) ; Return a list of patients in a ward
  1. N ILST,DFN
  1. I +$G(WARD)<1 S LST(1)="^No ward identified" Q
  1. S (ILST,DFN)=0
  1. S WARD=$P(^DIC(42,WARD,0),"^")
  1. F S DFN=$O(^DPT("CN",WARD,DFN)) Q:DFN'>0 D
  1. . S ILST=ILST+1,LST(ILST)=+DFN_U_$P(^DPT(+DFN,0),U)_U_$G(^DPT(+DFN,.101))
  1. I ILST<1 S LST(1)="^No patients found."
  1. Q
  1. LAST5(LST,ID) ; Return a list of patients matching A9999 identifiers
  1. N I,IEN,XREF
  1. S (I,IEN)=0,XREF=$S($L(ID)=5:"BS5",1:"BS")
  1. F S IEN=$O(^DPT(XREF,ID,IEN)) Q:'IEN D
  1. . Q:'$D(^DPT(IEN,0)) ;Added Patch OR*3*544
  1. . S I=I+1,LST(I)=IEN_U_$P(^DPT(IEN,0),U)_U_$$DOB^DPTLK1(IEN,2)_U_$$SSN^DPTLK1(IEN) ; DG249
  1. Q
  1. ;
  1. LAST5RPL(LST,ID) ; ; Return list matching A9999 id's, but from RPL only.
  1. N ORRPL,ORCNT,ORPT,ORPIEN
  1. S ORRPL=$G(^VA(200,DUZ,101))
  1. S ORRPL=$P(ORRPL,U,2)
  1. I (('ORRPL)!(ORRPL="")) S LST(0)="" Q
  1. ;
  1. S (ORCNT,ORPT)=0
  1. F S ORPT=$O(^OR(100.21,ORRPL,10,ORPT)) Q:'ORPT D
  1. .S ORPIEN=+$G(^OR(100.21,ORRPL,10,ORPT,0))
  1. .I ((ORPIEN<0)!(ORPIEN="")) Q
  1. .S ORCNT=ORCNT+1
  1. .S LST(ORCNT)=ORPIEN_U_$P(^DPT(ORPIEN,0),U)_U_$$DOB^DPTLK1(ORPIEN,2)_U_$$SSN^DPTLK1(ORPIEN) ; DG249.
  1. ;
  1. Q
  1. ;
  1. FULLSSN(LST,ID) ; Return a list of patients matching full SSN entered
  1. N I,IEN
  1. S (I,IEN)=0
  1. F S IEN=$O(^DPT("SSN",ID,IEN)) Q:'IEN D
  1. . S I=I+1,LST(I)=IEN_U_$P(^DPT(IEN,0),U)_U_$$DOB^DPTLK1(IEN,2)_U_$$SSN^DPTLK1(IEN) ; DG249
  1. Q
  1. ;
  1. FSSNRPL(LST,ID) ; Return list matching Full SSN, but from RPL only.
  1. N ORRPL,ORCNT,ORPT,ORLPT,ORPIEN
  1. S ORRPL=$G(^VA(200,DUZ,101))
  1. S ORRPL=$P(ORRPL,U,2)
  1. I (('ORRPL)!(ORRPL="")) S LST(0)="" Q
  1. ;
  1. S (ORCNT,ORPT)=0
  1. F S ORPT=$O(^DPT("SSN",ID,ORPT)) Q:'ORPT D
  1. .S ORLPT=0
  1. .F S ORLPT=$O(^OR(100.21,ORRPL,10,ORLPT)) Q:'ORLPT D
  1. ..S ORPIEN=+$G(^OR(100.21,ORRPL,10,ORLPT,0))
  1. ..I ((ORPIEN<0)!(ORPIEN="")) Q
  1. ..I (ORPIEN'=ORPT) Q
  1. ..S ORCNT=ORCNT+1
  1. ..S LST(ORCNT)=ORPIEN_U_$P(^DPT(ORPIEN,0),U)_U_$$DOB^DPTLK1(ORPIEN,2)_U_$$SSN^DPTLK1(ORPIEN) ; DG249.
  1. ;
  1. Q
  1. ;
  1. TOP(LST) ; Return top for all patients list (last selected for now)
  1. N IEN
  1. S IEN=$G(^DISV(DUZ,"^DPT("))
  1. I IEN S LST(1)=IEN_U_$P($G(^DPT(IEN,0)),U)
  1. Q
  1. ENCTITL(REC,DFN,LOC,PROV) ; Return external values for encounter
  1. ; LOCNAME^LOCABBR^ROOMBED^PROVNAME
  1. K ^TMP("OR QUICK ORDER AUDIT",$J,"REC") ;RTW
  1. S $P(REC,U,1)=$P($G(^SC(+LOC,0)),U,1,2)
  1. S $P(REC,U,3)=$P($G(^DPT(DFN,.101)),U)
  1. S $P(REC,U,4)=$$GET1^DIQ(200,+PROV,.01)
  1. S ^TMP("OR QUICK ORDER AUDIT",$J,"REC")=REC
  1. Q
  1. LISTALL(Y,FROM,DIR) ; Return a bolus of patient names. From is either Name or IEN^Name.
  1. N I,IEN,CNT,FROMIEN,ORIDNAME S CNT=44,I=0,FROMIEN=0
  1. I $P(FROM,U,2)'="" S FROMIEN=$P(FROM,U,1),FROM=$O(^DPT("B",$P(FROM,U,2)),-DIR)
  1. F S FROM=$O(^DPT("B",FROM),DIR) Q:FROM="" D Q:I=CNT
  1. . S IEN=FROMIEN,FROMIEN=0 F S IEN=$O(^DPT("B",FROM,IEN)) Q:'IEN D Q:I=CNT
  1. . . Q:$D(^DPT(IEN,-9)) ; skip if patient is a merged stub
  1. . . S ORIDNAME=""
  1. . . S ORIDNAME=$G(^DPT(IEN,0)) ; Get zero node name.
  1. . . ; S X1=$G(^DPT(IEN,.1))_" "_$G(^DPT(IEN,.101))
  1. . . S I=I+1 S Y(I)=IEN_U_FROM_U_U_U_U_$P(ORIDNAME,U) ;_"^"_X ; _"^"_X1 ;" ("_X_")"
  1. Q
  1. APPTLST(LST,DFN) ; return a list of appointments
  1. ; APPTTIME^LOCIEN^LOCNAME^EXTSTATUS
  1. N ERR,ERRMSG,VASD,VAERR K ^UTILITY("VASD",$J)
  1. S VASD("F")=$$HTFM^XLFDT($H-30,1)
  1. S VASD("T")=$$HTFM^XLFDT($H+1,1)_".2359"
  1. S VASD("W")="123456789"
  1. D SDA^ORQRY01(.ERR,.ERRMSG)
  1. I ERR K ^UTILITY("VASD",$J) K LST S LST(1)=ERRMSG Q
  1. S I=0 F S I=$O(^UTILITY("VASD",$J,I)) Q:'I D
  1. . S LST(I)=$P(^UTILITY("VASD",$J,I,"I"),U,1,2)_U_$P(^("E"),U,2,3)
  1. K ^UTILITY("VASD",$J)
  1. Q
  1. ADMITLST(LST,DFN) ; return a list of admissions
  1. ; MOVETIME^LOCIEN^LOCNAME^TYPE
  1. N TIM,MOV,X0,Y,MTIM,XTYP,XLOC,HLOC,ILST S ILST=0
  1. S TIM="" F S TIM=$O(^DGPM("ATID1",DFN,TIM)) Q:TIM'>0 D
  1. . S MOV=0 F S MOV=$O(^DGPM("ATID1",DFN,TIM,MOV)) Q:MOV'>0 D
  1. . . N VSTR,TIUDA
  1. . . S X0=$G(^DGPM(MOV,0)) I X0']"" Q
  1. . . S MTIM=$P(X0,U)
  1. . . S XTYP=$P($G(^DG(405.1,+$P(X0,U,4),0)),U,1)
  1. . . S XLOC=$P($G(^DIC(42,+$P(X0,U,6),0)),U,1),HLOC=+$G(^(44))
  1. . . S VSTR=HLOC_";"_MTIM_";H",TIUDA=$$HASDS^TIULX(DFN,VSTR)
  1. . . S ILST=ILST+1,LST(ILST)=MTIM_U_HLOC_U_XLOC_U_XTYP_U_MOV_U_TIUDA
  1. Q
  1. CLINRNG(LST) ; return date ranges for clinic appointments
  1. S LST(1)="T;T^Today"
  1. S LST(2)="T+1;T+1^Tomorrow"
  1. S LST(3)="T-1;T-1^Yesterday"
  1. S LST(4)="T-7;T^Past Week"
  1. S LST(5)="T-31;T^Past Month"
  1. S LST(6)="S^Specify Date Range..."
  1. Q
  1. ;
  1. N %,%H,X,SUNDAY,START
  1. S LST(1)=DT_";"_DT_"^Today",X=$$HTFM^XLFDT($H+1,1)
  1. S LST(2)=X_";"_X_"^Tomorrow"
  1. S X=+$H F Q:X#7=3 S X=X-1 ; $H#7=3 is Sunday
  1. S LST(3)=$$HTFM^XLFDT(X)_";"_$$HTFM^XLFDT(X+6)_"^This Week"
  1. S LST(4)=$$HTFM^XLFDT(X+7)_";"_$$HTFM^XLFDT(X+13)_"^Next Week"
  1. S LST(5)=$E(DT,1,5)_"01;"_$E(DT,1,5)_"31^This Month"
  1. S X=$E(DT,4,5)+1 S:X=13 X=1 S X=$E(DT,1,3)_$TR($J(X,2)," ",0)
  1. S LST(6)=X_"01;"_X_"31^Next Month"
  1. S LST(7)="^Specify Dates"
  1. Q
  1. DFLTSRC(VAL) ; return default patient list source (T, W, C, P, S)
  1. N SRV S SRV=$$GET1^DIQ(200,DUZ,29,"I")
  1. S VAL=$$GET^XPAR("ALL^SRV.`"_SRV,"ORLP DEFAULT LIST SOURCE")
  1. Q
  1. SAVDFLT(OK,X) ; save new default patient list settings (X=type^ien^sdt;edt)
  1. G SAVDFLT^ORWPT1
  1. ;
  1. DISCHRG(Y,DFN,ADMITDT) ; Get discharge movement information
  1. N VAIP
  1. I +$G(ADMITDT)=0 S Y=DT Q
  1. S VAIP("D")=ADMITDT D 52^VADPT
  1. I +VAIP(17)=0 S Y=DT Q
  1. S Y=+VAIP(17,1)
  1. Q
  1. CWAD(Y,DFN) ; returns CWAD flags for a patient
  1. S Y=$$CWAD^ORQPT2(DFN)
  1. Q
  1. LEGACY(ORLST,DFN) ; return message if data on the legacy system
  1. ; ORLST(0)=1 if data, ORLST(n)=display message if data
  1. S ORLST(0)=0
  1. I $L($T(HXDATA^A7RDPAGU)) D
  1. . D HXDATA^A7RDPAGU(.ORLST,DFN)
  1. . I $O(ORLST(0)) S ORLST(0)=1
  1. Q
  1. INPLOC(REC,DFN) ; Return a patient's current location
  1. N X
  1. S X=$G(^DPT(DFN,.102)),REC=0
  1. I X S X=$P($G(^DGPM(X,0)),U,6)
  1. I X S REC=+$G(^DIC(42,X,44))
  1. I X S $P(REC,U,2)=$P($G(^DIC(42,X,0)),U,1)
  1. I X S X=$P($G(^DIC(42,X,0)),U,3)
  1. S $P(REC,U,3)=X
  1. Q
  1. AGE(DFN,BEG) ; returns age based on date of birth and date of death (or DT)
  1. N END,X
  1. S END=+$G(^DPT(DFN,.35)),END=$S(END:END,1:DT)
  1. S X=$E(END,1,3)-$E(BEG,1,3)-($E(END,4,7)<$E(BEG,4,7))
  1. Q X
  1. GETFICN(ORWRSLT,DFN) ;returns ICN plus checksum for a DFN
  1. S ORWRSLT="-1^UNKNOWN ERROR"
  1. S ORWRSLT=$$GETICN^MPIF001(DFN)
  1. Q
  1. ROK(X) ; Routine OK (in UCI) (NDBI)
  1. S X=$G(X) Q:'$L(X) 0 Q:$L(X)>8 0 X ^%ZOSF("TEST") Q:$T 1 Q 0