iSharkFly-Open
/
VistA-Scheduling
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
VistA-Scheduling/m/BSDX28.m

145 lines
5.3 KiB
Mathematica
Raw Normal View History

edits and clean-ups prior to release, first step
2010-07-18 07:17:02 -04:00
BSDX28 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 7/18/10 2:30pm
Change version to 1.4 on all routines BSDX08 has fix for drag and drop because it referenced a non existent cancellation reason
2010-09-20 08:16:53 -04:00
;;1.4;BSDX;;Sep 07, 2010
edits and clean-ups prior to release, first step
2010-07-18 07:17:02 -04:00
;
Updated version numbers
2010-07-18 09:58:35 -04:00
; Change Log:
Two updates: Search by Primary ID now enabled; bug in make appointment code that causes storage of non-canonical appointment times (3091103.0900 e.g. rather than 3091103.09). causes a problem when retrieving appointments.
2010-07-14 08:08:39 -04:00
; HMW 3050721 Added test for inactivated record
Updated version numbers
2010-07-18 09:58:35 -04:00
; V1.3 WV/SMH 3100714
; - add PID search
; - return PID instead of SSN (change header and logic)
; - Change Error trap to new style.
Initial committ of scheduling package
2009-11-30 03:53:28 -05:00
;
PTLOOKRS(BSDXY,BSDXP,BSDXC) ;EP Patient Lookup
;
;Find up to BSDXC patients matching BSDXP*
Two updates: Search by Primary ID now enabled; bug in make appointment code that causes storage of non-canonical appointment times (3091103.0900 e.g. rather than 3091103.09). causes a problem when retrieving appointments.
2010-07-14 08:08:39 -04:00
;Supports DOB Lookup, Primary Long ID lookup
Initial committ of scheduling package
2009-11-30 03:53:28 -05:00
;
Two updates: Search by Primary ID now enabled; bug in make appointment code that causes storage of non-canonical appointment times (3091103.0900 e.g. rather than 3091103.09). causes a problem when retrieving appointments.
2010-07-14 08:08:39 -04:00
N $ET S $ET="G ERROR^BSDX28"
Updated version numbers
2010-07-18 09:58:35 -04:00
; rm ctrl chars
Initial committ of scheduling package
2009-11-30 03:53:28 -05:00
S BSDXP=$TR(BSDXP,$C(13),"")
S BSDXP=$TR(BSDXP,$C(10),"")
S BSDXP=$TR(BSDXP,$C(9),"")
Updated version numbers
2010-07-18 09:58:35 -04:00
; num of pts to find
Initial committ of scheduling package
2009-11-30 03:53:28 -05:00
S:BSDXC="" BSDXC=10
N BSDXHRN,BSDXZ,BSDXDLIM,BSDXRET,BSDXDPT,BSDXRET,BSDXIEN,BSDXFILE
N BSDXIENS,BSDXFIELDS,BSDXFLAGS,BSDXVALUE,BSDXNUMBER,BSDXINDEXES,BSDXSCREEN
N BSDXTARG,BSDXMSG,BSDXRSLT
S BSDXDLIM="^"
Two updates: Search by Primary ID now enabled; bug in make appointment code that causes storage of non-canonical appointment times (3091103.0900 e.g. rather than 3091103.09). causes a problem when retrieving appointments.
2010-07-14 08:08:39 -04:00
S BSDXRET="T00030NAME^T00030HRN^T00030PID^D00030DOB^T00030IEN"_$C(30)
Initial committ of scheduling package
2009-11-30 03:53:28 -05:00
I '+$G(DUZ) S BSDXY=BSDXRET_$C(31) Q
I '$D(DUZ(2)) S BSDXY=BSDXRET_$C(31) Q
Updated version numbers
2010-07-18 09:58:35 -04:00
PID ;PID Lookup
; If this ID exists, go get it. If "UJOPID" index doesn't exist,
; won't work anyways.
I $D(^DPT("UJOPID",BSDXP)) DO SET BSDXY=BSDXRET_$C(31) QUIT
. S BSDXIEN=$O(^DPT("UJOPID",BSDXP,""))
. Q:'$D(^DPT(BSDXIEN,0))
. S BSDXDPT=$G(^DPT(BSDXIEN,0))
. S BSDXZ=$P(BSDXDPT,U) ;NAME
. S BSDXHRN=$P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,2) ;CHART
. I BSDXHRN="" Q ;NO CHART AT THIS DUZ2
. ; Inactivated Chart get an *
. I $P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,3) S BSDXHRN=BSDXHRN_"(*)" Q
. S $P(BSDXZ,BSDXDLIM,2)=BSDXHRN
. S $P(BSDXZ,BSDXDLIM,3)=$P(^DPT(BSDXIEN,.36),U,3) ;PID
. S Y=$P(BSDXDPT,U,3) X ^DD("DD")
. S $P(BSDXZ,BSDXDLIM,4)=Y ;DOB
. S $P(BSDXZ,BSDXDLIM,5)=BSDXIEN
. S BSDXRET=BSDXRET_BSDXZ_$C(30)
Initial committ of scheduling package
2009-11-30 03:53:28 -05:00
;
DOB ;DOB Lookup
I +DUZ(2),((BSDXP?1.2N1"/"1.2N1"/"1.4N)!(BSDXP?1.2N1" "1.2N1" "1.4N)!(BSDXP?1.2N1"-"1.2N1"-"1.4N)) D S BSDXY=BSDXRET_$C(31) Q
. S X=BSDXP S %DT="P" D ^%DT S BSDXP=Y Q:'+Y
. Q:'$D(^DPT("ADOB",BSDXP))
. S BSDXIEN=0 F S BSDXIEN=$O(^DPT("ADOB",BSDXP,BSDXIEN)) Q:'+BSDXIEN D
. . Q:'$D(^DPT(BSDXIEN,0))
. . S BSDXDPT=$G(^DPT(BSDXIEN,0))
. . S BSDXZ=$P(BSDXDPT,U) ;NAME
. . S BSDXHRN=$P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,2) ;CHART
. . I BSDXHRN="" Q ;NO CHART AT THIS DUZ2
. . I $P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,3) S BSDXHRN=BSDXHRN_"(*)" Q ;HMW 20050721 Record Inactivated
. . S $P(BSDXZ,BSDXDLIM,2)=BSDXHRN
Updated version numbers
2010-07-18 09:58:35 -04:00
. . S $P(BSDXZ,BSDXDLIM,3)=$P(^DPT(BSDXIEN,.36),U,3) ;PID
Initial committ of scheduling package
2009-11-30 03:53:28 -05:00
. . S Y=$P(BSDXDPT,U,3) X ^DD("DD")
. . S $P(BSDXZ,BSDXDLIM,4)=Y ;DOB
. . S $P(BSDXZ,BSDXDLIM,5)=BSDXIEN
. . S BSDXRET=BSDXRET_BSDXZ_$C(30)
. . Q
. Q
;
Updated version numbers
2010-07-18 09:58:35 -04:00
CHART
;Chart# Lookup
Initial committ of scheduling package
2009-11-30 03:53:28 -05:00
I +DUZ(2),BSDXP]"",$D(^AUPNPAT("D",BSDXP)) D S BSDXY=BSDXRET_$C(31) Q
. S BSDXIEN=0 F S BSDXIEN=$O(^AUPNPAT("D",BSDXP,BSDXIEN)) Q:'+BSDXIEN I $D(^AUPNPAT("D",BSDXP,BSDXIEN,DUZ(2))) D Q
. . Q:'$D(^DPT(BSDXIEN,0))
. . S BSDXDPT=$G(^DPT(BSDXIEN,0))
. . S BSDXZ=$P(BSDXDPT,U) ;NAME
. . S BSDXHRN=BSDXP ;CHART
. . I $D(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),$P(^(0),U,3) S BSDXHRN=BSDXHRN_"(*)" Q ;HMW 20050721 Record Inactivated
. . S $P(BSDXZ,BSDXDLIM,2)=BSDXHRN
Updated version numbers
2010-07-18 09:58:35 -04:00
. . S $P(BSDXZ,BSDXDLIM,3)=$P(^DPT(BSDXIEN,.36),U,3) ;PID
Initial committ of scheduling package
2009-11-30 03:53:28 -05:00
. . S Y=$P(BSDXDPT,U,3) X ^DD("DD")
. . S $P(BSDXZ,BSDXDLIM,4)=Y ;DOB
. . S $P(BSDXZ,BSDXDLIM,5)=BSDXIEN
. . S BSDXRET=BSDXRET_BSDXZ_$C(30)
. . Q
. Q
Updated version numbers
2010-07-18 09:58:35 -04:00
;
Two updates: Search by Primary ID now enabled; bug in make appointment code that causes storage of non-canonical appointment times (3091103.0900 e.g. rather than 3091103.09). causes a problem when retrieving appointments.
2010-07-14 08:08:39 -04:00
SSN ;SSN Lookup
Initial committ of scheduling package
2009-11-30 03:53:28 -05:00
I (BSDXP?9N)!(BSDXP?3N1"-"2N1"-"4N),$D(^DPT("SSN",BSDXP)) D S BSDXY=BSDXRET_$C(31) Q
. S BSDXIEN=0 F S BSDXIEN=$O(^DPT("SSN",BSDXP,BSDXIEN)) Q:'+BSDXIEN D Q
. . Q:'$D(^DPT(BSDXIEN,0))
. . S BSDXDPT=$G(^DPT(BSDXIEN,0))
. . S BSDXZ=$P(BSDXDPT,U) ;NAME
. . S BSDXHRN=$P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,2) ;CHART
. . I BSDXHRN="" Q ;NO CHART AT THIS DUZ2
. . I $P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,3) S BSDXHRN=BSDXHRN_"(*)" Q ;HMW 20050721 Record Inactivated
. . S $P(BSDXZ,BSDXDLIM,2)=BSDXHRN
Updated version numbers
2010-07-18 09:58:35 -04:00
. . S $P(BSDXZ,BSDXDLIM,3)=$P(^DPT(BSDXIEN,.36),U,3) ;PID
Initial committ of scheduling package
2009-11-30 03:53:28 -05:00
. . S Y=$P(BSDXDPT,U,3) X ^DD("DD")
. . S $P(BSDXZ,BSDXDLIM,4)=Y ;DOB
. . S $P(BSDXZ,BSDXDLIM,5)=BSDXIEN
. . S BSDXRET=BSDXRET_BSDXZ_$C(30)
. . Q
. Q
;
S BSDXFILE=9000001
S BSDXIENS=""
S BSDXFIELDS=".01"
S BSDXFLAGS="M"
S BSDXVALUE=BSDXP
S BSDXNUMBER=BSDXC
S BSDXINDEXES=""
S BSDXSCREEN=$S(+DUZ(2):"I $D(^AUPNPAT(Y,41,DUZ(2),0))",1:"")
S BSDXIDEN=""
S BSDXTARG="BSDXRSLT"
S BSDXMSG=""
D FIND^DIC(BSDXFILE,BSDXIENS,BSDXFIELDS,BSDXFLAGS,BSDXVALUE,BSDXNUMBER,BSDXINDEXES,BSDXSCREEN,BSDXIDEN,BSDXTARG,BSDXMSG)
I '+$G(BSDXRSLT("DILIST",0)) S BSDXY=BSDXRET_$C(31) Q
N BSDXCNT S BSDXCNT=2
F BSDXX=1:1:$P(BSDXRSLT("DILIST",0),U) D
. S BSDXIEN=BSDXRSLT("DILIST",2,BSDXX)
. S BSDXZ=BSDXRSLT("DILIST","ID",BSDXX,.01) ;NAME
. S BSDXHRN=$P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,2) ;CHART
. I BSDXHRN="" Q ;NO CHART AT THIS DUZ2
. I $P($G(^AUPNPAT(BSDXIEN,41,DUZ(2),0)),U,3) S BSDXHRN=BSDXHRN_"(*)" Q ;HMW 20050721 Record Inactivated
. S $P(BSDXZ,BSDXDLIM,2)=BSDXHRN
. S BSDXDPT=$G(^DPT(BSDXIEN,0))
Updated version numbers
2010-07-18 09:58:35 -04:00
. S $P(BSDXZ,BSDXDLIM,3)=$P(^DPT(BSDXIEN,.36),U,3) ;PID
Initial committ of scheduling package
2009-11-30 03:53:28 -05:00
. S Y=$P(BSDXDPT,U,3) X ^DD("DD")
. S $P(BSDXZ,BSDXDLIM,4)=Y ;DOB
. S $P(BSDXZ,BSDXDLIM,5)=BSDXIEN
. S $P(BSDXRET,$C(30),BSDXCNT)=BSDXZ
. S BSDXCNT=BSDXCNT+1
. Q
S BSDXY=BSDXRET_$C(30)_$C(31)
Q
;
ERROR ;
D ERR("RPMS Error")
Q
;
ERR(ERRNO) ;Error processing
S BSDXRET="T00030NAME^T00030HRN^T00030SSN^D00030DOB^T00030IEN"_$C(30)_"^^^^"_$C(30)_$C(31)
Q