- SCMRBK ;ALB/SCK - Broker Utilities for multiple patient reassignments; 4/8/96
- ;;5.3;Scheduling;**148,157,204**;AUG 13, 1993
- ;
- 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")
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMRBK 8547 printed Jan 18, 2025@03:42:57 Page 2
- SCMRBK ;ALB/SCK - Broker Utilities for multiple patient reassignments; 4/8/96
- +1 ;;5.3;Scheduling;**148,157,204**;AUG 13, 1993
- +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 ;