- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPT.m
r613 r623 1 ORWPT ; SLC/KCM/REV - Patient Lookup Functions ;3/18/05 10:50 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,132,149,206,187,190,215,243**;Dec 17, 1997;Build 242 3 ; 4 ; Ref. to ^UTILITY via IA 10061 5 ; 6 IDINFO(REC,DFN) ; Return identifying information for a patient 7 ; PID^DOB^SEX^VET^SC%^WARD^RM-BED^NAME 8 N X0,X1,X101,X3,XV ; name/dob/sex/ssn, ward, room-bed, sc%, vet 9 S X0=$G(^DPT(DFN,0)),X1=$G(^(.1)),X101=$G(^(.101)),X3=$G(^(.3)),XV=$G(^("VET")) 10 S REC=$$SSN^DPTLK1(DFN)_U_$$DOB^DPTLK1(DFN,2)_U_$P(X0,U,2)_U_$P(XV,U)_U_$P(X3,U,2)_U_$P(X1,U)_U_$P(X101,U)_U_$P(X0,U) ;DG249 11 Q 12 PTINQ(REF,DFN) ; Return formatted pt inquiry report 13 K ^TMP("ORDATA",$J,1) 14 D DGINQ^ORCXPND1(DFN) 15 S REF=$NA(^TMP("ORDATA",$J,1)) 16 Q 17 SCDIS(LST,DFN) ; Return service connected % and rated disabilities 18 N VAEL,VAERR,I,ILST,DIS,SC,X 19 D ELIG^VADPT 20 S LST(1)="Service Connected: "_$S(+VAEL(3):$P(VAEL(3),U,2)_"%",1:"NO") 21 I 'VAEL(4),'$P($G(^DG(391,+VAEL(6),0)),U,2) S LST(2)="NOT A VETERAN." Q 22 S I=0,ILST=1 F S I=$O(^DPT(DFN,.372,I)) Q:'I S X=^(I,0) D 23 . S DIS=$P($G(^DIC(31,+X,0)),U) Q:DIS="" 24 . S SC=$S($P(X,U,3):"SC",$P(X,U,3)']"":"not specified",1:"NSC") 25 . S ILST=ILST+1,LST(ILST)=DIS_" ("_$P(X,U,2)_"% "_SC_")" 26 I ILST=1 S LST(2)="Rated Disabilities: NONE STATED" 27 Q 28 SHOW ; temporary - show patient inquiry screen 29 N I,Y,DIC S DIC=2,DIC(0)="AEMQ" D ^DIC Q:'Y 30 K ^TMP("ORDATA",$J,1) 31 D DGINQ^ORCXPND1(+Y) 32 S I=0 F S I=$O(^TMP("ORDATA",$J,1,I)) Q:'I W !,^(I) 33 K ^TMP("ORDATA",$J,1) 34 Q 35 SELCHK(REC,DFN) ; Check for sensitive pt 36 ; SENSITIVE 37 S REC=$$EN1^ORQPT2(DFN) 38 Q 39 DIEDON(VAL,DFN) ; Check for a date of death 40 S VAL=+$G(^DPT(DFN,.35)) 41 Q 42 SELECT(REC,DFN) ; Selects patient & returns key information 43 ; 1 2 3 4 5 6 7 8 9 10 11 12 44 ; NAME^SEX^DOB^SSN^LOCIEN^LOCNM^RMBD^CWAD^SENSITIVE^ADMITTED^CONV^SC^ 45 ; 13 14 15 16 46 ; SC%^ICN^AGE^TS 47 ; 48 ; for CCOW (RV - 2/27/03) name="-1", location=error message 49 I '$D(^DPT(+DFN,0)) S REC="-1^^^^^Patient is unknown to CPRS." Q 50 ; 51 N X 52 K ^TMP("ORWPCE",$J) ; delete PCE 'cache' when switching patients 53 S X=^DPT(DFN,0),REC=$P(X,U,1,3)_U_$P(X,U,9)_U_U_$G(^(.1))_U_$G(^(.101)) 54 S X=$P(REC,U,6) I $L(X) S $P(REC,U,5)=+$G(^DIC(42,+$O(^DIC(42,"B",X,0)),44)) 55 S $P(REC,U,8)=$$CWAD^ORQPT2(DFN)_U_$$EN1^ORQPT2(DFN) 56 ; I $P(REC,U,9) D EN2^ORQPT2(DFN) ;update DG security log ; DG249 57 S X=$G(^DPT(DFN,.105)) I X S $P(REC,U,10)=$P($G(^DGPM(X,0)),U) 58 S:'$D(IOST) IOST="P-OTHER" 59 S $P(REC,U,11)=0 60 D ELIG^VADPT S $P(REC,U,12)=$G(VAEL(3)) ;two pieces: SC^SC% 61 I $L($T(GETICN^MPIF001)) S X=+$$GETICN^MPIF001(DFN) S:X>0 $P(REC,U,14)=X 62 S $P(REC,U,15)=$$AGE(DFN,$P(REC,U,3)) 63 S $P(REC,U,16)=+$G(^DPT(DFN,.103)) ; treating specialty 64 K VAEL,VAERR ;VADPT call to kill? 65 S ^DISV(DUZ,"^DPT(")=DFN 66 Q 67 SHARE(VAL,IP,HWND,DFN) ; Set global to share DFN with other applications 68 K ^TMP("ORWCHART",$J),^TMP("ORECALL",$J),^TMP("ORWORD",$J) 69 K ^TMP("ORWDXMQ",$J) 70 S ^TMP("ORWCHART",$J,IP,HWND)=DFN 71 Q 72 BYWARD(LST,WARD) ; Return a list of patients in a ward 73 N ILST,DFN 74 I +$G(WARD)<1 S LST(1)="^No ward identified" Q 75 S (ILST,DFN)=0 76 S WARD=$P(^DIC(42,WARD,0),"^") ;DBIA #36 77 F S DFN=$O(^DPT("CN",WARD,DFN)) Q:DFN'>0 D 78 . S ILST=ILST+1,LST(ILST)=+DFN_U_$P(^DPT(+DFN,0),U)_U_$G(^DPT(+DFN,.101)) 79 I ILST<1 S LST(1)="^No patients found." 80 Q 81 LAST5(LST,ID) ; Return a list of patients matching A9999 identifiers 82 N I,IEN,XREF 83 S (I,IEN)=0,XREF=$S($L(ID)=5:"BS5",1:"BS") 84 F S IEN=$O(^DPT(XREF,ID,IEN)) Q:'IEN D 85 . S I=I+1,LST(I)=IEN_U_$P(^DPT(IEN,0),U)_U_$$DOB^DPTLK1(IEN,2)_U_$$SSN^DPTLK1(IEN) ; DG249 86 Q 87 ; 88 LAST5RPL(LST,ID) ; ; Return list matching A9999 id's, but from RPL only. 89 N ORRPL,ORCNT,ORPT,ORPIEN 90 ; IA ____ allows read access to NEW PERSON file node 101: 91 S ORRPL=$G(^VA(200,DUZ,101)) 92 S ORRPL=$P(ORRPL,U,2) 93 I (('ORRPL)!(ORRPL="")) S LST(0)="" Q 94 ; 95 S (ORCNT,ORPT)=0 96 F S ORPT=$O(^OR(100.21,ORRPL,10,ORPT)) Q:'ORPT D 97 .S ORPIEN=+$G(^OR(100.21,ORRPL,10,ORPT,0)) 98 .I ((ORPIEN<0)!(ORPIEN="")) Q 99 .S ORCNT=ORCNT+1 100 .S LST(ORCNT)=ORPIEN_U_$P(^DPT(ORPIEN,0),U)_U_$$DOB^DPTLK1(ORPIEN,2)_U_$$SSN^DPTLK1(ORPIEN) ; DG249. 101 ; 102 Q 103 ; 104 FULLSSN(LST,ID) ; Return a list of patients matching full SSN entered 105 N I,IEN 106 S (I,IEN)=0 107 F S IEN=$O(^DPT("SSN",ID,IEN)) Q:'IEN D 108 . S I=I+1,LST(I)=IEN_U_$P(^DPT(IEN,0),U)_U_$$DOB^DPTLK1(IEN,2)_U_$$SSN^DPTLK1(IEN) ; DG249 109 Q 110 ; 111 FSSNRPL(LST,ID) ; Return list matching Full SSN, but from RPL only. 112 N ORRPL,ORCNT,ORPT,ORLPT,ORPIEN 113 ; IA ____ allows read access to NEW PERSON file node 101: 114 S ORRPL=$G(^VA(200,DUZ,101)) 115 S ORRPL=$P(ORRPL,U,2) 116 I (('ORRPL)!(ORRPL="")) S LST(0)="" Q 117 ; 118 S (ORCNT,ORPT)=0 119 F S ORPT=$O(^DPT("SSN",ID,ORPT)) Q:'ORPT D 120 .S ORLPT=0 121 .F S ORLPT=$O(^OR(100.21,ORRPL,10,ORLPT)) Q:'ORLPT D 122 ..S ORPIEN=+$G(^OR(100.21,ORRPL,10,ORLPT,0)) 123 ..I ((ORPIEN<0)!(ORPIEN="")) Q 124 ..I (ORPIEN'=ORPT) Q 125 ..S ORCNT=ORCNT+1 126 ..S LST(ORCNT)=ORPIEN_U_$P(^DPT(ORPIEN,0),U)_U_$$DOB^DPTLK1(ORPIEN,2)_U_$$SSN^DPTLK1(ORPIEN) ; DG249. 127 ; 128 Q 129 ; 130 TOP(LST) ; Return top for all patients list (last selected for now) 131 N IEN 132 S IEN=$G(^DISV(DUZ,"^DPT(")) 133 I IEN S LST(1)=IEN_U_$P($G(^DPT(IEN,0)),U) 134 Q 135 ENCTITL(REC,DFN,LOC,PROV) ; Return external values for encounter 136 ; LOCNAME^LOCABBR^ROOMBED^PROVNAME 137 S $P(REC,U,1)=$P($G(^SC(+LOC,0)),U,1,2) 138 S $P(REC,U,3)=$P($G(^DPT(DFN,.101)),U) 139 S $P(REC,U,4)=$P($G(^VA(200,+PROV,0)),U) 140 Q 141 LISTALL(Y,FROM,DIR) ; Return a bolus of patient names. From is either Name or IEN^Name. 142 N I,IEN,CNT,FROMIEN,ORIDNAME S CNT=44,I=0,FROMIEN=0 143 I $P(FROM,U,2)'="" S FROMIEN=$P(FROM,U,1),FROM=$O(^DPT("B",$P(FROM,U,2)),-DIR) 144 F S FROM=$O(^DPT("B",FROM),DIR) Q:FROM="" D Q:I=CNT 145 . S IEN=FROMIEN,FROMIEN=0 F S IEN=$O(^DPT("B",FROM,IEN)) Q:'IEN D Q:I=CNT 146 . . S ORIDNAME="" 147 . . S ORIDNAME=$G(^DPT(IEN,0)) ; Get zero node name. 148 . . ; S X1=$G(^DPT(IEN,.1))_" "_$G(^DPT(IEN,.101)) 149 . . S I=I+1 S Y(I)=IEN_U_FROM_U_U_U_U_$P(ORIDNAME,U) ;_"^"_X ; _"^"_X1 ;" ("_X_")" 150 Q 151 APPTLST(LST,DFN) ; return a list of appointments 152 ; APPTTIME^LOCIEN^LOCNAME^EXTSTATUS 153 N ERR,ERRMSG,VASD,VAERR K ^UTILITY("VASD",$J) ;IA 10061 154 S VASD("F")=$$HTFM^XLFDT($H-30,1) 155 S VASD("T")=$$HTFM^XLFDT($H+1,1)_".2359" 156 S VASD("W")="123456789" 157 D SDA^ORQRY01(.ERR,.ERRMSG) 158 I ERR K ^UTILITY("VASD",$J) K LST S LST(1)=ERRMSG Q 159 S I=0 F S I=$O(^UTILITY("VASD",$J,I)) Q:'I D 160 . S LST(I)=$P(^UTILITY("VASD",$J,I,"I"),U,1,2)_U_$P(^("E"),U,2,3) 161 K ^UTILITY("VASD",$J) 162 Q 163 ADMITLST(LST,DFN) ; return a list of admissions 164 ; MOVETIME^LOCIEN^LOCNAME^TYPE 165 N TIM,MOV,X0,Y,MTIM,XTYP,XLOC,HLOC,ILST S ILST=0 166 S TIM="" F S TIM=$O(^DGPM("ATID1",DFN,TIM)) Q:TIM'>0 D 167 . S MOV=0 F S MOV=$O(^DGPM("ATID1",DFN,TIM,MOV)) Q:MOV'>0 D 168 . . N VSTR,TIUDA 169 . . S X0=$G(^DGPM(MOV,0)) I X0']"" Q 170 . . S MTIM=$P(X0,U) 171 . . S XTYP=$P($G(^DG(405.1,+$P(X0,U,4),0)),U,1) 172 . . S XLOC=$P($G(^DIC(42,+$P(X0,U,6),0)),U,1),HLOC=+$G(^(44)) 173 . . S VSTR=HLOC_";"_MTIM_";H",TIUDA=$$HASDS^TIULX(DFN,VSTR) 174 . . S ILST=ILST+1,LST(ILST)=MTIM_U_HLOC_U_XLOC_U_XTYP_U_MOV_U_TIUDA 175 Q 176 CLINRNG(LST) ; return date ranges for clinic appointments 177 S LST(1)="T;T^Today" 178 S LST(2)="T+1;T+1^Tomorrow" 179 S LST(3)="T-1;T-1^Yesterday" 180 S LST(4)="T-7;T^Past Week" 181 S LST(5)="T-31;T^Past Month" 182 S LST(6)="S^Specify Date Range..." 183 Q 184 ; 185 N %,%H,X,SUNDAY,START 186 S LST(1)=DT_";"_DT_"^Today",X=$$HTFM^XLFDT($H+1,1) 187 S LST(2)=X_";"_X_"^Tomorrow" 188 S X=+$H F Q:X#7=3 S X=X-1 ; $H#7=3 is Sunday 189 S LST(3)=$$HTFM^XLFDT(X)_";"_$$HTFM^XLFDT(X+6)_"^This Week" 190 S LST(4)=$$HTFM^XLFDT(X+7)_";"_$$HTFM^XLFDT(X+13)_"^Next Week" 191 S LST(5)=$E(DT,1,5)_"01;"_$E(DT,1,5)_"31^This Month" 192 S X=$E(DT,4,5)+1 S:X=13 X=1 S X=$E(DT,1,3)_$TR($J(X,2)," ",0) 193 S LST(6)=X_"01;"_X_"31^Next Month" 194 S LST(7)="^Specify Dates" 195 Q 196 DFLTSRC(VAL) ; return default patient list source (T, W, C, P, S) 197 N SRV S SRV=+$G(^VA(200,DUZ,5)) 198 S VAL=$$GET^XPAR("ALL^SRV.`"_SRV,"ORLP DEFAULT LIST SOURCE") 199 Q 200 SAVDFLT(OK,X) ; save new default patient list settings (X=type^ien^sdt;edt) 201 G SAVDFLT^ORWPT1 202 ; 203 DISCHRG(Y,DFN,ADMITDT) ; Get discharge movement information 204 N VAIP 205 I +$G(ADMITDT)=0 S Y=DT Q 206 S VAIP("D")=ADMITDT D 52^VADPT 207 I +VAIP(17)=0 S Y=DT Q 208 S Y=+VAIP(17,1) 209 Q 210 CWAD(Y,DFN) ; returns CWAD flags for a patient 211 S Y=$$CWAD^ORQPT2(DFN) 212 Q 213 LEGACY(ORLST,DFN) ; return message if data on the legacy system 214 ; ORLST(0)=1 if data, ORLST(n)=display message if data 215 S ORLST(0)=0 216 I $L($T(HXDATA^A7RDPAGU)) D 217 . D HXDATA^A7RDPAGU(.ORLST,DFN) 218 . I $O(ORLST(0)) S ORLST(0)=1 219 Q 220 INPLOC(REC,DFN) ; Return a patient's current location 221 N X 222 S X=$G(^DPT(DFN,.102)),REC=0 223 I X S X=$P($G(^DGPM(X,0)),U,6) 224 I X S REC=+$G(^DIC(42,X,44)) 225 I X S $P(REC,U,2)=$P($G(^DIC(42,X,0)),U,1) 226 I X S X=$P($G(^DIC(42,X,0)),U,3) 227 S $P(REC,U,3)=X 228 Q 229 AGE(DFN,BEG) ; returns age based on date of birth and date of death (or DT) 230 N END,X 231 S END=+$G(^DPT(DFN,.35)),END=$S(END:END,1:DT) 232 S X=$E(END,1,3)-$E(BEG,1,3)-($E(END,4,7)<$E(BEG,4,7)) 233 Q X 234 ROK(X) ; Routine OK (in UCI) (NDBI) 235 S X=$G(X) Q:'$L(X) 0 Q:$L(X)>8 0 X ^%ZOSF("TEST") Q:$T 1 Q 0 236 ; 237 ;NDBI(X) ; National Database Integration site 1 = yes 0 = no 238 ; N R,G S X="A7RDUP" X ^%ZOSF("TEST") S R=$T,G=$S($D(^A7RCP):1,1:0),X=R+G,X=$S(X=2:1,1:0) Q X 1 ORWPT ; SLC/KCM/REV - Patient Lookup Functions ;11/23/06 10:50 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,132,149,206,187,190,215,269**;Dec 17, 1997 LOCAL ;Build 28 3 ; Modified from FOIA VISTA, 4 ; Copyright (C) 2007 WorldVistA 5 ; 6 ; This program is free software; you can redistribute it and/or modify 7 ; it under the terms of the GNU General Public License 8 ;;VOE VWPT PACKAGE ENHANCEMENT UPDATES ADDED 11/14/06 9 ; 10 Q 11 IDINFO(REC,DFN) ; Return identifying information for a patient 12 ;VWPT BELOW ADD HRN AND ALT HRN 13 ; PID^DOB^SEX^VET^SC%^WARD^RM-BED^NAME^HRN^ALTHRN 14 ; PID^DOB^SEX^VET^SC%^WARD^RM-BED^NAME 15 N X0,X1,X101,X3,XV ; name/dob/sex/ssn, ward, room-bed, sc%, vet 16 S X0=$G(^DPT(DFN,0)),X1=$G(^(.1)),X101=$G(^(.101)),X3=$G(^(.3)),XV=$G(^("VET")) 17 ;VWPT ENHANCED 18 N HRN,ID 19 S HRN=$$HRN^DGLBPID(DFN) 20 S ID=$$ID^DGLBPID(DFN) 21 I (ID=HRN)&(HRN'="") D 22 .S REC=U_$$DOB^DPTLK1(DFN,2)_U_$P(X0,U,2)_U_$P(XV,U)_U_$P(X3,U,2)_U_$P(X1,U)_U_$P(X101,U)_U_$P(X0,U)_U_$$HRNRET(DFN)_U_$$ALTHRN^ORWPT2(DFN) ;DG249 23 E D 24 .S REC=$$ID^DGLBPID(DFN)_U_$$DOB^DPTLK1(DFN,2)_U_$P(X0,U,2)_U_$P(XV,U)_U_$P(X3,U,2)_U_$P(X1,U)_U_$P(X101,U)_U_$P(X0,U)_U_$$HRNRET(DFN)_U_$$ALTHRN^ORWPT2(DFN) ;DG249 25 ;S REC=$$SSN^DPTLK1(DFN)_U_$$DOB^DPTLK1(DFN,2)_U_$P(X0,U,2)_U_$P(XV,U)_U_$P(X3,U,2)_U_$P(X1,U)_U_$P(X101,U)_U_$P(X0,U) ;DG249 26 ;END VWPT 27 Q 28 ;VWPT RETURN HRN .CHECK FOR "sensitive" patients 29 HRNRET(DFN) ; 30 N IRET 31 S IRET=$$HRN^DGLBPID(DFN) ;$$HRN^VWVOEDPT(DFN) 32 ;I (IRET'="")&$$SCREEN^DPTLK1(DFN) Q "*SENSITIVE*" ;"HRN SENSITIVE" 33 I (IRET'="") Q "'"_IRET_"'" ;"HRN:"_"'"_IRET_"'" 34 Q "" 35 ; END VWPT 36 PTINQ(REF,DFN) ; Return formatted pt inquiry report 37 K ^TMP("ORDATA",$J,1) 38 D DGINQ^ORCXPND1(DFN) 39 S REF=$NA(^TMP("ORDATA",$J,1)) 40 Q 41 SCDIS(LST,DFN) ; Return service connected % and rated disabilities 42 N VAEL,VAERR,I,ILST,DIS,SC,X 43 D ELIG^VADPT 44 S LST(1)="Service Connected: "_$S(+VAEL(3):$P(VAEL(3),U,2)_"%",1:"NO") 45 I 'VAEL(4),'$P($G(^DG(391,+VAEL(6),0)),U,2) S LST(2)="NOT A VETERAN." Q 46 S I=0,ILST=1 F S I=$O(^DPT(DFN,.372,I)) Q:'I S X=^(I,0) D 47 . S DIS=$P($G(^DIC(31,+X,0)),U) Q:DIS="" 48 . S SC=$S($P(X,U,3):"SC",$P(X,U,3)']"":"not specified",1:"NSC") 49 . S ILST=ILST+1,LST(ILST)=DIS_" ("_$P(X,U,2)_"% "_SC_")" 50 I ILST=1 S LST(2)="Rated Disabilities: NONE STATED" 51 Q 52 SHOW ; temporary - show patient inquiry screen 53 N I,Y,DIC S DIC=2,DIC(0)="AEMQ" D ^DIC Q:'Y 54 K ^TMP("ORDATA",$J,1) 55 D DGINQ^ORCXPND1(+Y) 56 S I=0 F S I=$O(^TMP("ORDATA",$J,1,I)) Q:'I W !,^(I) 57 K ^TMP("ORDATA",$J,1) 58 Q 59 SELCHK(REC,DFN) ; Check for sensitive pt 60 ; SENSITIVE 61 S REC=$$EN1^ORQPT2(DFN) 62 Q 63 DIEDON(VAL,DFN) ; Check for a date of death 64 S VAL=+$G(^DPT(DFN,.35)) 65 Q 66 SELECT(REC,DFN) ; Selects patient & returns key information 67 ; 1 2 3 4 5 6 7 8 9 10 11 12 68 ; NAME^SEX^DOB^SSN^LOCIEN^LOCNM^RMBD^CWAD^SENSITIVE^ADMITTED^CONV^SC^ 69 ;VWPT HRN , ALTERNATE HRN 70 ; 13 14 15 16 17 18 71 ; SC%^ICN^AGE^TS^HRN^AltHRN 72 ; ; 73 ; ;end vwpt 74 ; 75 ; 76 ; for CCOW (RV - 2/27/03) name="-1", location=error message 77 I '$D(^DPT(DFN,0)) S REC="-1^^^^^Patient is unknown to CPRS." Q 78 ; 79 N X,ID,HRN 80 K ^TMP("ORWPCE",$J) ; delete PCE 'cache' when switching patients 81 D VWPT1^ORWPT2 ;moved code to ORWPT2 to save space 82 S $P(REC,U,15)=$$AGE(DFN,$P(REC,U,3)) 83 S $P(REC,U,16)=+$G(^DPT(DFN,.103)) ; treating specialty 84 D VWPT2^ORWPT2 85 Q 86 SHARE(VAL,IP,HWND,DFN) ; Set global to share DFN with other applications 87 K ^TMP("ORWCHART",$J),^TMP("ORECALL",$J),^TMP("ORWORD",$J) 88 K ^TMP("ORWDXMQ",$J) 89 S ^TMP("ORWCHART",$J,IP,HWND)=DFN 90 Q 91 BYWARD(LST,WARD) ; Return a list of patients in a ward 92 N ILST,DFN 93 I +$G(WARD)<1 S LST(1)="^No ward identified" Q 94 S (ILST,DFN)=0 95 S WARD=$P(^DIC(42,WARD,0),"^") ;DBIA #36 96 F S DFN=$O(^DPT("CN",WARD,DFN)) Q:DFN'>0 D 97 . S ILST=ILST+1,LST(ILST)=+DFN_U_$P(^DPT(+DFN,0),U)_U_$G(^DPT(+DFN,.101)) 98 I ILST<1 S LST(1)="^No patients found." 99 Q 100 LAST5(LST,ID) ; Return a list of patients matching A9999 identifiers 101 N I,IEN,XREF 102 S (I,IEN)=0,XREF=$S($L(ID)=5:"BS5",1:"BS") 103 F S IEN=$O(^DPT(XREF,ID,IEN)) Q:'IEN D 104 . S I=I+1,LST(I)=IEN_U_$P(^DPT(IEN,0),U)_U_$$DOB^DPTLK1(IEN,2)_U_$$ID^DGLBPID(IEN) ;$$SSN^DPTLK1(IEN) ; DG249 105 Q 106 ; 107 LAST5RPL(LST,ID) ; ; Return list matching A9999 id's, but from RPL only. 108 N ORRPL,ORCNT,ORPT,ORPIEN 109 ; IA ____ allows read access to NEW PERSON file node 101: 110 S ORRPL=$G(^VA(200,DUZ,101)) 111 S ORRPL=$P(ORRPL,U,2) 112 I (('ORRPL)!(ORRPL="")) S LST(0)="" Q 113 ; 114 S (ORCNT,ORPT)=0 115 F S ORPT=$O(^OR(100.21,ORRPL,10,ORPT)) Q:'ORPT D 116 .S ORPIEN=+$G(^OR(100.21,ORRPL,10,ORPT,0)) 117 .I ((ORPIEN<0)!(ORPIEN="")) Q 118 .S ORCNT=ORCNT+1 119 .S LST(ORCNT)=ORPIEN_U_$P(^DPT(ORPIEN,0),U)_U_$$DOB^DPTLK1(ORPIEN,2)_U_$$ID^DGLBPID(ORPIEN) ;$$SSN^DPTLK1(ORPIEN) ; DG249. 120 ; 121 Q 122 ; 123 FULLSSN(LST,ID) ; Return a list of patients matching full SSN entered 124 N I,IEN 125 S (I,IEN)=0 126 F S IEN=$O(^DPT("SSN",ID,IEN)) Q:'IEN D 127 . S I=I+1,LST(I)=IEN_U_$P(^DPT(IEN,0),U)_U_$$DOB^DPTLK1(IEN,2)_U_$$ID^DGLBPID(IEN) ;$$SSN^DPTLK1(IEN) ; DG249 128 Q 129 ; 130 FSSNRPL(LST,ID) ; Return list matching Full SSN, but from RPL only. 131 N ORRPL,ORCNT,ORPT,ORLPT,ORPIEN 132 ; IA ____ allows read access to NEW PERSON file node 101: 133 S ORRPL=$G(^VA(200,DUZ,101)) 134 S ORRPL=$P(ORRPL,U,2) 135 I (('ORRPL)!(ORRPL="")) S LST(0)="" Q 136 ; 137 S (ORCNT,ORPT)=0 138 F S ORPT=$O(^DPT("SSN",ID,ORPT)) Q:'ORPT D 139 .S ORLPT=0 140 .F S ORLPT=$O(^OR(100.21,ORRPL,10,ORLPT)) Q:'ORLPT D 141 ..S ORPIEN=+$G(^OR(100.21,ORRPL,10,ORLPT,0)) 142 ..I ((ORPIEN<0)!(ORPIEN="")) Q 143 ..I (ORPIEN'=ORPT) Q 144 ..S ORCNT=ORCNT+1 145 ..S LST(ORCNT)=ORPIEN_U_$P(^DPT(ORPIEN,0),U)_U_$$DOB^DPTLK1(ORPIEN,2)_U_$$ID^DGLBPID(ORPIEN) ;SSN^DPTLK1(ORPIEN) ; DG249. 146 ; 147 Q 148 ; 149 TOP(LST) ; Return top for all patients list (last selected for now) 150 N IEN 151 S IEN=$G(^DISV(DUZ,"^DPT(")) 152 I IEN S LST(1)=IEN_U_$P($G(^DPT(IEN,0)),U) 153 Q 154 ENCTITL(REC,DFN,LOC,PROV) ; Return external values for encounter 155 ; LOCNAME^LOCABBR^ROOMBED^PROVNAME 156 S $P(REC,U,1)=$P($G(^SC(+LOC,0)),U,1,2) 157 S $P(REC,U,3)=$P($G(^DPT(DFN,.101)),U) 158 S $P(REC,U,4)=$P($G(^VA(200,+PROV,0)),U) 159 Q 160 LISTALL(Y,FROM,DIR) ; Return a bolus of patient names. From is either Name or IEN^Name. 161 N I,IEN,CNT,FROMIEN,ORIDNAME S CNT=44,I=0,FROMIEN=0 162 I $P(FROM,U,2)'="" S FROMIEN=$P(FROM,U,1),FROM=$O(^DPT("B",$P(FROM,U,2)),-DIR) 163 F S FROM=$O(^DPT("B",FROM),DIR) Q:FROM="" D Q:I=CNT 164 . S IEN=FROMIEN,FROMIEN=0 F S IEN=$O(^DPT("B",FROM,IEN)) Q:'IEN D Q:I=CNT 165 . . S ORIDNAME="" 166 . . S ORIDNAME=$G(^DPT(IEN,0)) ; Get zero node name. 167 . . ; S X1=$G(^DPT(IEN,.1))_" "_$G(^DPT(IEN,.101)) 168 . . S I=I+1 S Y(I)=IEN_U_FROM_U_U_U_U_$P(ORIDNAME,U) ;_"^"_X ; _"^"_X1 ;" ("_X_")" 169 Q 170 APPTLST(LST,DFN) ; return a list of appointments 171 ; APPTTIME^LOCIEN^LOCNAME^EXTSTATUS 172 N ERR,ERRMSG,VASD,VAERR K ^UTILITY("VASD",$J) ;IA 10061 173 S VASD("F")=$$HTFM^XLFDT($H-30,1) 174 S VASD("T")=$$HTFM^XLFDT($H+1,1)_".2359" 175 S VASD("W")="123456789" 176 D SDA^ORQRY01(.ERR,.ERRMSG) 177 I ERR K ^UTILITY("VASD",$J) K LST S LST(1)=ERRMSG Q 178 S I=0 F S I=$O(^UTILITY("VASD",$J,I)) Q:'I D 179 . S LST(I)=$P(^UTILITY("VASD",$J,I,"I"),U,1,2)_U_$P(^("E"),U,2,3) 180 K ^UTILITY("VASD",$J) 181 Q 182 ADMITLST(LST,DFN) ; return a list of admissions 183 ; MOVETIME^LOCIEN^LOCNAME^TYPE 184 N TIM,MOV,X0,Y,MTIM,XTYP,XLOC,HLOC,ILST S ILST=0 185 S TIM="" F S TIM=$O(^DGPM("ATID1",DFN,TIM)) Q:TIM'>0 D 186 . S MOV=0 F S MOV=$O(^DGPM("ATID1",DFN,TIM,MOV)) Q:MOV'>0 D 187 . . N VSTR,TIUDA 188 . . S X0=$G(^DGPM(MOV,0)) I X0']"" Q 189 . . S MTIM=$P(X0,U) 190 . . S XTYP=$P($G(^DG(405.1,+$P(X0,U,4),0)),U,1) 191 . . S XLOC=$P($G(^DIC(42,+$P(X0,U,6),0)),U,1),HLOC=+$G(^(44)) 192 . . S VSTR=HLOC_";"_MTIM_";H",TIUDA=$$HASDS^TIULX(DFN,VSTR) 193 . . S ILST=ILST+1,LST(ILST)=MTIM_U_HLOC_U_XLOC_U_XTYP_U_MOV_U_TIUDA 194 Q 195 CLINRNG(LST) ; return date ranges for clinic appointments 196 S LST(1)="T;T^Today" 197 S LST(2)="T+1;T+1^Tomorrow" 198 S LST(3)="T-1;T-1^Yesterday" 199 S LST(4)="T-7;T^Past Week" 200 S LST(5)="T-31;T^Past Month" 201 S LST(6)="S^Specify Date Range..." 202 Q 203 ; 204 N %,%H,X,SUNDAY,START 205 S LST(1)=DT_";"_DT_"^Today",X=$$HTFM^XLFDT($H+1,1) 206 S LST(2)=X_";"_X_"^Tomorrow" 207 S X=+$H F Q:X#7=3 S X=X-1 ; $H#7=3 is Sunday 208 S LST(3)=$$HTFM^XLFDT(X)_";"_$$HTFM^XLFDT(X+6)_"^This Week" 209 S LST(4)=$$HTFM^XLFDT(X+7)_";"_$$HTFM^XLFDT(X+13)_"^Next Week" 210 S LST(5)=$E(DT,1,5)_"01;"_$E(DT,1,5)_"31^This Month" 211 S X=$E(DT,4,5)+1 S:X=13 X=1 S X=$E(DT,1,3)_$TR($J(X,2)," ",0) 212 S LST(6)=X_"01;"_X_"31^Next Month" 213 S LST(7)="^Specify Dates" 214 Q 215 DFLTSRC(VAL) ; return default patient list source (T, W, C, P, S) 216 N SRV S SRV=+$G(^VA(200,DUZ,5)) 217 S VAL=$$GET^XPAR("ALL^SRV.`"_SRV,"ORLP DEFAULT LIST SOURCE") 218 Q 219 SAVDFLT(OK,X) ; save new default patient list settings (X=type^ien^sdt;edt) 220 G SAVDFLT^ORWPT1 221 ; 222 DISCHRG(Y,DFN,ADMITDT) ; Get discharge movement information 223 N VAIP 224 I +$G(ADMITDT)=0 S Y=DT Q 225 S VAIP("D")=ADMITDT D 52^VADPT 226 I +VAIP(17)=0 S Y=DT Q 227 S Y=+VAIP(17,1) 228 Q 229 CWAD(Y,DFN) ; returns CWAD flags for a patient 230 S Y=$$CWAD^ORQPT2(DFN) 231 Q 232 LEGACY(ORLST,DFN) ; return message if data on the legacy system 233 ; ORLST(0)=1 if data, ORLST(n)=display message if data 234 S ORLST(0)=0 235 I $L($T(HXDATA^A7RDPAGU)) D 236 . D HXDATA^A7RDPAGU(.ORLST,DFN) 237 . I $O(ORLST(0)) S ORLST(0)=1 238 Q 239 INPLOC(REC,DFN) ; Return a patient's current location 240 N X 241 S X=$G(^DPT(DFN,.102)),REC=0 242 I X S X=$P($G(^DGPM(X,0)),U,6) 243 I X S REC=+$G(^DIC(42,X,44)) 244 I X S $P(REC,U,2)=$P($G(^DIC(42,X,0)),U,1) 245 I X S X=$P($G(^DIC(42,X,0)),U,3) 246 S $P(REC,U,3)=X 247 Q 248 AGE(DFN,BEG) ; returns age based on date of birth and date of death (or DT) 249 N END,X 250 S END=+$G(^DPT(DFN,.35)),END=$S(END:END,1:DT) 251 S X=$E(END,1,3)-$E(BEG,1,3)-($E(END,4,7)<$E(BEG,4,7)) 252 Q X 253 ROK(X) ; Routine OK (in UCI) (NDBI) 254 S X=$G(X) Q:'$L(X) 0 Q:$L(X)>8 0 X ^%ZOSF("TEST") Q:$T 1 Q 0 255 ; 256 ;NDBI(X) ; National Database Integration site 1 = yes 0 = no 257 ; N R,G S X="A7RDUP" X ^%ZOSF("TEST") S R=$T,G=$S($D(^A7RCP):1,1:0),X=R+G,X=$S(X=2:1,1:0) Q X 258 ;
Note:
See TracChangeset
for help on using the changeset viewer.
