source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMRBK.m@ 636

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")
 ;