ORWPT ; SLC/KCM/REV - Patient Lookup Functions ;3/18/05 10:50
;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,132,149,206,187,190,215,243**;Dec 17, 1997;Build 242
;
; Ref. to ^UTILITY via IA 10061
;
IDINFO(REC,DFN) ; Return identifying information for a patient
; PID^DOB^SEX^VET^SC%^WARD^RM-BED^NAME
N X0,X1,X101,X3,XV ; name/dob/sex/ssn, ward, room-bed, sc%, vet
S X0=$G(^DPT(DFN,0)),X1=$G(^(.1)),X101=$G(^(.101)),X3=$G(^(.3)),XV=$G(^("VET"))
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
Q
PTINQ(REF,DFN) ; Return formatted pt inquiry report
K ^TMP("ORDATA",$J,1)
D DGINQ^ORCXPND1(DFN)
S REF=$NA(^TMP("ORDATA",$J,1))
Q
SCDIS(LST,DFN) ; Return service connected % and rated disabilities
N VAEL,VAERR,I,ILST,DIS,SC,X
D ELIG^VADPT
S LST(1)="Service Connected: "_$S(+VAEL(3):$P(VAEL(3),U,2)_"%",1:"NO")
I 'VAEL(4),'$P($G(^DG(391,+VAEL(6),0)),U,2) S LST(2)="NOT A VETERAN." Q
S I=0,ILST=1 F S I=$O(^DPT(DFN,.372,I)) Q:'I S X=^(I,0) D
. S DIS=$P($G(^DIC(31,+X,0)),U) Q:DIS=""
. S SC=$S($P(X,U,3):"SC",$P(X,U,3)']"":"not specified",1:"NSC")
. S ILST=ILST+1,LST(ILST)=DIS_" ("_$P(X,U,2)_"% "_SC_")"
I ILST=1 S LST(2)="Rated Disabilities: NONE STATED"
Q
SHOW ; temporary - show patient inquiry screen
N I,Y,DIC S DIC=2,DIC(0)="AEMQ" D ^DIC Q:'Y
K ^TMP("ORDATA",$J,1)
D DGINQ^ORCXPND1(+Y)
S I=0 F S I=$O(^TMP("ORDATA",$J,1,I)) Q:'I W !,^(I)
K ^TMP("ORDATA",$J,1)
Q
SELCHK(REC,DFN) ; Check for sensitive pt
; SENSITIVE
S REC=$$EN1^ORQPT2(DFN)
Q
DIEDON(VAL,DFN) ; Check for a date of death
S VAL=+$G(^DPT(DFN,.35))
Q
SELECT(REC,DFN) ; Selects patient & returns key information
; 1 2 3 4 5 6 7 8 9 10 11 12
; NAME^SEX^DOB^SSN^LOCIEN^LOCNM^RMBD^CWAD^SENSITIVE^ADMITTED^CONV^SC^
; 13 14 15 16
; SC%^ICN^AGE^TS
;
; for CCOW (RV - 2/27/03) name="-1", location=error message
I '$D(^DPT(+DFN,0)) S REC="-1^^^^^Patient is unknown to CPRS." Q
;
N X
K ^TMP("ORWPCE",$J) ; delete PCE 'cache' when switching patients
S X=^DPT(DFN,0),REC=$P(X,U,1,3)_U_$P(X,U,9)_U_U_$G(^(.1))_U_$G(^(.101))
S X=$P(REC,U,6) I $L(X) S $P(REC,U,5)=+$G(^DIC(42,+$O(^DIC(42,"B",X,0)),44))
S $P(REC,U,8)=$$CWAD^ORQPT2(DFN)_U_$$EN1^ORQPT2(DFN)
; I $P(REC,U,9) D EN2^ORQPT2(DFN) ;update DG security log ; DG249
S X=$G(^DPT(DFN,.105)) I X S $P(REC,U,10)=$P($G(^DGPM(X,0)),U)
S:'$D(IOST) IOST="P-OTHER"
S $P(REC,U,11)=0
D ELIG^VADPT S $P(REC,U,12)=$G(VAEL(3)) ;two pieces: SC^SC%
I $L($T(GETICN^MPIF001)) S X=+$$GETICN^MPIF001(DFN) S:X>0 $P(REC,U,14)=X
S $P(REC,U,15)=$$AGE(DFN,$P(REC,U,3))
S $P(REC,U,16)=+$G(^DPT(DFN,.103)) ; treating specialty
K VAEL,VAERR ;VADPT call to kill?
S ^DISV(DUZ,"^DPT(")=DFN
Q
SHARE(VAL,IP,HWND,DFN) ; Set global to share DFN with other applications
K ^TMP("ORWCHART",$J),^TMP("ORECALL",$J),^TMP("ORWORD",$J)
K ^TMP("ORWDXMQ",$J)
S ^TMP("ORWCHART",$J,IP,HWND)=DFN
Q
BYWARD(LST,WARD) ; Return a list of patients in a ward
N ILST,DFN
I +$G(WARD)<1 S LST(1)="^No ward identified" Q
S (ILST,DFN)=0
S WARD=$P(^DIC(42,WARD,0),"^") ;DBIA #36
F S DFN=$O(^DPT("CN",WARD,DFN)) Q:DFN'>0 D
. S ILST=ILST+1,LST(ILST)=+DFN_U_$P(^DPT(+DFN,0),U)_U_$G(^DPT(+DFN,.101))
I ILST<1 S LST(1)="^No patients found."
Q
LAST5(LST,ID) ; Return a list of patients matching A9999 identifiers
N I,IEN,XREF
S (I,IEN)=0,XREF=$S($L(ID)=5:"BS5",1:"BS")
F S IEN=$O(^DPT(XREF,ID,IEN)) Q:'IEN D
. S I=I+1,LST(I)=IEN_U_$P(^DPT(IEN,0),U)_U_$$DOB^DPTLK1(IEN,2)_U_$$SSN^DPTLK1(IEN) ; DG249
Q
;
LAST5RPL(LST,ID) ; ; Return list matching A9999 id's, but from RPL only.
N ORRPL,ORCNT,ORPT,ORPIEN
; IA ____ allows read access to NEW PERSON file node 101:
S ORRPL=$G(^VA(200,DUZ,101))
S ORRPL=$P(ORRPL,U,2)
I (('ORRPL)!(ORRPL="")) S LST(0)="" Q
;
S (ORCNT,ORPT)=0
F S ORPT=$O(^OR(100.21,ORRPL,10,ORPT)) Q:'ORPT D
.S ORPIEN=+$G(^OR(100.21,ORRPL,10,ORPT,0))
.I ((ORPIEN<0)!(ORPIEN="")) Q
.S ORCNT=ORCNT+1
.S LST(ORCNT)=ORPIEN_U_$P(^DPT(ORPIEN,0),U)_U_$$DOB^DPTLK1(ORPIEN,2)_U_$$SSN^DPTLK1(ORPIEN) ; DG249.
;
Q
;
FULLSSN(LST,ID) ; Return a list of patients matching full SSN entered
N I,IEN
S (I,IEN)=0
F S IEN=$O(^DPT("SSN",ID,IEN)) Q:'IEN D
. S I=I+1,LST(I)=IEN_U_$P(^DPT(IEN,0),U)_U_$$DOB^DPTLK1(IEN,2)_U_$$SSN^DPTLK1(IEN) ; DG249
Q
;
FSSNRPL(LST,ID) ; Return list matching Full SSN, but from RPL only.
N ORRPL,ORCNT,ORPT,ORLPT,ORPIEN
; IA ____ allows read access to NEW PERSON file node 101:
S ORRPL=$G(^VA(200,DUZ,101))
S ORRPL=$P(ORRPL,U,2)
I (('ORRPL)!(ORRPL="")) S LST(0)="" Q
;
S (ORCNT,ORPT)=0
F S ORPT=$O(^DPT("SSN",ID,ORPT)) Q:'ORPT D
.S ORLPT=0
.F S ORLPT=$O(^OR(100.21,ORRPL,10,ORLPT)) Q:'ORLPT D
..S ORPIEN=+$G(^OR(100.21,ORRPL,10,ORLPT,0))
..I ((ORPIEN<0)!(ORPIEN="")) Q
..I (ORPIEN'=ORPT) Q
..S ORCNT=ORCNT+1
..S LST(ORCNT)=ORPIEN_U_$P(^DPT(ORPIEN,0),U)_U_$$DOB^DPTLK1(ORPIEN,2)_U_$$SSN^DPTLK1(ORPIEN) ; DG249.
;
Q
;
TOP(LST) ; Return top for all patients list (last selected for now)
N IEN
S IEN=$G(^DISV(DUZ,"^DPT("))
I IEN S LST(1)=IEN_U_$P($G(^DPT(IEN,0)),U)
Q
ENCTITL(REC,DFN,LOC,PROV) ; Return external values for encounter
; LOCNAME^LOCABBR^ROOMBED^PROVNAME
S $P(REC,U,1)=$P($G(^SC(+LOC,0)),U,1,2)
S $P(REC,U,3)=$P($G(^DPT(DFN,.101)),U)
S $P(REC,U,4)=$P($G(^VA(200,+PROV,0)),U)
Q
LISTALL(Y,FROM,DIR) ; Return a bolus of patient names. From is either Name or IEN^Name.
N I,IEN,CNT,FROMIEN,ORIDNAME S CNT=44,I=0,FROMIEN=0
I $P(FROM,U,2)'="" S FROMIEN=$P(FROM,U,1),FROM=$O(^DPT("B",$P(FROM,U,2)),-DIR)
F S FROM=$O(^DPT("B",FROM),DIR) Q:FROM="" D Q:I=CNT
. S IEN=FROMIEN,FROMIEN=0 F S IEN=$O(^DPT("B",FROM,IEN)) Q:'IEN D Q:I=CNT
. . S ORIDNAME=""
. . S ORIDNAME=$G(^DPT(IEN,0)) ; Get zero node name.
. . ; S X1=$G(^DPT(IEN,.1))_" "_$G(^DPT(IEN,.101))
. . S I=I+1 S Y(I)=IEN_U_FROM_U_U_U_U_$P(ORIDNAME,U) ;_"^"_X ; _"^"_X1 ;" ("_X_")"
Q
APPTLST(LST,DFN) ; return a list of appointments
; APPTTIME^LOCIEN^LOCNAME^EXTSTATUS
N ERR,ERRMSG,VASD,VAERR K ^UTILITY("VASD",$J) ;IA 10061
S VASD("F")=$$HTFM^XLFDT($H-30,1)
S VASD("T")=$$HTFM^XLFDT($H+1,1)_".2359"
S VASD("W")="123456789"
D SDA^ORQRY01(.ERR,.ERRMSG)
I ERR K ^UTILITY("VASD",$J) K LST S LST(1)=ERRMSG Q
S I=0 F S I=$O(^UTILITY("VASD",$J,I)) Q:'I D
. S LST(I)=$P(^UTILITY("VASD",$J,I,"I"),U,1,2)_U_$P(^("E"),U,2,3)
K ^UTILITY("VASD",$J)
Q
ADMITLST(LST,DFN) ; return a list of admissions
; MOVETIME^LOCIEN^LOCNAME^TYPE
N TIM,MOV,X0,Y,MTIM,XTYP,XLOC,HLOC,ILST S ILST=0
S TIM="" F S TIM=$O(^DGPM("ATID1",DFN,TIM)) Q:TIM'>0 D
. S MOV=0 F S MOV=$O(^DGPM("ATID1",DFN,TIM,MOV)) Q:MOV'>0 D
. . N VSTR,TIUDA
. . S X0=$G(^DGPM(MOV,0)) I X0']"" Q
. . S MTIM=$P(X0,U)
. . S XTYP=$P($G(^DG(405.1,+$P(X0,U,4),0)),U,1)
. . S XLOC=$P($G(^DIC(42,+$P(X0,U,6),0)),U,1),HLOC=+$G(^(44))
. . S VSTR=HLOC_";"_MTIM_";H",TIUDA=$$HASDS^TIULX(DFN,VSTR)
. . S ILST=ILST+1,LST(ILST)=MTIM_U_HLOC_U_XLOC_U_XTYP_U_MOV_U_TIUDA
Q
CLINRNG(LST) ; return date ranges for clinic appointments
S LST(1)="T;T^Today"
S LST(2)="T+1;T+1^Tomorrow"
S LST(3)="T-1;T-1^Yesterday"
S LST(4)="T-7;T^Past Week"
S LST(5)="T-31;T^Past Month"
S LST(6)="S^Specify Date Range..."
Q
;
N %,%H,X,SUNDAY,START
S LST(1)=DT_";"_DT_"^Today",X=$$HTFM^XLFDT($H+1,1)
S LST(2)=X_";"_X_"^Tomorrow"
S X=+$H F Q:X#7=3 S X=X-1 ; $H#7=3 is Sunday
S LST(3)=$$HTFM^XLFDT(X)_";"_$$HTFM^XLFDT(X+6)_"^This Week"
S LST(4)=$$HTFM^XLFDT(X+7)_";"_$$HTFM^XLFDT(X+13)_"^Next Week"
S LST(5)=$E(DT,1,5)_"01;"_$E(DT,1,5)_"31^This Month"
S X=$E(DT,4,5)+1 S:X=13 X=1 S X=$E(DT,1,3)_$TR($J(X,2)," ",0)
S LST(6)=X_"01;"_X_"31^Next Month"
S LST(7)="^Specify Dates"
Q
DFLTSRC(VAL) ; return default patient list source (T, W, C, P, S)
N SRV S SRV=+$G(^VA(200,DUZ,5))
S VAL=$$GET^XPAR("ALL^SRV.`"_SRV,"ORLP DEFAULT LIST SOURCE")
Q
SAVDFLT(OK,X) ; save new default patient list settings (X=type^ien^sdt;edt)
G SAVDFLT^ORWPT1
;
DISCHRG(Y,DFN,ADMITDT) ; Get discharge movement information
N VAIP
I +$G(ADMITDT)=0 S Y=DT Q
S VAIP("D")=ADMITDT D 52^VADPT
I +VAIP(17)=0 S Y=DT Q
S Y=+VAIP(17,1)
Q
CWAD(Y,DFN) ; returns CWAD flags for a patient
S Y=$$CWAD^ORQPT2(DFN)
Q
LEGACY(ORLST,DFN) ; return message if data on the legacy system
; ORLST(0)=1 if data, ORLST(n)=display message if data
S ORLST(0)=0
I $L($T(HXDATA^A7RDPAGU)) D
. D HXDATA^A7RDPAGU(.ORLST,DFN)
. I $O(ORLST(0)) S ORLST(0)=1
Q
INPLOC(REC,DFN) ; Return a patient's current location
N X
S X=$G(^DPT(DFN,.102)),REC=0
I X S X=$P($G(^DGPM(X,0)),U,6)
I X S REC=+$G(^DIC(42,X,44))
I X S $P(REC,U,2)=$P($G(^DIC(42,X,0)),U,1)
I X S X=$P($G(^DIC(42,X,0)),U,3)
S $P(REC,U,3)=X
Q
AGE(DFN,BEG) ; returns age based on date of birth and date of death (or DT)
N END,X
S END=+$G(^DPT(DFN,.35)),END=$S(END:END,1:DT)
S X=$E(END,1,3)-$E(BEG,1,3)-($E(END,4,7)<$E(BEG,4,7))
Q X
ROK(X) ; Routine OK (in UCI) (NDBI)
S X=$G(X) Q:'$L(X) 0 Q:$L(X)>8 0 X ^%ZOSF("TEST") Q:$T 1 Q 0
;
;NDBI(X) ; National Database Integration site 1 = yes 0 = no
; 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
ORWPT ; SLC/KCM/REV - Patient Lookup Functions ;3/18/05 10:50
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,132,149,206,187,190,215,243**;Dec 17, 1997;Build 242
+2 ;
+3 ; Ref. to ^UTILITY via IA 10061
+4 ;
IDINFO(REC,DFN) ; Return identifying information for a patient
+1 ; PID^DOB^SEX^VET^SC%^WARD^RM-BED^NAME
+2 ; name/dob/sex/ssn, ward, room-bed, sc%, vet
NEW X0,X1,X101,X3,XV
+3 SET X0=$GET(^DPT(DFN,0))
SET X1=$GET(^(.1))
SET X101=$GET(^(.101))
SET X3=$GET(^(.3))
SET XV=$GET(^("VET"))
+4 ;DG249
SET REC=$$SSN^DPTLK1(DFN)_U_$$DOB^DPTLK1(DFN,2)_U_$PIECE(X0,U,2)_U_$PIECE(XV,U)_U_$PIECE(X3,U,2)_U_$PIECE(X1,U)_U_$PIECE(X101,U)_U_$PIECE(X0,U)
+5 QUIT
PTINQ(REF,DFN) ; Return formatted pt inquiry report
+1 KILL ^TMP("ORDATA",$JOB,1)
+2 DO DGINQ^ORCXPND1(DFN)
+3 SET REF=$NAME(^TMP("ORDATA",$JOB,1))
+4 QUIT
SCDIS(LST,DFN) ; Return service connected % and rated disabilities
+1 NEW VAEL,VAERR,I,ILST,DIS,SC,X
+2 DO ELIG^VADPT
+3 SET LST(1)="Service Connected: "_$SELECT(+VAEL(3):$PIECE(VAEL(3),U,2)_"%",1:"NO")
+4 IF 'VAEL(4)
IF '$PIECE($GET(^DG(391,+VAEL(6),0)),U,2)
SET LST(2)="NOT A VETERAN."
QUIT
+5 SET I=0
SET ILST=1
FOR
SET I=$ORDER(^DPT(DFN,.372,I))
IF 'I
QUIT
SET X=^(I,0)
Begin DoDot:1
+6 SET DIS=$PIECE($GET(^DIC(31,+X,0)),U)
IF DIS=""
QUIT
+7 SET SC=$SELECT($PIECE(X,U,3):"SC",$PIECE(X,U,3)']"":"not specified",1:"NSC")
+8 SET ILST=ILST+1
SET LST(ILST)=DIS_" ("_$PIECE(X,U,2)_"% "_SC_")"
End DoDot:1
+9 IF ILST=1
SET LST(2)="Rated Disabilities: NONE STATED"
+10 QUIT
SHOW ; temporary - show patient inquiry screen
+1 NEW I,Y,DIC
SET DIC=2
SET DIC(0)="AEMQ"
DO ^DIC
IF 'Y
QUIT
+2 KILL ^TMP("ORDATA",$JOB,1)
+3 DO DGINQ^ORCXPND1(+Y)
+4 SET I=0
FOR
SET I=$ORDER(^TMP("ORDATA",$JOB,1,I))
IF 'I
QUIT
WRITE !,^(I)
+5 KILL ^TMP("ORDATA",$JOB,1)
+6 QUIT
SELCHK(REC,DFN) ; Check for sensitive pt
+1 ; SENSITIVE
+2 SET REC=$$EN1^ORQPT2(DFN)
+3 QUIT
DIEDON(VAL,DFN) ; Check for a date of death
+1 SET VAL=+$GET(^DPT(DFN,.35))
+2 QUIT
SELECT(REC,DFN) ; Selects patient & returns key information
+1 ; 1 2 3 4 5 6 7 8 9 10 11 12
+2 ; NAME^SEX^DOB^SSN^LOCIEN^LOCNM^RMBD^CWAD^SENSITIVE^ADMITTED^CONV^SC^
+3 ; 13 14 15 16
+4 ; SC%^ICN^AGE^TS
+5 ;
+6 ; for CCOW (RV - 2/27/03) name="-1", location=error message
+7 IF '$DATA(^DPT(+DFN,0))
SET REC="-1^^^^^Patient is unknown to CPRS."
QUIT
+8 ;
+9 NEW X
+10 ; delete PCE 'cache' when switching patients
KILL ^TMP("ORWPCE",$JOB)
+11 SET X=^DPT(DFN,0)
SET REC=$PIECE(X,U,1,3)_U_$PIECE(X,U,9)_U_U_$GET(^(.1))_U_$GET(^(.101))
+12 SET X=$PIECE(REC,U,6)
IF $LENGTH(X)
SET $PIECE(REC,U,5)=+$GET(^DIC(42,+$ORDER(^DIC(42,"B",X,0)),44))
+13 SET $PIECE(REC,U,8)=$$CWAD^ORQPT2(DFN)_U_$$EN1^ORQPT2(DFN)
+14 ; I $P(REC,U,9) D EN2^ORQPT2(DFN) ;update DG security log ; DG249
+15 SET X=$GET(^DPT(DFN,.105))
IF X
SET $PIECE(REC,U,10)=$PIECE($GET(^DGPM(X,0)),U)
+16 IF '$DATA(IOST)
SET IOST="P-OTHER"
+17 SET $PIECE(REC,U,11)=0
+18 ;two pieces: SC^SC%
DO ELIG^VADPT
SET $PIECE(REC,U,12)=$GET(VAEL(3))
+19 IF $LENGTH($TEXT(GETICN^MPIF001))
SET X=+$$GETICN^MPIF001(DFN)
IF X>0
SET $PIECE(REC,U,14)=X
+20 SET $PIECE(REC,U,15)=$$AGE(DFN,$PIECE(REC,U,3))
+21 ; treating specialty
SET $PIECE(REC,U,16)=+$GET(^DPT(DFN,.103))
+22 ;VADPT call to kill?
KILL VAEL,VAERR
+23 SET ^DISV(DUZ,"^DPT(")=DFN
+24 QUIT
SHARE(VAL,IP,HWND,DFN) ; Set global to share DFN with other applications
+1 KILL ^TMP("ORWCHART",$JOB),^TMP("ORECALL",$JOB),^TMP("ORWORD",$JOB)
+2 KILL ^TMP("ORWDXMQ",$JOB)
+3 SET ^TMP("ORWCHART",$JOB,IP,HWND)=DFN
+4 QUIT
BYWARD(LST,WARD) ; Return a list of patients in a ward
+1 NEW ILST,DFN
+2 IF +$GET(WARD)<1
SET LST(1)="^No ward identified"
QUIT
+3 SET (ILST,DFN)=0
+4 ;DBIA #36
SET WARD=$PIECE(^DIC(42,WARD,0),"^")
+5 FOR
SET DFN=$ORDER(^DPT("CN",WARD,DFN))
IF DFN'>0
QUIT
Begin DoDot:1
+6 SET ILST=ILST+1
SET LST(ILST)=+DFN_U_$PIECE(^DPT(+DFN,0),U)_U_$GET(^DPT(+DFN,.101))
End DoDot:1
+7 IF ILST<1
SET LST(1)="^No patients found."
+8 QUIT
LAST5(LST,ID) ; Return a list of patients matching A9999 identifiers
+1 NEW I,IEN,XREF
+2 SET (I,IEN)=0
SET XREF=$SELECT($LENGTH(ID)=5:"BS5",1:"BS")
+3 FOR
SET IEN=$ORDER(^DPT(XREF,ID,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+4 ; DG249
SET I=I+1
SET LST(I)=IEN_U_$PIECE(^DPT(IEN,0),U)_U_$$DOB^DPTLK1(IEN,2)_U_$$SSN^DPTLK1(IEN)
End DoDot:1
+5 QUIT
+6 ;
LAST5RPL(LST,ID) ; ; Return list matching A9999 id's, but from RPL only.
+1 NEW ORRPL,ORCNT,ORPT,ORPIEN
+2 ; IA ____ allows read access to NEW PERSON file node 101:
+3 SET ORRPL=$GET(^VA(200,DUZ,101))
+4 SET ORRPL=$PIECE(ORRPL,U,2)
+5 IF (('ORRPL)!(ORRPL=""))
SET LST(0)=""
QUIT
+6 ;
+7 SET (ORCNT,ORPT)=0
+8 FOR
SET ORPT=$ORDER(^OR(100.21,ORRPL,10,ORPT))
IF 'ORPT
QUIT
Begin DoDot:1
+9 SET ORPIEN=+$GET(^OR(100.21,ORRPL,10,ORPT,0))
+10 IF ((ORPIEN<0)!(ORPIEN=""))
QUIT
+11 SET ORCNT=ORCNT+1
+12 ; DG249.
SET LST(ORCNT)=ORPIEN_U_$PIECE(^DPT(ORPIEN,0),U)_U_$$DOB^DPTLK1(ORPIEN,2)_U_$$SSN^DPTLK1(ORPIEN)
End DoDot:1
+13 ;
+14 QUIT
+15 ;
FULLSSN(LST,ID) ; Return a list of patients matching full SSN entered
+1 NEW I,IEN
+2 SET (I,IEN)=0
+3 FOR
SET IEN=$ORDER(^DPT("SSN",ID,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+4 ; DG249
SET I=I+1
SET LST(I)=IEN_U_$PIECE(^DPT(IEN,0),U)_U_$$DOB^DPTLK1(IEN,2)_U_$$SSN^DPTLK1(IEN)
End DoDot:1
+5 QUIT
+6 ;
FSSNRPL(LST,ID) ; Return list matching Full SSN, but from RPL only.
+1 NEW ORRPL,ORCNT,ORPT,ORLPT,ORPIEN
+2 ; IA ____ allows read access to NEW PERSON file node 101:
+3 SET ORRPL=$GET(^VA(200,DUZ,101))
+4 SET ORRPL=$PIECE(ORRPL,U,2)
+5 IF (('ORRPL)!(ORRPL=""))
SET LST(0)=""
QUIT
+6 ;
+7 SET (ORCNT,ORPT)=0
+8 FOR
SET ORPT=$ORDER(^DPT("SSN",ID,ORPT))
IF 'ORPT
QUIT
Begin DoDot:1
+9 SET ORLPT=0
+10 FOR
SET ORLPT=$ORDER(^OR(100.21,ORRPL,10,ORLPT))
IF 'ORLPT
QUIT
Begin DoDot:2
+11 SET ORPIEN=+$GET(^OR(100.21,ORRPL,10,ORLPT,0))
+12 IF ((ORPIEN<0)!(ORPIEN=""))
QUIT
+13 IF (ORPIEN'=ORPT)
QUIT
+14 SET ORCNT=ORCNT+1
+15 ; DG249.
SET LST(ORCNT)=ORPIEN_U_$PIECE(^DPT(ORPIEN,0),U)_U_$$DOB^DPTLK1(ORPIEN,2)_U_$$SSN^DPTLK1(ORPIEN)
End DoDot:2
End DoDot:1
+16 ;
+17 QUIT
+18 ;
TOP(LST) ; Return top for all patients list (last selected for now)
+1 NEW IEN
+2 SET IEN=$GET(^DISV(DUZ,"^DPT("))
+3 IF IEN
SET LST(1)=IEN_U_$PIECE($GET(^DPT(IEN,0)),U)
+4 QUIT
ENCTITL(REC,DFN,LOC,PROV) ; Return external values for encounter
+1 ; LOCNAME^LOCABBR^ROOMBED^PROVNAME
+2 SET $PIECE(REC,U,1)=$PIECE($GET(^SC(+LOC,0)),U,1,2)
+3 SET $PIECE(REC,U,3)=$PIECE($GET(^DPT(DFN,.101)),U)
+4 SET $PIECE(REC,U,4)=$PIECE($GET(^VA(200,+PROV,0)),U)
+5 QUIT
LISTALL(Y,FROM,DIR) ; Return a bolus of patient names. From is either Name or IEN^Name.
+1 NEW I,IEN,CNT,FROMIEN,ORIDNAME
SET CNT=44
SET I=0
SET FROMIEN=0
+2 IF $PIECE(FROM,U,2)'=""
SET FROMIEN=$PIECE(FROM,U,1)
SET FROM=$ORDER(^DPT("B",$PIECE(FROM,U,2)),-DIR)
+3 FOR
SET FROM=$ORDER(^DPT("B",FROM),DIR)
IF FROM=""
QUIT
Begin DoDot:1
+4 SET IEN=FROMIEN
SET FROMIEN=0
FOR
SET IEN=$ORDER(^DPT("B",FROM,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+5 SET ORIDNAME=""
+6 ; Get zero node name.
SET ORIDNAME=$GET(^DPT(IEN,0))
+7 ; S X1=$G(^DPT(IEN,.1))_" "_$G(^DPT(IEN,.101))
+8 ;_"^"_X ; _"^"_X1 ;" ("_X_")"
SET I=I+1
SET Y(I)=IEN_U_FROM_U_U_U_U_$PIECE(ORIDNAME,U)
End DoDot:2
IF I=CNT
QUIT
End DoDot:1
IF I=CNT
QUIT
+9 QUIT
APPTLST(LST,DFN) ; return a list of appointments
+1 ; APPTTIME^LOCIEN^LOCNAME^EXTSTATUS
+2 ;IA 10061
NEW ERR,ERRMSG,VASD,VAERR
KILL ^UTILITY("VASD",$JOB)
+3 SET VASD("F")=$$HTFM^XLFDT($HOROLOG-30,1)
+4 SET VASD("T")=$$HTFM^XLFDT($HOROLOG+1,1)_".2359"
+5 SET VASD("W")="123456789"
+6 DO SDA^ORQRY01(.ERR,.ERRMSG)
+7 IF ERR
KILL ^UTILITY("VASD",$JOB)
KILL LST
SET LST(1)=ERRMSG
QUIT
+8 SET I=0
FOR
SET I=$ORDER(^UTILITY("VASD",$JOB,I))
IF 'I
QUIT
Begin DoDot:1
+9 SET LST(I)=$PIECE(^UTILITY("VASD",$JOB,I,"I"),U,1,2)_U_$PIECE(^("E"),U,2,3)
End DoDot:1
+10 KILL ^UTILITY("VASD",$JOB)
+11 QUIT
ADMITLST(LST,DFN) ; return a list of admissions
+1 ; MOVETIME^LOCIEN^LOCNAME^TYPE
+2 NEW TIM,MOV,X0,Y,MTIM,XTYP,XLOC,HLOC,ILST
SET ILST=0
+3 SET TIM=""
FOR
SET TIM=$ORDER(^DGPM("ATID1",DFN,TIM))
IF TIM'>0
QUIT
Begin DoDot:1
+4 SET MOV=0
FOR
SET MOV=$ORDER(^DGPM("ATID1",DFN,TIM,MOV))
IF MOV'>0
QUIT
Begin DoDot:2
+5 NEW VSTR,TIUDA
+6 SET X0=$GET(^DGPM(MOV,0))
IF X0']""
QUIT
+7 SET MTIM=$PIECE(X0,U)
+8 SET XTYP=$PIECE($GET(^DG(405.1,+$PIECE(X0,U,4),0)),U,1)
+9 SET XLOC=$PIECE($GET(^DIC(42,+$PIECE(X0,U,6),0)),U,1)
SET HLOC=+$GET(^(44))
+10 SET VSTR=HLOC_";"_MTIM_";H"
SET TIUDA=$$HASDS^TIULX(DFN,VSTR)
+11 SET ILST=ILST+1
SET LST(ILST)=MTIM_U_HLOC_U_XLOC_U_XTYP_U_MOV_U_TIUDA
End DoDot:2
End DoDot:1
+12 QUIT
CLINRNG(LST) ; return date ranges for clinic appointments
+1 SET LST(1)="T;T^Today"
+2 SET LST(2)="T+1;T+1^Tomorrow"
+3 SET LST(3)="T-1;T-1^Yesterday"
+4 SET LST(4)="T-7;T^Past Week"
+5 SET LST(5)="T-31;T^Past Month"
+6 SET LST(6)="S^Specify Date Range..."
+7 QUIT
+8 ;
+9 NEW %,%H,X,SUNDAY,START
+10 SET LST(1)=DT_";"_DT_"^Today"
SET X=$$HTFM^XLFDT($HOROLOG+1,1)
+11 SET LST(2)=X_";"_X_"^Tomorrow"
+12 ; $H#7=3 is Sunday
SET X=+$HOROLOG
FOR
IF X#7=3
QUIT
SET X=X-1
+13 SET LST(3)=$$HTFM^XLFDT(X)_";"_$$HTFM^XLFDT(X+6)_"^This Week"
+14 SET LST(4)=$$HTFM^XLFDT(X+7)_";"_$$HTFM^XLFDT(X+13)_"^Next Week"
+15 SET LST(5)=$EXTRACT(DT,1,5)_"01;"_$EXTRACT(DT,1,5)_"31^This Month"
+16 SET X=$EXTRACT(DT,4,5)+1
IF X=13
SET X=1
SET X=$EXTRACT(DT,1,3)_$TRANSLATE($JUSTIFY(X,2)," ",0)
+17 SET LST(6)=X_"01;"_X_"31^Next Month"
+18 SET LST(7)="^Specify Dates"
+19 QUIT
DFLTSRC(VAL) ; return default patient list source (T, W, C, P, S)
+1 NEW SRV
SET SRV=+$GET(^VA(200,DUZ,5))
+2 SET VAL=$$GET^XPAR("ALL^SRV.`"_SRV,"ORLP DEFAULT LIST SOURCE")
+3 QUIT
SAVDFLT(OK,X) ; save new default patient list settings (X=type^ien^sdt;edt)
+1 GOTO SAVDFLT^ORWPT1
+2 ;
DISCHRG(Y,DFN,ADMITDT) ; Get discharge movement information
+1 NEW VAIP
+2 IF +$GET(ADMITDT)=0
SET Y=DT
QUIT
+3 SET VAIP("D")=ADMITDT
DO 52^VADPT
+4 IF +VAIP(17)=0
SET Y=DT
QUIT
+5 SET Y=+VAIP(17,1)
+6 QUIT
CWAD(Y,DFN) ; returns CWAD flags for a patient
+1 SET Y=$$CWAD^ORQPT2(DFN)
+2 QUIT
LEGACY(ORLST,DFN) ; return message if data on the legacy system
+1 ; ORLST(0)=1 if data, ORLST(n)=display message if data
+2 SET ORLST(0)=0
+3 IF $LENGTH($TEXT(HXDATA^A7RDPAGU))
Begin DoDot:1
+4 DO HXDATA^A7RDPAGU(.ORLST,DFN)
+5 IF $ORDER(ORLST(0))
SET ORLST(0)=1
End DoDot:1
+6 QUIT
INPLOC(REC,DFN) ; Return a patient's current location
+1 NEW X
+2 SET X=$GET(^DPT(DFN,.102))
SET REC=0
+3 IF X
SET X=$PIECE($GET(^DGPM(X,0)),U,6)
+4 IF X
SET REC=+$GET(^DIC(42,X,44))
+5 IF X
SET $PIECE(REC,U,2)=$PIECE($GET(^DIC(42,X,0)),U,1)
+6 IF X
SET X=$PIECE($GET(^DIC(42,X,0)),U,3)
+7 SET $PIECE(REC,U,3)=X
+8 QUIT
AGE(DFN,BEG) ; returns age based on date of birth and date of death (or DT)
+1 NEW END,X
+2 SET END=+$GET(^DPT(DFN,.35))
SET END=$SELECT(END:END,1:DT)
+3 SET X=$EXTRACT(END,1,3)-$EXTRACT(BEG,1,3)-($EXTRACT(END,4,7)<$EXTRACT(BEG,4,7))
+4 QUIT X
ROK(X) ; Routine OK (in UCI) (NDBI)
+1 SET X=$GET(X)
IF '$LENGTH(X)
QUIT 0
IF $LENGTH(X)>8
QUIT 0
XECUTE ^%ZOSF("TEST")
IF $TEST
QUIT 1
QUIT 0
+2 ;
+3 ;NDBI(X) ; National Database Integration site 1 = yes 0 = no
+4 ; 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
