- SCMCBK ;ALB/SCK - Broker Utilities for multiple patient assignments; 4/8/96 ; 11/30/11 4:23pm
- ;;5.3;Scheduling;**41,51,148,157,177,205,564**;AUG 13, 1993;Build 8
- ;
- Q
- ;
- PTCLBLD(SCOK,SC) ; Build patient list for a selected clinic
- ; 'SC BLD PAT CLN LIST'
- ;
- D NEWVAR^SCMCBK1
- D CHK^SCUTBK
- D TMP^SCUTBK
- ;
- D PARSE^SCMCBK1(.SC)
- ;
- I SCPOS'="" S SCOK=$$PTCLBRTP^SCAPMC26(.SCCLN,.SCPOS,"SCDTRNG")
- E S SCOK=$$PTCLBR^SCAPMC26(.SCCLN,.SCTEAM,"SCDTRNG")
- K ^TMP("SCMC",$J,"EXCLUDE PT")
- G:SCOK=0 PTCLNQ
- ;
- M ^TMP($J,"SC PCMM IN")=^TMP(SCOK,"SCCLPT")
- K ^TMP(SCOK,"SCCLPT")
- ;
- D ALPHA^SCAPMCU2("^TMP($J,""SC PCMM IN"")","^TMP($J,""SCCLPT"")")
- ;
- S SCOK=$J_U_^TMP($J,"SC PCMM IN",0)
- ;
- PTCLNQ D CLRVAR^SCMCBK1
- Q
- ;
- PTSCBLD(SCOK,SC) ; Build patient list for selected stop code
- ; 'SC BLD PAT SCDE LIST'
- ;
- D NEWVAR^SCMCBK1
- ;
- D CHK^SCUTBK
- D TMP^SCUTBK
- ;
- D PARSE^SCMCBK1(.SC)
- ;
- K ^TMP($J,"SCSCDE")
- ;
- ; Build exclude list
- S BLOCK=$S(SCPOS'="":"BLKPOS",1:"BLKTM")
- S SCBLOCK=$S(SCPOS'="":SCPOS,1:SCTEAM)
- D @BLOCK
- ;
- IF 'SCOK1 S SCOK="0^0^0^0" G PTSCQ
- ;
- S SCOK=0
- S SCOK=$$PTST^SCAPMC27(SCSCDE,"SCDTRNG",SCNUM,.SCLOC,"SCERMSG",SCMORE)
- K ^TMP("SCMC",$J,"EXCLUDE PT")
- ;
- M ^TMP($J,"SC PCMM IN")=@SCLOC
- S I1=$G(^TMP($J,"SC PCMM IN",0))
- F I=1:1:I1 S ^TMP($J,"PCMM TMP",I)=$G(^TMP($J,"SC PCMM IN",I))
- ;
- D ALPHA^SCAPMCU2("^TMP($J,""PCMM TMP"")","^TMP($J,""SCSCDE"")")
- S SCOK=$J_U_+I1_U_SCOK
- ;
- PTSCQ D CLRVAR^SCMCBK1
- Q
- ;
- PTTMBLD(SCOK,SC) ; Build a list of patients for a selected team and return the $J of the TMP globall
- ; where the list is stored.
- ; ' SC BLD PAT TM LIST '
- ;
- D NEWVAR^SCMCBK1
- D CHK^SCUTBK
- D TMP^SCUTBK
- ;
- D PARSE^SCMCBK1(.SC)
- K ^TMP($J,"SCTEAM")
- ;
- ; Build exclude list
- S SCOK=0
- S BLOCK=$S(SCPOS'="":"BLKPOS",1:"BLKTM")
- S SCBLOCK=$S(SCPOS'="":SCPOS,1:SCTEAM)
- D @BLOCK
- ;
- S SCOK=$$PTTM^SCAPMC2(SCFRMTM,"SCDTRNG",.SCLOC,"SCERMSG")
- 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 ^TMP($J,"PCMM TMP",I)=^TMP($J,"SC PCMM IN",I)
- ;
- D ALPHA^SCAPMCU2("^TMP($J,""PCMM TMP"")","^TMP($J,""SCTEAM"")")
- S I1="" F S I1=$O(^TMP($J,"SCTEAM",I1)) Q:'I1 S I=I1
- ;
- S SCOK=$J_U_+I_U_SCOK
- ;
- D CLRVAR^SCMCBK1
- Q
- ;
- PTPSBLD(SCOK,SC) ;
- ; ' SC BLD PAT POS LIST '
- ;
- D NEWVAR^SCMCBK1
- D CHK^SCUTBK
- D TMP^SCUTBK
- ;
- D PARSE^SCMCBK1(.SC)
- ;
- K ^TMP($J,"SCPOS")
- ;
- ; Build exclude list
- S BLOCK=$S(SCPOS'="":"BLKPOS",1:"BLKTM")
- S SCBLOCK=$S(SCPOS'="":SCPOS,1:SCTEAM)
- D @BLOCK
- ;
- S SCOK=0
- ;
- 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))
- F I=1:1:I1 S ^TMP($J,"PCMM TMP",I)=$G(^TMP($J,"SC PCMM IN",I))
- D ALPHA^SCAPMCU2("^TMP($J,""PCMM TMP"")","^TMP($J,""SCPOS"")")
- S SCOK=$J_U_+I1_U_SCOK
- ;
- ;IF '+$G(^TMP($J,"SCPOS",0)) D S SCOK=$J_U_SCOK
- ;. S I="" F S I=$O(^TMP($J,"SCPOS",I)) Q:'I S SCOK=I
- ;
- D CLRVAR^SCMCBK1
- Q
- ;
- PTAPBLD(SCOK,SC) ; Build patient list for selected appointment range.
- ; ' SC BLD PAT APT LIST '
- ;
- ;SD/564-this build includes modification as follows:
- ;- patients already assigned to another PC team then evaluated team SCTEAM are excluded
- ;- patients previously assigned and unassigned to evaluated position are included
- ;
- ;N SCCLN,SCTEAM,SCDTRNG,SCLOC,SCERMSG,SCNUM,SCCOUNT,SCMORE,SCOK1,SCER2,SCOUT,SCBLOCK
- ;
- D NEWVAR^SCMCBK1
- D CHK^SCUTBK
- D TMP^SCUTBK
- ;
- D PARSE^SCMCBK1(.SC)
- ;
- K ^TMP($J,"SCCLN")
- ;
- ; Build exclude list
- S BLOCK=$S(SCPOS'="":"BLKPOS",1:"BLKTM")
- S SCBLOCK=$S(SCPOS'="":SCPOS,1:SCTEAM)
- D @BLOCK
- ;
- IF 'SCOK1 S SCOK="0^0^0^0" G PTAPQ
- S SCOK=0
- S SCOK=$$PTAP^SCAPMC28(SCCLN,"SCDTRNG",SCNUM,.SCLOC,"SCERMSG",SCMORE)
- ;
- ;identify excluded to be included if unassigned from evaluated position-sd/564
- N SCTMP S SCTMP=$G(^TMP("SC TMP LIST",$J,0))
- N SS S SS=$G(^TMP("SCMC",$J,"EXCLUDE PT",0))
- N SDFN,XX F XX=1:1:SS S SDFN=+$G(^TMP("SCMC",$J,"EXCLUDE PT",XX)) D
- .N SCI S SCI=^TMP("SCMC",$J,"EXCLUDE PT",XX) D
- ..N SCII S SCII=$P(SCI,U,5) I SCII>0&(SCII<(DT+1)) D
- ...;PROCEED ONLY WITH THE CURRENT MONTH ASSIGNMENT
- ...N SCAS S SCAS=$P(SCI,U,4) I SCAS>0 I $E(DT,1,5)'=$E(SCAS,1,5) Q
- ...N SCPOS S SCPOS=$P(SCI,U,3) I SCPOS>0 I $P(^SCPT(404.43,SCPOS,0),U,2)'=$G(SC("POSITION")) Q
- ...N SCN,SCS S SCN=$P(SCI,U,2),SCS=$P(SCI,U,6)
- ...S SCTMP=SCTMP+1
- ...S ^TMP("SC TMP LIST",$J,SCTMP)=SDFN_U_SCN_U_SC("CLINIC")_U_U_SCS
- ...S ^TMP("SC TMP LIST",$J,"SCPTAP",SDFN,SCTMP)=""
- S ^TMP("SC TMP LIST",$J,0)=SCTMP
- ;
- K ^TMP("SCMC",$J,"EXCLUDE PT")
- ;
- ;eliminate patients if assigned to another PC team-SD/564
- N DFN S DFN="" F S DFN=$O(^TMP("SC TMP LIST",$J,"SCPTAP",DFN)) Q:DFN="" D
- .N SCEX S SCEX=$$GETPC^SCAPMCU2(DFN) ;call to get patient's PC assignment
- .N NSAS S NSAS=$P(SCEX,U,2) I +SCEX>0!(NSAS>0&(NSAS'=SCTEAM)) D
- ..N SCN S SCN=$O(^TMP("SC TMP LIST",$J,"SCPTAP",DFN,""))
- ..K ^TMP("SC TMP LIST",$J,"SCPTAP",DFN)
- ..K ^TMP("SC TMP LIST",$J,SCN)
- ..S ^TMP("SC TMP LIST",$J,0)=^TMP("SC TMP LIST",$J,0)-1
- ;
- M ^TMP($J,"SC PCMM IN")=@SCLOC
- S I1=$G(^TMP($J,"SC PCMM IN",0))
- ;reindex entries in ^TMP global list - SD/564
- N SCC S SCC=0 F I=1:1:I1 S SCC=$O(^TMP($J,"SC PCMM IN",SCC)) D
- .S ^TMP($J,"PCMM TMP",I)=^TMP($J,"SC PCMM IN",SCC)
- ;
- D ALPHA^SCAPMCU2("^TMP($J,""PCMM TMP"")","^TMP($J,""SCAPP"")")
- S SCOK=$J_U_I1_U_SCOK
- ;
- D CLRVAR^SCMCBK1
- PTAPQ 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
- ;
- 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
- ;
- PTLSTBLD(SCOK,SCVAL) ; Build the list of patients to be assigned in the ^TMP($J,"SC PATIENT 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)=""
- S SCOK=1
- PTBLDQ Q
- ;
- PTFILE(SCOK,SC) ; File the patient assignments in the ^TMP($J,"SC TEAM ASSIGN",SCDFN) global
- ; 'SC FILE PAT TM ASGN'
- ;
- ;205 remove;I XWBAPVER=177 D QUEUED^SCMCBK4(1) Q
- ;205 remove;I $$VPROGMR^SCUTBK3()'=1 Q
- ; pre 177 code follows....
- I XWBAPVER=1 D QUEUED^SCMCBK4(1) Q
- ;
- N SCADDFLD,SCTEAM,SCFILE,SCJOB,SCNEW,SCOLD,SCBAD,SCERMSG,SCX,SCDTVAR
- ;
- D CHK^SCUTBK
- D TMP^SCUTBK
- ;
- D PARSE^SCMCBK1(.SC)
- G:+$G(SCJOB)=0 FILEQ
- ;
- ;
- S SCADDFLD(.08)=$G(SC("TYPE"),99)
- S SCADDFLD(.1)=$G(SC("RESTRICT"),0)
- S SCADDFLD(.11)=DUZ
- S SCADDFLD(.12)=DT
- ;
- S SCX=$$ACPTATM^SCAPMC6("^TMP(SCJOB,""SC PATIENT LIST"")",SCTEAM,"SCADDFLD",SCDTVAR,"SCERMSG","SCNEW","SCOLD","SCBAD")
- D BAD^SCMCBK1(.SCBAD,.SCOLD,.SCOK)
- S SCOK(.1)=SCX
- ;
- K ^TMP(SCJOB,"SC PATIENT LIST")
- ;
- D CLRVAR^SCMCBK1
- FILEQ Q
- ;
- POSFILE(SCOK,SC) ; File the patient assignments in the ^TMP($J,"SC PATIENT LIST") global
- ; ' SC FILE PAT POS ASGN '
- ;
- ;205 remove;I XWBAPVER=177 D QUEUED^SCMCBK4(2) Q
- ;205 remove;I $$VPROGMR^SCUTBK3()'=1 Q
- ; pre 177 code follows...
- I XWBAPVER=1 D QUEUED^SCMCBK4(2) Q
- ;
- N SCADDFLD,SCTEAM,SCFILE,SCJOB,SCNEW,SCOLD,SCBAD,SCERMSG,SCX,SCPOS,SCDTVAR,SCMAFLD,SCADTM,SCNEW1
- ;
- D CHK^SCUTBK
- D TMP^SCUTBK
- ;
- D PARSE^SCMCBK1(.SC)
- G:+$G(SCJOB)=0 FILEQ
- S SCADTM=1
- ;
- S SCADDFLD(.05)=$G(SC("TYPE"),0)
- S SCADDFLD(.06)=DUZ
- S SCADDFLD(.07)=DT
- ;
- S SCX=$$ACPTATP^SCAPMC21("^TMP(SCJOB,""SC PATIENT LIST"")",SCPOS,"SCADDFLD",SCDTVAR,"SCERMSG",SCADTM,"","SCNEW","SCNEW1","SCOLD","SCBAD")
- ;
- D BAD2^SCMCBK1(.SCBAD,.SCOLD,.SCOK)
- S SCOK(.1)=SCX
- 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
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCBK 8690 printed Jan 18, 2025@03:40:58 Page 2
- SCMCBK ;ALB/SCK - Broker Utilities for multiple patient assignments; 4/8/96 ; 11/30/11 4:23pm
- +1 ;;5.3;Scheduling;**41,51,148,157,177,205,564**;AUG 13, 1993;Build 8
- +2 ;
- +3 QUIT
- +4 ;
- PTCLBLD(SCOK,SC) ; Build patient list for a selected clinic
- +1 ; 'SC BLD PAT CLN LIST'
- +2 ;
- +3 DO NEWVAR^SCMCBK1
- +4 DO CHK^SCUTBK
- +5 DO TMP^SCUTBK
- +6 ;
- +7 DO PARSE^SCMCBK1(.SC)
- +8 ;
- +9 IF SCPOS'=""
- SET SCOK=$$PTCLBRTP^SCAPMC26(.SCCLN,.SCPOS,"SCDTRNG")
- +10 IF '$TEST
- SET SCOK=$$PTCLBR^SCAPMC26(.SCCLN,.SCTEAM,"SCDTRNG")
- +11 KILL ^TMP("SCMC",$JOB,"EXCLUDE PT")
- +12 if SCOK=0
- GOTO PTCLNQ
- +13 ;
- +14 MERGE ^TMP($JOB,"SC PCMM IN")=^TMP(SCOK,"SCCLPT")
- +15 KILL ^TMP(SCOK,"SCCLPT")
- +16 ;
- +17 DO ALPHA^SCAPMCU2("^TMP($J,""SC PCMM IN"")","^TMP($J,""SCCLPT"")")
- +18 ;
- +19 SET SCOK=$JOB_U_^TMP($JOB,"SC PCMM IN",0)
- +20 ;
- PTCLNQ DO CLRVAR^SCMCBK1
- +1 QUIT
- +2 ;
- PTSCBLD(SCOK,SC) ; Build patient list for selected stop code
- +1 ; 'SC BLD PAT SCDE LIST'
- +2 ;
- +3 DO NEWVAR^SCMCBK1
- +4 ;
- +5 DO CHK^SCUTBK
- +6 DO TMP^SCUTBK
- +7 ;
- +8 DO PARSE^SCMCBK1(.SC)
- +9 ;
- +10 KILL ^TMP($JOB,"SCSCDE")
- +11 ;
- +12 ; Build exclude list
- +13 SET BLOCK=$SELECT(SCPOS'="":"BLKPOS",1:"BLKTM")
- +14 SET SCBLOCK=$SELECT(SCPOS'="":SCPOS,1:SCTEAM)
- +15 DO @BLOCK
- +16 ;
- +17 IF 'SCOK1
- SET SCOK="0^0^0^0"
- GOTO PTSCQ
- +18 ;
- +19 SET SCOK=0
- +20 SET SCOK=$$PTST^SCAPMC27(SCSCDE,"SCDTRNG",SCNUM,.SCLOC,"SCERMSG",SCMORE)
- +21 KILL ^TMP("SCMC",$JOB,"EXCLUDE PT")
- +22 ;
- +23 MERGE ^TMP($JOB,"SC PCMM IN")=@SCLOC
- +24 SET I1=$GET(^TMP($JOB,"SC PCMM IN",0))
- +25 FOR I=1:1:I1
- SET ^TMP($JOB,"PCMM TMP",I)=$GET(^TMP($JOB,"SC PCMM IN",I))
- +26 ;
- +27 DO ALPHA^SCAPMCU2("^TMP($J,""PCMM TMP"")","^TMP($J,""SCSCDE"")")
- +28 SET SCOK=$JOB_U_+I1_U_SCOK
- +29 ;
- PTSCQ DO CLRVAR^SCMCBK1
- +1 QUIT
- +2 ;
- PTTMBLD(SCOK,SC) ; Build a list of patients for a selected team and return the $J of the TMP globall
- +1 ; where the list is stored.
- +2 ; ' SC BLD PAT TM LIST '
- +3 ;
- +4 DO NEWVAR^SCMCBK1
- +5 DO CHK^SCUTBK
- +6 DO TMP^SCUTBK
- +7 ;
- +8 DO PARSE^SCMCBK1(.SC)
- +9 KILL ^TMP($JOB,"SCTEAM")
- +10 ;
- +11 ; Build exclude list
- +12 SET SCOK=0
- +13 SET BLOCK=$SELECT(SCPOS'="":"BLKPOS",1:"BLKTM")
- +14 SET SCBLOCK=$SELECT(SCPOS'="":SCPOS,1:SCTEAM)
- +15 DO @BLOCK
- +16 ;
- +17 SET SCOK=$$PTTM^SCAPMC2(SCFRMTM,"SCDTRNG",.SCLOC,"SCERMSG")
- +18 KILL ^TMP("SCMC",$JOB,"EXCLUDE PT")
- +19 MERGE ^TMP($JOB,"SC PCMM IN")=@SCLOC
- +20 ;
- +21 SET I=""
- FOR
- SET I=$ORDER(^TMP($JOB,"SC PCMM IN",I))
- if 'I
- QUIT
- Begin DoDot:1
- +22 SET ^TMP($JOB,"PCMM TMP",I)=^TMP($JOB,"SC PCMM IN",I)
- End DoDot:1
- +23 ;
- +24 DO ALPHA^SCAPMCU2("^TMP($J,""PCMM TMP"")","^TMP($J,""SCTEAM"")")
- +25 SET I1=""
- FOR
- SET I1=$ORDER(^TMP($JOB,"SCTEAM",I1))
- if 'I1
- QUIT
- SET I=I1
- +26 ;
- +27 SET SCOK=$JOB_U_+I_U_SCOK
- +28 ;
- +29 DO CLRVAR^SCMCBK1
- +30 QUIT
- +31 ;
- PTPSBLD(SCOK,SC) ;
- +1 ; ' SC BLD PAT POS LIST '
- +2 ;
- +3 DO NEWVAR^SCMCBK1
- +4 DO CHK^SCUTBK
- +5 DO TMP^SCUTBK
- +6 ;
- +7 DO PARSE^SCMCBK1(.SC)
- +8 ;
- +9 KILL ^TMP($JOB,"SCPOS")
- +10 ;
- +11 ; Build exclude list
- +12 SET BLOCK=$SELECT(SCPOS'="":"BLKPOS",1:"BLKTM")
- +13 SET SCBLOCK=$SELECT(SCPOS'="":SCPOS,1:SCTEAM)
- +14 DO @BLOCK
- +15 ;
- +16 SET SCOK=0
- +17 ;
- +18 SET SCOK=$$PTTP^SCAPMC11(SCFRMPOS,"SCDTRNG",.SCLOC,.SCERMSG)
- +19 KILL ^TMP("SCMC",$JOB,"EXCLUDE PT")
- +20 MERGE ^TMP($JOB,"SC PCMM IN")=@SCLOC
- +21 ;
- +22 SET I1=$GET(^TMP($JOB,"SC PCMM IN",0))
- +23 FOR I=1:1:I1
- SET ^TMP($JOB,"PCMM TMP",I)=$GET(^TMP($JOB,"SC PCMM IN",I))
- +24 DO ALPHA^SCAPMCU2("^TMP($J,""PCMM TMP"")","^TMP($J,""SCPOS"")")
- +25 SET SCOK=$JOB_U_+I1_U_SCOK
- +26 ;
- +27 ;IF '+$G(^TMP($J,"SCPOS",0)) D S SCOK=$J_U_SCOK
- +28 ;. S I="" F S I=$O(^TMP($J,"SCPOS",I)) Q:'I S SCOK=I
- +29 ;
- +30 DO CLRVAR^SCMCBK1
- +31 QUIT
- +32 ;
- PTAPBLD(SCOK,SC) ; Build patient list for selected appointment range.
- +1 ; ' SC BLD PAT APT LIST '
- +2 ;
- +3 ;SD/564-this build includes modification as follows:
- +4 ;- patients already assigned to another PC team then evaluated team SCTEAM are excluded
- +5 ;- patients previously assigned and unassigned to evaluated position are included
- +6 ;
- +7 ;N SCCLN,SCTEAM,SCDTRNG,SCLOC,SCERMSG,SCNUM,SCCOUNT,SCMORE,SCOK1,SCER2,SCOUT,SCBLOCK
- +8 ;
- +9 DO NEWVAR^SCMCBK1
- +10 DO CHK^SCUTBK
- +11 DO TMP^SCUTBK
- +12 ;
- +13 DO PARSE^SCMCBK1(.SC)
- +14 ;
- +15 KILL ^TMP($JOB,"SCCLN")
- +16 ;
- +17 ; Build exclude list
- +18 SET BLOCK=$SELECT(SCPOS'="":"BLKPOS",1:"BLKTM")
- +19 SET SCBLOCK=$SELECT(SCPOS'="":SCPOS,1:SCTEAM)
- +20 DO @BLOCK
- +21 ;
- +22 IF 'SCOK1
- SET SCOK="0^0^0^0"
- GOTO PTAPQ
- +23 SET SCOK=0
- +24 SET SCOK=$$PTAP^SCAPMC28(SCCLN,"SCDTRNG",SCNUM,.SCLOC,"SCERMSG",SCMORE)
- +25 ;
- +26 ;identify excluded to be included if unassigned from evaluated position-sd/564
- +27 NEW SCTMP
- SET SCTMP=$GET(^TMP("SC TMP LIST",$JOB,0))
- +28 NEW SS
- SET SS=$GET(^TMP("SCMC",$JOB,"EXCLUDE PT",0))
- +29 NEW SDFN,XX
- FOR XX=1:1:SS
- SET SDFN=+$GET(^TMP("SCMC",$JOB,"EXCLUDE PT",XX))
- Begin DoDot:1
- +30 NEW SCI
- SET SCI=^TMP("SCMC",$JOB,"EXCLUDE PT",XX)
- Begin DoDot:2
- +31 NEW SCII
- SET SCII=$PIECE(SCI,U,5)
- IF SCII>0&(SCII<(DT+1))
- Begin DoDot:3
- +32 ;PROCEED ONLY WITH THE CURRENT MONTH ASSIGNMENT
- +33 NEW SCAS
- SET SCAS=$PIECE(SCI,U,4)
- IF SCAS>0
- IF $EXTRACT(DT,1,5)'=$EXTRACT(SCAS,1,5)
- QUIT
- +34 NEW SCPOS
- SET SCPOS=$PIECE(SCI,U,3)
- IF SCPOS>0
- IF $PIECE(^SCPT(404.43,SCPOS,0),U,2)'=$GET(SC("POSITION"))
- QUIT
- +35 NEW SCN,SCS
- SET SCN=$PIECE(SCI,U,2)
- SET SCS=$PIECE(SCI,U,6)
- +36 SET SCTMP=SCTMP+1
- +37 SET ^TMP("SC TMP LIST",$JOB,SCTMP)=SDFN_U_SCN_U_SC("CLINIC")_U_U_SCS
- +38 SET ^TMP("SC TMP LIST",$JOB,"SCPTAP",SDFN,SCTMP)=""
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +39 SET ^TMP("SC TMP LIST",$JOB,0)=SCTMP
- +40 ;
- +41 KILL ^TMP("SCMC",$JOB,"EXCLUDE PT")
- +42 ;
- +43 ;eliminate patients if assigned to another PC team-SD/564
- +44 NEW DFN
- SET DFN=""
- FOR
- SET DFN=$ORDER(^TMP("SC TMP LIST",$JOB,"SCPTAP",DFN))
- if DFN=""
- QUIT
- Begin DoDot:1
- +45 ;call to get patient's PC assignment
- NEW SCEX
- SET SCEX=$$GETPC^SCAPMCU2(DFN)
- +46 NEW NSAS
- SET NSAS=$PIECE(SCEX,U,2)
- IF +SCEX>0!(NSAS>0&(NSAS'=SCTEAM))
- Begin DoDot:2
- +47 NEW SCN
- SET SCN=$ORDER(^TMP("SC TMP LIST",$JOB,"SCPTAP",DFN,""))
- +48 KILL ^TMP("SC TMP LIST",$JOB,"SCPTAP",DFN)
- +49 KILL ^TMP("SC TMP LIST",$JOB,SCN)
- +50 SET ^TMP("SC TMP LIST",$JOB,0)=^TMP("SC TMP LIST",$JOB,0)-1
- End DoDot:2
- End DoDot:1
- +51 ;
- +52 MERGE ^TMP($JOB,"SC PCMM IN")=@SCLOC
- +53 SET I1=$GET(^TMP($JOB,"SC PCMM IN",0))
- +54 ;reindex entries in ^TMP global list - SD/564
- +55 NEW SCC
- SET SCC=0
- FOR I=1:1:I1
- SET SCC=$ORDER(^TMP($JOB,"SC PCMM IN",SCC))
- Begin DoDot:1
- +56 SET ^TMP($JOB,"PCMM TMP",I)=^TMP($JOB,"SC PCMM IN",SCC)
- End DoDot:1
- +57 ;
- +58 DO ALPHA^SCAPMCU2("^TMP($J,""PCMM TMP"")","^TMP($J,""SCAPP"")")
- +59 SET SCOK=$JOB_U_I1_U_SCOK
- +60 ;
- +61 DO CLRVAR^SCMCBK1
- PTAPQ QUIT
- +1 ;
- 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 NEW SCJOB,SCSTART,SCEND,I,SCLAST,SCJOBID
- +10 ;
- +11 DO CHK^SCUTBK
- +12 DO TMP^SCUTBK
- +13 ;
- +14 DO PARSE^SCMCBK1(.SC)
- +15 ;
- +16 FOR I=SCSTART:1:SCEND
- if '$GET(^TMP(SCJOB,SCJOBID,I),0)
- QUIT
- Begin DoDot:1
- +17 SET SCDATA(I)=^TMP(SCJOB,SCJOBID,I)
- End DoDot:1
- +18 IF SCEND>SCLAST
- KILL ^TMP(SCJOB,SCJOBID)
- +19 ;
- +20 DO CLRVAR^SCMCBK1
- +21 QUIT
- +22 ;
- PTLSTBLD(SCOK,SCVAL) ; Build the list of patients to be assigned in the ^TMP($J,"SC PATIENT 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 SET ^TMP(SCJOB,"SC PATIENT LIST",SCDFN)=""
- +16 SET SCOK=1
- PTBLDQ QUIT
- +1 ;
- PTFILE(SCOK,SC) ; File the patient assignments in the ^TMP($J,"SC TEAM ASSIGN",SCDFN) global
- +1 ; 'SC FILE PAT TM ASGN'
- +2 ;
- +3 ;205 remove;I XWBAPVER=177 D QUEUED^SCMCBK4(1) Q
- +4 ;205 remove;I $$VPROGMR^SCUTBK3()'=1 Q
- +5 ; pre 177 code follows....
- +6 IF XWBAPVER=1
- DO QUEUED^SCMCBK4(1)
- QUIT
- +7 ;
- +8 NEW SCADDFLD,SCTEAM,SCFILE,SCJOB,SCNEW,SCOLD,SCBAD,SCERMSG,SCX,SCDTVAR
- +9 ;
- +10 DO CHK^SCUTBK
- +11 DO TMP^SCUTBK
- +12 ;
- +13 DO PARSE^SCMCBK1(.SC)
- +14 if +$GET(SCJOB)=0
- GOTO FILEQ
- +15 ;
- +16 ;
- +17 SET SCADDFLD(.08)=$GET(SC("TYPE"),99)
- +18 SET SCADDFLD(.1)=$GET(SC("RESTRICT"),0)
- +19 SET SCADDFLD(.11)=DUZ
- +20 SET SCADDFLD(.12)=DT
- +21 ;
- +22 SET SCX=$$ACPTATM^SCAPMC6("^TMP(SCJOB,""SC PATIENT LIST"")",SCTEAM,"SCADDFLD",SCDTVAR,"SCERMSG","SCNEW","SCOLD","SCBAD")
- +23 DO BAD^SCMCBK1(.SCBAD,.SCOLD,.SCOK)
- +24 SET SCOK(.1)=SCX
- +25 ;
- +26 KILL ^TMP(SCJOB,"SC PATIENT LIST")
- +27 ;
- +28 DO CLRVAR^SCMCBK1
- FILEQ QUIT
- +1 ;
- POSFILE(SCOK,SC) ; File the patient assignments in the ^TMP($J,"SC PATIENT LIST") global
- +1 ; ' SC FILE PAT POS ASGN '
- +2 ;
- +3 ;205 remove;I XWBAPVER=177 D QUEUED^SCMCBK4(2) Q
- +4 ;205 remove;I $$VPROGMR^SCUTBK3()'=1 Q
- +5 ; pre 177 code follows...
- +6 IF XWBAPVER=1
- DO QUEUED^SCMCBK4(2)
- QUIT
- +7 ;
- +8 NEW SCADDFLD,SCTEAM,SCFILE,SCJOB,SCNEW,SCOLD,SCBAD,SCERMSG,SCX,SCPOS,SCDTVAR,SCMAFLD,SCADTM,SCNEW1
- +9 ;
- +10 DO CHK^SCUTBK
- +11 DO TMP^SCUTBK
- +12 ;
- +13 DO PARSE^SCMCBK1(.SC)
- +14 if +$GET(SCJOB)=0
- GOTO FILEQ
- +15 SET SCADTM=1
- +16 ;
- +17 SET SCADDFLD(.05)=$GET(SC("TYPE"),0)
- +18 SET SCADDFLD(.06)=DUZ
- +19 SET SCADDFLD(.07)=DT
- +20 ;
- +21 SET SCX=$$ACPTATP^SCAPMC21("^TMP(SCJOB,""SC PATIENT LIST"")",SCPOS,"SCADDFLD",SCDTVAR,"SCERMSG",SCADTM,"","SCNEW","SCNEW1","SCOLD","SCBAD")
- +22 ;
- +23 DO BAD2^SCMCBK1(.SCBAD,.SCOLD,.SCOK)
- +24 SET SCOK(.1)=SCX
- +25 KILL ^TMP(SCJOB,"SC PATIENT LIST")
- +26 ;
- +27 DO CLRVAR^SCMCBK1
- +28 QUIT
- +29 ;
- 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 ;