SCMRBK ;ALB/SCK - Broker Utilities for multiple patient reassignments; 4/8/96
;;5.3;Scheduling;**148,157,204,1015**;AUG 13, 1993;Build 21
;
Q
;
PTGET(SCDATA,SC) ; Return a block of patients to the client
; 'SC GET PAT BLOCK'
;
; SCJOB = $J for the ^TMP global
; SCJOBID = The second subscript id for the ^TMP global
; SCSTART = Beginning entry number for the block retrieval in the ^TMP global
; SCEND = The ending entry number for the block retrieval
; SCLAST = The last entry number in the ^TMP global
;
; This RPC returns a list of patients from the temp global that was built by
; by the call to either SCMC BLD POS PAT LIST or SCMC BLD TEAM PAT LIST
;
N SCJOB,SCSTART,SCEND,I,SCLAST,SCJOBID
;
D CHK^SCUTBK
D TMP^SCUTBK
;
D PARSE^SCMCBK1(.SC)
;
F I=SCSTART:1:SCEND Q:'$G(^TMP(SCJOB,SCJOBID,I),0) D
. S SCDATA(I)=^TMP(SCJOB,SCJOBID,I)
I SCEND>SCLAST K ^TMP(SCJOB,SCJOBID)
;
D CLRVAR^SCMCBK1
Q
;
; This is invoked after the Save button is clicked in Patient reasignment-both team and pos
; RPC - SC BLD REASSIGN PAT LST
PTLSTBLD(SCOK,SCVAL) ; Build the list of patients to be assigned in the ^TMP($J,"SCPATIENT LIST",DFN) global
; 'SC BLD PAT LIST'
;
N SCJOB,SCDFN
;
D CHK^SCUTBK
D TMP^SCUTBK
;
S SCOK=0
I SCVAL["Start" D G PTBLDQ
. S SCOK=$J
. K ^TMP(SCOK,"SC PATIENT LIST")
;
S SCJOB=$P(SCVAL,U,1)
S SCDFN=$P(SCVAL,U,2)
S ^TMP(SCJOB,"SC PATIENT LIST",SCDFN)=$P(SCVAL,U,3) ; equals assignment IEN (PDR)
S SCOK=1
PTBLDQ ;
Q
;
; This is invoked by RPC (SC FILE PAT TM REASGN) for team reasignment
;
PTFILE(SCOK,SC) ; File the patient assignments in the ^TMP($J,"SC TEAM ASSIGN",SCDFN) global
; 'SCMC FILE PAT TM REASGN'
;
N SCADDFLD,SCTEAM,SCFILE,SCJOB,SCNEW,SCOLD,SCBAD,SCERMSG,SCX,SCDTVAR,SCOTH
N ZTPRI,ZTRTN,ZTDESC,ZTDTH,SCNOW
;
D CHK^SCUTBK
D TMP^SCUTBK ; this sets up a DUZ=.5 and a DT of the current date
D NOW^%DTC
S SCNOW=% ; get actual FM date/time for enter/edit documentation
;
D PARSE^SCMCBK1(.SC)
G:+$G(SCJOB)=0 FILEQ
;
; Additional fields for 404.42 PATIENT TEAM ASSIGNMENT FILE
S SCADDFLD(.08)=$G(SC("TYPE"),99)
S SCADDFLD(.1)=$G(SC("RESTRICT"),0)
; note, the fields below are not appropriate if team is being activated or modified. Be sure
; to kill as necessary before filing, and to add edit by and edit D/T where necessary - PDR
S SCADDFLD(.11)=DUZ ; user entering
S SCADDFLD(.12)=SCNOW ; entry date/time (changed from =DT - PDR)
;
I $G(SC("BKG"))="1" D BKG(1) Q ;Bail out to run in background
;
BKGTM ; Run Team Reassignment Filer in BKG
I $D(ZTQUEUED) S SCJOB=$J ; want to use Task Manager assigned $J if BKG
S SCX=$$ACPTRATM^SCAPMR6("^TMP(SCJOB,""SC PATIENT LIST"")",SCTEAM,SCFRMTM,.SCOTH,"SCADDFLD",SCDTVAR,"SCERMSG","SCNEW","SCOLD","SCBAD")
I '$D(ZTQUEUED) D
. D BAD^SCMCBK1(.SCBAD,.SCOLD,.SCOK) ; this sets up RPC return var SCOK for error report dialog
. S SCOK(.1)=SCX_U_"FORE"
;
K ^TMP(SCJOB,"SC PATIENT LIST")
D CLRVAR^SCMCBK1
;
FILEQ Q
;
; This is invoked by RPC ('SC FILE PAT POS REASGN') for position reasignment
POSFILE(SCOK,SC) ; File the patient assignments in the ^TMP($J,"SC PATIENT LIST") global
; ' SCMC FILE PAT POS REASGN '
;
N SCADDFLD,SCTEAM,SCFILE,SCJOB,SCNEW,SCOLD,SCBAD,SCERMSG,SCX
N SCPOSTO,SCPOSFRM,SCDTVAR,SCMAFLD,SCADTM,SCNEW1,SCNOW
;
D CHK^SCUTBK
D TMP^SCUTBK
S SCNOW=$$NOW^XLFDT
;
D PARSE^SCMCBK1(.SC)
S SCPOSTO=SC("POSITION")
S SCPOSFRM=SC("FROMPOSITION")
G:+$G(SCJOB)=0 FILEQ
S SCADTM=1
;
S SCADDFLD(.05)=$G(SC("TYPE"),0)
S SCADDFLD(.06)=DUZ
S SCADDFLD(.07)=SCNOW
;
I $G(SC("BKG"))="1" D BKG(2) Q
;
BKGPOS ; BACKGROUND JOB ENTRY POINT
I $D(ZTQUEUED) S SCJOB=$J ; want to use Task Manager assigned $J if BKG
S SCX=$$ACPTATP^SCAPMR21("^TMP(SCJOB,""SC PATIENT LIST"")",SCPOSTO,SCPOSFRM,"SCADDFLD",SCDTVAR,"SCERMSG",SCADTM,"","SCNEW","SCNEW1","SCOLD","SCBAD")
;
I '$D(ZTQUEUED) D
. D BAD2^SCMCBK1(.SCBAD,.SCOLD,.SCOK) ; this sets up RPC return var SCOK for error report dialog
. S SCOK(.1)=SCX_U_"FORE"
;
K ^TMP(SCJOB,"SC PATIENT LIST")
D CLRVAR^SCMCBK1
Q
;
BLKPOS ;
N SCX
S SCX=$G(SCDTRNG("END"))
S SCDTRNG("END")=3990101 ;check forever
S SCOK1=$$PTTP^SCAPMC(SCBLOCK,"SCDTRNG","^TMP(""SCMC"",$J,""EXCLUDE PT"")","SCER2")
S SCDTRNG("END")=SCX
Q
;
BLKTM ;
N SCX
S SCX=$G(SCDTRNG("END"))
S SCDTRNG("END")=3990101 ;check forever
S SCOK1=$$PTTM^SCAPMC(SCBLOCK,"SCDTRNG","^TMP(""SCMC"",$J,""EXCLUDE PT"")","SCER2")
S SCDTRNG("END")=SCX
Q
;
; This is used to get the patient list to fill the list box after team and position selection
;
PTPOSLST(SCOK,SC) ; Get a list of of patients for a team position
; RPC:'SCMC BLD POS PAT LIST'
;
N PD,FD,TD,ASNST,FC
D NEWVAR^SCMCBK1
D CHK^SCUTBK
D TMP^SCUTBK
S FD=SC("FROMDATE")
S TD=SC("TODATE")
S ASNSTAT=SC("ASSIGNSTAT") ; 0=assigned only, 1=Discharged only, 2=both
;
D PARSE^SCMCBK1(.SC)
;
K ^TMP($J,"SCPOS")
;
S SCOK=0
; This date setting could be accomplished on GUI using the .MULT[] broker array, and
; loaded into SCDTRNG via the call to parse. I've opted to set the array explicitly
; here.
S SCDTRNG("BEGIN")=FD
S SCDTRNG("END")=TD
S SCDTRNG("INCL")=0
; get list of pt active for time period specified
; future discharges included
S SCOK=$$PTTP^SCAPMC11(SCFRMPOS,"SCDTRNG",.SCLOC,.SCERMSG)
K ^TMP("SCMC",$J,"EXCLUDE PT")
M ^TMP($J,"SC PCMM IN")=@SCLOC
;
S I1=$G(^TMP($J,"SC PCMM IN",0))
S FC=0 ; initialize filtered count of patients
F I=1:1:I1 D
. S PD=$G(^TMP($J,"SC PCMM IN",I)) ; get the discharge date
. Q:$$FILTOUT(+$P(PD,U,5),+$P(PD,U,4))
. S ^TMP($J,"PCMM TMP",I)=$G(^TMP($J,"SC PCMM IN",I))
. S FC=FC+1
D ALPHA^SCAPMCU2("^TMP($J,""PCMM TMP"")","^TMP($J,""SCPOS"")")
S SCOK=$J_U_FC_U_SCOK
;
D CLRVAR^SCMCBK1
Q
;
FILTOUT(DD,AD) ; FILTER OUT CANDIDATE PATIENTS
;bp/cmf 204t0 -- SCDTVAR(def = dt) replaces DT
; Want actives only
Q:ASNSTAT=0 ((DD)&(DD'>SCDTVAR))!(AD>SCDTVAR)
; ; disch date before tomorrow, or assign date greater than today
;
; Want discharges between dates only
Q:ASNSTAT=1 (DD>TD)!(DD<FD)
; ; disch date is after TO date, or discharge date is before FROM date
;
; Want discharges and actives from date
Q:ASNSTAT=2 (DD&(DD<FD))!(AD>SCDTVAR)
; ; disch date less than FROM date, or assign date > dtvar
Q 0
;
;
; used to get the patient list after a team selection
;
PTTMLST(SCOK,SC) ; ; Get a list of of patients for a team - FILTER FOR ACTIVE
; RPC:'SCMC BLD TEAM PAT LIST'
;
;bp/cmf 204t0 -- SCDTVAR(def = dt) replaces DT
N TD,SCDD
D NEWVAR^SCMCBK1
D CHK^SCUTBK
D TMP^SCUTBK
;
D PARSE^SCMCBK1(.SC)
K ^TMP($J,"SCTEAM")
;
S SCOK=0
; get list of patient team assignments ordered by q
S SCOK=$$PTTM^SCAPMC2(SCFRMTM,"SCDTRNG",.SCLOC,"SCERMSG") ; SCLOC = ^TMP("SCTMP LIST",$J)
K ^TMP("SCMC",$J,"EXCLUDE PT")
M ^TMP($J,"SC PCMM IN")=@SCLOC
;
S I=""
F S I=$O(^TMP($J,"SC PCMM IN",I)) Q:'I D
. S TD=^TMP($J,"SC PCMM IN",I)
. S SCDD=$P(TD,U,5)
. Q:(SCDD'="")&(SCDD'>SCDTVAR) ; filter discharged assignments
. Q:$P(TD,U,4)>SCDTVAR ; filter future assignments
. S ^TMP($J,"PCMM TMP",I)=^TMP($J,"SC PCMM IN",I)
;
D ALPHA^SCAPMCU2("^TMP($J,""PCMM TMP"")","^TMP($J,""SCTEAM"")")
;
S SCOK=$J_U_+$O(^TMP($J,"SCTEAM",""),-1)_U_SCOK
;
D CLRVAR^SCMCBK1
Q
;
DISCHPOS(SCOK,SC) ; DISCHARGE POSITIONS FOR A TEAM - RPC: PDR SC DIS TEAM POS
; SC("DFN") = ptr to patient file
; SC("TMASGN") = ptr to team assignment file 404.42
; SC("DATE") = file date (date selected on client)
N SCBEGIN,SCEND,SCINCL,SCDATES,SCERR
D CHK^SCUTBK
D TMP^SCUTBK
S SCOK=1
S SCERR="SCERRMSG"
K @SCERR ;;bp/cmf 204 clean error array!!!!!!!!!! [iow-0899-40854]
D DISCHPOS^SCRPMTA(SC("DFN"),SC("TMASGN"),SC("DATE"),SCERR)
S SCOK='$D(@SCERR)
Q
;
BKG(SCX) ;hand off to taskman
;input SCX=toggle between team/position reassignment
;
S ZTPRI=10
S ZTRTN=$P($$S(SCX),"::")
S ZTDESC=$P($$S(SCX),"::",2)
S ZTDTH=$H
S ZTSAVE("SC*")=""
S ZTSAVE("^TMP($J,")=""
I '$G(SC("NOP")) D ^%ZTLOAD ; define NOP on GUI side if don't want BKG
S SCOK(0)=1_U_"BKG"_$G(ZTSK)
S SCOK(.1)=$$PASSCNT^SCMCBK5($$S(3))_U_"BKG"_U_$G(SC("NOP"))
Q
;
S(SCX) Q $P($T(T+SCX),";;",2)
;
T ;;
;;BKGTM^SCMRBK::PCMM TEAM REASSIGN BKG
;;BKGPOS^SCMRBK::PCMM POSITION REASSIGN BKG
;;^TMP($J,"SC PATIENT LIST")
;
SCMRBK ;ALB/SCK - Broker Utilities for multiple patient reassignments; 4/8/96
+1 ;;5.3;Scheduling;**148,157,204,1015**;AUG 13, 1993;Build 21
+2 ;
+3 QUIT
+4 ;
PTGET(SCDATA,SC) ; Return a block of patients to the client
+1 ; 'SC GET PAT BLOCK'
+2 ;
+3 ; SCJOB = $J for the ^TMP global
+4 ; SCJOBID = The second subscript id for the ^TMP global
+5 ; SCSTART = Beginning entry number for the block retrieval in the ^TMP global
+6 ; SCEND = The ending entry number for the block retrieval
+7 ; SCLAST = The last entry number in the ^TMP global
+8 ;
+9 ; This RPC returns a list of patients from the temp global that was built by
+10 ; by the call to either SCMC BLD POS PAT LIST or SCMC BLD TEAM PAT LIST
+11 ;
+12 NEW SCJOB,SCSTART,SCEND,I,SCLAST,SCJOBID
+13 ;
+14 DO CHK^SCUTBK
+15 DO TMP^SCUTBK
+16 ;
+17 DO PARSE^SCMCBK1(.SC)
+18 ;
+19 FOR I=SCSTART:1:SCEND
IF '$GET(^TMP(SCJOB,SCJOBID,I),0)
QUIT
Begin DoDot:1
+20 SET SCDATA(I)=^TMP(SCJOB,SCJOBID,I)
End DoDot:1
+21 IF SCEND>SCLAST
KILL ^TMP(SCJOB,SCJOBID)
+22 ;
+23 DO CLRVAR^SCMCBK1
+24 QUIT
+25 ;
+26 ; This is invoked after the Save button is clicked in Patient reasignment-both team and pos
+27 ; RPC - SC BLD REASSIGN PAT LST
PTLSTBLD(SCOK,SCVAL) ; Build the list of patients to be assigned in the ^TMP($J,"SCPATIENT LIST",DFN) global
+1 ; 'SC BLD PAT LIST'
+2 ;
+3 NEW SCJOB,SCDFN
+4 ;
+5 DO CHK^SCUTBK
+6 DO TMP^SCUTBK
+7 ;
+8 SET SCOK=0
+9 IF SCVAL["Start"
Begin DoDot:1
+10 SET SCOK=$JOB
+11 KILL ^TMP(SCOK,"SC PATIENT LIST")
End DoDot:1
GOTO PTBLDQ
+12 ;
+13 SET SCJOB=$PIECE(SCVAL,U,1)
+14 SET SCDFN=$PIECE(SCVAL,U,2)
+15 ; equals assignment IEN (PDR)
SET ^TMP(SCJOB,"SC PATIENT LIST",SCDFN)=$PIECE(SCVAL,U,3)
+16 SET SCOK=1
PTBLDQ ;
+1 QUIT
+2 ;
+3 ; This is invoked by RPC (SC FILE PAT TM REASGN) for team reasignment
+4 ;
PTFILE(SCOK,SC) ; File the patient assignments in the ^TMP($J,"SC TEAM ASSIGN",SCDFN) global
+1 ; 'SCMC FILE PAT TM REASGN'
+2 ;
+3 NEW SCADDFLD,SCTEAM,SCFILE,SCJOB,SCNEW,SCOLD,SCBAD,SCERMSG,SCX,SCDTVAR,SCOTH
+4 NEW ZTPRI,ZTRTN,ZTDESC,ZTDTH,SCNOW
+5 ;
+6 DO CHK^SCUTBK
+7 ; this sets up a DUZ=.5 and a DT of the current date
DO TMP^SCUTBK
+8 DO NOW^%DTC
+9 ; get actual FM date/time for enter/edit documentation
SET SCNOW=%
+10 ;
+11 DO PARSE^SCMCBK1(.SC)
+12 IF +$GET(SCJOB)=0
GOTO FILEQ
+13 ;
+14 ; Additional fields for 404.42 PATIENT TEAM ASSIGNMENT FILE
+15 SET SCADDFLD(.08)=$GET(SC("TYPE"),99)
+16 SET SCADDFLD(.1)=$GET(SC("RESTRICT"),0)
+17 ; note, the fields below are not appropriate if team is being activated or modified. Be sure
+18 ; to kill as necessary before filing, and to add edit by and edit D/T where necessary - PDR
+19 ; user entering
SET SCADDFLD(.11)=DUZ
+20 ; entry date/time (changed from =DT - PDR)
SET SCADDFLD(.12)=SCNOW
+21 ;
+22 ;Bail out to run in background
IF $GET(SC("BKG"))="1"
DO BKG(1)
QUIT
+23 ;
BKGTM ; Run Team Reassignment Filer in BKG
+1 ; want to use Task Manager assigned $J if BKG
IF $DATA(ZTQUEUED)
SET SCJOB=$JOB
+2 SET SCX=$$ACPTRATM^SCAPMR6("^TMP(SCJOB,""SC PATIENT LIST"")",SCTEAM,SCFRMTM,.SCOTH,"SCADDFLD",SCDTVAR,"SCERMSG","SCNEW","SCOLD","SCBAD")
+3 IF '$DATA(ZTQUEUED)
Begin DoDot:1
+4 ; this sets up RPC return var SCOK for error report dialog
DO BAD^SCMCBK1(.SCBAD,.SCOLD,.SCOK)
+5 SET SCOK(.1)=SCX_U_"FORE"
End DoDot:1
+6 ;
+7 KILL ^TMP(SCJOB,"SC PATIENT LIST")
+8 DO CLRVAR^SCMCBK1
+9 ;
FILEQ QUIT
+1 ;
+2 ; This is invoked by RPC ('SC FILE PAT POS REASGN') for position reasignment
POSFILE(SCOK,SC) ; File the patient assignments in the ^TMP($J,"SC PATIENT LIST") global
+1 ; ' SCMC FILE PAT POS REASGN '
+2 ;
+3 NEW SCADDFLD,SCTEAM,SCFILE,SCJOB,SCNEW,SCOLD,SCBAD,SCERMSG,SCX
+4 NEW SCPOSTO,SCPOSFRM,SCDTVAR,SCMAFLD,SCADTM,SCNEW1,SCNOW
+5 ;
+6 DO CHK^SCUTBK
+7 DO TMP^SCUTBK
+8 SET SCNOW=$$NOW^XLFDT
+9 ;
+10 DO PARSE^SCMCBK1(.SC)
+11 SET SCPOSTO=SC("POSITION")
+12 SET SCPOSFRM=SC("FROMPOSITION")
+13 IF +$GET(SCJOB)=0
GOTO FILEQ
+14 SET SCADTM=1
+15 ;
+16 SET SCADDFLD(.05)=$GET(SC("TYPE"),0)
+17 SET SCADDFLD(.06)=DUZ
+18 SET SCADDFLD(.07)=SCNOW
+19 ;
+20 IF $GET(SC("BKG"))="1"
DO BKG(2)
QUIT
+21 ;
BKGPOS ; BACKGROUND JOB ENTRY POINT
+1 ; want to use Task Manager assigned $J if BKG
IF $DATA(ZTQUEUED)
SET SCJOB=$JOB
+2 SET SCX=$$ACPTATP^SCAPMR21("^TMP(SCJOB,""SC PATIENT LIST"")",SCPOSTO,SCPOSFRM,"SCADDFLD",SCDTVAR,"SCERMSG",SCADTM,"","SCNEW","SCNEW1","SCOLD","SCBAD")
+3 ;
+4 IF '$DATA(ZTQUEUED)
Begin DoDot:1
+5 ; this sets up RPC return var SCOK for error report dialog
DO BAD2^SCMCBK1(.SCBAD,.SCOLD,.SCOK)
+6 SET SCOK(.1)=SCX_U_"FORE"
End DoDot:1
+7 ;
+8 KILL ^TMP(SCJOB,"SC PATIENT LIST")
+9 DO CLRVAR^SCMCBK1
+10 QUIT
+11 ;
BLKPOS ;
+1 NEW SCX
+2 SET SCX=$GET(SCDTRNG("END"))
+3 ;check forever
SET SCDTRNG("END")=3990101
+4 SET SCOK1=$$PTTP^SCAPMC(SCBLOCK,"SCDTRNG","^TMP(""SCMC"",$J,""EXCLUDE PT"")","SCER2")
+5 SET SCDTRNG("END")=SCX
+6 QUIT
+7 ;
BLKTM ;
+1 NEW SCX
+2 SET SCX=$GET(SCDTRNG("END"))
+3 ;check forever
SET SCDTRNG("END")=3990101
+4 SET SCOK1=$$PTTM^SCAPMC(SCBLOCK,"SCDTRNG","^TMP(""SCMC"",$J,""EXCLUDE PT"")","SCER2")
+5 SET SCDTRNG("END")=SCX
+6 QUIT
+7 ;
+8 ; This is used to get the patient list to fill the list box after team and position selection
+9 ;
PTPOSLST(SCOK,SC) ; Get a list of of patients for a team position
+1 ; RPC:'SCMC BLD POS PAT LIST'
+2 ;
+3 NEW PD,FD,TD,ASNST,FC
+4 DO NEWVAR^SCMCBK1
+5 DO CHK^SCUTBK
+6 DO TMP^SCUTBK
+7 SET FD=SC("FROMDATE")
+8 SET TD=SC("TODATE")
+9 ; 0=assigned only, 1=Discharged only, 2=both
SET ASNSTAT=SC("ASSIGNSTAT")
+10 ;
+11 DO PARSE^SCMCBK1(.SC)
+12 ;
+13 KILL ^TMP($JOB,"SCPOS")
+14 ;
+15 SET SCOK=0
+16 ; This date setting could be accomplished on GUI using the .MULT[] broker array, and
+17 ; loaded into SCDTRNG via the call to parse. I've opted to set the array explicitly
+18 ; here.
+19 SET SCDTRNG("BEGIN")=FD
+20 SET SCDTRNG("END")=TD
+21 SET SCDTRNG("INCL")=0
+22 ; get list of pt active for time period specified
+23 ; future discharges included
+24 SET SCOK=$$PTTP^SCAPMC11(SCFRMPOS,"SCDTRNG",.SCLOC,.SCERMSG)
+25 KILL ^TMP("SCMC",$JOB,"EXCLUDE PT")
+26 MERGE ^TMP($JOB,"SC PCMM IN")=@SCLOC
+27 ;
+28 SET I1=$GET(^TMP($JOB,"SC PCMM IN",0))
+29 ; initialize filtered count of patients
SET FC=0
+30 FOR I=1:1:I1
Begin DoDot:1
+31 ; get the discharge date
SET PD=$GET(^TMP($JOB,"SC PCMM IN",I))
+32 IF $$FILTOUT(+$PIECE(PD,U,5),+$PIECE(PD,U,4))
QUIT
+33 SET ^TMP($JOB,"PCMM TMP",I)=$GET(^TMP($JOB,"SC PCMM IN",I))
+34 SET FC=FC+1
End DoDot:1
+35 DO ALPHA^SCAPMCU2("^TMP($J,""PCMM TMP"")","^TMP($J,""SCPOS"")")
+36 SET SCOK=$JOB_U_FC_U_SCOK
+37 ;
+38 DO CLRVAR^SCMCBK1
+39 QUIT
+40 ;
FILTOUT(DD,AD) ; FILTER OUT CANDIDATE PATIENTS
+1 ;bp/cmf 204t0 -- SCDTVAR(def = dt) replaces DT
+2 ; Want actives only
+3 IF ASNSTAT=0
QUIT ((DD)&(DD'>SCDTVAR))!(AD>SCDTVAR)
+4 ; ; disch date before tomorrow, or assign date greater than today
+5 ;
+6 ; Want discharges between dates only
+7 IF ASNSTAT=1
QUIT (DD>TD)!(DD<FD)
+8 ; ; disch date is after TO date, or discharge date is before FROM date
+9 ;
+10 ; Want discharges and actives from date
+11 IF ASNSTAT=2
QUIT (DD&(DD<FD))!(AD>SCDTVAR)
+12 ; ; disch date less than FROM date, or assign date > dtvar
+13 QUIT 0
+14 ;
+15 ;
+16 ; used to get the patient list after a team selection
+17 ;
PTTMLST(SCOK,SC) ; ; Get a list of of patients for a team - FILTER FOR ACTIVE
+1 ; RPC:'SCMC BLD TEAM PAT LIST'
+2 ;
+3 ;bp/cmf 204t0 -- SCDTVAR(def = dt) replaces DT
+4 NEW TD,SCDD
+5 DO NEWVAR^SCMCBK1
+6 DO CHK^SCUTBK
+7 DO TMP^SCUTBK
+8 ;
+9 DO PARSE^SCMCBK1(.SC)
+10 KILL ^TMP($JOB,"SCTEAM")
+11 ;
+12 SET SCOK=0
+13 ; get list of patient team assignments ordered by q
+14 ; SCLOC = ^TMP("SCTMP LIST",$J)
SET SCOK=$$PTTM^SCAPMC2(SCFRMTM,"SCDTRNG",.SCLOC,"SCERMSG")
+15 KILL ^TMP("SCMC",$JOB,"EXCLUDE PT")
+16 MERGE ^TMP($JOB,"SC PCMM IN")=@SCLOC
+17 ;
+18 SET I=""
+19 FOR
SET I=$ORDER(^TMP($JOB,"SC PCMM IN",I))
IF 'I
QUIT
Begin DoDot:1
+20 SET TD=^TMP($JOB,"SC PCMM IN",I)
+21 SET SCDD=$PIECE(TD,U,5)
+22 ; filter discharged assignments
IF (SCDD'="")&(SCDD'>SCDTVAR)
QUIT
+23 ; filter future assignments
IF $PIECE(TD,U,4)>SCDTVAR
QUIT
+24 SET ^TMP($JOB,"PCMM TMP",I)=^TMP($JOB,"SC PCMM IN",I)
End DoDot:1
+25 ;
+26 DO ALPHA^SCAPMCU2("^TMP($J,""PCMM TMP"")","^TMP($J,""SCTEAM"")")
+27 ;
+28 SET SCOK=$JOB_U_+$ORDER(^TMP($JOB,"SCTEAM",""),-1)_U_SCOK
+29 ;
+30 DO CLRVAR^SCMCBK1
+31 QUIT
+32 ;
DISCHPOS(SCOK,SC) ; DISCHARGE POSITIONS FOR A TEAM - RPC: PDR SC DIS TEAM POS
+1 ; SC("DFN") = ptr to patient file
+2 ; SC("TMASGN") = ptr to team assignment file 404.42
+3 ; SC("DATE") = file date (date selected on client)
+4 NEW SCBEGIN,SCEND,SCINCL,SCDATES,SCERR
+5 DO CHK^SCUTBK
+6 DO TMP^SCUTBK
+7 SET SCOK=1
+8 SET SCERR="SCERRMSG"
+9 ;;bp/cmf 204 clean error array!!!!!!!!!! [iow-0899-40854]
KILL @SCERR
+10 DO DISCHPOS^SCRPMTA(SC("DFN"),SC("TMASGN"),SC("DATE"),SCERR)
+11 SET SCOK='$DATA(@SCERR)
+12 QUIT
+13 ;
BKG(SCX) ;hand off to taskman
+1 ;input SCX=toggle between team/position reassignment
+2 ;
+3 SET ZTPRI=10
+4 SET ZTRTN=$PIECE($$S(SCX),"::")
+5 SET ZTDESC=$PIECE($$S(SCX),"::",2)
+6 SET ZTDTH=$HOROLOG
+7 SET ZTSAVE("SC*")=""
+8 SET ZTSAVE("^TMP($J,")=""
+9 ; define NOP on GUI side if don't want BKG
IF '$GET(SC("NOP"))
DO ^%ZTLOAD
+10 SET SCOK(0)=1_U_"BKG"_$GET(ZTSK)
+11 SET SCOK(.1)=$$PASSCNT^SCMCBK5($$S(3))_U_"BKG"_U_$GET(SC("NOP"))
+12 QUIT
+13 ;
S(SCX) QUIT $PIECE($TEXT(T+SCX),";;",2)
+1 ;
T ;;
+1 ;;BKGTM^SCMRBK::PCMM TEAM REASSIGN BKG
+2 ;;BKGPOS^SCMRBK::PCMM POSITION REASSIGN BKG
+3 ;;^TMP($J,"SC PATIENT LIST")
+4 ;
