SCMCMU1 ;ALB/MJK - PCMM Mass Team/Position List Manager ; 10-JUL-1998
;;5.3;Scheduling;**148**;AUG 13, 1993
;
EN(SCTEAM,SCPOS,SCTPDIS,SCMUTYPE,SCDATE) ; -- main entry point for SCMC MU MASS TEAM UNASSIGNMENT
D EN^VALM("SCMC MU MASS TEAM UNASSIGNMENT")
Q
;
HDR ; -- header code
N X,SCTEAM0
S SCTEAM0=$G(^SCTM(404.51,+SCTEAM,0),"Unknown")
S X=$E(" Team: "_$P(SCTEAM0,U),1,40)
S X=$$SETSTR^VALM1(" Total: "_+$G(SCALLCNT)_" Selected: "_+$G(SCSELCNT),X,45,35)
S VALMHDR(1)=X
;
S X=""
IF SCMUTYPE="P" D
. S SCPOS0=$G(^SCTM(404.57,+SCPOS,0),"Unknown")
. S X=$E("Position: "_$P(SCPOS0,U),1,40)
. IF '$G(SCTPDIS(+SCPOS)) Q
. S X=$$SETSTR^VALM1("Clinic: "_$P($G(^SC(+$P(SCPOS0,U,9),0),"Unknown"),U),X,45,35)
.Q
;
S VALMHDR(2)=X
S X="Proposed Effective Date: "_$$FMTE^XLFDT($E(SCDATE,1,7),"5Z")
S X=$$SETSTR^VALM1(" View: "_SCVIEW_$S(SCVIEW="ALL":"",1:"ED"),X,45,35)
S VALMHDR(3)=X
Q
;
INIT ; -- init variables and list array
N SCPATS,SCI,SCALPHA,SCX,SCDTE
S SCPATS=$NA(^TMP("SCMU",$J,"PATIENTS"))
S SCALPHA=$NA(^TMP("SCMU",$J,"PATS ALPHA"))
K @SCPATS,@SCALPHA
;
; -- set up persistent structures
S SCPTINFO=$NA(^TMP("SCMU",$J,"PATIENT INFO")) ; useful patient data
S SCPTSEL=$NA(^TMP("SCMU",$J,"SELECTED")) ; patients selected
S SCPTALL=$NA(^TMP("SCMU",$J,"PATIENT ALL")) ; listman data
;
K @SCPTINFO,@SCPTSEL,@SCPTALL
S (SCALLCNT,SCSELCNT,SCMSG)=0
S SCVIEW="ALL"
;
W ! D WAIT^DICD
;
; -- change title is appropriate
IF SCMUTYPE="P" S VALM("TITLE")="Mass Position Unassignment"
;
; -- get patients
D DATE(SCDATE,.SCDTE)
IF SCMUTYPE="T",'$$PTTM^SCAPMC(SCTEAM,SCDTE,SCPATS) G INITQ
IF SCMUTYPE="P",'$$PTTP^SCAPMC(SCPOS,SCDTE,SCPATS) G INITQ
;
; -- build list for display
S SCI=0
F S SCI=$O(@SCPATS@(SCI)) Q:'SCI D
. S SCX=@SCPATS@(SCI)
. S @SCALPHA@($P(SCX,U,2)_SCI)=SCI
. Q
;
S SCNT=0
S SCI=""
F S SCI=$O(@SCALPHA@(SCI)) Q:SCI="" D
. S SCX=$G(@SCPATS@(+@SCALPHA@(SCI)))
. IF '$$FILTER(SCX,SCDATE) Q
. S SCNT=SCNT+1
. S Y=$$SETSTR^VALM1(SCNT,"",1,4) ; number
. S Y=$$SETSTR^VALM1($P(SCX,U,2),Y,15,25) ; pt name
. S Y=$$SETSTR^VALM1($P(SCX,U,6),Y,42,12) ; pt id
. S Y=$$SETSTR^VALM1($$FMTE^XLFDT($P(SCX,U,4),"5Z"),Y,56,10) ; assigned
. S Y=$$SETSTR^VALM1($$FMTE^XLFDT($P(SCX,U,5),"5Z"),Y,69,10) ; unassigned
. ;
. ; -- flag if this is a future assignment
. IF $P(SCX,U,4)>DT D
. . S Y=$$SETSTR^VALM1("*",Y,55,1)
. . IF 'SCMSG S SCMSG=1 D MSG
. ;
. ; -- flag if this is a future unassignment
. IF $P(SCX,U,5)>DT D
. . S Y=$$SETSTR^VALM1("*",Y,68,1)
. . IF 'SCMSG S SCMSG=1 D MSG
. ;
. S @SCPTALL@(SCNT,0)=Y
. S @SCPTALL@("IDX",SCNT,SCNT)=SCNT
. S @SCPTINFO@(SCNT)=SCX
. Q
K @SCPATS,@SCALPHA
S SCALLCNT=SCNT
;
; -- set up lm array
D BLD
;
INITQ Q
;
FILTER(SCX,SCDATE) ; -- apply filter criteria
N SCOK
S SCOK=1
; -- if inactivation date is =< effective then don't use
IF $P(SCX,U,5),$P(SCX,U,5)'>SCDATE S SCOK=0
Q SCOK
;
BLD ; -- build VALMAR
K @VALMAR
;
IF SCVIEW="ALL" D
. M @VALMAR=@SCPTALL
. S VALMCNT=SCALLCNT
. Q
;
ELSE D
. N SCNT
. S (SCNT,VALMCNT)=0
. F S SCNT=$O(@SCPTALL@(SCNT)) Q:'SCNT D
. . ; -- if in select view and patient not selected then don't use
. . IF SCVIEW="SELECT",'$D(@SCPTSEL@(SCNT)) Q
. . ; -- if in de-select view and patient selected then don't use
. . IF SCVIEW="DE-SELECT",$D(@SCPTSEL@(SCNT)) Q
. . ;
. . S VALMCNT=VALMCNT+1
. . S Y=@SCPTALL@(SCNT,0)
. . S @VALMAR@(VALMCNT,0)=$$SETSTR^VALM1(VALMCNT,Y,1,4)
. . ;
. . ; -- set idx to pointer back to SCPTALL (this is key!)
. . S @VALMAR@("IDX",VALMCNT,VALMCNT)=SCNT
. . Q
. Q
;
IF '$O(@VALMAR@(0)) D
. S @VALMAR@(1,0)=" "
. S @VALMAR@(2,0)=" "
. S @VALMAR@(3,0)=" No patients to list."
. Q
IF $G(VALMBG),'$D(@VALMAR@(VALMBG,0)) S VALMBG=1
K VALMHDR
D BACK("R")
Q
;
SETSEL(FLAG,SCNT) ; -- set selected flag indicator
N Y,SCPTCNT
;
; -- get pointer back to SCPTALL
S SCPTCNT=+$G(@VALMAR@("IDX",SCNT,SCNT))
IF FLAG="DE-SELECT",$D(@SCPTSEL@(SCPTCNT)) D
. K @SCPTSEL@(SCPTCNT)
. S SCSELCNT=$S(SCSELCNT=0:0,1:SCSELCNT-1)
;
IF FLAG="SELECT",'$D(@SCPTSEL@(SCPTCNT)) D
. S @SCPTSEL@(SCPTCNT)=""
. S SCSELCNT=$S(SCSELCNT=SCALLCNT:SCALLCNT,1:SCSELCNT+1)
;
S Y=$G(@VALMAR@(SCNT,0))
S Y=$$SETSTR^VALM1($S(FLAG="SELECT":"Yes",1:""),Y,8,3)
S @VALMAR@(SCNT,0)=Y
;
; -- need to do SCPTALL separately because of potential for differnt #'s
S Y=$G(@SCPTALL@(SCPTCNT,0))
S Y=$$SETSTR^VALM1($S(FLAG="SELECT":"Yes",1:""),Y,8,3)
S @SCPTALL@(SCPTCNT,0)=Y
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
D CLEAR^VALM1
K @VALMAR,SCSELCNT,SCVIEW,SCALLCNT,SCMSG
K @SCPTALL,@SCPTSEL,@SCPTINFO
K SCPTALL,SCPTSEL,SCPTINFO
Q
;
EXPND ; -- expand code
Q
;
ALL(SCACT) ; -- entry point for SCMC SELECT ALL & SCMC DESELECT ALL protocols
IF SCVIEW=SCACT D Q
. W !!,"All patients in current view are already '"_SCACT_"ED'."
. D PAUSE
. D BACK("")
. Q
D ACT(SCACT,SCPTALL)
Q
;
SOME(SCACT) ; -- entry point for SCMC SELECT SOME & SCMC DESELECT SOME protocols
IF SCVIEW=SCACT D Q
. W !!,"All patients in current view are already '"_SCACT_"ED'."
. D PAUSE
. D BACK("")
. Q
D EN^VALM2(XQORNOD(0),"O")
D ACT(SCACT,"VALMY")
Q
;
ACT(SCACT,SCLIST) ; -- change select flag
N SCNT
S SCNT=0
F S SCNT=$O(@SCLIST@(SCNT)) Q:'SCNT D SETSEL(SCACT,SCNT)
W !
D WAIT^DICD,BLD
Q
;
VIEW(SCVW) ; -- change view
S SCVIEW=SCVW
W !
D WAIT^DICD,BLD
Q
;
BACK(ACTION) ; -- return to lm processing
IF $G(SCMSG) D MSG
S VALMBCK=ACTION
Q
;
MSG ; -- set message var
S VALMSG="* Future date"
Q
;
DATE(SCDATE,SCDTE) ; -- setup date array
S SCDTE="SCDTE"
S SCDTE("BEGIN")=SCDATE
S SCDTE("END")=9999999
S SCDTE("INCL")=0
Q
;
PAUSE ; -- pause
N DIR,Y
S DIR(0)="EA"
S DIR("A")="Enter RETURN to continue:"
D ^DIR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCMU1 6070 printed Oct 16, 2024@18:41:36 Page 2
SCMCMU1 ;ALB/MJK - PCMM Mass Team/Position List Manager ; 10-JUL-1998
+1 ;;5.3;Scheduling;**148**;AUG 13, 1993
+2 ;
EN(SCTEAM,SCPOS,SCTPDIS,SCMUTYPE,SCDATE) ; -- main entry point for SCMC MU MASS TEAM UNASSIGNMENT
+1 DO EN^VALM("SCMC MU MASS TEAM UNASSIGNMENT")
+2 QUIT
+3 ;
HDR ; -- header code
+1 NEW X,SCTEAM0
+2 SET SCTEAM0=$GET(^SCTM(404.51,+SCTEAM,0),"Unknown")
+3 SET X=$EXTRACT(" Team: "_$PIECE(SCTEAM0,U),1,40)
+4 SET X=$$SETSTR^VALM1(" Total: "_+$GET(SCALLCNT)_" Selected: "_+$GET(SCSELCNT),X,45,35)
+5 SET VALMHDR(1)=X
+6 ;
+7 SET X=""
+8 IF SCMUTYPE="P"
Begin DoDot:1
+9 SET SCPOS0=$GET(^SCTM(404.57,+SCPOS,0),"Unknown")
+10 SET X=$EXTRACT("Position: "_$PIECE(SCPOS0,U),1,40)
+11 IF '$GET(SCTPDIS(+SCPOS))
QUIT
+12 SET X=$$SETSTR^VALM1("Clinic: "_$PIECE($GET(^SC(+$PIECE(SCPOS0,U,9),0),"Unknown"),U),X,45,35)
+13 QUIT
End DoDot:1
+14 ;
+15 SET VALMHDR(2)=X
+16 SET X="Proposed Effective Date: "_$$FMTE^XLFDT($EXTRACT(SCDATE,1,7),"5Z")
+17 SET X=$$SETSTR^VALM1(" View: "_SCVIEW_$SELECT(SCVIEW="ALL":"",1:"ED"),X,45,35)
+18 SET VALMHDR(3)=X
+19 QUIT
+20 ;
INIT ; -- init variables and list array
+1 NEW SCPATS,SCI,SCALPHA,SCX,SCDTE
+2 SET SCPATS=$NAME(^TMP("SCMU",$JOB,"PATIENTS"))
+3 SET SCALPHA=$NAME(^TMP("SCMU",$JOB,"PATS ALPHA"))
+4 KILL @SCPATS,@SCALPHA
+5 ;
+6 ; -- set up persistent structures
+7 ; useful patient data
SET SCPTINFO=$NAME(^TMP("SCMU",$JOB,"PATIENT INFO"))
+8 ; patients selected
SET SCPTSEL=$NAME(^TMP("SCMU",$JOB,"SELECTED"))
+9 ; listman data
SET SCPTALL=$NAME(^TMP("SCMU",$JOB,"PATIENT ALL"))
+10 ;
+11 KILL @SCPTINFO,@SCPTSEL,@SCPTALL
+12 SET (SCALLCNT,SCSELCNT,SCMSG)=0
+13 SET SCVIEW="ALL"
+14 ;
+15 WRITE !
DO WAIT^DICD
+16 ;
+17 ; -- change title is appropriate
+18 IF SCMUTYPE="P"
SET VALM("TITLE")="Mass Position Unassignment"
+19 ;
+20 ; -- get patients
+21 DO DATE(SCDATE,.SCDTE)
+22 IF SCMUTYPE="T"
IF '$$PTTM^SCAPMC(SCTEAM,SCDTE,SCPATS)
GOTO INITQ
+23 IF SCMUTYPE="P"
IF '$$PTTP^SCAPMC(SCPOS,SCDTE,SCPATS)
GOTO INITQ
+24 ;
+25 ; -- build list for display
+26 SET SCI=0
+27 FOR
SET SCI=$ORDER(@SCPATS@(SCI))
if 'SCI
QUIT
Begin DoDot:1
+28 SET SCX=@SCPATS@(SCI)
+29 SET @SCALPHA@($PIECE(SCX,U,2)_SCI)=SCI
+30 QUIT
End DoDot:1
+31 ;
+32 SET SCNT=0
+33 SET SCI=""
+34 FOR
SET SCI=$ORDER(@SCALPHA@(SCI))
if SCI=""
QUIT
Begin DoDot:1
+35 SET SCX=$GET(@SCPATS@(+@SCALPHA@(SCI)))
+36 IF '$$FILTER(SCX,SCDATE)
QUIT
+37 SET SCNT=SCNT+1
+38 ; number
SET Y=$$SETSTR^VALM1(SCNT,"",1,4)
+39 ; pt name
SET Y=$$SETSTR^VALM1($PIECE(SCX,U,2),Y,15,25)
+40 ; pt id
SET Y=$$SETSTR^VALM1($PIECE(SCX,U,6),Y,42,12)
+41 ; assigned
SET Y=$$SETSTR^VALM1($$FMTE^XLFDT($PIECE(SCX,U,4),"5Z"),Y,56,10)
+42 ; unassigned
SET Y=$$SETSTR^VALM1($$FMTE^XLFDT($PIECE(SCX,U,5),"5Z"),Y,69,10)
+43 ;
+44 ; -- flag if this is a future assignment
+45 IF $PIECE(SCX,U,4)>DT
Begin DoDot:2
+46 SET Y=$$SETSTR^VALM1("*",Y,55,1)
+47 IF 'SCMSG
SET SCMSG=1
DO MSG
End DoDot:2
+48 ;
+49 ; -- flag if this is a future unassignment
+50 IF $PIECE(SCX,U,5)>DT
Begin DoDot:2
+51 SET Y=$$SETSTR^VALM1("*",Y,68,1)
+52 IF 'SCMSG
SET SCMSG=1
DO MSG
End DoDot:2
+53 ;
+54 SET @SCPTALL@(SCNT,0)=Y
+55 SET @SCPTALL@("IDX",SCNT,SCNT)=SCNT
+56 SET @SCPTINFO@(SCNT)=SCX
+57 QUIT
End DoDot:1
+58 KILL @SCPATS,@SCALPHA
+59 SET SCALLCNT=SCNT
+60 ;
+61 ; -- set up lm array
+62 DO BLD
+63 ;
INITQ QUIT
+1 ;
FILTER(SCX,SCDATE) ; -- apply filter criteria
+1 NEW SCOK
+2 SET SCOK=1
+3 ; -- if inactivation date is =< effective then don't use
+4 IF $PIECE(SCX,U,5)
IF $PIECE(SCX,U,5)'>SCDATE
SET SCOK=0
+5 QUIT SCOK
+6 ;
BLD ; -- build VALMAR
+1 KILL @VALMAR
+2 ;
+3 IF SCVIEW="ALL"
Begin DoDot:1
+4 MERGE @VALMAR=@SCPTALL
+5 SET VALMCNT=SCALLCNT
+6 QUIT
End DoDot:1
+7 ;
+8 IF '$TEST
Begin DoDot:1
+9 NEW SCNT
+10 SET (SCNT,VALMCNT)=0
+11 FOR
SET SCNT=$ORDER(@SCPTALL@(SCNT))
if 'SCNT
QUIT
Begin DoDot:2
+12 ; -- if in select view and patient not selected then don't use
+13 IF SCVIEW="SELECT"
IF '$DATA(@SCPTSEL@(SCNT))
QUIT
+14 ; -- if in de-select view and patient selected then don't use
+15 IF SCVIEW="DE-SELECT"
IF $DATA(@SCPTSEL@(SCNT))
QUIT
+16 ;
+17 SET VALMCNT=VALMCNT+1
+18 SET Y=@SCPTALL@(SCNT,0)
+19 SET @VALMAR@(VALMCNT,0)=$$SETSTR^VALM1(VALMCNT,Y,1,4)
+20 ;
+21 ; -- set idx to pointer back to SCPTALL (this is key!)
+22 SET @VALMAR@("IDX",VALMCNT,VALMCNT)=SCNT
+23 QUIT
End DoDot:2
+24 QUIT
End DoDot:1
+25 ;
+26 IF '$ORDER(@VALMAR@(0))
Begin DoDot:1
+27 SET @VALMAR@(1,0)=" "
+28 SET @VALMAR@(2,0)=" "
+29 SET @VALMAR@(3,0)=" No patients to list."
+30 QUIT
End DoDot:1
+31 IF $GET(VALMBG)
IF '$DATA(@VALMAR@(VALMBG,0))
SET VALMBG=1
+32 KILL VALMHDR
+33 DO BACK("R")
+34 QUIT
+35 ;
SETSEL(FLAG,SCNT) ; -- set selected flag indicator
+1 NEW Y,SCPTCNT
+2 ;
+3 ; -- get pointer back to SCPTALL
+4 SET SCPTCNT=+$GET(@VALMAR@("IDX",SCNT,SCNT))
+5 IF FLAG="DE-SELECT"
IF $DATA(@SCPTSEL@(SCPTCNT))
Begin DoDot:1
+6 KILL @SCPTSEL@(SCPTCNT)
+7 SET SCSELCNT=$SELECT(SCSELCNT=0:0,1:SCSELCNT-1)
End DoDot:1
+8 ;
+9 IF FLAG="SELECT"
IF '$DATA(@SCPTSEL@(SCPTCNT))
Begin DoDot:1
+10 SET @SCPTSEL@(SCPTCNT)=""
+11 SET SCSELCNT=$SELECT(SCSELCNT=SCALLCNT:SCALLCNT,1:SCSELCNT+1)
End DoDot:1
+12 ;
+13 SET Y=$GET(@VALMAR@(SCNT,0))
+14 SET Y=$$SETSTR^VALM1($SELECT(FLAG="SELECT":"Yes",1:""),Y,8,3)
+15 SET @VALMAR@(SCNT,0)=Y
+16 ;
+17 ; -- need to do SCPTALL separately because of potential for differnt #'s
+18 SET Y=$GET(@SCPTALL@(SCPTCNT,0))
+19 SET Y=$$SETSTR^VALM1($SELECT(FLAG="SELECT":"Yes",1:""),Y,8,3)
+20 SET @SCPTALL@(SCPTCNT,0)=Y
+21 QUIT
+22 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 DO CLEAR^VALM1
+2 KILL @VALMAR,SCSELCNT,SCVIEW,SCALLCNT,SCMSG
+3 KILL @SCPTALL,@SCPTSEL,@SCPTINFO
+4 KILL SCPTALL,SCPTSEL,SCPTINFO
+5 QUIT
+6 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
ALL(SCACT) ; -- entry point for SCMC SELECT ALL & SCMC DESELECT ALL protocols
+1 IF SCVIEW=SCACT
Begin DoDot:1
+2 WRITE !!,"All patients in current view are already '"_SCACT_"ED'."
+3 DO PAUSE
+4 DO BACK("")
+5 QUIT
End DoDot:1
QUIT
+6 DO ACT(SCACT,SCPTALL)
+7 QUIT
+8 ;
SOME(SCACT) ; -- entry point for SCMC SELECT SOME & SCMC DESELECT SOME protocols
+1 IF SCVIEW=SCACT
Begin DoDot:1
+2 WRITE !!,"All patients in current view are already '"_SCACT_"ED'."
+3 DO PAUSE
+4 DO BACK("")
+5 QUIT
End DoDot:1
QUIT
+6 DO EN^VALM2(XQORNOD(0),"O")
+7 DO ACT(SCACT,"VALMY")
+8 QUIT
+9 ;
ACT(SCACT,SCLIST) ; -- change select flag
+1 NEW SCNT
+2 SET SCNT=0
+3 FOR
SET SCNT=$ORDER(@SCLIST@(SCNT))
if 'SCNT
QUIT
DO SETSEL(SCACT,SCNT)
+4 WRITE !
+5 DO WAIT^DICD
DO BLD
+6 QUIT
+7 ;
VIEW(SCVW) ; -- change view
+1 SET SCVIEW=SCVW
+2 WRITE !
+3 DO WAIT^DICD
DO BLD
+4 QUIT
+5 ;
BACK(ACTION) ; -- return to lm processing
+1 IF $GET(SCMSG)
DO MSG
+2 SET VALMBCK=ACTION
+3 QUIT
+4 ;
MSG ; -- set message var
+1 SET VALMSG="* Future date"
+2 QUIT
+3 ;
DATE(SCDATE,SCDTE) ; -- setup date array
+1 SET SCDTE="SCDTE"
+2 SET SCDTE("BEGIN")=SCDATE
+3 SET SCDTE("END")=9999999
+4 SET SCDTE("INCL")=0
+5 QUIT
+6 ;
PAUSE ; -- pause
+1 NEW DIR,Y
+2 SET DIR(0)="EA"
+3 SET DIR("A")="Enter RETURN to continue:"
+4 DO ^DIR
+5 QUIT
