BSDX36 ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
;
;COLLECT WAITLIST FOR GIVEN RESOURCE - RPC
CW(BSDXY,BSDXRES) ;COLLECT WAITLIST DATA
; .BSDXY = returned pointer to list of waitlist data
; BSDXRES = resource code - pointer to ^BSDXRES (BSDX RESOURCE)
; called by BSDX WAITLIST remote procedure
N BSDXI,BSDXNOD,BSDXRESN,BSDXSC,BSDXTMP,BSDWL,BSDXWLD,BSDXWLN,CI,WL
D ^XBKVAR S X="ERROR^BSDX36",@^%ZOSF("TRAP")
S BSDXI=0
K ^BSDXTMP($J)
S BSDXY="^BSDXTMP("_$J_")"
S ^BSDXTMP($J,0)="T00020ERRORID"_$C(30)
;check for valid resource
I '+BSDXRES D ERR("BSDX36: Invalid Resource ID") Q
I '$D(^BSDXRES(BSDXRES,0)) D ERR("BSDX36: Invalid Resource ID") Q
S BSDXNOD=^BSDXRES(BSDXRES,0)
S BSDXSC=$P(BSDXNOD,U,4)
;check that hospital location is defined for this resource
I '+BSDXSC D ERR("BSDX36: Resource "_$P(BSDXNOD,U,1)_" does not have a Hospital Location defined") Q
I '$D(^SC(BSDXSC,0)) D ERR("BSDX36: Resource "_$P(BSDXNOT,U,1)_" has an invalid Hospital Location defined") Q
;GET WL POINTER FROM ^BSDWL("B",SC,WL)
S BSDWL=$O(^BSDWL("B",BSDXSC,""))
S BSDXWLD=$G(^BSDWL(BSDWL,0))
;check if wait list is inactive
I $P(BSDXWLD,U,2) D ERR("BSDX36: WaitList for "_$P(^SC(BSDXSC,0),U,1)_" is inactive") Q
; 1 2 3 4 5
S BSDXTMP="I00020HOSPITAL_LOC_IEN^I00020WAIT_LIST_IEN^I00020PATIENT_IEN^T00030PATIENT_NAME^T00030HOME_PHONE^"
; 6 7 8 9 10 11
S BSDXTMP=BSDXTMP_"T00020WORK_PHONE^T00030CHART^D00020DATE_ADDED^T00030REASON^T00020PRIORITY^I00020PROVIDER^"
; 12 13
S BSDXTMP=BSDXTMP_"D00020RECALL_DATE^T00250COMMENT"_$C(30)
S ^BSDXTMP($J,0)=BSDXTMP
;loop through waitlist
;RETURN LOOKS LIKE:
; BSDXTMP(<counter>,"C",<c counter>)=Comment text
S WL=0
F S WL=$O(^BSDWL(BSDWL,1,WL)) Q:(WL="")||('WL) D
. S BSDXWLN=$G(^BSDWL(BSDWL,1,WL,0))
. S DFN=$P(BSDXWLN,U,1)
. S DPTN=$G(^DPT(DFN,.13))
. S BSDXI=BSDXI+1
. ; 1 2 3 4 5
. S BSDXTMP=BSDXSC_U_WL_U_$P(BSDXWLN,U,1)_U_$P(^DPT($P(BSDXWLN,U,1),0),U,1)_U_$P(DPTN,U,1)_U
. ; 6 7 8
. S BSDXTMP=BSDXTMP_$P(DPTN,U,2)_U_$$HRCN^BDGF2(DFN,+$$FAC^BSDU(BSDXSC))_U_$$FMTE^XLFDT($P(BSDXWLN,U,3))_U
. ; 9 10
. S BSDXTMP=BSDXTMP_$P(^BSDWLR($P(BSDXWLN,U,9),0),U,1)_U_$S($P(BSDXWLN,U,2)=1:"HIGH",$P(BSDXWLN,U,2)=2:"MIDDLE",$P(BSDXWLN,U,2)=3:"LOW",1:"")_U
. ; 11 12 13
. S BSDXTMP=BSDXTMP_$P(^VA(200,$P(BSDXWLN,U,6),0),U,1)_U_$$FMTE^XLFDT($P(BSDXWLN,U,5))_U_$G(^BSDWL(BSDWL,1,WL,1,1,0))
. S ^BSDXTMP($J,BSDXI)=BSDXTMP
. S CI=""
. F S CI=$O(^BSDWL(BSDWL,1,WL,1,CI)) Q:'+CI D
. . S BSDWLN=$G(^BSDWL(BSDWL,1,WL,1,CI,0))
. . S:$E(BSDWLN,$L(BSDWLN)-1,$L(BSDWLN))'=" " BSDWLN=BSDWLN_" "
. . S BSDXI=BSDXI+1
. . S ^BSDXTMP($J,BSDXI)=BSDWLN
. S BSDXI=BSDXI+1
. S ^BSDXTMP($J,BSDXI)=$C(30)
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=$C(31)
Q
;
ERROR ;
D ERR("RPMS Error")
Q
;
ERR(BSDXERR) ;Error processing
I +BSDXERR S BSDXERR=ERRNO+134234112 ;vbObjectError
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=BSDXERR_$C(30)
S BSDXI=BSDXI+1
S ^BSDXTMP($J,BSDXI)=$C(31)
Q
BSDX36 ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
+1 ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
+2 ;
+3 ;COLLECT WAITLIST FOR GIVEN RESOURCE - RPC
CW(BSDXY,BSDXRES) ;COLLECT WAITLIST DATA
+1 ; .BSDXY = returned pointer to list of waitlist data
+2 ; BSDXRES = resource code - pointer to ^BSDXRES (BSDX RESOURCE)
+3 ; called by BSDX WAITLIST remote procedure
+4 NEW BSDXI,BSDXNOD,BSDXRESN,BSDXSC,BSDXTMP,BSDWL,BSDXWLD,BSDXWLN,CI,WL
+5 DO ^XBKVAR
SET X="ERROR^BSDX36"
SET @^%ZOSF("TRAP")
+6 SET BSDXI=0
+7 KILL ^BSDXTMP($JOB)
+8 SET BSDXY="^BSDXTMP("_$JOB_")"
+9 SET ^BSDXTMP($JOB,0)="T00020ERRORID"_$CHAR(30)
+10 ;check for valid resource
+11 IF '+BSDXRES
DO ERR("BSDX36: Invalid Resource ID")
QUIT
+12 IF '$DATA(^BSDXRES(BSDXRES,0))
DO ERR("BSDX36: Invalid Resource ID")
QUIT
+13 SET BSDXNOD=^BSDXRES(BSDXRES,0)
+14 SET BSDXSC=$PIECE(BSDXNOD,U,4)
+15 ;check that hospital location is defined for this resource
+16 IF '+BSDXSC
DO ERR("BSDX36: Resource "_$PIECE(BSDXNOD,U,1)_" does not have a Hospital Location defined")
QUIT
+17 IF '$DATA(^SC(BSDXSC,0))
DO ERR("BSDX36: Resource "_$PIECE(BSDXNOT,U,1)_" has an invalid Hospital Location defined")
QUIT
+18 ;GET WL POINTER FROM ^BSDWL("B",SC,WL)
+19 SET BSDWL=$ORDER(^BSDWL("B",BSDXSC,""))
+20 SET BSDXWLD=$GET(^BSDWL(BSDWL,0))
+21 ;check if wait list is inactive
+22 IF $PIECE(BSDXWLD,U,2)
DO ERR("BSDX36: WaitList for "_$PIECE(^SC(BSDXSC,0),U,1)_" is inactive")
QUIT
+23 ; 1 2 3 4 5
+24 SET BSDXTMP="I00020HOSPITAL_LOC_IEN^I00020WAIT_LIST_IEN^I00020PATIENT_IEN^T00030PATIENT_NAME^T00030HOME_PHONE^"
+25 ; 6 7 8 9 10 11
+26 SET BSDXTMP=BSDXTMP_"T00020WORK_PHONE^T00030CHART^D00020DATE_ADDED^T00030REASON^T00020PRIORITY^I00020PROVIDER^"
+27 ; 12 13
+28 SET BSDXTMP=BSDXTMP_"D00020RECALL_DATE^T00250COMMENT"_$CHAR(30)
+29 SET ^BSDXTMP($JOB,0)=BSDXTMP
+30 ;loop through waitlist
+31 ;RETURN LOOKS LIKE:
+32 ; BSDXTMP(<counter>,"C",<c counter>)=Comment text
+33 SET WL=0
+34 FOR
SET WL=$ORDER(^BSDWL(BSDWL,1,WL))
IF (WL="")||('WL)
QUIT
Begin DoDot:1
+35 SET BSDXWLN=$GET(^BSDWL(BSDWL,1,WL,0))
+36 SET DFN=$PIECE(BSDXWLN,U,1)
+37 SET DPTN=$GET(^DPT(DFN,.13))
+38 SET BSDXI=BSDXI+1
+39 ; 1 2 3 4 5
+40 SET BSDXTMP=BSDXSC_U_WL_U_$PIECE(BSDXWLN,U,1)_U_$PIECE(^DPT($PIECE(BSDXWLN,U,1),0),U,1)_U_$PIECE(DPTN,U,1)_U
+41 ; 6 7 8
+42 SET BSDXTMP=BSDXTMP_$PIECE(DPTN,U,2)_U_$$HRCN^BDGF2(DFN,+$$FAC^BSDU(BSDXSC))_U_$$FMTE^XLFDT($PIECE(BSDXWLN,U,3))_U
+43 ; 9 10
+44 SET BSDXTMP=BSDXTMP_$PIECE(^BSDWLR($PIECE(BSDXWLN,U,9),0),U,1)_U_$SELECT($PIECE(BSDXWLN,U,2)=1:"HIGH",$PIECE(BSDXWLN,U,2)=2:"MIDDLE",$PIECE(BSDXWLN,U,2)=3:"LOW",1:"")_U
+45 ; 11 12 13
+46 SET BSDXTMP=BSDXTMP_$PIECE(^VA(200,$PIECE(BSDXWLN,U,6),0),U,1)_U_$$FMTE^XLFDT($PIECE(BSDXWLN,U,5))_U_$GET(^BSDWL(BSDWL,1,WL,1,1,0))
+47 SET ^BSDXTMP($JOB,BSDXI)=BSDXTMP
+48 SET CI=""
+49 FOR
SET CI=$ORDER(^BSDWL(BSDWL,1,WL,1,CI))
IF '+CI
QUIT
Begin DoDot:2
+50 SET BSDWLN=$GET(^BSDWL(BSDWL,1,WL,1,CI,0))
+51 IF $EXTRACT(BSDWLN,$LENGTH(BSDWLN)-1,$LENGTH(BSDWLN))'=" "
SET BSDWLN=BSDWLN_" "
+52 SET BSDXI=BSDXI+1
+53 SET ^BSDXTMP($JOB,BSDXI)=BSDWLN
End DoDot:2
+54 SET BSDXI=BSDXI+1
+55 SET ^BSDXTMP($JOB,BSDXI)=$CHAR(30)
End DoDot:1
+56 SET BSDXI=BSDXI+1
+57 SET ^BSDXTMP($JOB,BSDXI)=$CHAR(31)
+58 QUIT
+59 ;
ERROR ;
+1 DO ERR("RPMS Error")
+2 QUIT
+3 ;
ERR(BSDXERR) ;Error processing
+1 ;vbObjectError
IF +BSDXERR
SET BSDXERR=ERRNO+134234112
+2 SET BSDXI=BSDXI+1
+3 SET ^BSDXTMP($JOB,BSDXI)=BSDXERR_$CHAR(30)
+4 SET BSDXI=BSDXI+1
+5 SET ^BSDXTMP($JOB,BSDXI)=$CHAR(31)
+6 QUIT
